1c----------------------------------------------------------------------- 2c 3c R : A Computer Language for Statistical Data Analysis 4c Copyright (C) 1998-2016 The R Core Team 5c 6c This program is free software; you can redistribute it and/or modify 7c it under the terms of the GNU General Public License as published by 8c the Free Software Foundation; either version 2 of the License, or 9c (at your option) any later version. 10c 11c This program is distributed in the hope that it will be useful, 12c but WITHOUT ANY WARRANTY; without even the implied warranty of 13c MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14c GNU General Public License for more details. 15c 16c You should have received a copy of the GNU General Public License 17c along with this program; if not, a copy is available at 18c https://www.R-project.org/Licenses/ 19c 20c----------------------------------------------------------------------- 21 22C Called from R's smooth.spline in ../R/smspline.R as .Fortran(C, ..) 23C and from C's 24 25C An interface to sbart() --- fewer arguments BUT unspecified scrtch() dimension 26C 27C NB: this routine alters ws [and isetup]. 28C renamed for safety 29C 30 subroutine rbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, 31 & coef,sz,lev, 32 & crit,iparms,spar,parms, 33 & scrtch, ld4,ldnk,ier) 34c Args: 35 integer n,nk, iparms(4), ld4,ldnk,ier 36 double precision penalt,dofoff, xs(n),ys(n),ws(n), ssw, 37 & knot(nk+4), coef(nk), sz(n), lev(n), 38 & crit, spar, parms(5), 39 & scrtch(*) 40C ^^^^^^^^ dimension (9+2*ld4+ldnk)*nk = (17 + 1)*nk [last nk never accessed] 41c Vars: 42 integer isetup 43 44 if(iparms(4) .eq. 1) then ! spar is lambda 45 isetup = 2 46 else 47 isetup = 0 48 endif 49 call sbart(penalt,dofoff,xs,ys,ws,ssw,n,knot,nk, 50 & coef,sz,lev, crit, 51 & iparms(1),spar,iparms(2),iparms(3), 52c = icrit spar ispar iter 53 & parms(1),parms(2),parms(3),parms(4),parms(5), 54c = lspar uspar tol eps ratio 55 & isetup, scrtch(1), 56c = 0|2 xwy == X'W y 57 & scrtch( nk+1),scrtch(2*nk+1),scrtch(3*nk+1),scrtch(4*nk+1), 58c = hs0 hs1 hs2 hs3 ==> X'W X 59 & scrtch(5*nk+1),scrtch(6*nk+1),scrtch(7*nk+1),scrtch(8*nk+1), 60c = sg0 sg1 sg2 sg3 ==> SIGMA 61 & scrtch(9*nk+1), 62c = abd [ld4 x nk] ==> R 63 & scrtch(9*nk+ ld4*nk+1), scrtch(9*nk+2*ld4*nk+1), 64c = p1ip[ld4 x nk] p2ip [ldnk x nk] 65 & ld4,ldnk,ier) 66 67 return 68 end 69