gss/0000755000175100001440000000000012545263542011074 5ustar hornikusersgss/inst/0000755000175100001440000000000012345703270012044 5ustar hornikusersgss/inst/CITATION0000644000175100001440000000114212355360640013200 0ustar hornikuserscitHeader("To cite gss in publications use:") citEntry(entry = "Article", title = "Smoothing Spline ANOVA Models: {R} Package {gss}", author = personList(as.person("Chong Gu")), journal = "Journal of Statistical Software", year = "2014", volume = "58", number = "5", pages = "1--25", url = "http://www.jstatsoft.org/v58/i05/", textVersion = paste("Chong Gu (2014).", "Smoothing Spline ANOVA Models: R Package gss.", "Journal of Statistical Software, 58(5), 1-25.", "URL http://www.jstatsoft.org/v58/i05/.") ) gss/src/0000755000175100001440000000000012545250041011651 5ustar hornikusersgss/src/ddeev.f0000644000175100001440000002262612545250042013120 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine ddeev (vmu, nobs, q, ldqr, ldqc, n, nq, u, ldu, uaux, t *, x, theta, nlaht, score, varht, hes, ldh, gra, hwk1, hwk2, gwk1, *gwk2, kwk, ldk, work1, work2, work3, info) character*1 vmu integer nobs, ldqr, ldqc, n, nq, ldu, ldh, ldk, info double precision q(ldqr,ldqc,*), u(ldu,*), uaux(*), t(2,*), x(*), *theta(*), nlaht, score, varht, hes(ldh,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(ldk,ldk,*), work1(*), work2(*), wor *k3(*) double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nobs .lt. n .or. ldqr .lt. n .or. ldqc .lt. n .or. nq .le. 0 . *or. ldu .lt. n-1 .or. ldh .lt. nq .or. ldk .lt. n )then info = -1 return endif i=2 23004 if(.not.(i.le.nq))goto 23006 if( theta(i) .le. -25.d0 )then goto 23005 endif j=1 23009 if(.not.(j.le.n))goto 23011 call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) 23010 j=j+1 goto 23009 23011 continue call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1 *) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i), d *um, dum, dum, 01000, info) 23005 i=i+1 goto 23004 23006 continue call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) j=1 23012 if(.not.(j.lt.n-1))goto 23014 call dset (n-j-1, 0.d0, kwk(j+2,j,1), 1) 23013 j=j+1 goto 23012 23014 continue i=2 23015 if(.not.(i.le.nq))goto 23017 if( theta(i) .le. -25.d0 )then goto 23016 endif j=1 23020 if(.not.(j.le.n))goto 23022 call daxpy (n-j+1, -1.d0, kwk(j,j,i), 1, kwk(j,j,1), 1) 23021 j=j+1 goto 23020 23022 continue 23016 i=i+1 goto 23015 23017 continue i=1 23023 if(.not.(i.le.nq))goto 23025 if( theta(i) .le. -25.d0 )then goto 23024 endif j=1 23028 if(.not.(j.lt.n))goto 23030 call dcopy (n-j, kwk(j+1,j,i), 1, kwk(j,j+1,i), n) 23029 j=j+1 goto 23028 23030 continue 23024 i=i+1 goto 23023 23025 continue call dset (n, 10.d0 ** nlaht, work1, 1) call daxpy (n, 1.d0, work1, 1, t(2,1), 2) call dpbfa (t, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif i=1 23033 if(.not.(i.le.nq))goto 23035 if( theta(i) .le. -25.d0 )then goto 23034 endif j=1 23038 if(.not.(j.le.n))goto 23040 call dpbsl (t, 2, n, 1, kwk(1,j,i)) 23039 j=j+1 goto 23038 23040 continue 23034 i=i+1 goto 23033 23035 continue call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) if( vmu .ne. 'm' )then call dcopy (n, work1, 1, work2, 1) call dscal (n, 2.d0, work2, 1) else call dcopy (n, x, 1, work2, 1) endif i=1 23043 if(.not.(i.le.nq))goto 23045 if( theta(i) .le. -25.d0 )then goto 23044 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work2, 1, 0.d0, work3, * 1) gwk1(i) = - ddot (n, work1, 1, work3, 1) 23044 i=i+1 goto 23043 23045 continue i=1 23048 if(.not.(i.le.nq))goto 23050 gwk2(i) = 0.d0 if( theta(i) .le. -25.d0 )then goto 23049 endif j=1 23053 if(.not.(j.le.n))goto 23055 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,i), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) gwk2(i) = gwk2(i) - work1(j) else gwk2(i) = gwk2(i) - kwk(j,j,i) endif 23054 j=j+1 goto 23053 23055 continue 23049 i=i+1 goto 23048 23050 continue if( vmu .ne. 'm' )then call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23060 if(.not.(i.le.nq))goto 23062 if( theta(i) .le. -25.d0 )then goto 23061 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23065 if(.not.(j.le.i))goto 23067 if( theta(j) .le. -25.d0 )then goto 23066 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23066 j=j+1 goto 23065 23067 continue call dgemv ('t', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23070 if(.not.(j.le.i))goto 23072 if( theta(j) .le. -25.d0 )then goto 23071 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,j), n, work1, 1, 0.d0, work3, * 1) hwk1(i,j) = hwk1(i,j) + 2.d0 * ddot (n, work2, 1, work3, 1) 23071 j=j+1 goto 23070 23072 continue 23061 i=i+1 goto 23060 23062 continue else call dcopy (n, x, 1, work1, 1) call dpbsl (t, 2, n, 1, work1) i=1 23075 if(.not.(i.le.nq))goto 23077 if( theta(i) .le. -25.d0 )then goto 23076 endif call dgemv ('n', n, n, 1.d0, kwk(1,1,i), n, work1, 1, 0.d0, work2, * 1) j=1 23080 if(.not.(j.le.i))goto 23082 if( theta(j) .le. -25.d0 )then goto 23081 endif call dgemv ('t', n, n, 1.d0, kwk(1,1,j), n, x, 1, 0.d0, work3, 1) hwk1(i,j) = 2.d0 * ddot (n, work2, 1, work3, 1) 23081 j=j+1 goto 23080 23082 continue 23076 i=i+1 goto 23075 23077 continue endif i=1 23085 if(.not.(i.le.nq))goto 23087 if( theta(i) .le. -25.d0 )then goto 23086 endif hwk1(i,i) = hwk1(i,i) + gwk1(i) 23086 i=i+1 goto 23085 23087 continue i=1 23090 if(.not.(i.le.nq))goto 23092 if( theta(i) .le. -25.d0 )then goto 23091 endif m=1 23095 if(.not.(m.le.i))goto 23097 hwk2(i,m) = 0.d0 if( theta(m) .le. -25.d0 )then goto 23096 endif j=1 23100 if(.not.(j.le.n))goto 23102 if( vmu .ne. 'm' )then call dcopy (n, kwk(1,j,m), 1, work1, 1) call dpbsl (t, 2, n, 1, work1) hwk2(i,m) = hwk2(i,m) + 2.d0 * ddot (n, kwk(j,1,i), n, work1, 1) else hwk2(i,m) = hwk2(i,m) + ddot (n, kwk(j,1,i), n, kwk(1,j,m), 1) endif 23101 j=j+1 goto 23100 23102 continue 23096 m=m+1 goto 23095 23097 continue 23091 i=i+1 goto 23090 23092 continue i=1 23105 if(.not.(i.le.nq))goto 23107 if( theta(i) .le. -25.d0 )then goto 23106 endif hwk2(i,i) = hwk2(i,i) + gwk2(i) 23106 i=i+1 goto 23105 23107 continue if( vmu .eq. 'v' )then trc = dfloat (nobs) * 10.d0 ** (-nlaht) * varht / score i=1 23112 if(.not.(i.le.nq))goto 23114 if( theta(i) .le. -25.d0 )then goto 23113 endif gra(i) = gwk1(i) / trc / trc - 2.d0 * score * gwk2(i) / trc / dflo *at(nobs) 23113 i=i+1 goto 23112 23114 continue call dscal (nq, dfloat (nobs), gra, 1) endif if( vmu .eq. 'u' )then dum = 10.d0 ** nlaht i=1 23119 if(.not.(i.le.nq))goto 23121 if( theta(i) .le. -25.d0 )then goto 23120 endif gra(i) = dum * dum * gwk1(i) - 2.d0 * varht * dum * gwk2(i) 23120 i=i+1 goto 23119 23121 continue call dscal (nq, 1.d0/dfloat (n), gra, 1) endif if( vmu .eq. 'm' )then det = 10.d0 ** (-nlaht) * varht / score i=1 23126 if(.not.(i.le.nq))goto 23128 if( theta(i) .le. -25.d0 )then goto 23127 endif gra(i) = gwk1(i) / det - dfloat (nobs) / dfloat (n) * score * gwk2 *(i) 23127 i=i+1 goto 23126 23128 continue call dscal (nq, 1.d0 / dfloat (nobs), gra, 1) endif if( vmu .eq. 'v' )then i=1 23133 if(.not.(i.le.nq))goto 23135 if( theta(i) .le. -25.d0 )then goto 23134 endif j=1 23138 if(.not.(j.le.i))goto 23140 if( theta(j) .le. -25.d0 )then goto 23139 endif hes(i,j) = hwk1(i,j) / trc / trc - 2.d0 * gwk1(i) * gwk2(j) / trc *** 3 - 2.d0 * gwk1(j) * gwk2(i) / trc ** 3 - 2.d0 * score * hwk2(i *,j) / trc / dfloat (nobs) + 6.d0 * score * gwk2(i) * gwk2(j) / trc * / trc / dfloat (nobs) 23139 j=j+1 goto 23138 23140 continue call dscal (i, dfloat (nobs), hes(i,1), ldh) 23134 i=i+1 goto 23133 23135 continue endif if( vmu .eq. 'u' )then i=1 23145 if(.not.(i.le.nq))goto 23147 if( theta(i) .le. -25.d0 )then goto 23146 endif j=1 23150 if(.not.(j.le.i))goto 23152 if( theta(j) .le. -25.d0 )then goto 23151 endif hes(i,j) = dum * dum * hwk1(i,j) - 2.d0 * varht * dum * hwk2(i,j) 23151 j=j+1 goto 23150 23152 continue call dscal (i, 1.d0/dfloat (n), hes(i,1), ldh) 23146 i=i+1 goto 23145 23147 continue endif if( vmu .eq. 'm' )then i=1 23157 if(.not.(i.le.nq))goto 23159 if( theta(i) .le. -25.d0 )then goto 23158 endif j=1 23162 if(.not.(j.le.i))goto 23164 if( theta(j) .le. -25.d0 )then goto 23163 endif hes(i,j) = hwk1(i,j) / det - gwk1(i) * gwk2(j) / det / dfloat (n) *- gwk1(j) * gwk2(i) / det / dfloat (n) - dfloat (nobs) / dfloat (n *) * score * hwk2(i,j) + dfloat (nobs) / dfloat (n) ** 2 * score * *gwk2(i) * gwk2(j) 23163 j=j+1 goto 23162 23164 continue call dscal (i, 1.d0 / dfloat (nobs), hes(i,1), ldh) 23158 i=i+1 goto 23157 23159 continue endif return end gss/src/hzdnewton.f0000644000175100001440000002033312545250042014042 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine hzdnewton (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, * qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpv *t(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qd *wt(nqd,*), prec, mchpr, wk(*) integer imrs, iwt, ifit, imu, imuwk, iv, ivwk, icdnew, iwtnew, ifi *tnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 2) ifit = iwt + nqd*nx imu = ifit + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis ifitnew = iwtnew + nqd*nx iwk = ifitnew + nt call hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs *, nqd, qdwt, nx, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(ifit) *, wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(iwtne *w), wk(ifitnew), wk(iwk), info) return end subroutine hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt *, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, mrs, wt, fit, mu, muw *k, v, vwk, jpvt, cdnew, wtnew, fitnew, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpv *t(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qd *wt(nqd,*), prec, mchpr, mrs(*), wt(nqd,*), fit(*), mu(*), muwk(*), * v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, fitmean, dasum, lkhd, mumax, lkhdnew, *disc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 j=1 23003 if(.not.(j.le.nt))goto 23005 if(cntsum.eq.0)then mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) endif 23004 j=j+1 goto 23003 23005 continue mrs(i) = mrs(i) / dfloat (nobs) 23001 i=i+1 goto 23000 23002 continue kk=1 23008 if(.not.(kk.le.nx))goto 23010 i=1 23011 if(.not.(i.le.nqd))goto 23013 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23012 i=i+1 goto 23011 23013 continue 23009 kk=kk+1 goto 23008 23010 continue fitmean = 0.d0 i=1 23014 if(.not.(i.le.nt))goto 23016 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23015 i=i+1 goto 23014 23016 continue fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 23019 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23022 if(.not.(kk.le.nx))goto 23024 i=1 23025 if(.not.(i.le.nxis))goto 23027 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23028 if(.not.(j.le.nxis))goto 23030 vwk(i,j) = 0.d0 k=1 23031 if(.not.(k.le.nqd))goto 23033 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23032 k=k+1 goto 23031 23033 continue 23029 j=j+1 goto 23028 23030 continue 23026 i=i+1 goto 23025 23027 continue call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23023 kk=kk+1 goto 23022 23024 continue i=1 23034 if(.not.(i.le.nxi))goto 23036 j=i 23037 if(.not.(j.le.nxi))goto 23039 v(i,j) = v(i,j) + q(i,j) 23038 j=j+1 goto 23037 23039 continue 23035 i=i+1 goto 23034 23036 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23040 if(.not.(i.le.nxis))goto 23042 jpvt(i) = 0 23041 i=i+1 goto 23040 23042 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23043 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23043 endif 23044 continue i=rkv+1 23045 if(.not.(i.le.nxis))goto 23047 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23046 i=i+1 goto 23045 23047 continue 23048 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23051 if(.not.(kk.le.nx))goto 23053 i=1 23054 if(.not.(i.le.nqd))goto 23056 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23056 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) 23055 i=i+1 goto 23054 23056 continue if((flag.eq.1).or.(flag.eq.3))then goto 23053 endif 23052 kk=kk+1 goto 23051 23053 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23063 if(.not.(i.le.nt))goto 23065 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23065 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23064 i=i+1 goto 23063 23065 continue fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 goto 23050 endif if(flag.eq.3)then goto 23050 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23050 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23050 endif 23049 goto 23048 23050 continue if(flag.eq.1)then flag = 2 goto 23020 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23082 if(.not.(kk.le.nx))goto 23084 i=1 23085 if(.not.(i.le.nqd))goto 23087 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23086 i=i+1 goto 23085 23087 continue 23083 kk=kk+1 goto 23082 23084 continue i=1 23088 if(.not.(i.le.nt))goto 23090 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23089 i=i+1 goto 23088 23090 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23021 endif if(disc.lt.prec)then goto 23021 endif if(iter.lt.maxiter)then goto 23020 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 flag = 2 else info = 2 goto 23021 endif 23020 goto 23019 23021 continue i=1 23099 if(.not.(i.le.nt))goto 23101 call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23100 i=i+1 goto 23099 23101 continue call dprmut (mrs, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, mrs, 11, infowk) trc = ddot (nxis*nt, rs, 1, rs, 1) - dfloat (nobs) * ddot (nxis, m *rs, 1, mrs, 1) trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) mrs(1) = fitmean mrs(2) = trc kk=1 23104 if(.not.(kk.le.nx))goto 23106 i=1 23107 if(.not.(i.le.nqd))goto 23109 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23108 i=i+1 goto 23107 23109 continue 23105 kk=kk+1 goto 23104 23106 continue return end gss/src/Makevars0000644000175100001440000000005612545250042013347 0ustar hornikusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) gss/src/smolyak.c0000644000175100001440000016503512545250042013507 0ustar hornikusers/* This is Knut Petras' smolyak.c from SMOLPACK, * modified by Chong Gu to steal the nodes and * weights of the cubature for use in the * R package gss. * * The program implements the delayed Smolyak cubature * as discussed in the references by Knut Petras: * * [1] Asymptotically minimal Smolyak cubature, 2000 * [2] Fast Calculation of Coefficients in the Smolyak Algorithm * * Chong Gu, January 27, 2002, at Purdue. */ # include # include # include /* replace # include "smolyak.h" by one line -- C. Gu */ # define maxdim 40 /* replace # include "smolyak.h" by one line -- C. Gu */ #define uniw 256 /* total # of nodes of quadrature formulae */ #define fn 9 /* # of different basic formula */ #define gesfn 50 /* # of basic formulae (incl. multiplicities) */ static double quafo; /* cubature result */ static double x[maxdim]; /* function argument */ static double xnu[fn][uniw],dnu[fn][uniw]; /* Delta-parameter */ static double fsumme, wsum, wprod, summe; /* working var's */ static int d, q; /* cubature formula parameter */ static int n[fn], ninv[fn], sw[gesfn]; /* working var's */ int count, wcount; /* counter of f-calls and coefficient calls */ static int indeces[maxdim], argind[maxdim]; /* formula and nodal indeces */ static int indsum[maxdim][maxdim]; /* parameter for 'divide et conquer' */ static int anzw[uniw], lookind[fn][uniw], invlook[fn][uniw], maxind; /* tree parameter */ static int wind[maxdim]; /* Parameter for slow coefficient calculation */ static double (*f)(int, double x[]); /* integrand (global) */ static void formula(int,int); /* sub-formula "between two dimensions" */ static double eval(int); /* sub-formula calculator */ static double fsum(int); /* sum(f(+-x_nu)) (use of symmetry) */ /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static double wtt; static void formula1(int, int, double *pt, double *wt); static void eval1(int, double *pt, double *wt); static void fsum1(int, double *pt, double *wt); /* get pt and wt from formula1, eval1, fsum1 -- C. Gu */ static void init(); /* initialization */ static double calccoeff(int); /* coefficient calculator */ static double calccoeff2(int,int); /* coefficient calculator (slow) */ static double wl(int, int, int); /* 'divide */ static double we(int, int, int); /* and */ static void sumind(int, int); /* conquer' */ /*************** tree definitions: *************************/ struct tnode { int empty; double *coeff; int *belegt; struct tnode *left; struct tnode *right; }; static struct tnode *root; static double coeff(); /* tree manager */ static struct tnode *talloc(void); /* node generator */ static void frei(struct tnode *p); /* tree eraser */ /* Start of R interface -- C. Gu */ double f_dummy(int dd, double x[]) { count++; return 1; } void size_smolyak(int *dd, int *qq, int *size) /********************** get size ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula(1,q-d); frei(root); *size = count; } void quad_smolyak(int *dd, int *qq, double *pt, double *wt) /********************** get pt and wt ***************************/ { d=*dd; q=*qq; f=f_dummy; init(); formula1(1,q-d,pt,wt); frei(root); } /* End of R interface -- C. Gu */ double int_smolyak(int dd, int qq, double(*ff)(int,double xx[]), int size) /********************** main program ***************************/ /*** for formula parameter dd<40, qq-dd<48 ******/ { /* make parameter global: */ d=dd; q=qq; f=ff; /* Initialisation */ init(); /* call of Smolyak algorithm */ formula(1,q-d); /* free space */ frei(root); /* statistics ( if desired ) */ /* if (size) { printf("%i function calls and ", count); printf("%i coefficient calculations \n", wcount);}*/ return quafo; } void formula(int k,int l) /* If k==d: evaluation. */ /* Else: */ /* determine the required formula */ /* l is the index sum that may be distributed */ /* to the remaining dimensions */ { int i; if (k==d+1) { quafo = quafo + eval(0); } else for (i=0; (i<=l) ; i++) /* Use only non-dummy-formulae */ if (sw[i]=1; j--){ /* anzw[j] to the L E F T */ if (p->left==NULL){ /* if node not existing, node generation : */ p->left = (struct tnode *) calloc(maxdim, sizeof(struct tnode)); pt=(p->left+anzw[j]); pt->left=pt->right=NULL; pt->empty = 1; p=pt;} else p=(p->left+anzw[j]); /* one to the R I G H T */ if (p->right==NULL){ /* if node not existing: */ pt=talloc(); /* node generation */ pt->empty=1; pt->left=pt->right=NULL; if (j==1){ /* leaf with coefficient */ pt->coeff=(double *) calloc(maxdim, sizeof(double)); pt->belegt=(int *) calloc(maxdim, sizeof(int)); pt->empty=0; }; p->right=pt; }; p=p->right; } if (!*(p->belegt+anzw[0])){ /* evtl. coeff.-calc. necessary */ wcount++; *(p->coeff +anzw[0]) = calccoeff(q-d); *(p->belegt+anzw[0]) =1; }; return *(p->coeff +anzw[0]); } void frei(struct tnode *p) /* tree eraser */ { if (!(p->empty)) { free (p->coeff); free (p->belegt);}; if (!(p->left ==NULL)) frei(p->left); if (!(p->right ==NULL)) frei(p->right); free(p); } struct tnode *talloc(void) /* Space for new tree-node */ { return (struct tnode *) malloc (sizeof(struct tnode)); } /******** tree-functions finished ******/ void sumind(int r, int s) /* Calculation of sums of formula indices at division of dimension r...s */ { int q; if (s==r) indsum[r][s] = ninv[indeces[r]]; else { q=(r+s)/2; sumind(r,q); sumind(q+1,s); indsum[r][s] = indsum[r][q] + indsum[q+1][s]; }; } double calccoeff (int l) { sumind(1,d); /* calculation of parameters of subdivision */ return wl(1,d,l); /* start of 'divide and conquer' */ } double wl(int r,int s, int l) /* sums in dimension s...r with sum of formula numbers <=l */ { double sum=0; int i,q, p; if (r==s) /* one-dimensional */ { p=lookind[indeces[r]][argind[r]]; for (i=ninv[indeces[r]]; i<=l; i++) { if (sw[i]=ninv[maxform+1]) maxform=maxform+1; /* total number of used 1-dim nodes */ maxind = (nj[maxform]+1)/2; /* table of 1-dim nodal numbers 0..maxind-1 corresponding to a combination formula number/nodal number and inverse formula */ lookind[0][0] = 0; for (i=1; i<=maxform; i++) { formfakt=pow(2, maxform-i); for (j=0; j<(nj[i]+1)/4; j++) lookind[i][j] = formfakt*(2*j+1); /* in a linear ordering of all used nodes, the (2j+1)-th node of the i-th basic formula is lookind[i][j]-th node */ for (j=0; j<(nj[i]+1)/2; j++) invlook[i][formfakt*j] = j; /* the lookind[i][2^(maxform-i)]-th node in a linear ordering of all used nodes is the j-th node of the i-th basic formula. Note that maxrorm is the number of used different basic formulae */ }; /* root of the coefficient TREE */ root=talloc(); root->empty=1; root->left=root->right=NULL; /* one dimensional formulae (Deltas) */ xnu[0][0] = 0.5; dnu[0][0] = 1.0; xnu[1][0] = 5.000000000000000E-001; xnu[1][1] = 8.8729833462074168851793E-001; dnu[1][0] = -5.5555555555555555555556E-001; dnu[1][1] = 2.7777777777777777777778E-001; xnu[2][0] = 5.0000000000000000000000E-001; xnu[2][1] = 7.1712187467340127900104E-001; xnu[2][2] = 8.8729833462074168851793E-001; xnu[2][3] = 9.8024563435401014171175E-001; dnu[2][0] = -2.1898617511520737327189E-001; dnu[2][1] = 2.0069870738798111145253E-001; dnu[2][2] = -1.4353373284361105741349E-001; dnu[2][3] = 5.2328113013233632596912E-002; xnu[3][0] = 5.0000000000000000000000E-001; xnu[3][1] = 6.1169334321448344081410E-001; xnu[3][2] = 7.1712187467340127900104E-001; xnu[3][3] = 8.1055147336861320147034E-001; xnu[3][4] = 8.8729833462074168851793E-001; xnu[3][5] = 9.4422961643612849944521E-001; xnu[3][6] = 9.8024563435401014171175E-001; xnu[3][7] = 9.9691598160637751110426E-001; dnu[3][0] = -1.1270301943013372747934E-001; dnu[3][1] = 1.0957842920079374820185E-001; dnu[3][2] = -1.0038444269948660093556E-001; dnu[3][3] = 8.5755954568195690393677E-002; dnu[3][4] = -6.7036417312274610184300E-002; dnu[3][5] = 4.6463597657562268842947E-002; dnu[3][6] = -2.6526471514693762748452E-002; dnu[3][7] = 8.5008598149701301695137E-003; xnu[4][0] = 5.0000000000000000000000E-001; xnu[4][1] = 5.5624447156659331287292E-001; xnu[4][2] = 6.1169334321448344081410E-001; xnu[4][3] = 6.6556769662898841654632E-001; xnu[4][4] = 7.1712187467340127900104E-001; xnu[4][5] = 7.6565987182218781198605E-001; xnu[4][6] = 8.1055147336861320147034E-001; xnu[4][7] = 8.5124810324576353930490E-001; xnu[4][8] = 8.8729833462074168851793E-001; xnu[4][9] = 9.1836296908443436775138E-001; xnu[4][10] = 9.4422961643612849944521E-001; xnu[4][11] = 9.6482742871487002833506E-001; xnu[4][12] = 9.8024563435401014171175E-001; xnu[4][13] = 9.9076557477687005343368E-001; xnu[4][14] = 9.9691598160637751110426E-001; xnu[4][15] = 9.9954906248383379883111E-001; dnu[4][0] = -5.6377621538718997889636E-002; dnu[4][1] = 5.5978436510476728440072E-002; dnu[4][2] = -5.4789218672831429083502E-002; dnu[4][3] = 5.2834946790117404871908E-002; dnu[4][4] = -5.0157125382596721131319E-002; dnu[4][5] = 4.6813554990632236808329E-002; dnu[4][6] = -4.2877994543200514816583E-002; dnu[4][7] = 3.8439810249501765521353E-002; dnu[4][8] = -3.3603750473896758409784E-002; dnu[4][9] = 2.8489754747061678706099E-002; dnu[4][10] = -2.3232151026683275572245E-002; dnu[4][11] = 1.7978551653564661048389E-002; dnu[4][12] = -1.2897842450451543066137E-002; dnu[4][13] = 8.2230249271939054668942E-003; dnu[4][14] = -4.2835769453095770463562E-003; dnu[4][15] = 1.2723903957809372077014E-003; xnu[5][0] = 5.0000000000000000000000E-001; xnu[5][1] = 5.2817215652329639498598E-001; xnu[5][2] = 5.5624447156659331287292E-001; xnu[5][3] = 5.8411762577610373249116E-001; xnu[5][4] = 6.1169334321448344081410E-001; xnu[5][5] = 6.3887491101091215753268E-001; xnu[5][6] = 6.6556769662898841654632E-001; xnu[5][7] = 6.9167966209936517345824E-001; xnu[5][8] = 7.1712187467340127900104E-001; xnu[5][9] = 7.4180901347292051378108E-001; xnu[5][10] = 7.6565987182218781198605E-001; xnu[5][11] = 7.8859785502602290742185E-001; xnu[5][12] = 8.1055147336861320147034E-001; xnu[5][13] = 8.3145483001239029773051E-001; xnu[5][14] = 8.5124810324576353930490E-001; xnu[5][15] = 8.6987802217634737933861E-001; xnu[5][16] = 8.8729833462074168851793E-001; xnu[5][17] = 9.0347026597510880592815E-001; xnu[5][18] = 9.1836296908443436775138E-001; xnu[5][19] = 9.3195396909684523857321E-001; xnu[5][20] = 9.4422961643612849944521E-001; xnu[5][21] = 9.5518557847850214624890E-001; xnu[5][22] = 9.6482742871487002833506E-001; xnu[5][23] = 9.7317142918670145257425E-001; xnu[5][24] = 9.8024563435401014171175E-001; xnu[5][25] = 9.8609143737429089828903E-001; xnu[5][26] = 9.9076557477687005343368E-001; xnu[5][27] = 9.9434237877371473996926E-001; xnu[5][28] = 9.9691598160637751110426E-001; xnu[5][29] = 9.9860312968611097953823E-001; xnu[5][30] = 9.9954906248383379883111E-001; xnu[5][31] = 9.9993644406017880596898E-001; dnu[5][0] = -2.8188814180191987109744E-002; dnu[5][1] = 2.8138849915627150636298E-002; dnu[5][2] = -2.7989218255238568736295E-002; dnu[5][3] = 2.7740702178279681993919E-002; dnu[5][4] = -2.7394605263980886602235E-002; dnu[5][5] = 2.6952749667633031963438E-002; dnu[5][6] = -2.6417473395059144940870E-002; dnu[5][7] = 2.5791626976024229388405E-002; dnu[5][8] = -2.5078569652948020678807E-002; dnu[5][9] = 2.4282165203336599357974E-002; dnu[5][10] = -2.3406777495318230607005E-002; dnu[5][11] = 2.2457265826816098707127E-002; dnu[5][12] = -2.1438980012491308330637E-002; dnu[5][13] = 2.0357755058472159466947E-002; dnu[5][14] = -1.9219905124773999502032E-002; dnu[5][15] = 1.8032216390391286320054E-002; dnu[5][16] = -1.6801938573891486499334E-002; dnu[5][17] = 1.5536775555843982439942E-002; dnu[5][18] = -1.4244877374144904399846E-002; dnu[5][19] = 1.2934839663607373455379E-002; dnu[5][20] = -1.1615723310923858549074E-002; dnu[5][21] = 1.0297116957956355574594E-002; dnu[5][22] = -8.9892758695005258819409E-003; dnu[5][23] = 7.7033752332797489010654E-003; dnu[5][24] = -6.4518989979126939693347E-003; dnu[5][25] = 5.2491234548106609491364E-003; dnu[5][26] = -4.1115209485759406322653E-003; dnu[5][27] = 3.0577534110586231698391E-003; dnu[5][28] = -2.1084676488811257036154E-003; dnu[5][29] = 1.2895248973428441362139E-003; dnu[5][30] = -6.3981211766590320201509E-004; dnu[5][31] = 1.8161074092276532984679E-004; xnu[6][0] = 5.0000000000000000000000E-001; xnu[6][1] = 5.1409232447487284716970E-001; xnu[6][2] = 5.2817215652329639498598E-001; xnu[6][3] = 5.4222702004185544185509E-001; xnu[6][4] = 5.5624447156659331287292E-001; xnu[6][5] = 5.7021211657628008729691E-001; xnu[6][6] = 5.8411762577610373249116E-001; xnu[6][7] = 5.9794875135555007695773E-001; xnu[6][8] = 6.1169334321448344081410E-001; xnu[6][9] = 6.2533936515174158830648E-001; xnu[6][10] = 6.3887491101091215753268E-001; xnu[6][11] = 6.5228822077835702166766E-001; xnu[6][12] = 6.6556769662898841654632E-001; xnu[6][13] = 6.7870191891576607618811E-001; xnu[6][14] = 6.9167966209936517345824E-001; xnu[6][15] = 7.0448991061494433620452E-001; xnu[6][16] = 7.1712187467340127900104E-001; xnu[6][17] = 7.2956500599491616643675E-001; xnu[6][18] = 7.4180901347292051378108E-001; xnu[6][19] = 7.5384387876685830107739E-001; xnu[6][20] = 7.6565987182218781198605E-001; xnu[6][21] = 7.7724756631596627443319E-001; xnu[6][22] = 7.8859785502602290742185E-001; xnu[6][23] = 7.9970196512112144648713E-001; xnu[6][24] = 8.1055147336861320147034E-001; xnu[6][25] = 8.2113832125487975688706E-001; xnu[6][26] = 8.3145483001239029773051E-001; xnu[6][27] = 8.4149371554553961404354E-001; xnu[6][28] = 8.5124810324576353930490E-001; xnu[6][29] = 8.6071154268504945774249E-001; xnu[6][30] = 8.6987802217634737933861E-001; xnu[6][31] = 8.7874198319025681896313E-001; xnu[6][32] = 8.8729833462074168851793E-001; xnu[6][33] = 8.9554246689992418071732E-001; xnu[6][34] = 9.0347026597510880592815E-001; xnu[6][35] = 9.1107812718249020368626E-001; xnu[6][36] = 9.1836296908443436775138E-001; xnu[6][37] = 9.2532224738417513987891E-001; xnu[6][38] = 9.3195396909684523857321E-001; xnu[6][39] = 9.3825670724235263487081E-001; xnu[6][40] = 9.4422961643612849944521E-001; xnu[6][41] = 9.4987244988847001831932E-001; xnu[6][42] = 9.5518557847850214624890E-001; xnu[6][43] = 9.6017001273500621036491E-001; xnu[6][44] = 9.6482742871487002833506E-001; xnu[6][45] = 9.6916019888979644182741E-001; xnu[6][46] = 9.7317142918670145257425E-001; xnu[6][47] = 9.7686500321288056820737E-001; xnu[6][48] = 9.8024563435401014171175E-001; xnu[6][49] = 9.8331892577920828354614E-001; xnu[6][50] = 9.8609143737429089828903E-001; xnu[6][51] = 9.8857075731985285707820E-001; xnu[6][52] = 9.9076557477687005343368E-001; xnu[6][53] = 9.9268574979926018555688E-001; xnu[6][54] = 9.9434237877371473996926E-001; xnu[6][55] = 9.9574786058905306619925E-001; xnu[6][56] = 9.9691598160637751110426E-001; xnu[6][57] = 9.9786205234920359425472E-001; xnu[6][58] = 9.9860312968611097953823E-001; xnu[6][59] = 9.9915831765920369626532E-001; xnu[6][60] = 9.9954906248383379883111E-001; xnu[6][61] = 9.9979939983595534162598E-001; xnu[6][62] = 9.9993644406017880596898E-001; xnu[6][63] = 9.9999121517744579929001E-001; dnu[6][0] = -1.4094407090096179346916E-002; dnu[6][1] = 1.4088159516508301065327E-002; dnu[6][2] = -1.4069424957813575318149E-002; dnu[6][3] = 1.4038227896908623303424E-002; dnu[6][4] = -1.3994609127619079851888E-002; dnu[6][5] = 1.3938625738306850804262E-002; dnu[6][6] = -1.3870351089139840996960E-002; dnu[6][7] = 1.3789874783240936517434E-002; dnu[6][8] = -1.3697302631990716258054E-002; dnu[6][9] = 1.3592756614812395909604E-002; dnu[6][10] = -1.3476374833816515981719E-002; dnu[6][11] = 1.3348311463725179953077E-002; dnu[6][12] = -1.3208736697529129965519E-002; dnu[6][13] = 1.3057836688353048840249E-002; dnu[6][14] = -1.2895813488012114694202E-002; dnu[6][15] = 1.2722884982732382906287E-002; dnu[6][16] = -1.2539284826474884353420E-002; dnu[6][17] = 1.2345262372243838454530E-002; dnu[6][18] = -1.2141082601668299678987E-002; dnu[6][19] = 1.1927026053019270040223E-002; dnu[6][20] = -1.1703388747657003100662E-002; dnu[6][21] = 1.1470482114693874380400E-002; dnu[6][22] = -1.1228632913408049353564E-002; dnu[6][23] = 1.0978183152658912469630E-002; dnu[6][24] = -1.0719490006251933623228E-002; dnu[6][25] = 1.0452925722906011926111E-002; dnu[6][26] = -1.0178877529236079733474E-002; dnu[6][27] = 9.8977475240487497440139E-003; dnu[6][28] = -9.6099525623638830096600E-003; dnu[6][29] = 9.3159241280693950931570E-003; dnu[6][30] = -9.0161081951956431600270E-003; dnu[6][31] = 8.7109650797320868735761E-003; dnu[6][32] = -8.4009692870519326354323E-003; dnu[6][33] = 8.0866093647888599709740E-003; dnu[6][34] = -7.7683877779219912199780E-003; dnu[6][35] = 7.4468208324075910174052E-003; dnu[6][36] = -7.1224386864583871530823E-003; dnu[6][37] = 6.7957855048827733947865E-003; dnu[6][38] = -6.4674198318036867280122E-003; dnu[6][39] = 6.1379152800413850434832E-003; dnu[6][40] = -5.8078616599775673581358E-003; dnu[6][41] = 5.4778666939189508240164E-003; dnu[6][42] = -5.1485584789781778127510E-003; dnu[6][43] = 4.8205888648512683476492E-003; dnu[6][44] = -4.4946378920320673048077E-003; dnu[6][45] = 4.1714193769840788527921E-003; dnu[6][46] = -3.8516876166398779769824E-003; dnu[6][47] = 3.5362449977167777340232E-003; dnu[6][48] = -3.2259500250877643515858E-003; dnu[6][49] = 2.9217249379178197537798E-003; dnu[6][50] = -2.6245617274062313865695E-003; dnu[6][51] = 2.3355251860571608737027E-003; dnu[6][52] = -2.0557519892906183110438E-003; dnu[6][53] = 1.7864463917586498246922E-003; dnu[6][54] = -1.5288767059708576017734E-003; dnu[6][55] = 1.2843824718970101865639E-003; dnu[6][56] = -1.0544075979161109798758E-003; dnu[6][57] = 8.4057143271073495315687E-004; dnu[6][58] = -6.4476285603763544016464E-004; dnu[6][59] = 4.6918492427119075039702E-004; dnu[6][60] = -3.1627461843371723357680E-004; dnu[6][61] = 1.8887332316349233013718E-004; dnu[6][62] = -9.1240958700071150936623E-005; dnu[6][63] = 2.5268047603931258812333E-005; xnu[7][0] = 5.0000000000000000000000E-001; xnu[7][1] = 5.0704694320539123130709E-001; xnu[7][2] = 5.1409232447487284716970E-001; xnu[7][3] = 5.2113458238268180160620E-001; xnu[7][4] = 5.2817215652329639498598E-001; xnu[7][5] = 5.3520348802142758953165E-001; xnu[7][6] = 5.4222702004185544185509E-001; xnu[7][7] = 5.4924119829905960104514E-001; xnu[7][8] = 5.5624447156659331287292E-001; xnu[7][9] = 5.6323529218615098342533E-001; xnu[7][10] = 5.7021211657628008729691E-001; xnu[7][11] = 5.7717340574068905434622E-001; xnu[7][12] = 5.8411762577610373249116E-001; xnu[7][13] = 5.9104324837962609912320E-001; xnu[7][14] = 5.9794875135555007695773E-001; xnu[7][15] = 6.0483261912159059738317E-001; xnu[7][16] = 6.1169334321448344081410E-001; xnu[7][17] = 6.1852942279491486360633E-001; xnu[7][18] = 6.2533936515174158830648E-001; xnu[7][19] = 6.3212168620546338097247E-001; xnu[7][20] = 6.3887491101091215753268E-001; xnu[7][21] = 6.4559757425912334098185E-001; xnu[7][22] = 6.5228822077835702166766E-001; xnu[7][23] = 6.5894540603423834159087E-001; xnu[7][24] = 6.6556769662898841654632E-001; xnu[7][25] = 6.7215367079971901138831E-001; xnu[7][26] = 6.7870191891576607618811E-001; xnu[7][27] = 6.8521104397503911506877E-001; xnu[7][28] = 6.9167966209936517345824E-001; xnu[7][29] = 6.9810640302880796959126E-001; xnu[7][30] = 7.0448991061494433620452E-001; xnu[7][31] = 7.1082884331308165002815E-001; xnu[7][32] = 7.1712187467340127900104E-001; xnu[7][33] = 7.2336769383101423687111E-001; xnu[7][34] = 7.2956500599491616643675E-001; xnu[7][35] = 7.3571253293582943846704E-001; xnu[7][36] = 7.4180901347292051378108E-001; xnu[7][37] = 7.4785320395938073008506E-001; xnu[7][38] = 7.5384387876685830107739E-001; xnu[7][39] = 7.5977983076872851099646E-001; xnu[7][40] = 7.6565987182218781198605E-001; xnu[7][41] = 7.7148283324915574524615E-001; xnu[7][42] = 7.7724756631596627443319E-001; xnu[7][43] = 7.8295294271182721131149E-001; xnu[7][44] = 7.8859785502602290742185E-001; xnu[7][45] = 7.9418121722383127071718E-001; xnu[7][46] = 7.9970196512112144648713E-001; xnu[7][47] = 8.0515905685759320007779E-001; xnu[7][48] = 8.1055147336861320147034E-001; xnu[7][49] = 8.1587821885559711520679E-001; xnu[7][50] = 8.2113832125487975688706E-001; xnu[7][51] = 8.2633083270500874805039E-001; xnu[7][52] = 8.3145483001239029773051E-001; xnu[7][53] = 8.3650941511520923959944E-001; xnu[7][54] = 8.4149371554553961404354E-001; xnu[7][55] = 8.4640688488955735144733E-001; xnu[7][56] = 8.5124810324576353930490E-001; xnu[7][57] = 8.5601657768112601729334E-001; xnu[7][58] = 8.6071154268504945774249E-001; xnu[7][59] = 8.6533226062109063066465E-001; xnu[7][60] = 8.6987802217634737933861E-001; xnu[7][61] = 8.7434814680846830141141E-001; xnu[7][62] = 8.7874198319025681896313E-001; xnu[7][63] = 8.8305890965188004535834E-001; xnu[7][64] = 8.8729833462074168851793E-001; xnu[7][65] = 8.9145969705914150819259E-001; xnu[7][66] = 8.9554246689992418071732E-001; xnu[7][67] = 8.9954614548042070089990E-001; xnu[7][68] = 9.0347026597510880592815E-001; xnu[7][69] = 9.0731439382756870671791E-001; xnu[7][70] = 9.1107812718249020368626E-001; xnu[7][71] = 9.1476109731870070008905E-001; xnu[7][72] = 9.1836296908443436775138E-001; xnu[7][73] = 9.2188344133635430051916E-001; xnu[7][74] = 9.2532224738417513987891E-001; xnu[7][75] = 9.2867915544311607826256E-001; xnu[7][76] = 9.3195396909684523857321E-001; xnu[7][77] = 9.3514652777405695292558E-001; xnu[7][78] = 9.3825670724235263487081E-001; xnu[7][79] = 9.4128442012367095342085E-001; xnu[7][80] = 9.4422961643612849944521E-001; xnu[7][81] = 9.4709228416777951142968E-001; xnu[7][82] = 9.4987244988847001831932E-001; xnu[7][83] = 9.5257017940663079759465E-001; xnu[7][84] = 9.5518557847850214624890E-001; xnu[7][85] = 9.5771879357788252032198E-001; xnu[7][86] = 9.6017001273500621036491E-001; xnu[7][87] = 9.6253946645353782618207E-001; xnu[7][88] = 9.6482742871487002833506E-001; xnu[7][89] = 9.6703421807886289399974E-001; xnu[7][90] = 9.6916019888979644182741E-001; xnu[7][91] = 9.7120578259554152990628E-001; xnu[7][92] = 9.7317142918670145257425E-001; xnu[7][93] = 9.7505764876064743827892E-001; xnu[7][94] = 9.7686500321288056820737E-001; xnu[7][95] = 9.7859410805493048136810E-001; xnu[7][96] = 9.8024563435401014171175E-001; xnu[7][97] = 9.8182031078490606626049E-001; xnu[7][98] = 9.8331892577920828354614E-001; xnu[7][99] = 9.8474232975122961588545E-001; xnu[7][100] = 9.8609143737429089828903E-001; xnu[7][101] = 9.8736722987620133388036E-001; xnu[7][102] = 9.8857075731985285707820E-001; xnu[7][103] = 9.8970314083543134190307E-001; xnu[7][104] = 9.9076557477687005343368E-001; xnu[7][105] = 9.9175932878931636438083E-001; xnu[7][106] = 9.9268574979926018555688E-001; xnu[7][107] = 9.9354626397701703359495E-001; xnu[7][108] = 9.9434237877371473996926E-001; xnu[7][109] = 9.9507568520038507959027E-001; xnu[7][110] = 9.9574786058905306619925E-001; xnu[7][111] = 9.9636067214139430766410E-001; xnu[7][112] = 9.9691598160637751110426E-001; xnu[7][113] = 9.9741575140031050025957E-001; xnu[7][114] = 9.9786205234920359425472E-001; xnu[7][115] = 9.9825707295744513692434E-001; xnu[7][116] = 9.9860312968611097953823E-001; xnu[7][117] = 9.9890267724797863728092E-001; xnu[7][118] = 9.9915831765920369626532E-001; xnu[7][119] = 9.9937280723404755735176E-001; xnu[7][120] = 9.9954906248383379883111E-001; xnu[7][121] = 9.9969016901251179096404E-001; xnu[7][122] = 9.9979939983595534162598E-001; xnu[7][123] = 9.9988024546221602366522E-001; xnu[7][124] = 9.9993644406017880596898E-001; xnu[7][125] = 9.9997199810352718788193E-001; xnu[7][126] = 9.9999121517744579929001E-001; xnu[7][127] = 9.9999879818987423231012E-001; dnu[7][0] = -7.0472035450480896734578E-003; dnu[7][1] = 7.0464225345802041774796E-003; dnu[7][2] = -7.0440797582541505326634E-003; dnu[7][3] = 7.0401759812768306624229E-003; dnu[7][4] = -7.0347124789067876590744E-003; dnu[7][5] = 7.0276910363249821385840E-003; dnu[7][6] = -7.0191139484543116517120E-003; dnu[7][7] = 7.0089840197283044049361E-003; dnu[7][8] = -6.9973045638095399259442E-003; dnu[7][9] = 6.9840794032584692578639E-003; dnu[7][10] = -6.9693128691534254021309E-003; dnu[7][11] = 6.9530098006627306317656E-003; dnu[7][12] = -6.9351755445699204984798E-003; dnu[7][13] = 6.9158159547532143382480E-003; dnu[7][14] = -6.8949373916204682587172E-003; dnu[7][15] = 6.8725467215009483161260E-003; dnu[7][16] = -6.8486513159953581290272E-003; dnu[7][17] = 6.8232590512856457141999E-003; dnu[7][18] = -6.7963783074061979548022E-003; dnu[7][19] = 6.7680179674781068068327E-003; dnu[7][20] = -6.7381874169082579908596E-003; dnu[7][21] = 6.7068965425550492564832E-003; dnu[7][22] = -6.6741557318625899765387E-003; dnu[7][23] = 6.6399758719652653251888E-003; dnu[7][24] = -6.6043683487645649827596E-003; dnu[7][25] = 6.5673450459800764181907E-003; dnu[7][26] = -6.5289183441765244201247E-003; dnu[7][27] = 6.4891011197686996429211E-003; dnu[7][28] = -6.4479067440060573471011E-003; dnu[7][29] = 6.4053490819386809834209E-003; dnu[7][30] = -6.3614424913661914531436E-003; dnu[7][31] = 6.3162018217710393822703E-003; dnu[7][32] = -6.2696424132374421767099E-003; dnu[7][33] = 6.2217800953570176315748E-003; dnu[7][34] = -6.1726311861219192272652E-003; dnu[7][35] = 6.1222124908059929493146E-003; dnu[7][36] = -6.0705413008341498394934E-003; dnu[7][37] = 6.0176353926397813152249E-003; dnu[7][38] = -5.9635130265096350201115E-003; dnu[7][39] = 5.9081929454151178816124E-003; dnu[7][40] = -5.8516943738285015503310E-003; dnu[7][41] = 5.7940370165219762842120E-003; dnu[7][42] = -5.7352410573469371902001E-003; dnu[7][43] = 5.6753271579902983008672E-003; dnu[7][44] = -5.6143164567040246767818E-003; dnu[7][45] = 5.5522305670034632684997E-003; dnu[7][46] = -5.4890915763294562348151E-003; dnu[7][47] = 5.4249220446686570495123E-003; dnu[7][48] = -5.3597450031259668116140E-003; dnu[7][49] = 5.2935839524425989654714E-003; dnu[7][50] = -5.2264628614530059630555E-003; dnu[7][51] = 5.1584061654738108409604E-003; dnu[7][52] = -5.0894387646180398667368E-003; dnu[7][53] = 5.0195860220284203990905E-003; dnu[7][54] = -4.9488737620243748720069E-003; dnu[7][55] = 4.8773282681587057305415E-003; dnu[7][56] = -4.8049762811819415048301E-003; dnu[7][57] = 4.7318449969150326471362E-003; dnu[7][58] = -4.6579620640346975465785E-003; dnu[7][59] = 4.5833555817803942033526E-003; dnu[7][60] = -4.5080540975978215800133E-003; dnu[7][61] = 4.4320866047412471320571E-003; dnu[7][62] = -4.3554825398660434367881E-003; dnu[7][63] = 4.2782717806538448095865E-003; dnu[7][64] = -4.2004846435259663177174E-003; dnu[7][65] = 4.1221518815164340152753E-003; dnu[7][66] = -4.0433046823944299854870E-003; dnu[7][67] = 3.9639746671474245551263E-003; dnu[7][68] = -3.8841938889609956099821E-003; dnu[7][69] = 3.8039948328595282916087E-003; dnu[7][70] = -3.7234104162037955087026E-003; dnu[7][71] = 3.6424739902769035319399E-003; dnu[7][72] = -3.5612193432291935765854E-003; dnu[7][73] = 3.4796807046952114697225E-003; dnu[7][74] = -3.3978927524413866973932E-003; dnu[7][75] = 3.3158906214509439470610E-003; dnu[7][76] = -3.2337099159018433636835E-003; dnu[7][77] = 3.1513867245428793585820E-003; dnu[7][78] = -3.0689576400206925217416E-003; dnu[7][79] = 2.9864597827540829024736E-003; dnu[7][80] = -2.9039308299887836817462E-003; dnu[7][81] = 2.8214090506922220792273E-003; dnu[7][82] = -2.7389333469594754120082E-003; dnu[7][83] = 2.6565433025935282831440E-003; dnu[7][84] = -2.5742792394890888809216E-003; dnu[7][85] = 2.4921822823827693006000E-003; dnu[7][86] = -2.4102944324256341738246E-003; dnu[7][87] = 2.3286586498784273886390E-003; dnu[7][88] = -2.2473189460160339308202E-003; dnu[7][89] = 2.1663204840464914272688E-003; dnu[7][90] = -2.0857096884920394263960E-003; dnu[7][91] = 2.0055343620375116994450E-003; dnu[7][92] = -1.9258438083199354620415E-003; dnu[7][93] = 1.8466889585128254091286E-003; dnu[7][94] = -1.7681224988583888670116E-003; dnu[7][95] = 1.6901989955434601911750E-003; dnu[7][96] = -1.6129750125439342307013E-003; dnu[7][97] = 1.5365092173512891617039E-003; dnu[7][98] = -1.4608624689589098768899E-003; dnu[7][99] = 1.3860978822967254969976E-003; dnu[7][100] = -1.3122808637022147812835E-003; dnu[7][101] = 1.2394791133287839653391E-003; dnu[7][102] = -1.1677625930285804368514E-003; dnu[7][103] = 1.0972034626819194194015E-003; dnu[7][104] = -1.0278759946636732617923E-003; dnu[7][105] = 9.5985648550693620626136E-004; dnu[7][106] = -8.9322319587932491235173E-004; dnu[7][107] = 8.2805636407722630260841E-004; dnu[7][108] = -7.6443835254388278387516E-004; dnu[7][109] = 7.0245399782757232135761E-004; dnu[7][110] = -6.4219123594850509816130E-004; dnu[7][111] = 5.8374205871497970384667E-004; dnu[7][112] = -5.2720381143165805354149E-004; dnu[7][113] = 4.7268075842926269123151E-004; dnu[7][114] = -4.2028571635537372133344E-004; dnu[7][115] = 3.7014140212225166523158E-004; dnu[7][116] = -3.2238102065234630638566E-004; dnu[7][117] = 2.7714765746518735745887E-004; dnu[7][118] = -2.3459246214726554551974E-004; dnu[7][119] = 1.9487264223664114660778E-004; dnu[7][120] = -1.5815182927018453366651E-004; dnu[7][121] = 1.2460620024149864701227E-004; dnu[7][122] = -9.4436690910239873306717E-005; dnu[7][123] = 6.7877455474614359864921E-005; dnu[7][124] = -4.5183414893318604279565E-005; dnu[7][125] = 2.6637646834890306562676E-005; dnu[7][126] = -1.2689112411790928068031E-005; dnu[7][127] = 3.4689682162054133584769E-006; xnu[8][0] = 5.0000000000000000000000E-001; xnu[8][1] = 5.0352356922966837324257E-001; xnu[8][2] = 5.0704694320539123130709E-001; xnu[8][3] = 5.1056992668916554416748E-001; xnu[8][4] = 5.1409232447487284716970E-001; xnu[8][5] = 5.1761394140422051163016E-001; xnu[8][6] = 5.2113458238268180160620E-001; xnu[8][7] = 5.2465405239543431335782E-001; xnu[8][8] = 5.2817215652329639498598E-001; xnu[8][9] = 5.3168869995866114493983E-001; xnu[8][10] = 5.3520348802142758953165E-001; xnu[8][11] = 5.3871632617492864128376E-001; xnu[8][12] = 5.4222702004185544185509E-001; xnu[8][13] = 5.4573537542017769545473E-001; xnu[8][14] = 5.4924119829905960104514E-001; xnu[8][15] = 5.5274429487477099426633E-001; xnu[8][16] = 5.5624447156659331287292E-001; xnu[8][17] = 5.5974153503272000256669E-001; xnu[8][18] = 5.6323529218615098342533E-001; xnu[8][19] = 5.6672555021058080067206E-001; xnu[8][20] = 5.7021211657628008729691E-001; xnu[8][21] = 5.7369479905596997002704E-001; xnu[8][22] = 5.7717340574068905434622E-001; xnu[8][23] = 5.8064774505565262868030E-001; xnu[8][24] = 5.8411762577610373249116E-001; xnu[8][25] = 5.8758285704315573785372E-001; xnu[8][26] = 5.9104324837962609912320E-001; xnu[8][27] = 5.9449860970586093052960E-001; xnu[8][28] = 5.9794875135555007695773E-001; xnu[8][29] = 6.0139348409153234877826E-001; xnu[8][30] = 6.0483261912159059738317E-001; xnu[8][31] = 6.0826596811423631404069E-001; xnu[8][32] = 6.1169334321448344081410E-001; xnu[8][33] = 6.1511455705961108857785E-001; xnu[8][34] = 6.1852942279491486360633E-001; xnu[8][35] = 6.2193775408944651079646E-001; xnu[8][36] = 6.2533936515174158830648E-001; xnu[8][37] = 6.2873407074553489524063E-001; xnu[8][38] = 6.3212168620546338097247E-001; xnu[8][39] = 6.3550202745275627176810E-001; xnu[8][40] = 6.3887491101091215753268E-001; xnu[8][41] = 6.4224015402136278874800E-001; xnu[8][42] = 6.4559757425912334098185E-001; xnu[8][43] = 6.4894699014842891171828E-001; xnu[8][44] = 6.5228822077835702166766E-001; xnu[8][45] = 6.5562108591843590015010E-001; xnu[8][46] = 6.5894540603423834159087E-001; xnu[8][47] = 6.6226100230296092760332E-001; xnu[8][48] = 6.6556769662898841654632E-001; xnu[8][49] = 6.6886531165944310981029E-001; xnu[8][50] = 6.7215367079971901138831E-001; xnu[8][51] = 6.7543259822900060450540E-001; xnu[8][52] = 6.7870191891576607618811E-001; xnu[8][53] = 6.8196145863327482763471E-001; xnu[8][54] = 6.8521104397503911506877E-001; xnu[8][55] = 6.8845050237027967240092E-001; xnu[8][56] = 6.9167966209936517345824E-001; xnu[8][57] = 6.9489835230923539773967E-001; xnu[8][58] = 6.9810640302880796959126E-001; xnu[8][59] = 7.0130364518436854633556E-001; xnu[8][60] = 7.0448991061494433620452E-001; xnu[8][61] = 7.0766503208766083188217E-001; xnu[8][62] = 7.1082884331308165002815E-001; xnu[8][63] = 7.1398117896053137129164E-001; xnu[8][64] = 7.1712187467340127900104E-001; xnu[8][65] = 7.2025076708443789789144E-001; xnu[8][66] = 7.2336769383101423687111E-001; xnu[8][67] = 7.2647249357038364189194E-001; xnu[8][68] = 7.2956500599491616643675E-001; xnu[8][69] = 7.3264507184731736792908E-001; xnu[8][70] = 7.3571253293582943846704E-001; xnu[8][71] = 7.3876723214941457764179E-001; xnu[8][72] = 7.4180901347292051378108E-001; xnu[8][73] = 7.4483772200222807771818E-001; xnu[8][74] = 7.4785320395938073008506E-001; xnu[8][75] = 7.5085530670769593912527E-001; xnu[8][76] = 7.5384387876685830107739E-001; xnu[8][77] = 7.5681876982799428925371E-001; xnu[8][78] = 7.5977983076872851099646E-001; xnu[8][79] = 7.6272691366822134369754E-001; xnu[8][80] = 7.6565987182218781198605E-001; xnu[8][81] = 7.6857855975789755799089E-001; xnu[8][82] = 7.7148283324915574524615E-001; xnu[8][83] = 7.7437254933126472430380E-001; xnu[8][84] = 7.7724756631596627443319E-001; xnu[8][85] = 7.8010774380636422090881E-001; xnu[8][86] = 7.8295294271182721131149E-001; xnu[8][87] = 7.8578302526287141699609E-001; xnu[8][88] = 7.8859785502602290742185E-001; xnu[8][89] = 7.9139729691865942541974E-001; xnu[8][90] = 7.9418121722383127071718E-001; xnu[8][91] = 7.9694948360506097719637E-001; xnu[8][92] = 7.9970196512112144648713E-001; xnu[8][93] = 8.0243853224079217665963E-001; xnu[8][94] = 8.0515905685759320007779E-001; xnu[8][95] = 8.0786341230449631900687E-001; xnu[8][96] = 8.1055147336861320147034E-001; xnu[8][97] = 8.1322311630585987327081E-001; xnu[8][98] = 8.1587821885559711520679E-001; xnu[8][99] = 8.1851666025524624753565E-001; xnu[8][100] = 8.2113832125487975688706E-001; xnu[8][101] = 8.2374308413178619439088E-001; xnu[8][102] = 8.2633083270500874805039E-001; xnu[8][103] = 8.2890145234985686771097E-001; xnu[8][104] = 8.3145483001239029773051E-001; xnu[8][105] = 8.3399085422387485108267E-001; xnu[8][106] = 8.3650941511520923959944E-001; xnu[8][107] = 8.3901040443132225891910E-001; xnu[8][108] = 8.4149371554553961404354E-001; xnu[8][109] = 8.4395924347391966287784E-001; xnu[8][110] = 8.4640688488955735144733E-001; xnu[8][111] = 8.4883653813685561645313E-001; xnu[8][112] = 8.5124810324576353930490E-001; xnu[8][113] = 8.5364148194598055170579E-001; xnu[8][114] = 8.5601657768112601729334E-001; xnu[8][115] = 8.5837329562287354788348E-001; xnu[8][116] = 8.6071154268504945774249E-001; xnu[8][117] = 8.6303122753769481634259E-001; xnu[8][118] = 8.6533226062109063066465E-001; xnu[8][119] = 8.6761455415974577383172E-001; xnu[8][120] = 8.6987802217634737933861E-001; xnu[8][121] = 8.7212258050567354115472E-001; xnu[8][122] = 8.7434814680846830141141E-001; xnu[8][123] = 8.7655464058527907126126E-001; xnu[8][124] = 8.7874198319025681896313E-001; xnu[8][125] = 8.8091009784491957458672E-001; xnu[8][126] = 8.8305890965188004535834E-001; xnu[8][127] = 8.8518834560853841213875E-001; xnu[8][128] = 8.8729833462074168851793E-001; xnu[8][129] = 8.8938880751641137235105E-001; xnu[8][130] = 8.9145969705914150819259E-001; xnu[8][131] = 8.9351093796176971108496E-001; xnu[8][132] = 8.9554246689992418071732E-001; xnu[8][133] = 8.9755422252555026338988E-001; xnu[8][134] = 8.9954614548042070089990E-001; xnu[8][135] = 9.0151817840963434389085E-001; xnu[8][136] = 9.0347026597510880592815E-001; xnu[8][137] = 9.0540235486907329718058E-001; xnu[8][138] = 9.0731439382756870671791E-001; xnu[8][139] = 9.0920633364396290369770E-001; xnu[8][140] = 9.1107812718249020368626E-001; xnu[8][141] = 9.1292972939182500054383E-001; xnu[8][142] = 9.1476109731870070008905E-001; xnu[8][143] = 9.1657219012158631236397E-001; xnu[8][144] = 9.1836296908443436775138E-001; xnu[8][145] = 9.2013339763051522117512E-001; xnu[8][146] = 9.2188344133635430051916E-001; xnu[8][147] = 9.2361306794579044219027E-001; xnu[8][148] = 9.2532224738417513987891E-001; xnu[8][149] = 9.2701095177273431290670E-001; xnu[8][150] = 9.2867915544311607826256E-001; xnu[8][151] = 9.3032683495214998490117E-001; xnu[8][152] = 9.3195396909684523857321E-001; xnu[8][153] = 9.3356053892965760780721E-001; xnu[8][154] = 9.3514652777405695292558E-001; xnu[8][155] = 9.3671192124042965509622E-001; xnu[8][156] = 9.3825670724235263487081E-001; xnu[8][157] = 9.3978087601327813128378E-001; xnu[8][158] = 9.4128442012367095342085E-001; xnu[8][159] = 9.4276733449864250446303E-001; xnu[8][160] = 9.4422961643612849944521E-001; xnu[8][161] = 9.4567126562565993583304E-001; xnu[8][162] = 9.4709228416777951142968E-001; xnu[8][163] = 9.4849267659415829518778E-001; xnu[8][164] = 9.4987244988847001831932E-001; xnu[8][165] = 9.5123161350808283752414E-001; xnu[8][166] = 9.5257017940663079759465E-001; xnu[8][167] = 9.5388816205752945181220E-001; xnu[8][168] = 9.5518557847850214624890E-001; xnu[8][169] = 9.5646244825718529503981E-001; xnu[8][170] = 9.5771879357788252032198E-001; xnu[8][171] = 9.5895463924953875081824E-001; xnu[8][172] = 9.6017001273500621036491E-001; xnu[8][173] = 9.6136494418167462076137E-001; xnu[8][174] = 9.6253946645353782618207E-001; xnu[8][175] = 9.6369361516476834842161E-001; xnu[8][176] = 9.6482742871487002833506E-001; xnu[8][177] = 9.6594094832547681967268E-001; xnu[8][178] = 9.6703421807886289399974E-001; xnu[8][179] = 9.6810728495822540331247E-001; xnu[8][180] = 9.6916019888979644182741E-001; xnu[8][181] = 9.7019301278683486068516E-001; xnu[8][182] = 9.7120578259554152990628E-001; xnu[8][183] = 9.7219856734293332429533E-001; xnu[8][184] = 9.7317142918670145257425E-001; xnu[8][185] = 9.7412443346706867853133E-001; xnu[8][186] = 9.7505764876064743827892E-001; xnu[8][187] = 9.7597114693628679474913E-001; xnu[8][188] = 9.7686500321288056820737E-001; xnu[8][189] = 9.7773929621909184878677E-001; xnu[8][190] = 9.7859410805493048136810E-001; xnu[8][191] = 9.7942952435510011067792E-001; xnu[8][192] = 9.8024563435401014171175E-001; xnu[8][193] = 9.8104253095232573787034E-001; xnu[8][194] = 9.8182031078490606626049E-001; xnu[8][195] = 9.8257907428995783298937E-001; xnu[8][196] = 9.8331892577920828354614E-001; xnu[8][197] = 9.8403997350887997398176E-001; xnu[8][198] = 9.8474232975122961588545E-001; xnu[8][199] = 9.8542611086639622162798E-001; xnu[8][200] = 9.8609143737429089828903E-001; xnu[8][201] = 9.8673843402625346338665E-001; xnu[8][202] = 9.8736722987620133388036E-001; xnu[8][203] = 9.8797795835100587656440E-001; xnu[8][204] = 9.8857075731985285707820E-001; xnu[8][205] = 9.8914576916237926976304E-001; xnu[8][206] = 9.8970314083543134190307E-001; xnu[8][207] = 9.9024302393836066970799E-001; xnu[8][208] = 9.9076557477687005343368E-001; xnu[8][209] = 9.9127095442554030212529E-001; xnu[8][210] = 9.9175932878931636438083E-001; xnu[8][211] = 9.9223086866440726729820E-001; xnu[8][212] = 9.9268574979926018555688E-001; xnu[8][213] = 9.9312415295650377634075E-001; xnu[8][214] = 9.9354626397701703359495E-001; xnu[8][215] = 9.9395227384756214023332E-001; xnu[8][216] = 9.9434237877371473996926E-001; xnu[8][217] = 9.9471678026012041935822E-001; xnu[8][218] = 9.9507568520038507959027E-001; xnu[8][219] = 9.9541930597914712183853E-001; xnu[8][220] = 9.9574786058905306619925E-001; xnu[8][221] = 9.9606157276543155884129E-001; xnu[8][222] = 9.9636067214139430766410E-001; xnu[8][223] = 9.9664539442584248310532E-001; xnu[8][224] = 9.9691598160637751110426E-001; xnu[8][225] = 9.9717268217836170296553E-001; xnu[8][226] = 9.9741575140031050025957E-001; xnu[8][227] = 9.9764545157440515113072E-001; xnu[8][228] = 9.9786205234920359425472E-001; xnu[8][229] = 9.9806583103965751889305E-001; xnu[8][230] = 9.9825707295744513692434E-001; xnu[8][231] = 9.9843607174263008064974E-001; xnu[8][232] = 9.9860312968611097953823E-001; xnu[8][233] = 9.9875855803173619998262E-001; xnu[8][234] = 9.9890267724797863728092E-001; xnu[8][235] = 9.9903581726246516165093E-001; xnu[8][236] = 9.9915831765920369626532E-001; xnu[8][237] = 9.9927052784858395301327E-001; xnu[8][238] = 9.9937280723404755735176E-001; xnu[8][239] = 9.9946552541540528111790E-001; xnu[8][240] = 9.9954906248383379883111E-001; xnu[8][241] = 9.9962380947167123679948E-001; xnu[8][242] = 9.9969016901251179096404E-001; xnu[8][243] = 9.9974855623359359526763E-001; xnu[8][244] = 9.9979939983595534162598E-001; xnu[8][245] = 9.9984314322415886588808E-001; xnu[8][246] = 9.9988024546221602366522E-001; xnu[8][247] = 9.9991118183989386959794E-001; xnu[8][248] = 9.9993644406017880596898E-001; xnu[8][249] = 9.9995654057233914140003E-001; xnu[8][250] = 9.9997199810352718788193E-001; xnu[8][251] = 9.9998336504924313844142E-001; xnu[8][252] = 9.9999121517744579929001E-001; xnu[8][253] = 9.9999614906812879401388E-001; xnu[8][254] = 9.9999879818987423231012E-001; xnu[8][255] = 9.9999983647836719219063E-001; dnu[8][0] = -3.5236017725240448367289E-003; dnu[8][1] = 3.5235041442227400686498E-003; dnu[8][2] = -3.5232112672901020887398E-003; dnu[8][3] = 3.5227231656397573838983E-003; dnu[8][4] = -3.5220398791270752663317E-003; dnu[8][5] = 3.5211614635481560479832E-003; dnu[8][6] = -3.5200879906384153312115E-003; dnu[8][7] = 3.5188195480707652615937E-003; dnu[8][8] = -3.5173562394533938295372E-003; dnu[8][9] = 3.5156981843271435475412E-003; dnu[8][10] = -3.5138455181624910692920E-003; dnu[8][11] = 3.5117983923561295551537E-003; dnu[8][12] = -3.5095569742271558258560E-003; dnu[8][13] = 3.5071214470128645821259E-003; dnu[8][14] = -3.5044920098641522024681E-003; dnu[8][15] = 3.5016688778405328640984E-003; dnu[8][16] = -3.4986522819047699629721E-003; dnu[8][17] = 3.4954424689171260377234E-003; dnu[8][18] = -3.4920397016292346289319E-003; dnu[8][19] = 3.4884442586775977292236E-003; dnu[8][20] = -3.4846564345767127010655E-003; dnu[8][21] = 3.4806765397118327574657E-003; dnu[8][22] = -3.4765049003313653158828E-003; dnu[8][23] = 3.4721418585389127471901E-003; dnu[8][24] = -3.4675877722849602492399E-003; dnu[8][25] = 3.4628430153582157781065E-003; dnu[8][26] = -3.4579079773766071691240E-003; dnu[8][27] = 3.4527830637779417740149E-003; dnu[8][28] = -3.4474686958102341293586E-003; dnu[8][29] = 3.4419653105217073549737E-003; dnu[8][30] = -3.4362733607504741580630E-003; dnu[8][31] = 3.4303933151139034897570E-003; dnu[8][32] = -3.4243256579976790645136E-003; dnu[8][33] = 3.4180708895445561092032E-003; dnu[8][34] = -3.4116295256428228571000E-003; dnu[8][35] = 3.4050020979144734418687E-003; dnu[8][36] = -3.3981891537030989774011E-003; dnu[8][37] = 3.3911912560615037304123E-003; dnu[8][38] = -3.3840089837390534034163E-003; dnu[8][39] = 3.3766429311687626453919E-003; dnu[8][40] = -3.3690937084541289954298E-003; dnu[8][41] = 3.3613619413557205401809E-003; dnu[8][42] = -3.3534482712775246282416E-003; dnu[8][43] = 3.3453533552530650329179E-003; dnu[8][44] = -3.3370778659312949882693E-003; dnu[8][45] = 3.3286224915622735410861E-003; dnu[8][46] = -3.3199879359826326625944E-003; dnu[8][47] = 3.3111749186008425472876E-003; dnu[8][48] = -3.3021841743822824913798E-003; dnu[8][49] = 3.2930164538341246889724E-003; dnu[8][50] = -3.2836725229900382090953E-003; dnu[8][51] = 3.2741531633947203202702E-003; dnu[8][52] = -3.2644591720882622100624E-003; dnu[8][53] = 3.2545913615903560041347E-003; dnu[8][54] = -3.2445505598843498214605E-003; dnu[8][55] = 3.2343376104011574084413E-003; dnu[8][56] = -3.2239533720030286735506E-003; dnu[8][57] = 3.2133987189671871946092E-003; dnu[8][58] = -3.2026745409693404917104E-003; dnu[8][59] = 3.1917817430670685489766E-003; dnu[8][60] = -3.1807212456830957265718E-003; dnu[8][61] = 3.1694939845884508295582E-003; dnu[8][62] = -3.1581009108855196911351E-003; dnu[8][63] = 3.1465429909909941834386E-003; dnu[8][64] = -3.1348212066187210883550E-003; dnu[8][65] = 3.1229365547624537427064E-003; dnu[8][66] = -3.1108900476785088157874E-003; dnu[8][67] = 3.0986827128683299817099E-003; dnu[8][68] = -3.0863155930609596136326E-003; dnu[8][69] = 3.0737897461954189510710E-003; dnu[8][70] = -3.0611062454029964746573E-003; dnu[8][71] = 3.0482661789894434646161E-003; dnu[8][72] = -3.0352706504170749197467E-003; dnu[8][73] = 3.0221207782867731729442E-003; dnu[8][74] = -3.0088176963198906576125E-003; dnu[8][75] = 2.9953625533400473573579E-003; dnu[8][76] = -2.9817565132548175100558E-003; dnu[8][77] = 2.9680007550372991380706E-003; dnu[8][78] = -2.9540964727075589408062E-003; dnu[8][79] = 2.9400448753139440160228E-003; dnu[8][80] = -2.9258471869142507751655E-003; dnu[8][81] = 2.9115046465567402885106E-003; dnu[8][82] = -2.8970185082609881421060E-003; dnu[8][83] = 2.8823900409985557147716E-003; dnu[8][84] = -2.8676205286734685951001E-003; dnu[8][85] = 2.8527112701024866615598E-003; dnu[8][86] = -2.8376635789951491504336E-003; dnu[8][87] = 2.8224787839335768444255E-003; dnu[8][88] = -2.8071582283520123383909E-003; dnu[8][89] = 2.7917032705160781880498E-003; dnu[8][90] = -2.7761152835017316342499E-003; dnu[8][91] = 2.7603956551738935322869E-003; dnu[8][92] = -2.7445457881647281174076E-003; dnu[8][93] = 2.7285670998515493199771E-003; dnu[8][94] = -2.7124610223343285247561E-003; dnu[8][95] = 2.6962290024127779680319E-003; dnu[8][96] = -2.6798725015629834058070E-003; dnu[8][97] = 2.6633929959135592898706E-003; dnu[8][98] = -2.6467919762212994827357E-003; dnu[8][99] = 2.6300709478462965560248E-003; dnu[8][100] = -2.6132314307265029815277E-003; dnu[8][101] = 2.5962749593517080743133E-003; dnu[8][102] = -2.5792030827369054204802E-003; dnu[8][103] = 2.5620173643950267591546E-003; dnu[8][104] = -2.5447193823090199333684E-003; dnu[8][105] = 2.5273107289032506252914E-003; dnu[8][106] = -2.5097930110142101995453E-003; dnu[8][107] = 2.4921678498605151495699E-003; dnu[8][108] = -2.4744368810121874360035E-003; dnu[8][109] = 2.4566017543592094868339E-003; dnu[8][110] = -2.4386641340793528652707E-003; dnu[8][111] = 2.4206256986052856760690E-003; dnu[8][112] = -2.4024881405909707524150E-003; dnu[8][113] = 2.3842531668773746263160E-003; dnu[8][114] = -2.3659224984575163235681E-003; dnu[8][115] = 2.3474978704408952326600E-003; dnu[8][116] = -2.3289810320173487732893E-003; dnu[8][117] = 2.3103737464204034374082E-003; dnu[8][118] = -2.2916777908901971016763E-003; dnu[8][119] = 2.2728949566360664274378E-003; dnu[8][120] = -2.2540270487989107900066E-003; dnu[8][121] = 2.2350758864134636345022E-003; dnu[8][122] = -2.2160433023706235660286E-003; dnu[8][123] = 2.1969311433800209763024E-003; dnu[8][124] = -2.1777412699330217183940E-003; dnu[8][125] = 2.1584755562663973996390E-003; dnu[8][126] = -2.1391358903269224047932E-003; dnu[8][127] = 2.1197241737371909221716E-003; dnu[8][128] = -2.1002423217629831588587E-003; dnu[8][129] = 2.0806922632825487288194E-003; dnu[8][130] = -2.0610759407582170076376E-003; dnu[8][131] = 2.0413953102107891917508E-003; dnu[8][132] = -2.0216523411972149927435E-003; dnu[8][133] = 2.0018490167921084428078E-003; dnu[8][134] = -1.9819873335737122775631E-003; dnu[8][135] = 1.9620693016149788733009E-003; dnu[8][136] = -1.9420969444804978049911E-003; dnu[8][137] = 1.9220722992300657945837E-003; dnu[8][138] = -1.9019974164297641458043E-003; dnu[8][139] = 1.8818743601714816912025E-003; dnu[8][140] = -1.8617052081018977543513E-003; dnu[8][141] = 1.8414920514620195598335E-003; dnu[8][142] = -1.8212369951384517659700E-003; dnu[8][143] = 1.8009421577276621593433E-003; dnu[8][144] = -1.7806096716145967882927E-003; dnu[8][145] = 1.7602416830670896134102E-003; dnu[8][146] = -1.7398403523476057348613E-003; dnu[8][147] = 1.7194078538439529593811E-003; dnu[8][148] = -1.6989463762206933486966E-003; dnu[8][149] = 1.6784581225930838067080E-003; dnu[8][150] = -1.6579453107254719735305E-003; dnu[8][151] = 1.6374101732561698478224E-003; dnu[8][152] = -1.6168549579509216818417E-003; dnu[8][153] = 1.5962819279871736839512E-003; dnu[8][154] = -1.5756933622714396792910E-003; dnu[8][155] = 1.5550915557921377307891E-003; dnu[8][156] = -1.5344788200103462608708E-003; dnu[8][157] = 1.5138574832909927223987E-003; dnu[8][158] = -1.4932298913770414512368E-003; dnu[8][159] = 1.4725984079092879114196E-003; dnu[8][160] = -1.4519654149943918408731E-003; dnu[8][161] = 1.4313333138237893412643E-003; dnu[8][162] = -1.4107045253461110396137E-003; dnu[8][163] = 1.3900814909956971752233E-003; dnu[8][164] = -1.3694666734797377060041E-003; dnu[8][165] = 1.3488625576264729333326E-003; dnu[8][166] = -1.3282716512967641415720E-003; dnu[8][167] = 1.3076964863611805461264E-003; dnu[8][168] = -1.2871396197445444404608E-003; dnu[8][169] = 1.2666036345396266287484E-003; dnu[8][170] = -1.2460911411913846503000E-003; dnu[8][171] = 1.2256047787527824196154E-003; dnu[8][172] = -1.2051472162128170869123E-003; dnu[8][173] = 1.1847211538969024757289E-003; dnu[8][174] = -1.1643293249392136943195E-003; dnu[8][175] = 1.1439744968259798618913E-003; dnu[8][176] = -1.1236594730080169654101E-003; dnu[8][177] = 1.1033870945800166459678E-003; dnu[8][178] = -1.0831602420232457136344E-003; dnu[8][179] = 1.0629818370073626652228E-003; dnu[8][180] = -1.0428548442460197131980E-003; dnu[8][181] = 1.0227822733997914672317E-003; dnu[8][182] = -1.0027671810187558497225E-003; dnu[8][183] = 9.8281267251575273865993E-004; dnu[8][184] = -9.6292190415996773102075E-004; dnu[8][185] = 9.4309808507904237696790E-004; dnu[8][186] = -9.2334447925641270456432E-004; dnu[8][187] = 9.0366440750904465039505E-004; dnu[8][188] = -8.8406124942919443350579E-004; dnu[8][189] = 8.6453844527230803583806E-004; dnu[8][190] = -8.4509949777173009558748E-004; dnu[8][191] = 8.2574797385957285327574E-004; dnu[8][192] = -8.0648750627196711535064E-004; dnu[8][193] = 7.8732179501606083094277E-004; dnu[8][194] = -7.6825460867564458085196E-004; dnu[8][195] = 7.4928978553228318107157E-004; dnu[8][196] = -7.3043123447945493844494E-004; dnu[8][197] = 7.1168293570860259950151E-004; dnu[8][198] = -6.9304894114836274849880E-004; dnu[8][199] = 6.7453337464176556563600E-004; dnu[8][200] = -6.5614043185110739064173E-004; dnu[8][201] = 6.3787437988673473672259E-004; dnu[8][202] = -6.1973955666439198266955E-004; dnu[8][203] = 6.0174037000632982440356E-004; dnu[8][204] = -5.8388129651429021842567E-004; dnu[8][205] = 5.6616688025798832458331E-004; dnu[8][206] = -5.4860173134095970970073E-004; dnu[8][207] = 5.3119052442670035687534E-004; dnu[8][208] = -5.1393799733183663089639E-004; dnu[8][209] = 4.9684894981938042897235E-004; dnu[8][210] = -4.7992824275346810313068E-004; dnu[8][211] = 4.6318079780655564168411E-004; dnu[8][212] = -4.4661159793966245617026E-004; dnu[8][213] = 4.3022568890426392406400E-004; dnu[8][214] = -4.1402818203861315130421E-004; dnu[8][215] = 3.9802425864877543575304E-004; dnu[8][216] = -3.8221917627194139209526E-004; dnu[8][217] = 3.6661827711238395602767E-004; dnu[8][218] = -3.5122699891378616067880E-004; dnu[8][219] = 3.3605088848005409732297E-004; dnu[8][220] = -3.2109561797425254420128E-004; dnu[8][221] = 3.0636700400611260464706E-004; dnu[8][222] = -2.9187102935748985192333E-004; dnu[8][223] = 2.7761386698865378985736E-004; dnu[8][224] = -2.6360190571582919306239E-004; dnu[8][225] = 2.4984177665640024225928E-004; dnu[8][226] = -2.3634037921463134561575E-004; dnu[8][227] = 2.2310490505070162374404E-004; dnu[8][228] = -2.1014285817768061591171E-004; dnu[8][229] = 1.9746206912343685221695E-004; dnu[8][230] = -1.8507070106112583261579E-004; dnu[8][231] = 1.7297724606495193567507E-004; dnu[8][232] = -1.6119051032643119483180E-004; dnu[8][233] = 1.4971958842545586543710E-004; dnu[8][234] = -1.3857382873259367872945E-004; dnu[8][235] = 1.2776279479761843100676E-004; dnu[8][236] = -1.1729623106196260243797E-004; dnu[8][237] = 1.0718404501710846857448E-004; dnu[8][238] = -9.7436321118320573341744E-005; dnu[8][239] = 8.8063382772541597737195E-005; dnu[8][240] = -7.9075915205566116981157E-005; dnu[8][241] = 7.0485151102052395706581E-005; dnu[8][242] = -6.2303100120749462771247E-005; dnu[8][243] = 5.4542772822870761025480E-005; dnu[8][244] = -4.7218316126617180477170E-005; dnu[8][245] = 4.0344961400701764692553E-005; dnu[8][246] = -3.3938727737915739053586E-005; dnu[8][247] = 2.8015975392808212607024E-005; dnu[8][248] = -2.2593183623060767475330E-005; dnu[8][249] = 1.7687568602759479431384E-005; dnu[8][250] = -1.3318826217940261494781E-005; dnu[8][251] = 9.5106840952937908339661E-006; dnu[8][252] = -6.2892960976606935680311E-006; dnu[8][253] = 3.6831203455116083442839E-006; dnu[8][254] = -1.7416856803596676839876E-006; dnu[8][255] = 4.7285796697500352441360E-007; } gss/src/drkl.f0000644000175100001440000001647512545250042012772 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine drkl (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, p *rec, maxiter, jpvt, wk, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, prec, wk(*) integer imrs, iwt, iwtsum, imu, imuwk, iv, ivwk, icdnew, iwtnew, i *wtnewsum imrs = 1 iwt = imrs + nxis iwtsum = iwt + nt*nqd imu = iwtsum + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nt*nqd call drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, prec, *maxiter, wk(imrs), wk(iwt), wk(iwtsum), wk(imu), wk(imuwk), wk(iv) *, wk(ivwk), jpvt, wk(icdnew), wk(iwtnew), wk(iwtnewsum), info) return end subroutine drkl1 (cd, nxis, qdrs, nqd, nt, bwt, qdwt, wt0, mchpr, *prec, maxiter, mrs, wt, wtsum, mu, muwk, v, vwk, jpvt, cdnew, wtne *w, wtnewsum, info) integer nxis, nqd, nt, maxiter, jpvt(*), info double precision cd(*), qdrs(nqd,*), bwt(*), qdwt(nt,*), wt0(*), m *chpr, mrs(*), wt(nt,*), wtsum(*), mu(*), muwk(*), v(nxis,*), vwk(n *xis,*), cdnew(*), wtnew(nt,*), wtnewsum(*), prec integer i, j, k, m, iter, flag, idamax, infowk double precision tmp, ddot, rkl, rklnew, mumax, disc, disc0 info = 0 call dset (nxis, 0.d0, mrs, 1) m=1 23000 if(.not.(m.le.nt))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(m,i) = qdwt(m,i) * wt0(i) 23004 i=i+1 goto 23003 23005 continue i=1 23006 if(.not.(i.le.nxis))goto 23008 muwk(i) = ddot (nqd, qdrs(1,i), 1, wt(m,1), nt) 23007 i=i+1 goto 23006 23008 continue call daxpy (nxis, bwt(m), muwk, 1, mrs, 1) wtsum(m) = 0.d0 23001 m=m+1 goto 23000 23002 continue i=1 23009 if(.not.(i.le.nqd))goto 23011 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23012 if(.not.(m.le.nt))goto 23014 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23013 m=m+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue rkl = 0.d0 m=1 23015 if(.not.(m.le.nt))goto 23017 tmp = 0.d0 i=1 23018 if(.not.(i.le.nqd))goto 23020 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wt(m,i)) * disc 23019 i=i+1 goto 23018 23020 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23016 m=m+1 goto 23015 23017 continue iter = 0 flag = 0 23021 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23024 if(.not.(m.le.nt))goto 23026 i=1 23027 if(.not.(i.le.nxis))goto 23029 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23028 i=i+1 goto 23027 23029 continue i=1 23030 if(.not.(i.le.nxis))goto 23032 j=i 23033 if(.not.(j.le.nxis))goto 23035 vwk(i,j) = 0.d0 k=1 23036 if(.not.(k.le.nqd))goto 23038 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23037 k=k+1 goto 23036 23038 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23034 j=j+1 goto 23033 23035 continue 23031 i=i+1 goto 23030 23032 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23025 m=m+1 goto 23024 23026 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23039 if(.not.(i.le.nxis))goto 23041 jpvt(i) = 0 23040 i=i+1 goto 23039 23041 continue call dmcdc (v, nxis, nxis, muwk, jpvt, infowk) 23042 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) call dset (nt, 0.d0, wtnewsum, 1) i=1 23045 if(.not.(i.le.nqd))goto 23047 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23047 endif m=1 23050 if(.not.(m.le.nt))goto 23052 wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) 23051 m=m+1 goto 23050 23052 continue 23046 i=i+1 goto 23045 23047 continue rklnew = 0.d0 m=1 23053 if(.not.(m.le.nt))goto 23055 tmp = 0.d0 i=1 23056 if(.not.(i.le.nqd))goto 23058 disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc 23057 i=i+1 goto 23056 23058 continue rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) 23054 m=m+1 goto 23053 23055 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23061 if(.not.(m.le.nt))goto 23063 i=1 23064 if(.not.(i.le.nqd))goto 23066 wtsum(m) = wtsum(m) + wt(m,i) 23065 i=i+1 goto 23064 23066 continue 23062 m=m+1 goto 23061 23063 continue rkl = 0.d0 m=1 23067 if(.not.(m.le.nt))goto 23069 tmp = 0.d0 i=1 23070 if(.not.(i.le.nqd))goto 23072 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23071 i=i+1 goto 23070 23072 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23068 m=m+1 goto 23067 23069 continue iter = 0 goto 23044 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23044 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23044 endif 23043 goto 23042 23044 continue if(flag.eq.1)then flag = 2 goto 23022 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23081 if(.not.(i.le.nqd))goto 23083 m=1 23084 if(.not.(m.le.nt))goto 23086 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23085 m=m+1 goto 23084 23086 continue 23082 i=i+1 goto 23081 23083 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) if(disc.lt.prec)then goto 23023 endif call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt*nqd, wtnew, 1, wt, 1) call dcopy (nt, wtnewsum, 1, wtsum, 1) rkl = rklnew if(iter.lt.maxiter)then goto 23022 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) m=1 23093 if(.not.(m.le.nt))goto 23095 i=1 23096 if(.not.(i.le.nqd))goto 23098 wtsum(m) = wtsum(m) + wt(m,i) 23097 i=i+1 goto 23096 23098 continue 23094 m=m+1 goto 23093 23095 continue rkl = 0.d0 m=1 23099 if(.not.(m.le.nt))goto 23101 tmp = 0.d0 i=1 23102 if(.not.(i.le.nqd))goto 23104 tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) 23103 i=i+1 goto 23102 23104 continue rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) 23100 m=m+1 goto 23099 23101 continue iter = 0 flag = 2 else info = 2 goto 23023 endif 23022 goto 23021 23023 continue i=1 23105 if(.not.(i.le.nqd))goto 23107 wt0(i) = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) 23106 i=i+1 goto 23105 23107 continue return end gss/src/cdennewton10.f0000644000175100001440000001602612545250042014333 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine cdennewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, *intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs *, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew) *, wk(iwtnew), wk(iwk), info) return end subroutine cdennewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, * intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, i *nfo) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, wtsum, lkhd, mumax, wtsumnew, l *khdnew, disc, disc0 info = 0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23001 i=i+1 goto 23000 23002 continue wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) 23009 i=i+1 goto 23008 23010 continue i=1 23011 if(.not.(i.le.nxis))goto 23013 j=i 23014 if(.not.(j.le.nxis))goto 23016 v(i,j) = 0.d0 k=1 23017 if(.not.(k.le.nobs))goto 23019 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23018 k=k+1 goto 23017 23019 continue v(i,j) = v(i,j) - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23015 j=j+1 goto 23014 23016 continue 23012 i=i+1 goto 23011 23013 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23022 if(.not.(i.le.nxis))goto 23024 jpvt(i) = 0 23023 i=i+1 goto 23022 23024 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23025 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23025 endif 23026 continue i=rkv+1 23027 if(.not.(i.le.nxis))goto 23029 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23028 i=i+1 goto 23027 23029 continue 23030 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23033 if(.not.(i.le.nobs))goto 23035 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23035 endif wtnew(i) = dexp (-tmp) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif 23034 i=i+1 goto 23033 23035 continue wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) if(cntsum.ne.0)then i=1 23044 if(.not.(i.le.nobs))goto 23046 wt(i) = dfloat (cnt(i)) 23045 i=i+1 goto 23044 23046 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 goto 23032 endif if(flag.eq.3)then goto 23032 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23032 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23032 endif 23031 goto 23030 23032 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23057 if(.not.(i.le.nobs))goto 23059 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23058 i=i+1 goto 23057 23059 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) if(cntsum.ne.0)then i=1 23070 if(.not.(i.le.nobs))goto 23072 wt(i) = dfloat (cnt(i)) 23071 i=i+1 goto 23070 23072 continue else call dset (nobs, 1.d0, wt, 1) endif wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue i=1 23073 if(.not.(i.le.nxis))goto 23075 j=i 23076 if(.not.(j.le.nxis))goto 23078 v(i,j) = 0.d0 k=1 23079 if(.not.(k.le.nobs))goto 23081 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23080 k=k+1 goto 23079 23081 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23077 j=j+1 goto 23076 23078 continue 23074 i=i+1 goto 23073 23075 continue i=1 23084 if(.not.(i.le.nxis))goto 23086 jpvt(i) = 0 23085 i=i+1 goto 23084 23086 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23087 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23087 endif 23088 continue i=rkv+1 23089 if(.not.(i.le.nxis))goto 23091 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23090 i=i+1 goto 23089 23091 continue i=1 23092 if(.not.(i.le.nobs))goto 23094 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif 23093 i=i+1 goto 23092 23094 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/dtrev.f0000644000175100001440000000364512545250042013155 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dtrev (vmu, t, ldt, n, z, score, varht, info, work) character*1 vmu integer n, info double precision t(ldt,*), z(*), score, varht, work(*) double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif la = t(1,1) alph = dfloat (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) call dpbfa (t, ldt, n, 1, info) if( info .ne. 0 )then return endif call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) if( vmu .eq. 'v' )then tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23006 if(.not.(j.gt.0))goto 23008 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23007 j=j-1 goto 23006 23008 continue nume = ddot (n, work, 1, work, 1) / dfloat (n) deno = deno / dfloat (n) varht = alph * la * nume / deno score = nume / deno / deno endif if( vmu .eq. 'm' )then deno = dlog (t(2,n)) j=n-1 23011 if(.not.(j.gt.0))goto 23013 deno = deno + dlog (t(2,j)) 23012 j=j-1 goto 23011 23013 continue nume = ddot (n, z, 1, work, 1) / dfloat (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dfloat (n)) endif if( vmu .eq. 'u' )then nume = ddot (n, work, 1, work, 1) / dfloat (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp j=n-1 23016 if(.not.(j.gt.0))goto 23018 tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp 23017 j=j-1 goto 23016 23018 continue deno = deno / dfloat (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * *deno endif return end gss/src/dprmut.f0000644000175100001440000000361212545250042013336 0ustar hornikusers subroutine dprmut (x,npar,jpvt,job) integer npar,jpvt(npar),job double precision x(npar) c c Purpose: permute the elements of the array x according to the index c vector jpvt (either forward or backward permutation). c c On Entry: c x(npar) array to be permuted c npar size of x (and jpvt) c jpvt indices of the permutation c job indicator of forward or backward permutation c if job = 0 forward permutation c x(jpvt(i)) moved to x(i) c if job is nonzero backward permutation c x(i) moved to x(jpvt(i)) c On Exit: c x(npar) array with permuted entries c c Written: Yin Ling U. of Maryland, August,1978 c c $Header: dprmut.f,v 2.1 86/04/08 14:05:53 lindstrom Exp $ c integer i,j,k double precision t c if (npar .le. 1) then return endif do 10 j = 1,npar jpvt(j) = -jpvt(j) 10 continue if (job .eq. 0) then c forward permutation do 30 i = 1,npar if (jpvt(i) .gt. 0) then goto 30 endif j = i jpvt(j) = -jpvt(j) k = jpvt(j) c while 20 if (jpvt(k) .lt. 0) then t = x(j) x(j) = x(k) x(k) = t jpvt(k) = -jpvt(k) j = k k = jpvt(k) goto 20 c endwhile endif 30 continue endif if (job .ne. 0 ) then c backward permutation do 50 i = 1,npar if (jpvt(i) .gt. 0) then goto 50 endif jpvt(i) = -jpvt(i) j = jpvt(i) c while 40 if (j .ne. i) then t = x(i) x(i) = x(j) x(j) = t jpvt(j) = -jpvt(j) j = jpvt(j) goto 40 c endwhile endif 50 continue endif return end gss/src/dset.f0000644000175100001440000000176412545250042012770 0ustar hornikusers subroutine dset(n,da,dx,incx) integer n,incx double precision da,dx(*) c c Purpose : set vector dx to constant da. Unrolled loops are used for c increment equal to one. c c On Entry: c n length of dx c da any constant c incx increment for dx c c On Exit: c dx(n) vector with all n entries set to da c c $Header: dset.f,v 2.1 86/04/08 14:06:25 lindstrom Exp $ c integer i,m,mp1,nincx c if(n.le.0)return if(incx.eq.1)go to 20 c c code for increment not equal to 1 c nincx = n*incx do 10 i = 1,nincx,incx dx(i) = da 10 continue return c c code for increment equal to 1 c c c clean-up loop c 20 m = mod(n,5) if( m .eq. 0 ) go to 40 do 30 i = 1,m dx(i) = da 30 continue if( n .lt. 5 ) return 40 mp1 = m + 1 do 50 i = mp1,n,5 dx(i) = da dx(i + 1) = da dx(i + 2) = da dx(i + 3) = da dx(i + 4) = da 50 continue return end gss/src/dsms.f0000644000175100001440000000504212545250042012770 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dsms (s, lds, nobs, nnull, jpvt, q, ldq, nlaht, sms, ld *sms, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldsms, info double precision s(lds,*), q(ldq,*), nlaht, sms(ldsms,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldsms .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23002 if(.not.(j.le.n0))goto 23004 call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+ *2,j), dum, dum, dum, 01000, info) 23003 j=j+1 goto 23002 23004 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23007 if(.not.(j.le.n0))goto 23009 call dpbsl (wk, 2, n, 1, q(n0+1,j)) 23008 j=j+1 goto 23007 23009 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23010 if(.not.(j.le.n0))goto 23012 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j), * dum, dum, dum, dum, 10000, info) 23011 j=j+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.n0))goto 23015 j=1 23016 if(.not.(j.lt.i))goto 23018 sms(i,j) = sms(j,i) 23017 j=j+1 goto 23016 23018 continue j=i 23019 if(.not.(j.le.n0))goto 23021 sms(i,j) = q(j,i) - ddot (n, q(n0+1,j), 1, q(i,n0+1), ldq) 23020 j=j+1 goto 23019 23021 continue sms(i,i) = sms(i,i) + 10.d0**nlaht 23014 i=i+1 goto 23013 23015 continue j=1 23022 if(.not.(j.le.n0))goto 23024 call dtrsl (s, lds, n0, sms(1,j), 01, info) 23023 j=j+1 goto 23022 23024 continue i=1 23025 if(.not.(i.le.n0))goto 23027 call dcopy (n0, sms(i,1), ldsms, wk, 1) call dtrsl (s, lds, n0, wk, 01, info) call dprmut (wk, n0, jpvt, 1) call dcopy (n0, wk, 1, sms(i,1), ldsms) 23026 i=i+1 goto 23025 23027 continue j=1 23028 if(.not.(j.le.n0))goto 23030 call dprmut (sms(1,j), n0, jpvt, 1) 23029 j=j+1 goto 23028 23030 continue j=1 23031 if(.not.(j.le.n0))goto 23033 call dcopy (n, q(j,n0+1), ldq, q(n0+1,j), 1) 23032 j=j+1 goto 23031 23033 continue return end gss/src/dmudr1.f0000644000175100001440000001613712545250042013225 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dmudr1 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, qraux, * jpvt, twk, traux, qwk, ywk, thewk, hes, gra, hwk1, hwk2, gwk1, gw *k2, pvtwk, kwk, work1, work2, info) integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, jpvt(*), p *vtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), qraux(*), traux(*), twk(2,*), * qwk(ldqr,*), ywk(*), thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk *2(nq,*), gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*), work1(*), * work2(*) character*1 vmu double precision alph, scrold, scrwk, nlawk, limnla(2), tmp, dasum *, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 n0 = nnull n = nobs - nnull maxitwk = maxite if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. (ini *t .ne. 0 .and. init .ne. 1) .or. (maxitwk .le.0) .or. (prec .le. 0 *.d0) )then info = -3 return endif if( lds .lt. nobs .or. nobs .le. n0 .or. n0 .lt. 1 .or. ldqr .lt. *nobs .or. ldqc .lt. nobs .or. nq .le. 0 )then info = -1 return endif call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, i *nfo, work1) if( info .ne. 0 )then return endif if( init .eq. 1 )then call dcopy (nq, theta, 1, thewk, 1) else i=1 23008 if(.not.(i.le.nq))goto 23010 thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if( thewk(i) .gt. 0.d0 )then thewk(i) = 1.d0 / thewk(i) endif 23009 i=i+1 goto 23008 23010 continue j=1 23013 if(.not.(j.le.nobs))goto 23015 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23014 j=j+1 goto 23013 23015 continue i=1 23016 if(.not.(i.le.nq))goto 23018 j=1 23019 if(.not.(j.le.nobs))goto 23021 call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23020 j=j+1 goto 23019 23021 continue 23017 i=i+1 goto 23016 23018 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk, *scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk, *c, d, info, twk) call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp, 010 *00, info) i=1 23024 if(.not.(i.le.nq))goto 23026 call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1, 0.d *0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if( thewk(i) .gt. 0.d0 )then thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 endif 23025 i=i+1 goto 23024 23026 continue endif scrold = 1.d10 job = 0 23029 continue if( nq .eq. 1 )then theta(1) = 0.d0 goto 23031 endif j=1 23034 if(.not.(j.le.nobs))goto 23036 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23035 j=j+1 goto 23034 23036 continue i=1 23037 if(.not.(i.le.nq))goto 23039 if( thewk(i) .le. -25.d0 )then goto 23038 endif j=1 23042 if(.not.(j.le.nobs))goto 23044 call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1, qwk(j,j), 1) 23043 j=j+1 goto 23042 23044 continue 23038 i=i+1 goto 23037 23039 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk *, scrwk, varht, info, twk, work1) if(info .ne. 0 )then return endif if( scrold .lt. scrwk )then tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( alph * tmp .gt. - prec )then info = -5 return endif alph = alph / 2.d0 i=1 23051 if(.not.(i.le.nq))goto 23053 thewk(i) = theta(i) + alph * gwk1(i) 23052 i=i+1 goto 23051 23053 continue goto 23030 endif maxitwk = maxitwk - 1 call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs, q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2 *,n0+1), ldqr, traux, twk, ywk(n0+1), thewk, nlawk, scrwk, varht, h *es, nq, gra, hwk1, hwk2, gwk1, gwk2, kwk, n, work1, work2, c, info *) iwk = 0 i=1 23054 if(.not.(i.le.nq))goto 23056 if( thewk(i) .le. -25.d0 )then goto 23055 endif iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) 23055 i=i+1 goto 23054 23056 continue iwk = 0 i=1 23059 if(.not.(i.le.nq))goto 23061 if( thewk(i) .le. -25.d0 )then goto 23060 endif iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) 23060 i=i+1 goto 23059 23061 continue i=1 23064 if(.not.(i.lt.iwk))goto 23066 call dcopy (iwk-i, hes(i+1,i), 1, hes(i,i+1), nq) 23065 i=i+1 goto 23064 23066 continue call dmcdc (hes, nq, iwk, gwk2, pvtwk, info) call dprmut (gwk1, iwk, pvtwk, 0) call dposl (hes, nq, iwk, gwk1) call dprmut (gwk1, iwk, pvtwk, 1) alph = -1.d0 j = iwk i=nq 23067 if(.not.(i.ge.1))goto 23069 if( thewk(i) .le. -25.0 )then gwk1(i) = 0.d0 else gwk1(i) = gwk1(iwk) iwk = iwk - 1 endif 23068 i=i-1 goto 23067 23069 continue call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if( tmp .gt. 1.d0 )then call dscal (nq, 1.d0/tmp, gwk1, 1) endif i=1 23074 if(.not.(i.le.nq))goto 23076 if( thewk(i) .le. -25.d0 )then goto 23075 endif thewk(i) = thewk(i) - nlawk 23075 i=i+1 goto 23074 23076 continue call dcopy (nq, thewk, 1, theta, 1) tmp = gra(idamax (nq, gra, 1)) ** 2 if( tmp .lt. prec ** 2 .or. scrold - scrwk .lt. prec * (scrwk + 1 *.d0) .and. tmp .lt. prec * (scrwk + 1.d0) ** 2 )then goto 23031 endif if( maxitwk .lt. 1 )then info = -4 return endif scrold = scrwk i=1 23083 if(.not.(i.le.nq))goto 23085 thewk(i) = thewk(i) + alph * gwk1(i) 23084 i=i+1 goto 23083 23085 continue job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 23030 goto 23029 23031 continue j=1 23086 if(.not.(j.le.nobs))goto 23088 call dset (nobs-j+1, 0.d0, qwk(j,j), 1) 23087 j=j+1 goto 23086 23088 continue i=1 23089 if(.not.(i.le.nq))goto 23091 if( theta(i) .le. -25.d0 )then goto 23090 endif j=1 23094 if(.not.(j.le.nobs))goto 23096 call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1, qwk(j,j), 1) 23095 j=j+1 goto 23094 23096 continue 23090 i=i+1 goto 23089 23091 continue call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht *, score, varht, info, twk, work1) if(info .ne. 0 )then return endif call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht, *c, d, info, twk) return end gss/src/gaussq.f0000644000175100001440000003164312545250042013333 0ustar hornikusersc To get dgamma, "send dgamma from fnlib". c To get d1mach, mail netlib c send d1mach from core c subroutine gaussq(kind, n, alpha, beta, kpts, endpts, b, t, w) c c this set of routines computes the nodes t(j) and weights c w(j) for gaussian-type quadrature rules with pre-assigned c nodes. these are used when one wishes to approximate c c integral (from a to b) f(x) w(x) dx c c n c by sum w f(t ) c j=1 j j c c (note w(x) and w(j) have no connection with each other.) c here w(x) is one of six possible non-negative weight c functions (listed below), and f(x) is the c function to be integrated. gaussian quadrature is particularly c useful on infinite intervals (with appropriate weight c functions), since then other techniques often fail. c c associated with each weight function w(x) is a set of c orthogonal polynomials. the nodes t(j) are just the zeroes c of the proper n-th degree polynomial. c c input parameters (all real numbers are in double precision) c c kind an integer between 1 and 6 giving the type of c quadrature rule: c c kind = 1: legendre quadrature, w(x) = 1 on (-1, 1) c kind = 2: chebyshev quadrature of the first kind c w(x) = 1/sqrt(1 - x*x) on (-1, +1) c kind = 3: chebyshev quadrature of the second kind c w(x) = sqrt(1 - x*x) on (-1, 1) c kind = 4: hermite quadrature, w(x) = exp(-x*x) on c (-infinity, +infinity) c kind = 5: jacobi quadrature, w(x) = (1-x)**alpha * (1+x)** c beta on (-1, 1), alpha, beta .gt. -1. c note: kind=2 and 3 are a special case of this. c kind = 6: generalized laguerre quadrature, w(x) = exp(-x)* c x**alpha on (0, +infinity), alpha .gt. -1 c c n the number of points used for the quadrature rule c alpha real parameter used only for gauss-jacobi and gauss- c laguerre quadrature (otherwise use 0.d0). c beta real parameter used only for gauss-jacobi quadrature-- c (otherwise use 0.d0) c kpts (integer) normally 0, unless the left or right end- c point (or both) of the interval is required to be a c node (this is called gauss-radau or gauss-lobatto c quadrature). then kpts is the number of fixed c endpoints (1 or 2). c endpts real array of length 2. contains the values of c any fixed endpoints, if kpts = 1 or 2. c b real scratch array of length n c c output parameters (both double precision arrays of length n) c c t will contain the desired nodes. c w will contain the desired weights w(j). c c underflow may sometimes occur, but is harmless. c c references c 1. golub, g. h., and welsch, j. h., "calculation of gaussian c quadrature rules," mathematics of computation 23 (april, c 1969), pp. 221-230. c 2. golub, g. h., "some modified matrix eigenvalue problems," c siam review 15 (april, 1973), pp. 318-334 (section 7). c 3. stroud and secrest, gaussian quadrature formulas, prentice- c hall, englewood cliffs, n.j., 1966. c c original version 20 jan 1975 from stanford c modified 21 dec 1983 by eric grosse c imtql2 => gausq2 c hex constant => d1mach (from core library) c compute pi using datan c removed accuracy claims, description of method c added single precision version c double precision b(n), t(n), w(n), endpts(2), muzero, t1, x gam, solve, dsqrt, alpha, beta c call class (kind, n, alpha, beta, b, t, muzero) c c the matrix of coefficients is assumed to be symmetric. c the array t contains the diagonal elements, the array c b the off-diagonal elements. c make appropriate changes in the lower right 2 by 2 c submatrix. c if (kpts.eq.0) go to 100 if (kpts.eq.2) go to 50 c c if kpts=1, only t(n) must be changed c t(n) = solve(endpts(1), n, t, b)*b(n-1)**2 + endpts(1) go to 100 c c if kpts=2, t(n) and b(n-1) must be recomputed c 50 gam = solve(endpts(1), n, t, b) t1 = ((endpts(1) - endpts(2))/(solve(endpts(2), n, t, b) - gam)) b(n-1) = dsqrt(t1) t(n) = endpts(1) + gam*t1 c c note that the indices of the elements of b run from 1 to n-1 c and thus the value of b(n) is arbitrary. c now compute the eigenvalues of the symmetric tridiagonal c matrix, which has been modified as necessary. c the method used is a ql-type method with origin shifting c 100 w(1) = 1.0d0 do 105 i = 2, n 105 w(i) = 0.0d0 c call gausq2 (n, t, b, w, ierr) do 110 i = 1, n 110 w(i) = muzero * w(i) * w(i) c return end c c c double precision function solve(shift, n, a, b) c c this procedure performs elimination to solve for the c n-th component of the solution delta to the equation c c (jn - shift*identity) * delta = en, c c where en is the vector of all zeroes except for 1 in c the n-th position. c c the matrix jn is symmetric tridiagonal, with diagonal c elements a(i), off-diagonal elements b(i). this equation c must be solved to obtain the appropriate changes in the lower c 2 by 2 submatrix of coefficients for orthogonal polynomials. c c double precision shift, a(n), b(n), alpha c alpha = a(1) - shift nm1 = n - 1 do 10 i = 2, nm1 10 alpha = a(i) - shift - b(i-1)**2/alpha solve = 1.0d0/alpha return end c c c subroutine class(kind, n, alpha, beta, b, a, muzero) c c this procedure supplies the coefficients a(j), b(j) of the c recurrence relation c c b p (x) = (x - a ) p (x) - b p (x) c j j j j-1 j-1 j-2 c c for the various classical (normalized) orthogonal polynomials, c and the zero-th moment c c muzero = integral w(x) dx c c of the given polynomial's weight function w(x). since the c polynomials are orthonormalized, the tridiagonal matrix is c guaranteed to be symmetric. c c the input parameter alpha is used only for laguerre and c jacobi polynomials, and the parameter beta is used only for c jacobi polynomials. the laguerre and jacobi polynomials c require the gamma function. c double precision a(n), b(n), muzero, alpha, beta double precision abi, a2b2, dgamma, pi, dsqrt, ab c pi = 4.0d0 * datan(1.0d0) nm1 = n - 1 go to (10, 20, 30, 40, 50, 60), kind c c kind = 1: legendre polynomials p(x) c on (-1, +1), w(x) = 1. c 10 muzero = 2.0d0 do 11 i = 1, nm1 a(i) = 0.0d0 abi = i 11 b(i) = abi/dsqrt(4*abi*abi - 1.0d0) a(n) = 0.0d0 return c c kind = 2: chebyshev polynomials of the first kind t(x) c on (-1, +1), w(x) = 1 / sqrt(1 - x*x) c 20 muzero = pi do 21 i = 1, nm1 a(i) = 0.0d0 21 b(i) = 0.5d0 b(1) = dsqrt(0.5d0) a(n) = 0.0d0 return c c kind = 3: chebyshev polynomials of the second kind u(x) c on (-1, +1), w(x) = sqrt(1 - x*x) c 30 muzero = pi/2.0d0 do 31 i = 1, nm1 a(i) = 0.0d0 31 b(i) = 0.5d0 a(n) = 0.0d0 return c c kind = 4: hermite polynomials h(x) on (-infinity, c +infinity), w(x) = exp(-x**2) c 40 muzero = dsqrt(pi) do 41 i = 1, nm1 a(i) = 0.0d0 41 b(i) = dsqrt(i/2.0d0) a(n) = 0.0d0 return c c kind = 5: jacobi polynomials p(alpha, beta)(x) on c (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and c beta greater than -1 c 50 ab = alpha + beta abi = 2.0d0 + ab muzero = 2.0d0 ** (ab + 1.0d0) * dgamma(alpha + 1.0d0) * dgamma( x beta + 1.0d0) / dgamma(abi) a(1) = (beta - alpha)/abi b(1) = dsqrt(4.0d0*(1.0d0 + alpha)*(1.0d0 + beta)/((abi + 1.0d0)* 1 abi*abi)) a2b2 = beta*beta - alpha*alpha do 51 i = 2, nm1 abi = 2.0d0*i + ab a(i) = a2b2/((abi - 2.0d0)*abi) 51 b(i) = dsqrt (4.0d0*i*(i + alpha)*(i + beta)*(i + ab)/ 1 ((abi*abi - 1)*abi*abi)) abi = 2.0d0*n + ab a(n) = a2b2/((abi - 2.0d0)*abi) return c c kind = 6: laguerre polynomials l(alpha)(x) on c (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater c than -1. c 60 muzero = dgamma(alpha + 1.0d0) do 61 i = 1, nm1 a(i) = 2.0d0*i - 1.0d0 + alpha 61 b(i) = dsqrt(i*(i + alpha)) a(n) = 2.0d0*n - 1 + alpha return end c c subroutine gausq2(n, d, e, z, ierr) c c this subroutine is a translation of an algol procedure, 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 this is a modified version of the 'eispack' routine imtql2. c c this subroutine finds the eigenvalues and first components of the c eigenvectors of a symmetric tridiagonal matrix by the implicit ql c 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 e contains the subdiagonal elements of the input matrix c in its first n-1 positions. e(n) is arbitrary; c c z contains the first row of the identity matrix. 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 the first components of the orthonormal eigenvectors c of the symmetric tridiagonal matrix. if an error exit is c made, z contains the eigenvectors associated with the stored c eigenvalues; 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 ------------------------------------------------------------------ c integer i, j, k, l, m, n, ii, mml, ierr real*8 d(n), e(n), z(n), b, c, f, g, p, r, s, machep real*8 dsqrt, dabs, dsign, d1mach c machep=d1mach(4) c ierr = 0 if (n .eq. 1) go to 1001 c e(n) = 0.0d0 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 if (dabs(e(m)) .le. machep * (dabs(d(m)) + dabs(d(m+1)))) x 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.0d0 * e(l)) r = dsqrt(g*g+1.0d0) g = d(m) - p + e(l) / (g + dsign(r, g)) s = 1.0d0 c = 1.0d0 p = 0.0d0 mml = m - l c 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 (dabs(f) .lt. dabs(g)) go to 150 c = g / f r = dsqrt(c*c+1.0d0) e(i+1) = f * r s = 1.0d0 / r c = c * s go to 160 150 s = f / g r = dsqrt(s*s+1.0d0) e(i+1) = g * r c = 1.0d0 / r s = s * c 160 g = d(i+1) - p r = (d(i) - g) * s + 2.0d0 * c * b p = s * r d(i+1) = g + p g = c * r - b c :::::::::: form first component of vector :::::::::: f = z(i+1) z(i+1) = s * z(i) + c * f 200 z(i) = c * z(i) - s * f c d(l) = d(l) - p e(l) = g e(m) = 0.0d0 go to 105 240 continue c 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 p = z(i) z(i) = z(k) z(k) = p 300 continue c go to 1001 c :::::::::: set error -- no convergence to an c eigenvalue after 30 iterations :::::::::: 1000 ierr = l 1001 return c :::::::::: last card of gausq2 :::::::::: end c c c double precision function dgamma(x) double precision x dgamma = 1.0d0 return end gss/src/dsytr.f0000644000175100001440000000376012545250042013174 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dsytr (x, ldx, n, tol, info, work) integer ldx, n, info double precision x(ldx,*), tol, work(*) double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, *ddot integer j info = 0 if( ldx .lt. n .or. n .le. 2 )then info = -1 return endif nrmtot = ddot (n, x, ldx+1, x, ldx+1) j=1 23002 if(.not.(j.lt.n ))goto 23004 nrmtot = nrmtot + 2.d0 * ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) 23003 j=j+1 goto 23002 23004 continue toltot = 1.d0 23005 if( 1.d0 + toltot .gt. 1.d0 )then toltot = toltot / 2.d0 goto 23005 endif 23006 continue toltot = 4.d0 * toltot ** 2 if( toltot .lt. tol )then toltot = tol endif toltot = toltot * nrmtot dn = dfloat (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) tolcum = 0.d0 j=1 23009 if(.not.(j.lt.n-1 ))goto 23011 nrmtot = nrmtot - x(j,j) * x(j,j) nrmxj = ddot (n-j, x(j+1,j), 1, x(j+1,j), 1) dn = dfloat (n-j) tolcum = tolcum + toluni * dn * dn if( 2.d0 * nrmxj .le. tolcum )then x(j,j+1) = 0.d0 call dscal (n-j, 0.d0, x(j+1,j), 1) tolcum = tolcum - 2.d0 * nrmxj toltot = toltot - 2.d0 * nrmxj goto 23010 endif if( x(j+1,j) .lt. 0.d0 )then x(j,j+1) = dsqrt (nrmxj) else x(j,j+1) = - dsqrt (nrmxj) endif nrmtot = nrmtot - 2.d0 * nrmxj call dscal (n-j, -1.d0/x(j,j+1), x(j+1,j), 1) x(j+1,j) = 1.d0 + x(j+1,j) alph = 1.d0 / x(j+1,j) call dsymv ('l', n-j, alph, x(j+1,j+1), ldx, x(j+1,j), 1, 0.d0, wo *rk(j+1), 1) alph = - ddot (n-j, work(j+1), 1, x(j+1,j), 1) / 2.d0 / x(j+1,j) call daxpy (n-j, alph, x(j+1,j), 1, work(j+1), 1) call dsyr2 ('l', n-j, -1.d0, x(j+1,j), 1, work(j+1), 1, x(j+1,j+1) *, ldx) 23010 j=j+1 goto 23009 23011 continue x(n-1,n) = x(n,n-1) return end gss/src/dnewton.f0000644000175100001440000002436712545250042013513 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine dnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, * nqd, nt, bwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nt, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,*), bwt(*), * qdwt(nt,*), prec, mchpr, wk(*) integer imrs, iwt, iwtsum, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtsumnew, ifitnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 3) iwtsum = iwt + nqd*nt ifit = iwtsum + nt imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtsumnew = iwtnew + nqd*nt ifitnew = iwtsumnew + nt iwk = ifitnew + nobs call dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, nqd, * nt, bwt, qdwt, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(iwtsum *), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew *), wk(iwtnew), wk(iwtsumnew), wk(ifitnew), wk(iwk), info) return end subroutine dnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs *, nqd, nt, bwt, qdwt, prec, maxiter, mchpr, mrs, wt, wtsum, fit, m *u, muwk, v, vwk, jpvt, cdnew, wtnew, wtsumnew, fitnew, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nt, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,*), bwt(*), * qdwt(nt,*), prec, mchpr, mrs(*), wt(nt,*), wtsum(*), fit(*), mu(* *), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nt,*), wtsumne *w(*), fitnew(*), wk(*) integer i, j, k, m, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / dfloat (cntsum) endif 23001 i=i+1 goto 23000 23002 continue m=1 23011 if(.not.(m.le.nt))goto 23013 wtsum(m) = 0.d0 23012 m=m+1 goto 23011 23013 continue i=1 23014 if(.not.(i.le.nqd))goto 23016 tmp = dexp (ddot (nxis, qdrs(i,1), nqd, cd, 1)) m=1 23017 if(.not.(m.le.nt))goto 23019 wt(m,i) = qdwt(m,i) * tmp wtsum(m) = wtsum(m) + wt(m,i) 23018 m=m+1 goto 23017 23019 continue 23015 i=i+1 goto 23014 23016 continue norm = 0.d0 m=1 23020 if(.not.(m.le.nt))goto 23022 norm = norm + bwt(m) * dlog (wtsum(m)) 23021 m=m+1 goto 23020 23022 continue fitmean = 0.d0 i=1 23023 if(.not.(i.le.nobs))goto 23025 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23024 i=i+1 goto 23023 23025 continue if(cntsum.eq.0)then fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) endif call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean + norm iter = 0 flag = 0 23030 continue iter = iter + 1 call dset(nxis, 0.d0, mu, 1) call dset(nxis*nxis, 0.d0, v, 1) m=1 23033 if(.not.(m.le.nt))goto 23035 i=1 23036 if(.not.(i.le.nxis))goto 23038 muwk(i) = - ddot (nqd, wt(m,1), nt, qdrs(1,i), 1) / wtsum(m) 23037 i=i+1 goto 23036 23038 continue i=1 23039 if(.not.(i.le.nxis))goto 23041 j=i 23042 if(.not.(j.le.nxis))goto 23044 vwk(i,j) = 0.d0 k=1 23045 if(.not.(k.le.nqd))goto 23047 vwk(i,j) = vwk(i,j) + wt(m,k) * qdrs(k,i) * qdrs(k,j) 23046 k=k+1 goto 23045 23047 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call daxpy (nxis, bwt(m), muwk, 1, mu, 1) call daxpy (nxis*nxis, bwt(m), vwk, 1, v, 1) 23034 m=m+1 goto 23033 23035 continue i=1 23048 if(.not.(i.le.nxi))goto 23050 j=i 23051 if(.not.(j.le.nxi))goto 23053 v(i,j) = v(i,j) + q(i,j) 23052 j=j+1 goto 23051 23053 continue 23049 i=i+1 goto 23048 23050 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23054 if(.not.(i.le.nxis))goto 23056 jpvt(i) = 0 23055 i=i+1 goto 23054 23056 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23057 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23057 endif 23058 continue i=rkv+1 23059 if(.not.(i.le.nxis))goto 23061 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23060 i=i+1 goto 23059 23061 continue 23062 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) m=1 23065 if(.not.(m.le.nt))goto 23067 wtsumnew(m) = 0.d0 23066 m=m+1 goto 23065 23067 continue i=1 23068 if(.not.(i.le.nqd))goto 23070 tmp = ddot (nxis, qdrs(i,1), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23070 endif tmp = dexp (tmp) m=1 23073 if(.not.(m.le.nt))goto 23075 wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) 23074 m=m+1 goto 23073 23075 continue 23069 i=i+1 goto 23068 23070 continue norm = 0.d0 m=1 23076 if(.not.(m.le.nt))goto 23078 norm = norm + bwt(m) * dlog (wtsumnew(m)) 23077 m=m+1 goto 23076 23078 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23081 if(.not.(i.le.nobs))goto 23083 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23083 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23082 i=i+1 goto 23081 23083 continue if(cntsum.eq.0)then fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) endif call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23092 if(.not.(m.le.nt))goto 23094 wtsum(m) = 0.d0 i=1 23095 if(.not.(i.le.nqd))goto 23097 wtsum(m) = wtsum(m) + wt(m,i) 23096 i=i+1 goto 23095 23097 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23093 m=m+1 goto 23092 23094 continue call dset (nobs, 1.d0, fit, 1) iter = 0 goto 23064 endif if(flag.eq.3)then goto 23064 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23064 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23064 endif 23063 goto 23062 23064 continue if(flag.eq.1)then flag = 2 goto 23031 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23108 if(.not.(i.le.nqd))goto 23110 m=1 23111 if(.not.(m.le.nt))goto 23113 disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) 23112 m=m+1 goto 23111 23113 continue 23109 i=i+1 goto 23108 23110 continue i=1 23114 if(.not.(i.le.nobs))goto 23116 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23115 i=i+1 goto 23114 23116 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+da *bs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23032 endif if(disc.lt.prec)then goto 23032 endif if(iter.lt.maxiter)then goto 23031 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 m=1 23125 if(.not.(m.le.nt))goto 23127 wtsum(m) = 0.d0 i=1 23128 if(.not.(i.le.nqd))goto 23130 wtsum(m) = wtsum(m) + wt(m,i) 23129 i=i+1 goto 23128 23130 continue lkhd = lkhd + bwt(m) * dlog (wtsum(m)) 23126 m=m+1 goto 23125 23127 continue call dset (nobs, 1.d0, fit, 1) iter = 0 flag = 2 else info = 2 goto 23032 endif 23031 goto 23030 23032 continue i=1 23131 if(.not.(i.le.nobs))goto 23133 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) if(nxis-rkv.gt.0)then call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) endif 23132 i=i+1 goto 23131 23133 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23140 if(.not.(i.le.nobs))goto 23142 lkhd = lkhd + dlog (fit(i)) 23141 i=i+1 goto 23140 23142 continue lkhd = lkhd / dfloat (nobs) else trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 i=1 23143 if(.not.(i.le.nobs))goto 23145 lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) 23144 i=i+1 goto 23143 23145 continue lkhd = lkhd / dfloat (cntsum) endif m=1 23146 if(.not.(m.le.nt))goto 23148 lkhd = lkhd - bwt(m) * dlog (wtsum(m)) 23147 m=m+1 goto 23146 23148 continue mrs(1) = lkhd mrs(2) = trc return end gss/src/dcrdr.f0000644000175100001440000000456612545250042013132 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht, * r, ldr, nr, cr, ldcr, dr, lddr, wk, info) integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr *(ldcr,*), dr(lddr,*), wk(2,*) double precision dum, ddot integer i, j, n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq .or. ldr .lt. nobs .or. nr .lt. 1 .or. ldcr .lt. nobs .o *r. lddr .lt. nnull )then info = -1 return endif n0 = nnull n = nobs - nnull j=1 23002 if(.not.(j.le.nr))goto 23004 call dcopy (nobs, r(1,j), 1, cr(1,j), 1) 23003 j=j+1 goto 23002 23004 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23005 if(.not.(j.le.nr))goto 23007 call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum *, dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n *0+2,j), dum, dum, dum, 01000, info) 23006 j=j+1 goto 23005 23007 continue call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif j=1 23010 if(.not.(j.le.nr))goto 23012 call dpbsl (wk, 2, n, 1, cr(n0+1,j)) 23011 j=j+1 goto 23010 23012 continue call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) j=1 23013 if(.not.(j.le.nr))goto 23015 call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j *), dum, dum, dum, dum, 10000, info) 23014 j=j+1 goto 23013 23015 continue j=1 23016 if(.not.(j.le.nr))goto 23018 i=1 23019 if(.not.(i.le.n0))goto 23021 dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) 23020 i=i+1 goto 23019 23021 continue call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) 23017 j=j+1 goto 23016 23018 continue j=1 23022 if(.not.(j.le.nr))goto 23024 call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j), dum, dum *, dum, dum, 10000, info) 23023 j=j+1 goto 23022 23024 continue return end gss/src/hzdaux.f0000644000175100001440000002125612545250042013332 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, *wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), m *chpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23000 if(.not.(kk.le.nx))goto 23002 i=1 23003 if(.not.(i.le.nqd))goto 23005 wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1 *)) 23004 i=i+1 goto 23003 23005 continue 23001 kk=kk+1 goto 23000 23002 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23006 if(.not.(kk.le.nx))goto 23008 i=1 23009 if(.not.(i.le.nxis))goto 23011 j=i 23012 if(.not.(j.le.nxis))goto 23014 vwk(i,j) = 0.d0 k=1 23015 if(.not.(k.le.nqd))goto 23017 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23016 k=k+1 goto 23015 23017 continue 23013 j=j+1 goto 23012 23014 continue 23010 i=i+1 goto 23009 23011 continue call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) 23007 kk=kk+1 goto 23006 23008 continue i=1 23018 if(.not.(i.le.nxi))goto 23020 j=i 23021 if(.not.(j.le.nxi))goto 23023 v(i,j) = v(i,j) + q(i,j) 23022 j=j+1 goto 23021 23023 continue 23019 i=i+1 goto 23018 23020 continue i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue return end subroutine hzdaux2 (v, nxis, jpvt, r, nr, se) double precision v(nxis,*), r(nxis,*), se(*) integer nxis, jpvt(*), nr double precision ddot integer i, infowk i=1 23032 if(.not.(i.le.nr))goto 23034 call dprmut (r(1,i), nxis, jpvt, 0) call dtrsl (v, nxis, nxis, r(1,i), 11, infowk) se(i) = dsqrt (ddot (nxis, r(1,i), 1, r(1,i), 1)) 23033 i=i+1 goto 23032 23034 continue return end subroutine hrkl (cd, nxis, qdrs, nqd, nx, qdwt, wt0, mchpr, wt, mu *, mu0, v, jpvt, wk, cdnew, wtnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), qdwt(nqd,*), wt0(nqd,*), * mchpr, wt(nqd,*), mu(*), mu0(*), v(nxis,*), wk(*), cdnew(*), wtne *w(nqd,*), prec integer i, j, k, kk, idamax, iter, flag, infowk double precision tmp, ddot, dasum, rkl, mumax, rklnew, disc, disc0 info = 0 call dset (nxis, 0.d0, mu0, 1) kk=1 23035 if(.not.(kk.le.nx))goto 23037 i=1 23038 if(.not.(i.le.nxis))goto 23040 mu0(i) = mu0(i) + ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) 23039 i=i+1 goto 23038 23040 continue 23036 kk=kk+1 goto 23035 23037 continue rkl = 0.d0 kk=1 23041 if(.not.(kk.le.nx))goto 23043 i=1 23044 if(.not.(i.le.nqd))goto 23046 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) wt(i,kk) = qdwt(i,kk) * dexp (tmp) rkl = rkl + (wt(i,kk) - wt0(i,kk)*tmp) 23045 i=i+1 goto 23044 23046 continue 23042 kk=kk+1 goto 23041 23043 continue iter = 0 flag = 0 23047 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23050 if(.not.(kk.le.nx))goto 23052 i=1 23053 if(.not.(i.le.nxis))goto 23055 mu(i) = mu(i) - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) j=i 23056 if(.not.(j.le.nxis))goto 23058 k=1 23059 if(.not.(k.le.nqd))goto 23061 v(i,j) = v(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23060 k=k+1 goto 23059 23061 continue 23057 j=j+1 goto 23056 23058 continue 23054 i=i+1 goto 23053 23055 continue 23051 kk=kk+1 goto 23050 23052 continue call daxpy (nxis, 1.d0, mu0, 1, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23062 if(.not.(i.le.nxis))goto 23064 jpvt(i) = 0 23063 i=i+1 goto 23062 23064 continue call dmcdc (v, nxis, nxis, wk, jpvt, infowk) 23065 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) rklnew = 0.d0 kk=1 23068 if(.not.(kk.le.nx))goto 23070 i=1 23071 if(.not.(i.le.nqd))goto 23073 tmp = ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23073 endif wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) 23072 i=i+1 goto 23071 23073 continue 23069 kk=kk+1 goto 23068 23070 continue if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 goto 23067 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23067 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23067 endif 23066 goto 23065 23067 continue if(flag.eq.1)then flag = 2 goto 23048 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23086 if(.not.(kk.le.nx))goto 23088 i=1 23089 if(.not.(i.le.nqd))goto 23091 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23090 i=i+1 goto 23089 23091 continue 23087 kk=kk+1 goto 23086 23088 continue disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23049 endif if(disc.lt.prec)then goto 23049 endif if(iter.lt.maxiter)then goto 23048 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 flag = 2 else info = 2 goto 23049 endif 23048 goto 23047 23049 continue kk=1 23100 if(.not.(kk.le.nx))goto 23102 i=1 23103 if(.not.(i.le.nqd))goto 23105 wt0(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) 23104 i=i+1 goto 23103 23105 continue 23101 kk=kk+1 goto 23100 23102 continue return end subroutine coxaux (cd, nn, q, nxiz, qdrs, nqd, nt, twt, mchpr, qdw *t, wt, wtsum, muwk, v, vwk, jpvt) integer nn, nxiz, nqd, nt, jpvt(*) double precision cd(*), q(nxiz,*), qdrs(nqd,*), twt(*), mchpr, qdw *t(nqd,*), wt(nqd,*), wtsum(*), muwk(*), v(nn,*), vwk(nn,*) integer i, j, k, m, rkv double precision ddot, tmp call dset(nt, 0.d0, wtsum, 1) i=1 23106 if(.not.(i.le.nqd))goto 23108 tmp = dexp (ddot (nn, qdrs(i,1), nqd, cd, 1)) m=1 23109 if(.not.(m.le.nt))goto 23111 wt(i,m) = qdwt(i,m) * tmp wtsum(m) = wtsum(m) + wt(i,m) 23110 m=m+1 goto 23109 23111 continue 23107 i=i+1 goto 23106 23108 continue call dset(nn*nn, 0.d0, v, 1) m=1 23112 if(.not.(m.le.nt))goto 23114 i=1 23115 if(.not.(i.le.nn))goto 23117 muwk(i) = ddot (nqd, wt(1,m), 1, qdrs(1,i), 1) / wtsum(m) 23116 i=i+1 goto 23115 23117 continue i=1 23118 if(.not.(i.le.nn))goto 23120 j=i 23121 if(.not.(j.le.nn))goto 23123 vwk(i,j) = 0.d0 k=1 23124 if(.not.(k.le.nqd))goto 23126 vwk(i,j) = vwk(i,j) + wt(k,m) * qdrs(k,i) * qdrs(k,j) 23125 k=k+1 goto 23124 23126 continue vwk(i,j) = vwk(i,j) / wtsum(m) - muwk(i) * muwk(j) 23122 j=j+1 goto 23121 23123 continue 23119 i=i+1 goto 23118 23120 continue call daxpy (nn*nn, twt(m), vwk, 1, v, 1) 23113 m=m+1 goto 23112 23114 continue i=1 23127 if(.not.(i.le.nxiz))goto 23129 j=i 23130 if(.not.(j.le.nxiz))goto 23132 v(i,j) = v(i,j) + q(i,j) 23131 j=j+1 goto 23130 23132 continue 23128 i=i+1 goto 23127 23129 continue i=1 23133 if(.not.(i.le.nn))goto 23135 jpvt(i) = 0 23134 i=i+1 goto 23133 23135 continue call dchdc (v, nn, nn, vwk, jpvt, 1, rkv) 23136 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23136 endif 23137 continue i=rkv+1 23138 if(.not.(i.le.nn))goto 23140 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23139 i=i+1 goto 23138 23140 continue return end gss/src/dcoef.f0000644000175100001440000000262512545250042013106 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dcoef (s, lds, nobs, nnull, qraux, jpvt, z, q, ldq, nla *ht, c, d, info, twk) integer lds, nobs, nnull, jpvt(*), ldq, info double precision s(lds,*), qraux(*), z(*), q(ldq,*), nlaht, c(*), *d(*), twk(2,*) double precision dum, ddot integer n, n0 info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if( info .ne. 0 )then info = -2 return endif call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), du *m, dum, dum, dum, 10000, info) call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, *10000, info) j=1 23004 if(.not.(j.le.n0))goto 23006 d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) 23005 j=j+1 goto 23004 23006 continue call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end gss/src/dgold.f0000644000175100001440000000522312545250042013114 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht *, info, twk, work) character*1 vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, tw *k(2,*), work(*) double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( n .lt. 1 .or. n .gt. ldq )then info = -1 return endif mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif 23010 continue if( mup - mlo .lt. 1.d-7 )then goto 23012 endif if( tmpl .lt. tmpu )then upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if( info .ne. 0 )then info = -2 return endif else low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if( info .ne. 0 )then info = -2 return endif endif 23011 goto 23010 23012 continue nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if( info .ne. 0 )then info = -2 return endif return end gss/src/dcore.f0000644000175100001440000000444412545250042013123 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, n *laht, score, varht, info, twk, work) character*1 vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), *varht, twk(2,*), work(*) double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif if( nnull .lt. 1 .or. nobs .le. nnull .or. nobs .gt. ldq )then info = -1 return endif n0 = nnull n = nobs - nnull call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if( info .ne. 0 )then return endif call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+ *2), dum, dum, dum, 01000, info) if( job .eq. 0 )then mchpr = 1.d0 23008 if( 1.d0 + mchpr .gt. 1.d0 )then mchpr = mchpr / 2.d0 goto 23008 endif 23009 continue mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) endif low = limnla(1) upp = limnla(2) if( job .le. 0 )then call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht, s *core(1), varht, info, twk, work) if( vmu .eq. 'v' )then score(1) = score(1) * dfloat (nobs) / dfloat (n) endif if( vmu .eq. 'm' )then score(1) = score(1) * dfloat (n) / dfloat (nobs) endif if( vmu .eq. 'u' )then score(1) = score(1) * dfloat (n) / dfloat (nobs) + 2.d0 * varht endif else call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nla *ht, score, varht, info, twk, work) dum = dfloat (nobs) / dfloat (n) j=1 23018 if(.not.(j.le.job+1))goto 23020 if( vmu .eq. 'v' )then score(j) = score(j) * dum endif if( vmu .eq. 'm' )then score(j) = score(j) / dum endif if( vmu .eq. 'u' )then score(j) = score(j) / dum + 2.d0 * varht endif 23019 j=j+1 goto 23018 23020 continue endif return end gss/src/dmudr.f0000644000175100001440000000263512545250042013142 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dmudr (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, *tol, init, prec, maxite, theta, nlaht, score, varht, c, d, wk, inf *o) integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), wk(*) character*1 vmu integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk *1, ihwk2, igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = iwork2 + n ipvtwk = ijpvt + n0 call dmudr1 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, tol, *init, prec, maxite, theta, nlaht, score, varht, c, d, wk(iqraux), *wk(ijpvt), wk(itwk), wk(itraux), wk(iqwk), wk(iywk), wk(ithewk), w *k(ihes), wk(igra), wk(ihwk1), wk(ihwk2), wk(igwk1), wk(igwk2), wk( *ipvtwk), wk(ikwk), wk(iwork1), wk(iwork2), info) return end gss/src/dqrslm.f0000644000175100001440000000252212545250042013324 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dqrslm (x, ldx, n, k, qraux, a, lda, job, info, work) integer ldx, n, k, lda, job, info double precision x(ldx,*), qraux(*), a(lda,*), work(*) double precision tmp, alph, ddot integer i, j, step info = 0 if( lda .lt. n .or. n .lt. k .or. k .lt. 1 )then info = -1 return endif if( job .ne. 0 .and. job .ne. 1 )then info = 1 return endif if( job .eq. 0 )then j = 1 step = 1 else j = k step = -1 endif 23006 if( j .ge. 1 .and. j .le. k )then if( qraux(j) .eq. 0.0d0 )then j = j + step goto 23006 endif tmp = x(j,j) x(j,j) = qraux(j) i=1 23010 if(.not.(i.lt.j))goto 23012 alph = - ddot (n-j+1, x(j,j), 1, a(j,i), 1) / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, a(j,i), 1) 23011 i=i+1 goto 23010 23012 continue alph = 1.d0 / x(j,j) call dsymv ('l', n-j+1, alph, a(j,j), lda, x(j,j), 1, 0.d0, work(j *), 1) alph = - ddot (n-j+1, work(j), 1, x(j,j), 1) / 2.d0 / x(j,j) call daxpy (n-j+1, alph, x(j,j), 1, work(j), 1) call dsyr2 ('l', n-j+1, -1.d0, x(j,j), 1, work(j), 1, a(j,j), lda) x(j,j) = tmp j = j + step goto 23006 endif 23007 continue return end gss/src/dmudr0.f0000644000175100001440000000140012545250042013207 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dmudr0 (vmu, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, * tol, init, prec, maxite, theta, nlaht, score, varht, c, d, wk, in *fo) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite, info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec, theta( **), nlaht, score, varht, c(*), d(*), wk(*) character*1 vmu1 if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif call dmudr (vmu1, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, tol, *init, prec, maxite, theta, nlaht, score, varht, c, d, wk, info) return end gss/src/cdennewton.f0000644000175100001440000003621512545250042014174 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine cdennewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), qdwt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, qdwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk( *imrs), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(ic *dnew), wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine cdennewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, qdwt, prec, maxiter, mchpr, wt, wtsum, mrs, fi *t, mu, muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, inf *o) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), qdwt(*), prec, mchpr, wt(nqd,*), wtsum(*), mrs(*), fit(*), *mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), wt *newsum(*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / dfloat (cntsum) endif 23001 i=i+1 goto 23000 23002 continue if(cntsum.eq.0)then trc = 1.d0 / dfloat (nobs) else trc = 1.d0 / dfloat (cntsum) endif norm = 0.d0 kk=1 23013 if(.not.(kk.le.nx))goto 23015 wtsum(kk) = 0.d0 i=1 23016 if(.not.(i.le.nqd))goto 23018 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) wtsum(kk) = wtsum(kk) + wt(i,kk) 23017 i=i+1 goto 23016 23018 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23014 kk=kk+1 goto 23013 23015 continue fitmean = 0.d0 i=1 23019 if(.not.(i.le.nobs))goto 23021 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23020 i=i+1 goto 23019 23021 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23024 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23027 if(.not.(kk.le.nx))goto 23029 i=1 23030 if(.not.(i.le.nxis))goto 23032 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23031 i=i+1 goto 23030 23032 continue i=1 23033 if(.not.(i.le.nxis))goto 23035 j=i 23036 if(.not.(j.le.nxis))goto 23038 vwk(i,j) = 0.d0 k=1 23039 if(.not.(k.le.nqd))goto 23041 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23040 k=k+1 goto 23039 23041 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23028 kk=kk+1 goto 23027 23029 continue i=1 23042 if(.not.(i.le.nxi))goto 23044 j=i 23045 if(.not.(j.le.nxi))goto 23047 v(i,j) = v(i,j) + q(i,j) 23046 j=j+1 goto 23045 23047 continue 23043 i=i+1 goto 23042 23044 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23048 if(.not.(i.le.nxis))goto 23050 jpvt(i) = 0 23049 i=i+1 goto 23048 23050 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23051 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23051 endif 23052 continue i=rkv+1 23053 if(.not.(i.le.nxis))goto 23055 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23054 i=i+1 goto 23053 23055 continue 23056 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23059 if(.not.(kk.le.nx))goto 23061 wtnewsum(kk) = 0.d0 i=1 23062 if(.not.(i.le.nqd))goto 23064 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23063 i=i+1 goto 23062 23064 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23060 kk=kk+1 goto 23059 23061 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23067 if(.not.(i.le.nobs))goto 23069 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23069 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23068 i=i+1 goto 23067 23069 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23076 if(.not.(kk.le.nx))goto 23078 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23077 kk=kk+1 goto 23076 23078 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 goto 23058 endif if(flag.eq.3)then goto 23058 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23058 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23058 endif 23057 goto 23056 23058 continue if(flag.eq.1)then flag = 2 goto 23025 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23089 if(.not.(kk.le.nx))goto 23091 i=1 23092 if(.not.(i.le.nqd))goto 23094 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23093 i=i+1 goto 23092 23094 continue 23090 kk=kk+1 goto 23089 23091 continue i=1 23095 if(.not.(i.le.nobs))goto 23097 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23096 i=i+1 goto 23095 23097 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23026 endif if(disc.lt.prec)then goto 23026 endif if(iter.lt.maxiter)then goto 23025 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) kk=1 23106 if(.not.(kk.le.nx))goto 23108 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) 23107 kk=kk+1 goto 23106 23108 continue call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23026 endif 23025 goto 23024 23026 continue i=1 23109 if(.not.(i.le.nobs))goto 23111 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23110 i=i+1 goto 23109 23111 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23116 if(.not.(i.le.nobs))goto 23118 lkhd = lkhd + dlog (fit(i)) 23117 i=i+1 goto 23116 23118 continue lkhd = lkhd / dfloat (nobs) else trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 i=1 23119 if(.not.(i.le.nobs))goto 23121 lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) 23120 i=i+1 goto 23119 23121 continue lkhd = lkhd / dfloat (cntsum) endif kk=1 23122 if(.not.(kk.le.nx))goto 23124 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23123 kk=kk+1 goto 23122 23124 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine cdenrkl (cd, nxis, qdrs, nqd, nx, xxwt, qdwt, wt0, mchp *r, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter, info) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), qdwt(*), wt0(nq *d,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(*), v(nxis,*), v *wk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23125 if(.not.(kk.le.nx))goto 23127 i=1 23128 if(.not.(i.le.nqd))goto 23130 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) * qdwt(i) 23129 i=i+1 goto 23128 23130 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23126 kk=kk+1 goto 23125 23127 continue rkl = 0.d0 kk=1 23131 if(.not.(kk.le.nx))goto 23133 tmp = 0.d0 i=1 23134 if(.not.(i.le.nqd))goto 23136 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23135 i=i+1 goto 23134 23136 continue rkl = rkl + xxwt(kk) * tmp 23132 kk=kk+1 goto 23131 23133 continue iter = 0 flag = 0 23137 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23140 if(.not.(kk.le.nx))goto 23142 i=1 23143 if(.not.(i.le.nxis))goto 23145 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23144 i=i+1 goto 23143 23145 continue i=1 23146 if(.not.(i.le.nxis))goto 23148 j=i 23149 if(.not.(j.le.nxis))goto 23151 vwk(i,j) = 0.d0 k=1 23152 if(.not.(k.le.nqd))goto 23154 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23153 k=k+1 goto 23152 23154 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23150 j=j+1 goto 23149 23151 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23147 i=i+1 goto 23146 23148 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23141 kk=kk+1 goto 23140 23142 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23155 if(.not.(i.le.nxis))goto 23157 jpvt(i) = 0 23156 i=i+1 goto 23155 23157 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23158 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23161 if(.not.(kk.le.nx))goto 23163 i=1 23164 if(.not.(i.le.nqd))goto 23166 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) * qd *wt(i) 23165 i=i+1 goto 23164 23166 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23162 kk=kk+1 goto 23161 23163 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23169 if(.not.(kk.le.nx))goto 23171 tmp = 0.d0 i=1 23172 if(.not.(i.le.nqd))goto 23174 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23173 i=i+1 goto 23172 23174 continue rklnew = rklnew + xxwt(kk) * tmp 23170 kk=kk+1 goto 23169 23171 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23177 if(.not.(kk.le.nx))goto 23179 call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23178 kk=kk+1 goto 23177 23179 continue rkl = 0.d0 kk=1 23180 if(.not.(kk.le.nx))goto 23182 tmp = 0.d0 i=1 23183 if(.not.(i.le.nqd))goto 23185 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23184 i=i+1 goto 23183 23185 continue rkl = rkl + xxwt(kk) * tmp 23181 kk=kk+1 goto 23180 23182 continue iter = 0 goto 23160 endif if(flag.eq.3)then goto 23160 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23160 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23160 endif 23159 goto 23158 23160 continue if(flag.eq.1)then flag = 2 goto 23138 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23196 if(.not.(kk.le.nx))goto 23198 i=1 23199 if(.not.(i.le.nqd))goto 23201 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23200 i=i+1 goto 23199 23201 continue 23197 kk=kk+1 goto 23196 23198 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23139 endif if(disc.lt.prec)then goto 23139 endif if(iter.lt.maxiter)then goto 23138 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dset (nqd*nx, 1.d0/dfloat(nqd), wt, 1) rkl = 0.d0 kk=1 23210 if(.not.(kk.le.nx))goto 23212 tmp = 0.d0 i=1 23213 if(.not.(i.le.nqd))goto 23215 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23214 i=i+1 goto 23213 23215 continue rkl = rkl + xxwt(kk) * tmp 23211 kk=kk+1 goto 23210 23212 continue iter = 0 flag = 2 else info = 2 goto 23139 endif 23138 goto 23137 23139 continue rkl = 0.d0 kk=1 23216 if(.not.(kk.le.nx))goto 23218 tmp = 0.d0 i=1 23219 if(.not.(i.le.nqd))goto 23221 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23220 i=i+1 goto 23219 23221 continue rkl = rkl + xxwt(kk) * tmp 23217 kk=kk+1 goto 23216 23218 continue wt(1,1) = rkl return end gss/src/dmcdc.f0000644000175100001440000000450512545250042013077 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dmcdc (a, lda, p, e, jpvt, info) integer lda, p, jpvt(*), info double precision a(lda,*), e(*) double precision beta, delta, theta, tmp, dasum, ddot integer i, j, jmax, jtmp, idamax info = 0 if( lda .lt. p .or. p .lt. 1 )then info = -1 return endif tmp = 1.d0 23002 if( 1.d0 + tmp .gt. 1.d0 )then tmp = tmp / 2.d0 goto 23002 endif 23003 continue jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dfloat (p*p-1)) if( tmp .lt. 1.d0 )then tmp = 1.d0 endif j=2 23006 if(.not.(j.le.p))goto 23008 jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) 23007 j=j+1 goto 23006 23008 continue delta = dasum (p, a, lda+1) / dfloat (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) j=1 23009 if(.not.(j.le.p))goto 23011 jpvt(j) = j 23010 j=j+1 goto 23009 23011 continue j=1 23012 if(.not.(j.le.p))goto 23014 jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if( jmax .ne. j )then call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp endif i=1 23017 if(.not.(i.lt.j))goto 23019 a(i,j) = a(i,j) / a(i,i) 23018 i=i+1 goto 23017 23019 continue i=j+1 23020 if(.not.(i.le.p))goto 23022 a(j,i) = a(j,i) - ddot (j-1, a(1,j), 1, a(1,i), 1) 23021 i=i+1 goto 23020 23022 continue if( j .eq. p )then theta = 0.d0 else jmax = idamax (p-j, a(j,j+1), lda) + j theta = dabs (a(j,jmax)) endif tmp = dmax1 (delta, dabs (a(j,j)), theta ** 2 / beta) e(j) = tmp - a(j,j) a(j,j) = tmp i=j+1 23025 if(.not.(i.le.p))goto 23027 a(i,i) = a(i,i) - a(j,i) ** 2 / a(j,j) 23026 i=i+1 goto 23025 23027 continue 23013 j=j+1 goto 23012 23014 continue j=1 23028 if(.not.(j.le.p))goto 23030 a(j,j) = dsqrt (a(j,j)) call dscal (p-j, a(j,j), a(j,j+1), lda) 23029 j=j+1 goto 23028 23030 continue return end gss/src/llrmnewton.f0000644000175100001440000004221312545250042014224 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine llrmnewton (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qd *rs, nqd, nx, xxwt, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), prec, mchpr, wk(*) integer iwt, iwtsum, imrs, ifit, imu, imuwk, iv, ivwk, icdnew, iwt *new, iwtnewsum, ifitnew, iwk iwt = 1 iwtsum = iwt + nqd*nx imrs = iwtsum + nx ifit = imrs + nxis imu = ifit + nobs imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis iwtnewsum = iwtnew + nqd*nx ifitnew = iwtnewsum + nx iwk = ifitnew + nobs call llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, qdrs, n *qd, nx, xxwt, prec, maxiter, mchpr, wk(iwt), wk(iwtsum), wk(imrs), * wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), * wk(iwtnew), wk(iwtnewsum), wk(ifitnew), wk(iwk), info) return end subroutine llrmnewton1 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, q *drs, nqd, nx, xxwt, prec, maxiter, mchpr, wt, wtsum, mrs, fit, mu, * muwk, v, vwk, jpvt, cdnew, wtnew, wtnewsum, fitnew, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*) *, info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), xx *wt(*), prec, mchpr, wt(nqd,*), wtsum(*), mrs(*), fit(*), mu(*), mu *wk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), wtnewsum(*) *, fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision norm, tmp, ddot, fitmean, lkhd, mumax, lkhdnew, d *isc, disc0, trc info = 0 i=1 23000 if(.not.(i.le.nxis))goto 23002 mrs(i) = 0.d0 if(cntsum.eq.0)then j=1 23005 if(.not.(j.le.nobs))goto 23007 mrs(i) = mrs(i) + rs(i,j) 23006 j=j+1 goto 23005 23007 continue mrs(i) = mrs(i) / dfloat (nobs) else j=1 23008 if(.not.(j.le.nobs))goto 23010 mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) 23009 j=j+1 goto 23008 23010 continue mrs(i) = mrs(i) / dfloat (cntsum) endif 23001 i=i+1 goto 23000 23002 continue if(cntsum.eq.0)then trc = 1.d0 / dfloat (nobs) else trc = 1.d0 / dfloat (cntsum) endif norm = 0.d0 kk=1 23013 if(.not.(kk.le.nx))goto 23015 wtsum(kk) = 0.d0 i=1 23016 if(.not.(i.le.nqd))goto 23018 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) wtsum(kk) = wtsum(kk) + wt(i,kk) 23017 i=i+1 goto 23016 23018 continue norm = norm + xxwt(kk) * dlog (wtsum(kk)) 23014 kk=kk+1 goto 23013 23015 continue fitmean = 0.d0 i=1 23019 if(.not.(i.le.nobs))goto 23021 tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23020 i=i+1 goto 23019 23021 continue call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean * trc + norm iter = 0 flag = 0 23024 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23027 if(.not.(kk.le.nx))goto 23029 i=1 23030 if(.not.(i.le.nxis))goto 23032 muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23031 i=i+1 goto 23030 23032 continue i=1 23033 if(.not.(i.le.nxis))goto 23035 j=i 23036 if(.not.(j.le.nxis))goto 23038 vwk(i,j) = 0.d0 k=1 23039 if(.not.(k.le.nqd))goto 23041 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23040 k=k+1 goto 23039 23041 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - muwk(i) * muwk(j) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23028 kk=kk+1 goto 23027 23029 continue i=1 23042 if(.not.(i.le.nxi))goto 23044 j=i 23045 if(.not.(j.le.nxi))goto 23047 v(i,j) = v(i,j) + q(i,j) 23046 j=j+1 goto 23045 23047 continue 23043 i=i+1 goto 23042 23044 continue call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23048 if(.not.(i.le.nxis))goto 23050 jpvt(i) = 0 23049 i=i+1 goto 23048 23050 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23051 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23051 endif 23052 continue i=rkv+1 23053 if(.not.(i.le.nxis))goto 23055 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23054 i=i+1 goto 23053 23055 continue 23056 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) norm = 0.d0 kk=1 23059 if(.not.(kk.le.nx))goto 23061 wtnewsum(kk) = 0.d0 i=1 23062 if(.not.(i.le.nqd))goto 23064 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1)) wtnewsum(kk) = wtnewsum(kk) + wtnew(i,kk) 23063 i=i+1 goto 23062 23064 continue norm = norm + xxwt(kk) * dlog (wtnewsum(kk)) 23060 kk=kk+1 goto 23059 23061 continue if((flag.eq.0).or.(flag.eq.2))then fitmean = 0.d0 i=1 23067 if(.not.(i.le.nobs))goto 23069 tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if(tmp.gt.3.d2)then flag = flag + 1 goto 23069 endif fitnew(i) = dexp (tmp) if(cntsum.ne.0)then tmp = tmp * dfloat (cnt(i)) endif fitmean = fitmean + tmp 23068 i=i+1 goto 23067 23069 continue call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + nor *m endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) tmp = dfloat (nqd) call dset (nqd*nx, 1.d0, wt, 1) call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0/tmp, fit, 1) fitmean = - dlog (tmp) lkhd = - fitmean iter = 0 goto 23058 endif if(flag.eq.3)then goto 23058 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23058 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23058 endif 23057 goto 23056 23058 continue if(flag.eq.1)then flag = 2 goto 23025 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23086 if(.not.(kk.le.nx))goto 23088 i=1 23089 if(.not.(i.le.nqd))goto 23091 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23090 i=i+1 goto 23089 23091 continue 23087 kk=kk+1 goto 23086 23088 continue i=1 23092 if(.not.(i.le.nobs))goto 23094 disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) 23093 i=i+1 goto 23092 23094 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs( *lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23026 endif if(disc.lt.prec)then goto 23026 endif if(iter.lt.maxiter)then goto 23025 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) tmp = dfloat (nqd) call dset (nqd*nx, 1.d0, wt, 1) call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0/tmp, fit, 1) fitmean = - dlog (tmp) lkhd = - fitmean iter = 0 flag = 2 else info = 2 goto 23026 endif 23025 goto 23024 23026 continue i=1 23103 if(.not.(i.le.nobs))goto 23105 call daxpy (nxis, -1.d0, mrs, 1, rs(1,i), 1) call dprmut (rs(1,i), nxis, jpvt, 0) if(cntsum.ne.0)then call dscal (nxis, dsqrt(dfloat(cnt(i))), rs(1,i), 1) endif call dtrsl (v, nxis, nxis, rs(1,i), 11, infowk) 23104 i=i+1 goto 23103 23105 continue trc = ddot (nobs*nxis, rs, 1, rs, 1) if(cntsum.eq.0)then trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 i=1 23110 if(.not.(i.le.nobs))goto 23112 lkhd = lkhd + dlog (fit(i)) 23111 i=i+1 goto 23110 23112 continue lkhd = lkhd / dfloat (nobs) else trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 i=1 23113 if(.not.(i.le.nobs))goto 23115 lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) 23114 i=i+1 goto 23113 23115 continue lkhd = lkhd / dfloat (cntsum) endif kk=1 23116 if(.not.(kk.le.nx))goto 23118 lkhd = lkhd - xxwt(kk) * dlog (wtsum(kk)) 23117 kk=kk+1 goto 23116 23118 continue wtsum(1) = lkhd wtsum(2) = trc return end subroutine llrmaux (cd, nxis, q, nxi, qdrs, nqd, nx, xxwt, mchpr, *wt, wtsum, mu, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), xxwt(*), mchpr *, wt(nqd,*), wtsum(*), mu(*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot kk=1 23119 if(.not.(kk.le.nx))goto 23121 wtsum(kk) = 0.d0 i=1 23122 if(.not.(i.le.nqd))goto 23124 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) wtsum(kk) = wtsum(kk) + wt(i,kk) 23123 i=i+1 goto 23122 23124 continue 23120 kk=kk+1 goto 23119 23121 continue call dset (nxis*nxis, 0.d0, v, 1) kk=1 23125 if(.not.(kk.le.nx))goto 23127 i=1 23128 if(.not.(i.le.nxis))goto 23130 mu(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) / wtsum(kk) 23129 i=i+1 goto 23128 23130 continue i=1 23131 if(.not.(i.le.nxis))goto 23133 j=i 23134 if(.not.(j.le.nxis))goto 23136 vwk(i,j) = 0.d0 k=1 23137 if(.not.(k.le.nqd))goto 23139 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23138 k=k+1 goto 23137 23139 continue vwk(i,j) = vwk(i,j) / wtsum(kk) - mu(i) * mu(j) 23135 j=j+1 goto 23134 23136 continue 23132 i=i+1 goto 23131 23133 continue call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23126 kk=kk+1 goto 23125 23127 continue i=1 23140 if(.not.(i.le.nxi))goto 23142 j=i 23143 if(.not.(j.le.nxi))goto 23145 v(i,j) = v(i,j) + q(i,j) 23144 j=j+1 goto 23143 23145 continue 23141 i=i+1 goto 23140 23142 continue i=1 23146 if(.not.(i.le.nxis))goto 23148 jpvt(i) = 0 23147 i=i+1 goto 23146 23148 continue call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) 23149 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23149 endif 23150 continue i=rkv+1 23151 if(.not.(i.le.nxis))goto 23153 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23152 i=i+1 goto 23151 23153 continue return end subroutine llrmrkl (cd, nxis, qdrs, nqd, nx, xxwt, wt0, offset, mc *hpr, wt, wtnew, mu, muwk, v, vwk, jpvt, cdnew, prec, maxiter, info *) integer nxis, nqd, nx, jpvt(*), maxiter, info double precision cd(*), qdrs(nqd,nxis,*), xxwt(*), wt0(nqd,*), off *set(nqd,*), mchpr, wt(nqd,*), wtnew(nqd,*), mu(*), muwk(*), v(nxis *,*), vwk(nxis,*), cdnew(*), prec integer i, j, k, kk, iter, flag, idamax, infowk double precision ddot, dasum, rkl, tmp, mumax, rklnew, disc, disc0 kk=1 23154 if(.not.(kk.le.nx))goto 23156 i=1 23157 if(.not.(i.le.nqd))goto 23159 wt(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1) + offset(i, *kk)) 23158 i=i+1 goto 23157 23159 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23155 kk=kk+1 goto 23154 23156 continue rkl = 0.d0 kk=1 23160 if(.not.(kk.le.nx))goto 23162 tmp = 0.d0 i=1 23163 if(.not.(i.le.nqd))goto 23165 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23164 i=i+1 goto 23163 23165 continue rkl = rkl + xxwt(kk) * tmp 23161 kk=kk+1 goto 23160 23162 continue iter = 0 flag = 0 23166 continue iter = iter + 1 call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) kk=1 23169 if(.not.(kk.le.nx))goto 23171 i=1 23172 if(.not.(i.le.nxis))goto 23174 muwk(i) = ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) 23173 i=i+1 goto 23172 23174 continue i=1 23175 if(.not.(i.le.nxis))goto 23177 j=i 23178 if(.not.(j.le.nxis))goto 23180 vwk(i,j) = 0.d0 k=1 23181 if(.not.(k.le.nqd))goto 23183 vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) 23182 k=k+1 goto 23181 23183 continue vwk(i,j) = vwk(i,j) - muwk(i) * muwk(j) 23179 j=j+1 goto 23178 23180 continue muwk(i) = ddot (nqd, wt0(1,kk), 1, qdrs(1,i,kk), 1) - muwk(i) 23176 i=i+1 goto 23175 23177 continue call daxpy (nxis, xxwt(kk), muwk, 1, mu, 1) call daxpy (nxis*nxis, xxwt(kk), vwk, 1, v, 1) 23170 kk=kk+1 goto 23169 23171 continue mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23184 if(.not.(i.le.nxis))goto 23186 jpvt(i) = 0 23185 i=i+1 goto 23184 23186 continue call dmcdc (v, nxis, nxis, cdnew, jpvt, infowk) 23187 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) kk=1 23190 if(.not.(kk.le.nx))goto 23192 i=1 23193 if(.not.(i.le.nqd))goto 23195 wtnew(i,kk) = dexp (ddot (nxis, qdrs(i,1,kk), nqd, cdnew, 1) + off *set(i,kk)) 23194 i=i+1 goto 23193 23195 continue call dscal (nqd, 1.d0/dasum(nqd,wtnew(1,kk),1), wtnew(1,kk), 1) 23191 kk=kk+1 goto 23190 23192 continue if((flag.eq.0).or.(flag.eq.2))then rklnew = 0.d0 kk=1 23198 if(.not.(kk.le.nx))goto 23200 tmp = 0.d0 i=1 23201 if(.not.(i.le.nqd))goto 23203 tmp = tmp + dlog(wt0(i,kk)/wtnew(i,kk)) * wt0(i,kk) 23202 i=i+1 goto 23201 23203 continue rklnew = rklnew + xxwt(kk) * tmp 23199 kk=kk+1 goto 23198 23200 continue endif if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) kk=1 23206 if(.not.(kk.le.nx))goto 23208 i=1 23209 if(.not.(i.le.nqd))goto 23211 wt(i,kk) = dexp (offset(i,kk)) 23210 i=i+1 goto 23209 23211 continue call dscal (nqd, 1.d0/dasum(nqd,wt(1,kk),1), wt(1,kk), 1) 23207 kk=kk+1 goto 23206 23208 continue rkl = 0.d0 kk=1 23212 if(.not.(kk.le.nx))goto 23214 tmp = 0.d0 i=1 23215 if(.not.(i.le.nqd))goto 23217 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23216 i=i+1 goto 23215 23217 continue rkl = rkl + xxwt(kk) * tmp 23213 kk=kk+1 goto 23212 23214 continue iter = 0 goto 23189 endif if(flag.eq.3)then goto 23189 endif if(rklnew-rkl.lt.1.d1*(1.d0+dabs(rkl))*mchpr)then goto 23189 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/mumax).lt.1.d1*mchpr)then goto 23189 endif 23188 goto 23187 23189 continue if(flag.eq.1)then flag = 2 goto 23167 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 kk=1 23228 if(.not.(kk.le.nx))goto 23230 i=1 23231 if(.not.(i.le.nqd))goto 23233 disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk) *))) 23232 i=i+1 goto 23231 23233 continue 23229 kk=kk+1 goto 23228 23230 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(rkl)))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl *))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew if(disc0.lt.prec)then goto 23168 endif if(disc.lt.prec)then goto 23168 endif if(iter.lt.maxiter)then goto 23167 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) call dset (nqd*nx, 1.d0/dfloat(nqd), wt, 1) rkl = 0.d0 kk=1 23242 if(.not.(kk.le.nx))goto 23244 tmp = 0.d0 i=1 23245 if(.not.(i.le.nqd))goto 23247 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23246 i=i+1 goto 23245 23247 continue rkl = rkl + xxwt(kk) * tmp 23243 kk=kk+1 goto 23242 23244 continue iter = 0 flag = 2 else info = 2 goto 23168 endif 23167 goto 23166 23168 continue rkl = 0.d0 kk=1 23248 if(.not.(kk.le.nx))goto 23250 tmp = 0.d0 i=1 23251 if(.not.(i.le.nqd))goto 23253 tmp = tmp + dlog(wt0(i,kk)/wt(i,kk)) * wt0(i,kk) 23252 i=i+1 goto 23251 23253 continue rkl = rkl + xxwt(kk) * tmp 23249 kk=kk+1 goto 23248 23250 continue wt(1,1) = rkl return end gss/src/dnewton10.f0000644000175100001440000001625212545250042013646 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, int *rs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, p *rec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), w *k(iwtnew), wk(iwk), info) return end subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, in *trs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info *) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchp *r, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, * disc, disc0 info = 0 wtsum = 0.d0 i=1 23000 if(.not.(i.le.nobs))goto 23002 tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif wtsum = wtsum + wt(i) 23001 i=i+1 goto 23000 23002 continue if(cntsum.eq.0)then lkhd = wtsum / dfloat (nobs) else lkhd = wtsum / dfloat (cntsum) endif lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23007 continue iter = iter + 1 i=1 23010 if(.not.(i.le.nxis))goto 23012 mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum 23011 i=i+1 goto 23010 23012 continue i=1 23013 if(.not.(i.le.nxis))goto 23015 j=i 23016 if(.not.(j.le.nxis))goto 23018 v(i,j) = 0.d0 k=1 23019 if(.not.(k.le.nobs))goto 23021 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23020 k=k+1 goto 23019 23021 continue v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23017 j=j+1 goto 23016 23018 continue 23014 i=i+1 goto 23013 23015 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23024 if(.not.(i.le.nxis))goto 23026 jpvt(i) = 0 23025 i=i+1 goto 23024 23026 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23027 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23027 endif 23028 continue i=rkv+1 23029 if(.not.(i.le.nxis))goto 23031 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23030 i=i+1 goto 23029 23031 continue 23032 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) wtsumnew = 0.d0 i=1 23035 if(.not.(i.le.nobs))goto 23037 tmp = ddot (nxis, rs(i,1), nobs, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23037 endif wtnew(i) = dexp (-tmp) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif wtsumnew = wtsumnew + wtnew(i) 23036 i=i+1 goto 23035 23037 continue if(cntsum.eq.0)then lkhdnew = wtsumnew / dfloat (nobs) else lkhdnew = wtsumnew / dfloat (cntsum) endif lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23046 if(.not.(i.le.nobs))goto 23048 if(cntsum.ne.0)then wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23047 i=i+1 goto 23046 23048 continue lkhd = 0.d0 iter = 0 goto 23034 endif if(flag.eq.3)then goto 23034 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23034 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23034 endif 23033 goto 23032 23034 continue if(flag.eq.1)then flag = 2 goto 23008 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23061 if(.not.(i.le.nobs))goto 23063 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23062 i=i+1 goto 23061 23063 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew if(disc0.lt.prec)then goto 23009 endif if(disc.lt.prec)then goto 23009 endif if(iter.lt.maxiter)then goto 23008 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 i=1 23072 if(.not.(i.le.nobs))goto 23074 if(cntsum.ne.0)then wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 endif wtsum = wtsum + wt(i) 23073 i=i+1 goto 23072 23074 continue lkhd = 0.d0 iter = 0 flag = 2 else info = 2 goto 23009 endif 23008 goto 23007 23009 continue call dscal (nobs, 1.d0/wtsum, wt, 1) i=1 23077 if(.not.(i.le.nxis))goto 23079 j=i 23080 if(.not.(j.le.nxis))goto 23082 v(i,j) = 0.d0 k=1 23083 if(.not.(k.le.nobs))goto 23085 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23084 k=k+1 goto 23083 23085 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23081 j=j+1 goto 23080 23082 continue 23078 i=i+1 goto 23077 23079 continue i=1 23088 if(.not.(i.le.nxis))goto 23090 jpvt(i) = 0 23089 i=i+1 goto 23088 23090 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23091 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23091 endif 23092 continue i=rkv+1 23093 if(.not.(i.le.nxis))goto 23095 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23094 i=i+1 goto 23093 23095 continue i=1 23096 if(.not.(i.le.nobs))goto 23098 call dcopy (nxis, rs(i,1), nobs, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif 23097 i=i+1 goto 23096 23098 continue call dcopy (nobs, wtnew, 1, wt, 1) return end gss/src/reg.f0000644000175100001440000001234012545250042012576 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine reg (sr, nobs, nnull, q, nxi, y, method, alpha, varht, *score, dc, mchpr, v, mu, jpvt, wk, rkv, info) double precision sr(nobs,*), q(nxi,*), y(*), alpha, varht, score, *dc(*), mchpr, v(nnull+nxi,*), mu(*), wk(*) integer nobs, nnull, nxi, method, jpvt(*), rkv, info double precision ddot, dasum, rss, trc, dum integer i, j, nn, idamax, infowk info = 0 nn = nnull + nxi i=1 23000 if(.not.(i.le.nn))goto 23002 mu(i) = ddot (nobs, sr(1,i), 1, y, 1) j=i 23003 if(.not.(j.le.nn))goto 23005 v(i,j) = ddot (nobs, sr(1,i), 1, sr(1,j), 1) if(i.gt.nnull)then v(i,j) = v(i,j) + q(i-nnull,j-nnull) endif 23004 j=j+1 goto 23003 23005 continue 23001 i=i+1 goto 23000 23002 continue infowk = 0 i=1 23008 if(.not.(i.le.nn))goto 23010 infowk = infowk + jpvt(i) 23009 i=i+1 goto 23008 23010 continue call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) 23011 if(v(rkv,rkv).lt.v(infowk+j,infowk+j)*dsqrt(mchpr))then rkv = rkv - 1 goto 23011 endif 23012 continue i=rkv+1 23013 if(.not.(i.le.nn))goto 23015 v(i,i) = v(j,j) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23014 i=i+1 goto 23013 23015 continue call dcopy (nn, mu, 1, dc, 1) call dprmut (dc, nn, jpvt, 0) call dtrsl (v, nn, nn, dc, 11, infowk) call dset (nn-rkv, 0.d0, dc(rkv+1), 1) call dtrsl (v, nn, nn, dc, 01, infowk) call dprmut (dc, nn, jpvt, 1) if(method.eq.4)then return endif i=1 23018 if(.not.(i.le.nobs))goto 23020 wk(i) = y(i) - ddot (nn, sr(i,1), nobs, dc, 1) 23019 i=i+1 goto 23018 23020 continue if(method.eq.5)then wk(nobs+1) = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) i=1 23023 if(.not.(i.le.nobs))goto 23025 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23024 i=i+1 goto 23023 23025 continue return endif if(method.eq.3)then rss = ddot (nobs, y, 1, wk, 1) if(nnull.gt.0)then call dqrdc (sr, nobs, nobs, nnull, wk, dum, dum, 0) i=1 23030 if(.not.(i.le.nxi))goto 23032 call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nn *ull+i), dum, dum, dum, 01000, infowk) 23031 i=i+1 goto 23030 23032 continue endif call dcopy (nxi, q, nxi+1, wk, 1) i=1 23033 if(.not.(i.le.nxi))goto 23035 j=i 23036 if(.not.(j.le.nxi))goto 23038 q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnu *ll+1,nnull+j), 1) 23037 j=j+1 goto 23036 23038 continue 23034 i=i+1 goto 23033 23035 continue i=1 23039 if(.not.(i.le.nxi))goto 23041 j=i 23042 if(.not.(j.le.nxi))goto 23044 sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) 23043 j=j+1 goto 23042 23044 continue 23040 i=i+1 goto 23039 23041 continue call dcopy (nxi, wk, 1, q, nxi+1) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 i=1 23045 if(.not.(i.le.rkv-nnull))goto 23047 trc = trc + dlog (mu(nxi-i+1)) 23046 i=i+1 goto 23045 23047 continue call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) i=1 23048 if(.not.(i.le.rkv-nnull))goto 23050 trc = trc - dlog (mu(nxi-i+1)) 23049 i=i+1 goto 23048 23050 continue score = rss / dfloat (nobs) * dexp (trc/dfloat(nobs-nnull)) varht = rss / dfloat (nobs-nnull) else rss = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) i=1 23051 if(.not.(i.le.nobs))goto 23053 call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) 23052 i=i+1 goto 23051 23053 continue trc = dasum (nobs, wk, 1) / dfloat (nobs) if(method.eq.2)then score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) else score = rss + 2.d0 * varht * alpha * trc endif endif wk(1) = rss wk(2) = trc return end subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) integer nn, jpvt(*), rkv, nr, nnull double precision ddot integer i, j, infowk i=1 23056 if(.not.(i.le.nr))goto 23058 call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if(nn-rkv.gt.0)then call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) endif call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) 23057 i=i+1 goto 23056 23058 continue call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) i=1 23061 if(.not.(i.le.nnull))goto 23063 call dtrsl (v, nn, nn, wk(1,i), 11, infowk) 23062 i=i+1 goto 23061 23063 continue i=1 23064 if(.not.(i.le.nnull))goto 23066 j=i 23067 if(.not.(j.le.nnull))goto 23069 sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) 23068 j=j+1 goto 23067 23069 continue 23065 i=i+1 goto 23064 23066 continue return end gss/src/dsidr.f0000644000175100001440000000206112545250042013125 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dsidr (vmu, s, lds, nobs, nnull, y, q, ldq, tol, job, l *imnla, nlaht, score, varht, c, d, qraux, jpvt, wk, info) character*1 vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, *score(*), varht, c(*), d(*), qraux(*), wk(*) info = 0 if( nnull .lt. 1 .or. nnull .ge. nobs .or. nobs .gt. lds .or. nobs * .gt. ldq )then info = -1 return endif if( vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u' )then info = -3 return endif call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, *info, wk) if( info .ne. 0 )then return endif call dcore (vmu, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, *score, varht, info, wk, wk(2*nobs+1)) if( info .ne. 0 )then return endif call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, * d, info, wk) return end gss/src/dsidr0.f0000644000175100001440000000133012545250042013203 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dsidr0 (vmu, s, lds, nobs, nnull, y, q, ldq, tol, job, *limnla, nlaht, score, varht, c, d, qraux, jpvt, wk, info) integer vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, *score(*), varht, c(*), d(*), qraux(*), wk(*) character*1 vmu1 if( vmu .eq. 1 )then vmu1 = 'v' endif if( vmu .eq. 2 )then vmu1 = 'm' endif if( vmu .eq. 3 )then vmu1 = 'u' endif call dsidr (vmu1, s, lds, nobs, nnull, y, q, ldq, tol, job, limnla *, nlaht, score, varht, c, d, qraux, jpvt, wk, info) return end gss/src/dstup.f0000644000175100001440000000173512545250042013166 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldqr, ld *qc, nq, info, work) integer lds, nobs, nnull, jpvt(*), ldqr, ldqc, nq, info double precision s(lds,*), y(*), qraux(*), q(ldqr,ldqc,*), work(*) double precision dum integer j info = 0 if( nobs .lt. 1 .or. nobs .gt. lds .or. nobs .gt. ldqr .or. nobs . *gt. ldqc )then info = -1 return endif j=1 23002 if(.not.(j.le.nnull))goto 23004 jpvt(j) = 0 23003 j=j+1 goto 23002 23004 continue call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, * 01100, info) if( info .ne. 0 )then return endif j=1 23007 if(.not.(j.le.nq))goto 23009 call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info, *work) 23008 j=j+1 goto 23007 23009 continue return end gss/src/ratfor/0000755000175100001440000000000012236246664013163 5ustar hornikusersgss/src/ratfor/hzdnewton.r0000644000175100001440000001615512355360640015367 0ustar hornikusers #::::::::::::::: # hzdnewton #::::::::::::::: subroutine hzdnewton (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, wk(*) integer imrs, iwt, ifit, imu, imuwk, iv, ivwk, icdnew, iwtnew, ifitnew, iwk imrs = 1 iwt = imrs + max0 (nxis, 2) ifit = iwt + nqd*nx imu = ifit + nt imuwk = imu + nxis iv = imuwk + nxis ivwk = iv + nxis*nxis icdnew = ivwk + nxis*nxis iwtnew = icdnew + nxis ifitnew = iwtnew + nqd*nx iwk = ifitnew + nt call hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, wk(imrs), wk(iwt), wk(ifit), wk(imu), wk(imuwk), wk(iv), wk(ivwk), jpvt, wk(icdnew), wk(iwtnew), wk(ifitnew), wk(iwk), info) return end #:::::::::::::::: # hzdnewton1 #:::::::::::::::: subroutine hzdnewton1 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, qdrs, nqd, qdwt, nx, prec, maxiter, mchpr, mrs, wt, fit, mu, muwk, v, vwk, jpvt, cdnew, wtnew, fitnew, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), nqd, nx, maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nxis,*), qdrs(nqd,nxis,*), qdwt(nqd,*), prec, mchpr, mrs(*), wt(nqd,*), fit(*), mu(*), muwk(*), v(nxis,*), vwk(nxis,*), cdnew(*), wtnew(nqd,*), fitnew(*), wk(*) integer i, j, k, kk, iter, flag, rkv, idamax, infowk double precision tmp, ddot, fitmean, dasum, lkhd, mumax, lkhdnew, disc, disc0, trc # Calculate constants info = 0 for (i=1;i<=nxis;i=i+1) { mrs(i) = 0.d0 for (j=1;j<=nt;j=j+1) { if (cntsum==0) mrs(i) = mrs(i) + rs(i,j) else mrs(i) = mrs(i) + rs(i,j) * dfloat (cnt(j)) } mrs(i) = mrs(i) / dfloat (nobs) } # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cd, 1) fit(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wt, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = ddot (nxi, cd, 1, wk, 1) / 2.d0 - fitmean iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient call dset (nxis, 0.d0, mu, 1) call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { muwk(i) = - ddot (nqd, wt(1,kk), 1, qdrs(1,i,kk), 1) for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis, 1.d0, muwk, 1, mu, 1) call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } call daxpy (nxis, 1.d0, mrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) } if ((flag==1)|(flag==3)) break } if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nt;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } fitmean = fitmean / dfloat (nobs) - dasum (nqd*nx, wtnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) fitmean = - dasum (nqd*nx, wt, 1) lkhd = - fitmean iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nt, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # Work array: # twk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, UW-Madison, 5/4/88 at Yale. double precision dum, ddot integer n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute U ( T + n*lambdahat I )^{-1} z call dset (n, 10.d0 ** nlaht, twk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, twk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, twk(1,2), 2) call dpbfa (twk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } call dpbsl (twk, 2, n, 1, z(n0+1)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, twk, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, twk, z(n0+2), z(n0+2), dum,_ dum, dum, dum, 10000, info) # compute c call dset (n0, 0.d0, c, 1) call dcopy (n, z(n0+1), 1, c(n0+1), 1) call dqrsl (s, lds, nobs, nnull, qraux, c, c, dum, dum, dum, dum, 10000,_ info) # compute d for (j=1;j<=n0;j=j+1) { d(j) = z(j) - ddot (n, z(n0+1), 1, q(n0+1,j), 1) } call dtrsl (s, lds, n0, d, 01, info) call dprmut (d, n0, jpvt, 1) return end #............................................................................... gss/src/ratfor/dgold.r0000644000175100001440000000767712355360640014451 0ustar hornikusers #::::::::::: # dgold #::::::::::: subroutine dgold (vmu, q, ldq, n, z, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by golden section search. character*1 vmu integer ldq, n, info double precision q(ldq,*), z(*), low, upp, nlaht, score, varht, twk(2,*),_ work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log(n*lambda). # score the GCV/GML/URE score at the estimated lambda. # varht the variance estimate at the estimated lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,n). # work of size at least (n). # Routines called directly: # Fortran -- dsqrt # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision ratio, mlo, mup, tmpl, tmpu ratio = ( dsqrt (5.d0) - 1.d0 ) / 2.d0 info = 0 # interchange the boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( n < 1 | n > ldq ) { info = -1 return } # initialize golden section search for scrht mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } # golden section search for estimate of lambda repeat { if ( mup - mlo < 1.d-7 ) break if ( tmpl < tmpu ) { upp = mup mup = mlo tmpu = tmpl mlo = upp - ratio * (upp - low) call dset (n, 10.d0 ** (mlo), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mlo call dtrev (vmu, twk, 2, n, z, tmpl, varht, info, work) if ( info != 0 ) { info = -2 return } } else { low = mlo mlo = mup tmpl = tmpu mup = low + ratio * (upp - low) call dset (n, 10.d0 ** (mup), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**mup call dtrev (vmu, twk, 2, n, z, tmpu, varht, info, work) if ( info != 0 ) { info = -2 return } } } # compute the return value nlaht = ( mup + mlo ) / 2.d0 call dset (n, 10.d0 ** (nlaht), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**nlaht call dtrev (vmu, twk, 2, n, z, score, varht, info, work) if ( info != 0 ) { info = -2 return } return end #............................................................................... gss/src/ratfor/dsytr.r0000644000175100001440000001013212355360640014501 0ustar hornikusers #::::::::::: # dsytr #::::::::::: subroutine dsytr (x, ldx, n, tol, info, work) # Acronym: Double-precision SYmmetric matrix TRidiagonalization. # Purpose: This routine performs the Householder tridiagonalization # algorithm on symmetric matrix `x', with truncation strategy as # described in Gu, Bates, Chen, and Wahba (1988). # References: 1. Golud and Van Loan (1983) Matrix Computation. (pp.276-7) # 2. Gu, Bates, Chen, and Wahba(1988), TR#823, Stat, UW-M. # 3. Dongarra et al.(1979) LINPACK User's Guide. (Chap. 9) # Relation with LINPACK: This routine computes the tridiagonalization # U^{T}XU=T, where X is symmetric, T is tridiagonal, and U is an # orthogonal matrix as the product of Housholder matrices. To compute # U^{T}y or Uy for vector y, we can use routine `dqrsl' of LINPACK. # The calling procedure is: # # 1. Create vector `qraux' by # call dcopy(n-2, x(2,1), ldx+1, qraux, 1) # 2. Call `dqrsl' as # call dqrsl (x(2,1), ldx, n-1, n-2, qraux, y(2), ... ) integer ldx, n, info double precision x(ldx,*), tol, work(*) # On entry: # x symmetric matrix, only LOWER triangle refered. # ldx leading dimension of x. # n size of matrix `x'. # tol truncation tolarence; if zero, set to square machine # precision. # On Exit: # x diagonal: diagonal elements of tridiag. transf. # upper triangle: off-diagonal of tridiag. transf. # lower triangle: overwritten by Householder factors. # info 0 : normal termination. # -1 : dimension error. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dfloat, dsqrt # Blas -- daxpy, ddot, dscal # Blas2 -- dsymv, dsyr2 # Written: Chong Gu, Statistics, UW-Madison, latest version 8/29/88. double precision nrmtot, nrmxj, alph, toltot, tolcum, toluni, dn, ddot integer j info = 0 # check dimension if ( ldx < n | n <= 2 ) { info = -1 return } # total Frobenius norm nrmtot = ddot (n, x, ldx+1, x, ldx+1) for ( j=1 ; j 1.d0 ) toltot = toltot / 2.d0 toltot = 4.d0 * toltot ** 2 # set truncation criterion if ( toltot < tol ) toltot = tol toltot = toltot * nrmtot dn = dfloat (n) toluni = toltot * 6.d0 / dn / ( dn - 1.d0 ) / ( 2.d0 * dn - 1.d0 ) # initialization tolcum = 0.d0 # main process for ( j=1 ; j= 0. # -3 : tuning parameters are out of scope. # -4 : fails to converge within maxite steps. # -5 : fails to find a reasonable descent direction. # >0 : the matrix S is rank deficient: rank(S)+1. # s,q,y destroyed. # others intact. # Work arrays: # wk of size (nobs*nobs*(nq+2)) # Routines called directly: # Rkpack -- dmudr1 # Routines called indirectly: # Blas -- dasum, daxpy, dcopy, ddot, dnrm2, dscal, dswap, idamax # Blas2 -- dgemv, dsymv, dsyr2 # Fortran -- dabs, dexp, dfloat, dlog, dlog10, dmax1, dsqrt # Linpack -- dpbfa, dpbsl, dpofa, dposl, dqrdc, dqrsl, dtrsl # Rkpack -- dcoef, dcore, ddeev, deval, dgold, dmcdc, dqrslm, # dstup, dsytr, dtrev # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 3/9/91. integer n, n0 integer iqraux, itraux, itwk, iqwk, iywk, ithewk, ihes, igra, ihwk1, ihwk2,_ igwk1, igwk2, ikwk, iwork1, iwork2, ijpvt, ipvtwk n = nobs n0 = nnull iqraux = 1 itraux = iqraux + n0 itwk = itraux + (n-n0-2) iqwk = itwk + 2 * (n-n0) iywk = iqwk + n * n ithewk = iywk + n ihes = ithewk + nq igra = ihes + nq * nq ihwk1 = igra + nq ihwk2 = ihwk1 + nq * nq igwk1 = ihwk2 + nq * nq igwk2 = igwk1 + nq ikwk = igwk2 + nq iwork1 = ikwk + (n-n0) * (n-n0) * nq iwork2 = iwork1 + n ijpvt = iwork2 + n ipvtwk = ijpvt + n0 call dmudr1 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs wk(iqraux), wk(ijpvt), wk(itwk), wk(itraux), wk(iqwk),_ wk(iywk), wk(ithewk), wk(ihes), wk(igra), wk(ihwk1),_ wk(ihwk2), wk(igwk1), wk(igwk2), wk(ipvtwk), wk(ikwk),_ wk(iwork1), wk(iwork2),_ info) return end gss/src/ratfor/dqrslm.r0000644000175100001440000000544012355360640014644 0ustar hornikusers #:::::::::::: # dqrslm #:::::::::::: subroutine dqrslm (x, ldx, n, k, qraux, a, lda, job, info, work) # Acronym: `dqrsl' Matrix version # Purpose: This routine generates the matrix Q^{T}AQ or QAQ^{T}, where # Q is the products of Householder matrix stored in factored form in # the LOWER triangle of `x' and `qraux', and A is assumed to be # symmetric. This routine is designed to be compatible with LINPACK's # `dqrdc' subroutine. # References: 1. Dongarra et al. (1979) LINPACK Users' Guide. (chap. 9) # 2. Golud and Van Loan (1983) Matrix Computation. (pp.276-7) integer ldx, n, k, lda, job, info double precision x(ldx,*), qraux(*), a(lda,*), work(*) # On entry: # x output from `dqrdc', of size (ldx,k). # ldx leading dimension of x. # n size of matrix A and Q. # k number of factors in Q. # qraux output from `dqrdc'. # a matrix A (of size (lda,n)), only LOWER triangle refered. # lda leading dimension of a. # job 0: Q^{T} A Q. # 1: Q A Q^{T}. # On Exit: # a matrix Q^{T}AQ or QAQ^{T} in LOWER triangle. # info 0: normal termination. # 1: `job' is out of scope. # -1: dimension error. # others unchanged. # Work array: # work of size at least (n). # Routines called: # Blas -- ddot, daxpy # Blas2 -- dsymv, dsyr2 # Written: Chong Gu, Statistics, UW-Madison, latest version 8/29/88. double precision tmp, alph, ddot integer i, j, step info = 0 # check input if ( lda < n | n < k | k < 1 ) { info = -1 return } if ( job != 0 & job != 1 ) { info = 1 return } # set operation sequence if ( job == 0 ) { j = 1 step = 1 } else { j = k step = -1 } # main process while ( j >= 1 & j <= k ) { if ( qraux(j) == 0.0d0 ) { j = j + step next } tmp = x(j,j) x(j,j) = qraux(j) # update the columns 1 thru j-1 for (i=1;i3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) } wtsumnew = dasum (nobs, wtnew, 1) lkhdnew = dlog (wtsumnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 call dscal (nobs, 1.d0/wtsumnew, wtnew, 1) # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) if (cntsum!=0) { for (i=1;i<=nobs;i=i+1) wt(i) = dfloat (cnt(i)) } else call dset (nobs, 1.d0, wt, 1) wtsum = dasum (nobs, wt, 1) lkhd = dlog (wtsum) call dscal (nobs, 1.d0/wtsum, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc00: rank(S)+1. # Work array: # work of size at least (nobs). # Routines called directly: # Linpack -- dqrdc, dqrsl # Rkpack -- dqrslm # Written: Chong Gu, Statistics, Purdue, latest version 3/7/91. double precision dum integer j info = 0 # check dimension if ( nobs < 1 | nobs > lds | nobs > ldqr | nobs > ldqc ) { info = -1 return } # QR decomposition of S=FR # The indented line below is added on Mar 7, 1991, # with credit to Dick Franke for (j=1;j<=nnull;j=j+1) jpvt(j) = 0 call dqrdc (s, lds, nobs, nnull, qraux, jpvt, work, 1) # F^{T} y; test rank of R call dqrsl (s, lds, nobs, nnull, qraux, y, dum, y, work, dum, dum, 01100,_ info) if ( info != 0 ) return # F^{T} Q_{*} F for (j=1;j<=nq;j=j+1) { call dqrslm (s, lds, nobs, nnull, qraux, q(1,1,j), ldqr, 0, info,_ work) } return end #............................................................................... gss/src/ratfor/deval.r0000644000175100001440000000524612355360640014441 0ustar hornikusers #::::::::::: # deval #::::::::::: subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, varht,_ info, twk, work) # Purpose: To evaluate GCV/GML function based on tridiagonal form and to # search minimum on an interval by equally spaced (in log10 scale) grid # search. character*1 vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q tidiagonal matrix in diagonal and super diagonal. # ldq leading dimension of Q. # n size of the matrix. # z U^{T} F_{2}^{T} y. # nint number of intervals (number of grids minus 1). # low lower limit of log10(n*lambda). # upp upper limit of log10(n*lambda). # varht known variance if vmu=='u'. # On exit: # nlaht the estimated log10(n*lambda). # score the GCV/GML/URE score vector on grid points. # varht the variance estimate at the estimated n*lambda. # info 0: normal termination. # -1: dimension error. # -2: tridiagonal form is not non-negative definite. # -3: vmu or nint is out of scope. # Work arrays: # twk array of length at least (2,n). # work array of length at least (n). # Routines called directly: # Fortran -- dfloat # Blas -- daxpy, dcopy # Rkpack -- dtrev # Other -- dset # Written: Chong Gu, Statistics, Purdue, 12/29/91 latest version. double precision tmp, minscr, mlo, varhtwk integer j info = 0 # interchange boundaries if necessary if ( upp < low ) { mlo = low low = upp upp = mlo } # check job requests if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | nint < 1 ) { info = -3 return } # check dimension if ( 1 > n | n > ldq ) { info = -1 return } # evaluation for (j=1;j<=nint+1;j=j+1) { tmp = low + dfloat (j-1) * ( upp - low ) / dfloat (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if ( info != 0 ) { info = -2 return } if ( score(j) <= minscr | j == 1 ) { minscr = score(j) nlaht = tmp varhtwk = varht } } varht = varhtwk return end #............................................................................... gss/src/ratfor/dsidr.r0000644000175100001440000001536012355360640014451 0ustar hornikusers #:::::::::::: # dsidr #:::::::::::: subroutine dsidr (vmu,_ s, lds, nobs, nnull, y, q, ldq,_ # data tol, job, limnla,_ # job requests nlaht, score, varht, c, d,_ # output qraux, jpvt, wk,_ # work arrays info) # error message # Acronym: Double precision SIngle smoothing parameter DRiver. # Purpose: # # This routine is the double precision single smoothing parameter # driver of the RKPACK -- a minipackage for solving the equations # # ( n lambda I + Sigma ) c + S d = y # S' c = 0 , # # where Sigma is n-by-n and S is n-by-M, and lambda is the so-called # smoothing parameter chosen to minimize the GCV criterion # # (1/n) || ( I - A(lambda) ) y || ** 2 # V(lambda) = -------------------------------------- , # [ (1/n) tr ( I - A(lambda) ) ] ** 2 # # where A(lambda), satisfying # # A(lambda) y = Sigma c + S d , # # is the so-called influence matrix, OR to minimize the GML criterion # # (1/n) y' ( I - A(lambda) ) y # M(lambda) = ------------------------------------ , # det [ (I - A(lambda))+ ]^{1/(n-M)} # # where det[(...)+] is the product of nonzero eigenvalues of (...). # # The general theory behind this is described in Kimeldorf and Wahba # (1971), which seeks the minimizer of certain variational problem in # reproducing kernel hilbert space. The generalized cross validation # (GCV) method for choosing the smoothing parameter lambda is propos- # ed by Craven and Wahba (1979). The GML criterion is described and # compared with the GCV by Wahba (1985). An example of this general # scheme is the thin plate smoothing spline model, as described by # Wahba and Wendelberger (1980), and Bates et al. (1987). # # RKPACK is the implementation of the GCV/GML algorithm based on the # Householder tridiagonalization, as proposed by Gu et al. (1988). # It does not assume any structure of Sigma and S, except that S is # of full rank, Sigma is symmetric, and # # S' c = 0 ===> c' Sigma c >= 0 (*) # # The Sigma matrix is the reproducing kernel (or semi-kernel) evalu- # ated at the data points, and the matrix S is a set of null space # basis evaluated at the data points. # # Dsidr will do either golden-section search or regular grid search # for the minimizing lambda of V/M(lambda). In the goden-section # search case, it does assume bowl-shaped V/M(lambda) curve. If this # is not true, the user may specify shorter searching intervals on # which the curve may be bowl-shaped. The precision of n*lambda is # 1.d-7 in the log10 scale. In the regular grid search case, it # provides a "GCV/GML curve" on the searching interval. (For the # later case user should provide `score' as a vector, though in the # golden section search case only minimum GCV/GML value is recorded.) # # RKPACK is a cubic order package. In fitting univariate smoothing # spline models, a linear order algorithm developed independently # by Hutchinson and deHoog (1985) and by O'Sullivan (1985) is recommended. # Code by Woltring (1986) and O'Sullivan is available from NETLIB. character*1 vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, score(*),_ varht, c(*), d(*), qraux(*), wk(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # s the matrix S of size (nobs,nnull). # lds the leading dimension of s. # nobs the number of observations. # nnull the dimension of the null space. # y the observations. # q the matrix Q, only the lower triangle referred. # tol tolerance for truncation in `dsytr'. If 0.d0, set to # square of machine precision. # job <=0 : golden-section search # 0 -- searching interval specified automatically. # -1 -- search on (limnla(1), limnla(2)). # >0 : regular grid search on [limnla(1), limnla(2)] # #(grids) = job + 1. # limnla the searching interval (in log10 scale), see job. # varht known variance if vmu=='u'. # On exit: # nlaht the GCV/GML/URE estimate of log10(nobs*lambda). # limnla searching range for nlaht. # score job <= 0 : GCV/GML/URE value at nlaht. # job > 0 : GCV/GML/URE vector on the regular grid points. # varht the variance estimate. # c the parameters c. # d the parameters d. # s,qraux,jpvt # QR decomposition of S=FR, as from Linpack `dqrdc'. # q first nnull columns: F^{T} Q F_{1}. # BOTTOM-RIGHT corner: tridiagonalization of # F_{2}^{T} Q F_{2}. # info 0: normal termination. # -1: dimension error. # -2: F_{2}^{T} Q F_{2} !>= 0. # -3: vmu is out of scope. # >0: the matrix S is rank deficient: rank(S)+1. # others intact. # Work arrays: # wk of size at least (3*nobs). # Routines called directly: # Rkpack -- dcoef, dcore, dstup # Routines called indirectly: # Fortran -- dexp, dfloat, dlog, dlog10, dsqrt # Blas -- dasum, daxpy, dcopy, ddot, dnrm2, dscal # Blas2 -- dsymv, dsyr2 # Linpack -- dpbfa, dpbsl, dqrdc, dqrsl, dtrsl # Rkpack -- deval, dgold, dqrslm, dsytr, dtrev # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq ) { info = -1 return } # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # main process call dstup (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nobs, 1, info,_ wk) if ( info != 0 ) return call dcore (vmu, q, ldq, nobs, nnull, tol, y, job, limnla, nlaht, score,_ varht, info, wk, wk(2*nobs+1)) if ( info != 0 ) return call dcoef (s, lds, nobs, nnull, qraux, jpvt, y, q, ldq, nlaht, c, d,_ info, wk) return end #............................................................................... gss/src/ratfor/dcrdr.r0000644000175100001440000000660412355360640014443 0ustar hornikusers #::::::::::: # dcrdr #::::::::::: subroutine dcrdr (s, lds, nobs, nnull, qraux, jpvt, q, ldq, nlaht,_ r, ldr, nr, cr, ldcr, dr, lddr, wk, info) # Purpose: To compute auxiliary quantities cr and dr for posterior covariance # Usage: Use s, qraux, jpvt, q, and nlaht returned by dsidr. integer lds, nobs, nnull, jpvt(*), ldq, ldr, nr, ldcr, lddr, info double precision s(lds,*), qraux(*), q(ldq,*), nlaht, r(ldr,*), cr(ldcr,*),_ dr(lddr,*), wk(2,*) # On entry: # s,qraux,jpvt # QR-decomposition of S = F R. # nobs number of observations. # nnull dimension of null space. # q U^{T} F_{2}^{T} Q F_{2} U in BOTTOM-RIGHT corner's # LOWER triangle and SUPER DIAGONAL; # F_{2}^{T} Q F_{1} in BOTTOM-LEFT corner; # ldq leading dimension of q. # nlaht estimated log10(n*lambda). # r R(t,s^{T}). # nr length of s. # On exit: # cr (M^{-1}-M^{-1}S(S^{T}M^{-1}S)^{-1}S^{T}M^{-1})R(t,s^{T}) # dr (S^{T}M^{-1}S)^{-1}S^{T}M^{-1}R(t,s^{T}) # info 0: normal termination. # >0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # others intact. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, 2/27/96 at Ann Arbor. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldr < nobs |_ nr < 1 | ldcr < nobs | lddr < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # copy r to cr for (j=1;j<=nr;j=j+1) call dcopy (nobs, r(1,j), 1, cr(1,j), 1) # compute diag(I, U^{T}) F^{T} R(t,s^{T}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) { call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), dum, cr(1,j), dum,_ dum, dum, 01000, info) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), dum, cr(n0+2,j), dum, dum, dum, 01000, info) } # compute U ( T + n*lambdahat I )^{-1} diag(I, U^{T}) F^{T} R(t,s^{T}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=nr;j=j+1) call dpbsl (wk, 2, n, 1, cr(n0+1,j)) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=nr;j=j+1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, cr(n0+2,j), cr(n0+2,j),_ dum, dum, dum, dum, 10000, info) # compute dr for (j=1;j<=nr;j=j+1) { for (i=1;i<=n0;i=i+1) dr(i,j) = cr(i,j) - ddot (n, cr(n0+1,j), 1, q(n0+1,i), 1) call dtrsl (s, lds, n0, dr(1,j), 01, info) call dprmut (dr(1,j), n0, jpvt, 1) } # compute cr for (j=1;j<=nr;j=j+1) { call dset (n0, 0.d0, cr(1,j), 1) call dqrsl (s, lds, nobs, nnull, qraux, cr(1,j), cr(1,j),_ dum, dum, dum, dum, 10000, info) } return end #.............................................................................. gss/src/ratfor/dmudr1.r0000644000175100001440000002510012355360640014531 0ustar hornikusers#::::::::::: # dmudr1 #::::::::::: subroutine dmudr1 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs qraux, jpvt, twk, traux, qwk, ywk, thewk,_ # work arrays hes, gra, hwk1, hwk2, gwk1, gwk2, pvtwk,_ kwk, work1, work2,_ info) # Acronym: Double precision MUltiple smoothing parameter DRiver. # Purpose: This routine implements the iterative algorithm for minimizing # GCV/GML scores with multiple smoothing parameters described in # Gu and Wahba(1988, Minimizing GCV/GML scores with multiple smoothing # parameters via the Newton method). # WARNING: Please be sure that you understand what this routine does before # you call it. Pilot runs with small problems are recommended. This # routine performs VERY INTENSIVE numerical calculations for big nobs. integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ jpvt(*), pvtwk(*), info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ qraux(*), traux(*), twk(2,*), qwk(ldqr,*), ywk(*),_ thewk(*), hes(nq,*), gra(*), hwk1(nq,*), hwk2(nq,*),_ gwk1(*), gwk2(*), kwk(nobs-nnull,nobs-nnull,*),_ work1(*), work2(*) character*1 vmu # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # s the matrix S, of size (lds,nnull). # nobs the number of observations. # nnull the dimension of the null space. # q the matrices Q_{i}'s, of dimension (ldqr,ldqc,nq). # nq the number of Q_{i}'s. # y the response vector of size (nobs) # tol the tolerance for truncation in the tridiagonalization. # init 0 : No initial values provided for the theta. # 1 : Initial values provided for the theta. # theta initial values of theta if init = 1. # prec precision requested for the minimum score value. # maxite maximum number of iterations allowed. # varht known variance if vmu=='u'. # On exit: # theta the vector of parameter log10(theta) used in the final model, # of dimension (nq). -25 indicates effective minus infinity. # nlaht the estimated log10(n*lambda)|theta in the final model. # score the minimum GCV/GML/URE score found at (theta, nlaht). # varht the variance estimate. # c,d the coefficients estimates. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T} Q_{*}^{theta} F_{2} !>= 0. # -3 : tuning parameters are out of scope. # -4 : fails to converge within maxite steps. # -5 : fails to find a reasonable descent direction. # >0 : the matrix S is rank deficient: rank(S)+1. # Work arrays: # qraux of size at least (nnull). # jpvt of size at least (nnull). # twk of size at least (2,nobs-nnull). # traux of size at least (nobs-nnull-2). # qwk of size at least (nobs,nobs). # ywk of size at least (nobs). # thewk of size at least (nq). # hes of size at least (nq,nq). # gra of size at least (nq). # hwk1-2 of sizes at least (nq,nq). # gwk1-2 of sizes at least (nq). # pvtwk of size at least (nq). # kwk of size at least (nobs-nnull,nobs-nnull,nq). # work1-2 of sizes at least (nobs). # Routines called directly: # Blas -- dasum, daxpy, dcopy, ddot, dscal, idamax # Blas2 -- dsymv # Fortran -- dfloat, dlog, dlog10 # Linpack -- dpofa, dposl, sqrsl # Rkpack -- dcoef, dcore, ddeev, dmcdc, dstup # Other -- dprmut, dset # Routines called indirectly: # Blas -- dasum, daxpy, dcopy, ddot, dnrm2, dscal, dswap, idamax # Blas2 -- dgemv, dsymv, dsyr2 # Fortran -- dabs, dexp, dfloat, dlog, dlog10, dsqrt # Linpack -- dpbfa, dpbsl, dqrdc, dqrsl, dtrsl # Rkpack -- deval, dgold, dqrslm, dsytr, dtrev # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 1/6/92. double precision alph, scrold, scrwk, nlawk, limnla(2),_ tmp, dasum, ddot integer n, n0, i, j, iwk, maxitwk, idamax, job info = 0 # set working parameters n0 = nnull n = nobs - nnull maxitwk = maxite # check tuning parameters if ( (vmu != 'v' & vmu != 'm' & vmu != 'u') | (init != 0 & init != 1) |_ (maxitwk <=0) | (prec <= 0.d0) ) { info = -3 return } # check dimension if ( lds < nobs | nobs <= n0 | n0 < 1 | ldqr < nobs | ldqc < nobs |_ nq <= 0 ) { info = -1 return } # initialize call dstup (s, lds, nobs, n0, qraux, jpvt, y, q, ldqr, ldqc, nq, info,_ work1) if ( info != 0 ) return if ( init == 1 ) call dcopy (nq, theta, 1, thewk, 1) else { # use the "plug-in" weights as the starting theta for (i=1;i<=nq;i=i+1) { thewk(i) = dasum (n, q(n0+1,n0+1,i), ldqr+1) if ( thewk(i) > 0.d0 ) thewk(i) = 1.d0 / thewk(i) } # fit an initial model for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, thewk(i), q(j,j,i), 1, qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, 0, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlawk,_ c, d, info, twk) # assign weights due to norm \theta^{2}c^{T}(Q_{i})c call dqrsl (s, lds, nobs, n0, qraux, c, tmp, c, tmp, tmp, tmp,_ 01000, info) for (i=1;i<=nq;i=i+1) { call dsymv('l', n, thewk(i), q(n0+1,n0+1,i), ldqr, c(n0+1), 1,_ 0.d0, work1, 1) thewk(i) = ddot (n, c(n0+1), 1, work1, 1) * thewk(i) if ( thewk(i) > 0.d0 ) thewk(i) = dlog10 (thewk(i)) else thewk(i) = -25.d0 } } scrold = 1.d10 # main process job = 0 repeat { # nq == 1 if ( nq == 1 ) { theta(1) = 0.d0 break } # form Qwk = \sum_{i=1}^{nq} \thewk_{i} Q_{i} for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** thewk(i), q(j,j,i), 1,_ qwk(j,j), 1) } # main calculation call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlawk,_ scrwk, varht, info, twk, work1) if (info != 0 ) return # half the increment if no gain if ( scrold < scrwk ) { # algorithm halts tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( alph * tmp > - prec ) { info = -5 return } alph = alph / 2.d0 for (i=1;i<=nq;i=i+1) thewk(i) = theta(i) + alph * gwk1(i) next } # count for one iteration maxitwk = maxitwk - 1 # compute the gradient and the Hessian call dcopy (n-2, qwk(n0+2,n0+1), ldqr+1, traux, 1) call dcopy (n, qwk(n0+1,n0+1), ldqr+1, twk(2,1), 2) call dcopy (n-1, qwk(n0+1,n0+2), ldqr+1, twk(1,2), 2) call ddeev (vmu, nobs,_ q(n0+1,n0+1,1), ldqr, ldqc, n, nq, qwk(n0+2,n0+1),_ ldqr, traux, twk, ywk(n0+1),_ thewk, nlawk, scrwk, varht,_ # inputs hes, nq, gra,_ # outputs hwk1, hwk2, gwk1, gwk2,_ kwk, n, work1, work2, c,_ info) # get the active subset iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(1,i), 1, hes(1,iwk), 1) } iwk = 0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next iwk = iwk + 1 call dcopy (nq, hes(i,1), nq, hes(iwk,1), nq) gwk1(iwk) = gra(i) work2(iwk) = gra(i) } # compute the Newton direction for (i=1;i=1;i=i-1) { if ( thewk(i) <= -25.0 ) gwk1(i) = 0.d0 else { gwk1(i) = gwk1(iwk) iwk = iwk - 1 } } call dscal (nq, 1.d0/dlog(1.d1), gwk1, 1) tmp = dabs (gwk1(idamax (nq, gwk1, 1))) if ( tmp > 1.d0 ) call dscal (nq, 1.d0/tmp, gwk1, 1) # set thewk such that nlawk = 0.d0 for (i=1;i<=nq;i=i+1) { if ( thewk(i) <= -25.d0 ) next thewk(i) = thewk(i) - nlawk } call dcopy (nq, thewk, 1, theta, 1) # check convergence tmp = gra(idamax (nq, gra, 1)) ** 2 if ( tmp < prec ** 2_ # zero gradient | scrold - scrwk < prec * (scrwk + 1.d0)_ # small change & tmp < prec * (scrwk + 1.d0) ** 2 ) { # small gradient break } # fail to converge if ( maxitwk < 1 ) { info = -4 return } # update records scrold = scrwk # increment thewk for (i=1;i<=nq;i=i+1) thewk(i) = thewk(i) + alph * gwk1(i) job = -1 limnla(1) = -1.d0 limnla(2) = 1.d0 } # the end of the main loop # compute the model to be returned for (j=1;j<=nobs;j=j+1) call dset (nobs-j+1, 0.d0, qwk(j,j), 1) for (i=1;i<=nq;i=i+1) { if ( theta(i) <= -25.d0 ) next for (j=1;j<=nobs;j=j+1) call daxpy (nobs-j+1, 10.d0 ** theta(i), q(j,j,i), 1,_ qwk(j,j), 1) } call dcopy (nobs, y, 1, ywk, 1) call dcore (vmu, qwk, ldqr, nobs, n0, tol, ywk, job, limnla, nlaht,_ score, varht, info, twk, work1) if (info != 0 ) return call dcoef (s, lds, nobs, n0, qraux, jpvt, ywk, qwk, ldqr, nlaht,_ c, d, info, twk) return end #.................................................................................... gss/src/ratfor/dnewton10.r0000644000175100001440000001424712355360640015166 0ustar hornikusers #::::::::::::::: # dnewton10 #::::::::::::::: subroutine dnewton10 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nobs iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nobs call dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk(icdnew), wk(iwtnew), wk(iwk), info) return end #:::::::::::::::: # dnewton101 #:::::::::::::::: subroutine dnewton101 (cd, nxis, q, nxi, rs, nobs, cntsum, cnt, intrs, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtnew, wk, info) integer nxis, nxi, nobs, cntsum, cnt(*), maxiter, jpvt(*), info double precision cd(*), q(nxi,*), rs(nobs,*), intrs(*), prec, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision wtsum, tmp, ddot, lkhd, mumax, wtsumnew, lkhdnew, disc, disc0 # Initialization info = 0 wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(i,1), nobs, cd, 1) wt(i) = dexp (-tmp) if (cntsum!=0) wt(i) = wt(i) * dfloat (cnt(i)) wtsum = wtsum + wt(i) } if (cntsum==0) lkhd = wtsum / dfloat (nobs) else lkhd = wtsum / dfloat (cntsum) lkhd = dlog (lkhd) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 # Iteration repeat { iter = iter + 1 # Calculate hessian and gradient for (i=1;i<=nxis;i=i+1) mu(i) = ddot (nobs, wt, 1, rs(1,i), 1) / wtsum for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { v(i,j) = 0.d0 for (k=1;k<=nobs;k=k+1) v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) v(i,j) = v(i,j) / wtsum - mu(i) * mu(j) if (j<=nxi) v(i,j) = v(i,j) + q(i,j) } } call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) wtsumnew = wtsumnew + wtnew(i) } if (cntsum==0) lkhdnew = wtsumnew / dfloat (nobs) else lkhdnew = wtsumnew / dfloat (cntsum) lkhdnew = dlog (lkhdnew) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) wtsum = 0.d0 for (i=1;i<=nobs;i=i+1) { if (cntsum!=0) wt(i) = dfloat (cnt(i)) else wt(i) = 1.d0 wtsum = wtsum + wt(i) } lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nobs, wtnew, 1, wt, 1) wtsum = wtsumnew lkhd = lkhdnew # Check convergence if (disc03.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) tmp = dfloat (nqd) call dset (nqd*nx, 1.d0, wt, 1) call dset (nx, tmp, wtsum, 1) call dset (nobs, 1.d0/tmp, fit, 1) fitmean = - dlog (tmp) lkhd = - fitmean iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc0 1.d0 ) tmp = tmp / 2.d0 jmax = idamax (p, a, lda+1) beta = dmax1 (2.d0 * tmp, dabs (a(jmax,jmax))) tmp = dsqrt (dfloat (p*p-1)) if ( tmp < 1.d0 ) tmp = 1.d0 for (j=2;j<=p;j=j+1) { jmax = idamax (j-1, a(1,j), 1) beta = dmax1 (beta, dabs (a(jmax,j)) / tmp) } delta = dasum (p, a, lda+1) / dfloat (p) * 1.d-7 delta = dmax1 (delta, 1.d-10) for (j=1;j<=p;j=j+1) jpvt(j) = j # compute P^{T}AP + E = LDL^{T} for (j=1;j<=p;j=j+1) { # pivoting jmax = idamax (p-j+1, a(j,j), lda+1) + j - 1 if ( jmax != j ) { call dswap (j-1, a(1,j), 1, a(1,jmax), 1) call dswap (jmax-j-1, a(j,j+1), lda, a(j+1,jmax), 1) call dswap (p-jmax, a(j,jmax+1), lda, a(jmax,jmax+1), lda) tmp = a(j,j) a(j,j) = a(jmax,jmax) a(jmax,jmax) = tmp jtmp = jpvt(j) jpvt(j) = jpvt(jmax) jpvt(jmax) = jtmp } # compute j-th column of L^{T} for (i=1;i3.d2) { flag = flag + 1 break } for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * dexp (tmp) wtnewsum(m) = wtnewsum(m) + wtnew(m,i) } } rklnew = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) { disc = wt0(i) * qdwt(m,i) tmp = tmp + dlog (disc/wtnew(m,i)) * disc } rklnew = rklnew + bwt(m) * (tmp + dlog (wtnewsum(m))) } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) call dset (nt, 0.d0, wtsum, 1) for (m=1;m<=nt;m=m+1) { for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) } rkl = 0.d0 for (m=1;m<=nt;m=m+1) { tmp = 0.d0 for (i=1;i<=nqd;i=i+1) tmp = tmp + dlog (wt0(i)) * wt0(i) * qdwt(m,i) rkl = rkl + bwt(m) * (tmp + dlog (wtsum(m))) } iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1){ for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc = dmax1 (disc, dabs(rkl-rklnew)/(1.d0+dabs(rkl))) # Check convergence if (disc3.d2) { flag = flag + 1 break } wtnew(i) = dexp (-tmp) * rho(i) if (cntsum!=0) wtnew(i) = wtnew(i) * dfloat (cnt(i)) } call dscal (nt, 1/dfloat(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (i=1;i<=nt;i=i+1) { wt(i) = rho(i) if (cntsum!=0) wt(i) = wt(i) * dfloat (cnt(i)) } call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax))<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nt;i=i+1) disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew # Check convergence if (disc03.d2) { flag = flag + 1 break } tmp = dexp (tmp) for (m=1;m<=nt;m=m+1) { wtnew(m,i) = qdwt(m,i) * tmp wtsumnew(m) = wtsumnew(m) + wtnew(m,i) } } norm = 0.d0 for (m=1;m<=nt;m=m+1) norm = norm + bwt(m) * dlog (wtsumnew(m)) if ((flag==0)|(flag==2)) { fitmean = 0.d0 for (i=1;i<=nobs;i=i+1) { tmp = ddot (nxis, rs(1,i), 1, cdnew, 1) if (tmp>3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } if (cntsum==0) fitmean = fitmean / dfloat (nobs) else fitmean = fitmean / dfloat (cntsum) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) call dcopy (nt*nqd, qdwt, 1, wt, 1) lkhd = 0.d0 for (m=1;m<=nt;m=m+1) { wtsum(m) = 0.d0 for (i=1;i<=nqd;i=i+1) wtsum(m) = wtsum(m) + wt(m,i) lkhd = lkhd + bwt(m) * dlog (wtsum(m)) } call dset (nobs, 1.d0, fit, 1) iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (i=1;i<=nqd;i=i+1) { for (m=1;m<=nt;m=m+1) disc = dmax1 (disc, dabs(wt(m,i)-wtnew(m,i))/(1.d0+dabs(wt(m,i)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1.d0+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nt, wtnew, 1, wt, 1) call dcopy (nt, wtsumnew, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc00) call dset (nxis-rkv, 0.d0, rs(rkv+1,i), 1) } trc = ddot (nobs*nxis, rs, 1, rs, 1) if (cntsum==0) { trc = trc / dfloat(nobs) / (dfloat(nobs)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dlog (fit(i)) lkhd = lkhd / dfloat (nobs) } else { trc = trc / dfloat(cntsum) / (dfloat(cntsum)-1.d0) lkhd = 0.d0 for (i=1;i<=nobs;i=i+1) lkhd = lkhd + dfloat (cnt(i)) * dlog (fit(i)) lkhd = lkhd / dfloat (cntsum) } for (m=1;m<=nt;m=m+1) lkhd = lkhd - bwt(m) * dlog (wtsum(m)) mrs(1) = lkhd mrs(2) = trc return end gss/src/ratfor/dmudr0.r0000644000175100001440000000150012355360640014526 0ustar hornikuserssubroutine dmudr0 (vmu,_ s, lds, nobs, nnull, q, ldqr, ldqc, nq, y,_ # inputs tol, init, prec, maxite,_ # tune para theta, nlaht, score, varht, c, d,_ # outputs wk, info) integer vmu integer lds, nobs, nnull, ldqr, ldqc, nq, init, maxite,_ info double precision s(lds,*), q(ldqr,ldqc,*), y(*), tol, prec,_ theta(*), nlaht, score, varht, c(*), d(*),_ wk(*) character*1 vmu1 if ( vmu == 1 ) vmu1 = 'v' if ( vmu == 2 ) vmu1 = 'm' if ( vmu == 3 ) vmu1 = 'u' call dmudr (vmu1, s, lds, nobs, nnull, q, ldqr, ldqc, nq, y, tol, init, prec, maxite, theta, nlaht, score, varht, c, d, wk, info) return end gss/src/ratfor/dsidr0.r0000644000175100001440000000152212355360640014524 0ustar hornikuserssubroutine dsidr0 (vmu,_ s, lds, nobs, nnull, y, q, ldq,_ # data tol, job, limnla,_ # job requests nlaht, score, varht, c, d,_ # output qraux, jpvt, wk,_ # work arrays info) # error message integer vmu integer lds, nobs, nnull, ldq, job, jpvt(*), info double precision s(lds,*), y(*), q(ldq,*), tol, limnla(2), nlaht, score(*),_ varht, c(*), d(*), qraux(*), wk(*) character*1 vmu1 if ( vmu == 1 ) vmu1 = 'v' if ( vmu == 2 ) vmu1 = 'm' if ( vmu == 3 ) vmu1 = 'u' call dsidr (vmu1, s, lds, nobs, nnull, y, q, ldq, tol, job, limnla, nlaht, score, varht, c, d, qraux, jpvt, wk, info) return end gss/src/ratfor/dcore.r0000644000175100001440000001051412355360640014434 0ustar hornikusers #::::::::::: # dcore #::::::::::: subroutine dcore (vmu, q, ldq, nobs, nnull, tol, z, job, limnla, nlaht,_ score, varht, info, twk, work) # Purpose: To evaluate the GCV/GML score function at various trial values # of n*lambda using the tridiagonalization GCV/GML algorithm. Perform # either golden section search or regular grid search for minimizing # n*lambda. character*1 vmu integer ldq, nobs, nnull, job, info double precision q(ldq,*), tol, z(*), limnla(2), nlaht, score(*), varht,_ twk(2,*), work(*) # On entry: # vmu 'v': GCV criterion. # 'm': GML criterion. # 'u': unbiased risk estimate. # q F^{T} Q F, only refer the LOWER triangle of the BOTTOM- # RIGHT corner, i.e., F_{2}^{T} Q F_{2}. # ldq leading dimension of Q. # nobs number of observations. # nnull dimension of null space. # tol tolerance of truncation. # z F^{T} y. # job 0: searching interval for nlaht chosen automatically. # -1: searching interval for nlaht provided by limnla. # >0: search regular grid points on [limnla(1),limnla(2)]: # #(grids) = job + 1. # limnla searching interval in log10 scale, see job. # varht known variance if vmu=='u'. # On exit: # q tridiagonal form in diagonal and superdiagonal of the # corner, Householder factors in strict lower triangle of # the corner. # z diag(I, U^{T}) F^{T} y. # limnla see limnla of entry. # nlaht the estimated log10(n*lambda). # score job <= 0 : the GCV/GML/URE score at nlaht. # job > 0 : the GCV/GML/URE score at the regular grid points. # varht variance estimate. # info 0 : normal termination. # -1 : dimension error. # -2 : F_{2}^{T}QF_{2} is not non-negative definite. # -3 : vmu is none of 'v', 'm', or 'u'. # Work arrays: # twk of size at least (2,nobs-nnull). # work of size at least (nobs-nnull). # Routines called directly: # Fortran -- dfloat, dlog10 # Blas -- dasum, dcopy # Linpack -- dqrsl # Rkpack -- deval, dgold, dsytr # Written: Chong Gu, Statistics, Purdue, latest version 3/24/92. double precision dum, low, upp, dasum, mchpr integer n0, n, j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nnull < 1 | nobs <= nnull | nobs > ldq ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # tridiagonalization U^{T} ( F_{2}^{T} Q F_{2} ) U = T call dsytr (q(n0+1,n0+1), ldq, n, tol, info, work) if ( info != 0 ) return # U^{T} z_{2} call dcopy (n-2, q(n0+2,n0+1), ldq+1, work, 1) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, work, z(n0+2), dum, z(n0+2),_ dum, dum, dum, 01000, info) # set searching range if ( job == 0 ) { mchpr = 1.d0 while ( 1.d0 + mchpr > 1.d0 ) mchpr = mchpr / 2.d0 mchpr = mchpr * 2.d0 limnla(2) = dmax1 (dasum (n, q(n0+1,n0+1), ldq+1) * 1.d2, mchpr) limnla(1) = limnla(2) * mchpr limnla(2) = dlog10 (limnla(2)) limnla(1) = dlog10 (limnla(1)) } low = limnla(1) upp = limnla(2) if ( job <= 0 ) { # compute score and estimate nlaht thru golden-section search call dgold (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), low, upp, nlaht,_ score(1), varht, info, twk, work) if ( vmu == 'v' ) score(1) = score(1) * dfloat (nobs) / dfloat (n) if ( vmu == 'm' ) score(1) = score(1) * dfloat (n) / dfloat (nobs) if ( vmu == 'u' ) score(1) = score(1) * dfloat (n) / dfloat (nobs) + 2.d0 * varht } else { # regular grid evaluation call deval (vmu, q(n0+1,n0+1), ldq, n, z(n0+1), job, low, upp, nlaht,_ score, varht, info, twk, work) dum = dfloat (nobs) / dfloat (n) for (j=1;j<=job+1;j=j+1) { if ( vmu == 'v' ) score(j) = score(j) * dum if ( vmu == 'm' ) score(j) = score(j) / dum if ( vmu == 'u' ) score(j) = score(j) / dum + 2.d0 * varht } } return end #............................................................................... gss/src/ratfor/dsms.r0000644000175100001440000000676312355360640014321 0ustar hornikusers #::::::::::: # dsms #::::::::::: subroutine dsms (s, lds, nobs, nnull, jpvt, q, ldq, nlaht,_ sms, ldsms, wk, info) # Purpose: To compute the auxiliary quantity sms for posterior covariance # Usage: Use s, qraux, jpvt, q, and nlaht returned by dsidr. integer lds, nobs, nnull, jpvt(*), ldq, ldsms, info double precision s(lds,*), q(ldq,*), nlaht, sms(ldsms,*), wk(2,*) # On entry: # s,jpvt QR-decomposition of S = F R. # nobs number of observations. # nnull dimension of null space. # q U^{T} F_{2}^{T} Q F_{2} U in BOTTOM-RIGHT corner's # LOWER triangle and SUPER DIAGONAL; # F_{2}^{T} Q F_{1} in BOTTOM-LEFT corner; # F_{1}^{T} Q F_{1} in UPPER-LEFT corner's LOWER triangle. # ldq leading dimension of q. # nlaht estimated log10(n*lambda). # On exit: # sms (S^{T}M^{-1}S)^{-1}. # info 0: normal termination. # >0: S is not of full rank: rank(S)+1 . # -1: dimension error. # -2: F_{2}^{T} Q F_{2} is not non-negative definite. # inputs intact but UPPER-RIGHT corner of q was used as work array. # Work array: # wk of size at least (2,nobs-nnull). # Routines called directly: # Blas -- daxpy, dcopy, ddot # Linpack -- dpbfa, dpbsl, dqrsl, dtrsl # Other -- dprmut, dset # Written: Chong Gu, Statistics, Purdue, latest version 4/17/92. double precision dum, ddot integer i, j, n, n0 info = 0 # check dimension if ( nnull < 1 | nnull >= nobs | nobs > lds | nobs > ldq | ldsms < nnull ) { info = -1 return } # set working parameters n0 = nnull n = nobs - nnull # compute sms # U^{T} (F_{2}^{T} Q F_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dcopy (n, q(n0+1,j), 1, q(j,n0+1), ldq) call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), dum, q(n0+2,j), dum, dum, dum, 01000, info) } # U^{T} (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dset (n, 10.d0 ** nlaht, wk(2,1), 2) call daxpy (n, 1.d0, q(n0+1,n0+1), ldq+1, wk(2,1), 2) call dcopy (n-1, q(n0+1,n0+2), ldq+1, wk(1,2), 2) call dpbfa (wk, 2, n, 1, info) if ( info != 0 ) { info = -2 return } for (j=1;j<=n0;j=j+1) call dpbsl (wk, 2, n, 1, q(n0+1,j)) # (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) call dcopy (n-2, q(n0+2,n0+1), ldq+1, wk, 1) for (j=1;j<=n0;j=j+1) { call dqrsl (q(n0+2,n0+1), ldq, n-1, n-2, wk, q(n0+2,j), q(n0+2,j),_ dum, dum, dum, dum, 10000, info) } # (F_{1}^{T}QF_{1} + n lambda I) - # (F_{1}^{T}QF_{2}^{T}) (F_{2}^{T}QF_{2} + n lambda I)^{-1} (F_{2}^{T}QF_{1}) for (i=1;i<=n0;i=i+1) { for (j=1;j3.d2) { flag = flag + 1 break } fitnew(i) = dexp (tmp) if (cntsum!=0) tmp = tmp * dfloat (cnt(i)) fitmean = fitmean + tmp } call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = ddot (nxi, cdnew, 1, wk, 1) / 2.d0 - fitmean * trc + norm } # Reset iteration with uniform starting value if (flag==1) { call dset (nxis, 0.d0, cd, 1) for (kk=1;kk<=nx;kk=kk+1) call dcopy (nqd, qdwt, 1, wt(1,kk), 1) call dset (nx, 1.d0, wtsum, 1) call dset (nobs, 1.d0, fit, 1) lkhd = 0.d0 iter = 0 break } if (flag==3) break if (lkhdnew-lkhd<1.d1*(1.d0+dabs(lkhd))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } for (i=1;i<=nobs;i=i+1) disc = dmax1 (disc, dabs(fit(i)-fitnew(i))/(1.d0+dabs(fit(i)))) disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+lkhd))**2, dabs(lkhd-lkhdnew)/(1+dabs(lkhd))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) call dcopy (nx, wtnewsum, 1, wtsum, 1) call dcopy (nobs, fitnew, 1, fit, 1) lkhd = lkhdnew # Check convergence if (disc0nnull) v(i,j) = v(i,j) + q(i-nnull,j-nnull) } } # Cholesky decomposition infowk = 0 for (i=1;i<=nn;i=i+1) infowk = infowk + jpvt(i) call dchdc (v, nn, nn, wk, jpvt, 1, rkv) j = idamax (rkv-infowk, v(infowk+1,infowk+1), nn+1) while (v(rkv,rkv)0) { call dqrdc (sr, nobs, nobs, nnull, wk, dum, dum, 0) for (i=1;i<=nxi;i=i+1) { call dqrsl (sr, nobs, nobs, nnull, wk, sr(1,nnull+i), dum, sr(1,nnull+i), dum, dum, dum, 01000, infowk) } } call dcopy (nxi, q, nxi+1, wk, 1) for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) q(i,j) = q(i,j) + ddot (nobs-nnull, sr(nnull+1,nnull+i), 1, sr(nnull+1,nnull+j), 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) { sr(i,j) = q(i,j) sr(j,i) = q(i,j) q(i,j) = q(j,i) } } call dcopy (nxi, wk, 1, q, nxi+1) # call rs (nobs, nxi, sr, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, sr, nobs, mu, wk, 3*nxi, info) trc = 0.d0 for (i=1;i<=rkv-nnull;i=i+1) trc = trc + dlog (mu(nxi-i+1)) # call rs (nxi, nxi, q, mu, 0, dum, wk, y, info) call dsyev ('n', 'u', nxi, q, nxi, mu, wk, 3*nxi, info) for (i=1;i<=rkv-nnull;i=i+1) trc = trc - dlog (mu(nxi-i+1)) # return values score = rss / dfloat (nobs) * dexp (trc/dfloat(nobs-nnull)) varht = rss / dfloat (nobs-nnull) } else { # GCV or Cp rss = ddot (nobs, wk, 1, wk, 1) / dfloat (nobs) # trace for (i=1;i<=nobs;i=i+1) { call dcopy (nn, sr(i,1), nobs, mu, 1) call dprmut (mu, nn, jpvt, 0) call dtrsl (v, nn, nn, mu, 11, infowk) wk(i) = ddot (nn, mu, 1, mu, 1) } trc = dasum (nobs, wk, 1) / dfloat (nobs) # return values if (method==2) { score = rss / (1.d0-alpha*trc)**2 varht = rss / (1.d0-trc) } else score = rss + 2.d0 * varht * alpha * trc } wk(1) = rss wk(2) = trc return end #:::::::::::: # regaux #:::::::::::: subroutine regaux (v, nn, jpvt, rkv, r, nr, sms, nnull, wk) double precision v(nn,*), r(nn,*), sms(nnull,*), wk(nn,*) integer nn, jpvt(*), rkv, nr, nnull double precision ddot integer i, j, infowk # drcr for (i=1;i<=nr;i=i+1) { call dprmut (r(1,i), nn, jpvt, 0) call dtrsl (v, nn, nn, r(1,i), 11, infowk) if (nn-rkv>0) call dset (nn-rkv, 0.d0, r(rkv+1,i), 1) call dtrsl (v, nn, nn, r(1,i), 01, infowk) call dprmut (r(1,i), nn, jpvt, 1) } # sms call dset (nn*nnull, 0.d0, wk, 1) call dset (nnull, 1.d0, wk, nn+1) for (i=1;i<=nnull;i=i+1) call dtrsl (v, nn, nn, wk(1,i), 11, infowk) for (i=1;i<=nnull;i=i+1) { for (j=i;j<=nnull;j=j+1) { sms(i,j) = ddot (nn, wk(1,i), 1, wk(1,j), 1) sms(j,i) = sms(i,j) } } return end gss/src/ratfor/hzdaux.r0000644000175100001440000001551212355360640014646 0ustar hornikusers #::::::::::::: # hzdaux1 #::::::::::::: subroutine hzdaux1 (cd, nxis, q, nxi, qdrs, nqd, qdwt, nx, mchpr, wt, v, vwk, jpvt) integer nxis, nxi, nqd, nx, jpvt(*) double precision cd(*), q(nxi,*), qdrs(nqd,nxis,*), qdwt(nqd,*), mchpr, wt(nqd,*), v(nxis,*), vwk(nxis,*) integer i, j, k, kk, rkv double precision ddot # Initialization for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) wt(i,kk) = qdwt(i,kk) * dexp (ddot (nxis, qdrs(i,1,kk), nqd, cd, 1)) } # H matrix call dset (nxis*nxis, 0.d0, v, 1) for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nxis;i=i+1) { for (j=i;j<=nxis;j=j+1) { vwk(i,j) = 0.d0 for (k=1;k<=nqd;k=k+1) vwk(i,j) = vwk(i,j) + wt(k,kk) * qdrs(k,i,kk) * qdrs(k,j,kk) } } call daxpy (nxis*nxis, 1.d0, vwk, 1, v, 1) } for (i=1;i<=nxi;i=i+1) { for (j=i;j<=nxi;j=j+1) v(i,j) = v(i,j) + q(i,j) } # Cholesky factorization for (i=1;i<=nxis;i=i+1) jpvt(i) = 0 call dchdc (v, nxis, nxis, vwk, jpvt, 1, rkv) while (v(rkv,rkv)3.d2) { flag = flag + 1 break } wtnew(i,kk) = qdwt(i,kk) * dexp (tmp) rklnew = rklnew + (wtnew(i,kk) - wt0(i,kk)*tmp) } } if (flag==1) { # Reset iteration with uniform starting value call dset (nxis, 0.d0, cd, 1) rkl = dasum (nqd*nx, qdwt, 1) call dcopy (nqd*nx, qdwt, 1, wt, 1) iter = 0 break } if (rklnew-rkl<1.d1*(1.d0+dabs(rkl))*mchpr) break call dscal (nxis, .5d0, mu, 1) if (dabs(mu(idamax(nxis, mu, 1))/mumax)<1.d1*mchpr) break } if (flag==1) { flag = 2 next } if (flag==3) { info = 1 return } # Calculate convergence criterion disc = 0.d0 for (kk=1;kk<=nx;kk=kk+1) { for (i=1;i<=nqd;i=i+1) disc = dmax1 (disc, dabs(wt(i,kk)-wtnew(i,kk))/(1.d0+dabs(wt(i,kk)))) } disc = dmax1 (disc, (mumax/(1.d0+rkl))**2) disc0 = dmax1 ((mumax/(1.d0+rkl))**2, dabs(rkl-rklnew)/(1+dabs(rkl))) # Set to new values call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nqd*nx, wtnew, 1, wt, 1) rkl = rklnew # Check convergence if (disc0= 0. # -3 : tuning parameters are out of scope. # Work arrays: # hwk1,2 of sizes at least (nq,nq). # gwk1,2 of sizes at least (nq). # kwk of size at least (n,n,nq). # work1-3 of sizes at least (n). # Routines called directly: # Fortran -- dfloat # Blas -- daxpy, dcopy, ddot, dscal # Blas2 -- dgemv # Linpack -- dpbfa, dpbsl, dqrsl # Rkpack -- dqrslm # Other -- dset # Written: Chong Gu, Statistics, Purdue, latest version 12/29/91. double precision trc, det, dum, ddot integer i, j, m info = 0 call dset (nq, 0.d0, gra, 1) call dset (nq*nq, 0.d0, hes, 1) # check tuning parameters if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } # check dimension if ( nobs < n | ldqr < n | ldqc < n | nq <= 0 | ldu < n-1 | ldh < nq | ldk < n ) { info = -1 return } # compute K_{i} = U^{T}(\theta_{i}Q_{i})U for (i=2;i<=nq;i=i+1) { # from i=2 to nq if ( theta(i) <= -25.d0 ) next for (j=1;j<=n;j=j+1) { call dcopy (n-j+1, q(j,j,i), 1, kwk(j,j,i), 1) call dscal (n-j+1, 10.d0 ** theta(i), kwk(j,j,i), 1) } call dqrslm (u, ldu, n-1, n-2, uaux, kwk(2,2,i), n, 0, info, work1) call dqrsl (u, ldu, n-1, n-2, uaux, kwk(2,1,i), dum, kwk(2,1,i),_ dum, dum, dum, 01000, info) } # compute K_{1} through the identity: U^{T}(\sum K_{i})U = T call dcopy (n, t(2,1), 2, kwk(1,1,1), n+1) call dcopy (n-1, t(1,2), 2, kwk(2,1,1), n+1) for (j=1;j -3: as from LINPACK's `dpbfa'. # Work array: # work of size at least (n). # Routines called directly: # Fortran -- dexp, dfloat, dlog # Blas -- dasum, dcopy, ddot, dscal # Linpack -- dpbfa, dpbsl # Written: Chong Gu, Statistics, UW-Madison, latest version 12/29/91. double precision nume, deno, tmp, alph, la, dasum, ddot integer j info = 0 # check vmu if ( vmu != 'v' & vmu != 'm' & vmu != 'u' ) { info = -3 return } la = t(1,1) # standardize the matrix for numerical stability alph = dfloat (n) / dasum (n, t(2,1), ldt) call dscal (n, alph, t(2,1), ldt) call dscal (n-1, alph, t(1,2), ldt) # decomposition call dpbfa (t, ldt, n, 1, info) if ( info != 0 ) return call dcopy (n, z, 1, work, 1) call dpbsl (t, ldt, n, 1, work) # GCV computation if ( vmu == 'v' ) { tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } nume = ddot (n, work, 1, work, 1) / dfloat (n) deno = deno / dfloat (n) varht = alph * la * nume / deno score = nume / deno / deno } # GML computation if ( vmu == 'm' ) { deno = dlog (t(2,n)) for (j=n-1;j>0;j=j-1) deno = deno + dlog (t(2,j)) nume = ddot (n, z, 1, work, 1) / dfloat (n) varht = alph * la * nume score = nume * dexp (2.d0 * deno / dfloat (n)) } # unbiased risk computation if ( vmu == 'u' ) { nume = ddot (n, work, 1, work, 1) / dfloat (n) tmp = 1.d0 / t(2,n) / t(2,n) deno = tmp for (j=n-1;j>0;j=j-1) { tmp = ( 1.d0 + t(1,j+1) * t(1,j+1) * tmp ) / t(2,j) / t(2,j) deno = deno + tmp } deno = deno / dfloat (n) score = alph * alph * la * la * nume - 2.d0 * varht * alph * la * deno } return end #............................................................................... gss/src/hzdnewton10.f0000644000175100001440000001707112545250042014210 0ustar hornikusersC Output from Public domain Ratfor, version 1.01 subroutine hzdnewton10 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cn *t, intrs, rho, prec, maxiter, mchpr, jpvt, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), maxiter, jpvt(*), inf *o double precision cd(*), q(nxi,*), rs(nt,*), intrs(*), rho(*), prec *, mchpr, wk(*) integer iwt, imu, iv, icdnew, iwtnew, iwk iwt = 1 imu = iwt + nt iv = imu + nxis icdnew = iv + nxis*nxis iwtnew = icdnew + nxis iwk = iwtnew + nt call hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, cnt, in *trs, rho, prec, maxiter, mchpr, wk(iwt), wk(imu), wk(iv), jpvt, wk *(icdnew), wk(iwtnew), wk(iwk), info) return end subroutine hzdnewton101 (cd, nxis, q, nxi, rs, nt, nobs, cntsum, c *nt, intrs, rho, prec, maxiter, mchpr, wt, mu, v, jpvt, cdnew, wtne *w, wk, info) integer nxis, nxi, nt, nobs, cntsum, cnt(*), maxiter, jpvt(*), inf *o double precision cd(*), q(nxi,*), rs(nt,*), intrs(*), rho(*), prec *, mchpr, wt(*), mu(*), v(nxis,*), cdnew(*), wtnew(*), wk(*) integer i, j, k, iter, flag, rkv, idamax, infowk double precision tmp, ddot, dasum, lkhd, mumax, lkhdnew, disc, dis *c0 info = 0 i=1 23000 if(.not.(i.le.nt))goto 23002 tmp = ddot (nxis, rs(i,1), nt, cd, 1) wt(i) = dexp (-tmp) * rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23001 i=i+1 goto 23000 23002 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum(nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cd, 1, 0.d0, wk, 1) lkhd = lkhd + ddot (nxi, cd, 1, wk, 1) / 2.d0 iter = 0 flag = 0 23005 continue iter = iter + 1 i=1 23008 if(.not.(i.le.nxis))goto 23010 mu(i) = ddot (nt, wt, 1, rs(1,i), 1) j=i 23011 if(.not.(j.le.nxis))goto 23013 v(i,j) = 0.d0 k=1 23014 if(.not.(k.le.nt))goto 23016 v(i,j) = v(i,j) + wt(k) * rs(k,i) * rs(k,j) 23015 k=k+1 goto 23014 23016 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23012 j=j+1 goto 23011 23013 continue 23009 i=i+1 goto 23008 23010 continue call daxpy (nxis, -1.d0, intrs, 1, mu, 1) call dsymv ('u', nxi, -1.d0, q, nxi, cd, 1, 1.d0, mu, 1) mumax = dabs(mu(idamax(nxis, mu, 1))) i=1 23019 if(.not.(i.le.nxis))goto 23021 jpvt(i) = 0 23020 i=i+1 goto 23019 23021 continue call dchdc (v, nxis, nxis, wk, jpvt, 1, rkv) 23022 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23022 endif 23023 continue i=rkv+1 23024 if(.not.(i.le.nxis))goto 23026 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23025 i=i+1 goto 23024 23026 continue 23027 continue call dcopy (nxis, mu, 1, cdnew, 1) call dprmut (cdnew, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, cdnew, 11, infowk) call dset (nxis-rkv, 0.d0, cdnew(rkv+1), 1) call dtrsl (v, nxis, nxis, cdnew, 01, infowk) call dprmut (cdnew, nxis, jpvt, 1) call daxpy (nxis, 1.d0, cd, 1, cdnew, 1) i=1 23030 if(.not.(i.le.nt))goto 23032 tmp = ddot (nxis, rs(i,1), nt, cdnew, 1) if(-tmp.gt.3.d2)then flag = flag + 1 goto 23032 endif wtnew(i) = dexp (-tmp) * rho(i) if(cntsum.ne.0)then wtnew(i) = wtnew(i) * dfloat (cnt(i)) endif 23031 i=i+1 goto 23030 23032 continue call dscal (nt, 1/dfloat(nobs), wtnew, 1) lkhdnew = dasum(nt, wtnew, 1) + ddot (nxis, intrs, 1, cdnew, 1) call dsymv ('u', nxi, 1.d0, q, nxi, cdnew, 1, 0.d0, wk, 1) lkhdnew = lkhdnew + ddot (nxi, cdnew, 1, wk, 1) / 2.d0 if(flag.eq.1)then call dset (nxis, 0.d0, cd, 1) i=1 23039 if(.not.(i.le.nt))goto 23041 wt(i) = rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23040 i=i+1 goto 23039 23041 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 goto 23029 endif if(flag.eq.3)then goto 23029 endif if(lkhdnew-lkhd.lt.1.d1*(1.d0+dabs(lkhd))*mchpr)then goto 23029 endif call dscal (nxis, .5d0, mu, 1) if(dabs(mu(idamax(nxis, mu, 1))/(1.d0+mumax)).lt.1.d1*mchpr)then goto 23029 endif 23028 goto 23027 23029 continue if(flag.eq.1)then flag = 2 goto 23006 endif if(flag.eq.3)then info = 1 return endif disc = 0.d0 i=1 23054 if(.not.(i.le.nt))goto 23056 disc = dmax1 (disc, dabs(wt(i)-wtnew(i))/(1.d0+dabs(wt(i)))) 23055 i=i+1 goto 23054 23056 continue disc = dmax1 (disc, (mumax/(1.d0+dabs(lkhd)))**2) disc0 = dmax1 ((mumax/(1.d0+dabs(lkhd)))**2, dabs(lkhd-lkhdnew)/(1 *.d0+dabs(lkhd))) call dcopy (nxis, cdnew, 1, cd, 1) call dcopy (nt, wtnew, 1, wt, 1) lkhd = lkhdnew if(disc0.lt.prec)then goto 23007 endif if(disc.lt.prec)then goto 23007 endif if(iter.lt.maxiter)then goto 23006 endif if(flag.eq.0)then call dset (nxis, 0.d0, cd, 1) i=1 23065 if(.not.(i.le.nt))goto 23067 wt(i) = rho(i) if(cntsum.ne.0)then wt(i) = wt(i) * dfloat (cnt(i)) endif 23066 i=i+1 goto 23065 23067 continue call dscal (nt, 1/dfloat(nobs), wt, 1) lkhd = dasum (nt, wt, 1) iter = 0 flag = 2 else info = 2 goto 23007 endif 23006 goto 23005 23007 continue lkhd = dasum (nt, wt, 1) + ddot (nxis, intrs, 1, cd, 1) tmp = 0.d0 disc = 0.d0 i=1 23070 if(.not.(i.le.nt))goto 23072 call dcopy (nxis, rs(i,1), nt, wk, 1) call dprmut (wk, nxis, jpvt, 0) call dtrsl (v, nxis, nxis, wk, 11, infowk) call dset (nxis-rkv, 0.d0, wk(rkv+1), 1) wtnew(i) = wt(i) * ddot (nxis, wk, 1, wk, 1) if(cntsum.ne.0)then wtnew(i) = wtnew(i) / dfloat (cnt(i)) endif tmp = tmp + wt(i) * (dexp (wtnew(i)/(1.d0-wtnew(i))) - 1.d0) if(cntsum.ne.0)then disc = disc + dfloat(cnt(i)) * wtnew(i)/(1.d0-wtnew(i)) else disc = disc + wtnew(i)/(1.d0-wtnew(i)) endif 23071 i=i+1 goto 23070 23072 continue wt(1) = lkhd wt(2) = tmp wt(3) = disc/dfloat(nobs) return end subroutine hzdaux101 (cd, nxis, q, nxi, rs, nt, rho, mchpr, v, jpv *t) integer nxis, nxi, nt, jpvt(*) double precision cd(*), q(nxi,*), rs(nt,*), rho(*), mchpr, v(nxis, **) integer i, j, k, rkv double precision tmp, ddot i=1 23077 if(.not.(i.le.nt))goto 23079 tmp = ddot (nxis, rs(i,1), nt, cd, 1) rho(i) = dexp (-tmp) * rho(i) 23078 i=i+1 goto 23077 23079 continue i=1 23080 if(.not.(i.le.nxis))goto 23082 j=i 23083 if(.not.(j.le.nxis))goto 23085 v(i,j) = 0.d0 k=1 23086 if(.not.(k.le.nt))goto 23088 v(i,j) = v(i,j) + rho(k) * rs(k,i) * rs(k,j) 23087 k=k+1 goto 23086 23088 continue if(j.le.nxi)then v(i,j) = v(i,j) + q(i,j) endif 23084 j=j+1 goto 23083 23085 continue 23081 i=i+1 goto 23080 23082 continue i=1 23091 if(.not.(i.le.nxis))goto 23093 jpvt(i) = 0 23092 i=i+1 goto 23091 23093 continue call dchdc (v, nxis, nxis, cd, jpvt, 1, rkv) 23094 if(v(rkv,rkv).lt.v(1,1)*dsqrt(mchpr))then rkv = rkv - 1 goto 23094 endif 23095 continue i=rkv+1 23096 if(.not.(i.le.nxis))goto 23098 v(i,i) = v(1,1) call dset (i-rkv-1, 0.d0, v(rkv+1,i), 1) 23097 i=i+1 goto 23096 23098 continue return end gss/src/deval.f0000644000175100001440000000246312545250042013121 0ustar hornikusersC Output from Public domain Ratfor, version 1.0 subroutine deval (vmu, q, ldq, n, z, nint, low, upp, nlaht, score, * varht, info, twk, work) character*1 vmu integer ldq, n, nint, info double precision q(ldq,*), z(*), low, upp, nlaht, score(*), varht, * twk(2,*), work(*) double precision tmp, minscr, mlo, varhtwk integer j info = 0 if( upp .lt. low )then mlo = low low = upp upp = mlo endif if( (vmu .ne. 'v' .and. vmu .ne. 'm' .and. vmu .ne. 'u') .or. nint * .lt. 1 )then info = -3 return endif if( 1 .gt. n .or. n .gt. ldq )then info = -1 return endif j=1 23006 if(.not.(j.le.nint+1))goto 23008 tmp = low + dfloat (j-1) * ( upp - low ) / dfloat (nint) call dset (n, 10.d0 ** (tmp), twk(2,1), 2) call daxpy (n, 1.d0, q, ldq+1, twk(2,1), 2) call dcopy (n-1, q(1,2), ldq+1, twk(1,2), 2) twk(1,1) = 10.d0**tmp call dtrev (vmu, twk, 2, n, z, score(j), varht, info, work) if( info .ne. 0 )then info = -2 return endif if( score(j) .le. minscr .or. j .eq. 1 )then minscr = score(j) nlaht = tmp varhtwk = varht endif 23007 j=j+1 goto 23006 23008 continue varht = varhtwk return end gss/NAMESPACE0000644000175100001440000000345112545242543012314 0ustar hornikusersuseDynLib(gss) # export user functions importFrom(stats, as.formula, dnorm, model.frame, model.matrix, model.offset, model.response, model.weights, na.omit, nlm, pnorm, predict, qlogis, quantile, residuals, terms, terms.formula, var) export(cdsscden, cpsscden, cqsscden, cdssden, cpssden, cqssden, dsscden, dssden, gauss.quad, gssanova, gssanova0, gssanova1, hzdcurve.sshzd, hzdrate.sshzd, nlm0, para.arma, project, psscden, pssden, qsscden, qssden, smolyak.quad, smolyak.size, ssanova, ssanova0, ssanova9, sscden, sscden1, sscox, ssden, ssden1, sshzd, sshzd1, ssllrm, survexp.sshzd) # export internal functions used in examples export(mkterm, mkphi.cubic, mkphi.tp, mkran, mkrk.cubic, mkrk.tp) # export internal functions for use in gss2 export(sspdsty, mspdsty, msphzd, msphzd1) export(ngreg.proj) # register S3 methods S3method(fitted, gssanova) S3method(fitted, ssanova) S3method(predict, ssanova) S3method(predict, ssanova0) S3method(predict, sscox) S3method(predict, ssllrm) S3method(print, gssanova) S3method(print, ssanova) S3method(print, ssanova0) S3method(print, sscden) S3method(print, sscox) S3method(print, ssden) S3method(print, sshzd) S3method(print, ssllrm) S3method(print, summary.gssanova) S3method(print, summary.gssanova0) S3method(print, summary.ssanova) S3method(project, gssanova) S3method(project, ssanova) S3method(project, ssanova9) S3method(project, sscden) S3method(project, sscden1) S3method(project, sscox) S3method(project, ssden) S3method(project, ssden1) S3method(project, sshzd) S3method(project, sshzd1) S3method(project, ssllrm) S3method(summary, gssanova) S3method(summary, gssanova0) S3method(summary, ssanova) S3method(summary, ssanova0) S3method(summary, ssanova9) S3method(residuals, gssanova) S3method(residuals, ssanova) gss/data/0000755000175100001440000000000012545250042011774 5ustar hornikusersgss/data/LakeAcidity.rda0000644000175100001440000000740512545250042014655 0ustar hornikusers‹]X \Mio¥Å%¹Ý² #2h2–¤óžl/Ku.Q–´(R)*$Ú—Û¢}³–leÆs¤¤)Œl²df(mD"}§{žs¿ß7÷÷»÷=ç=Ïû<ÿÿÿù¿ï­k7Ïá'  %e%E%eîRE‰ûPTPQPçFMçMn´‹§«çÖ e]nJ•{kqo_":ØÿJ'"Ûæð숸<Îɸë÷åqD¼°dèöÖdøöÜU0=Ô˜ã[ðˆd/"ž›É^D¿¶ÿu“öO/,!ÃûÓÚ¶Y:'"v—½ˆ—DcÎ"žËO †˜O¸7¥J ^ÈÈG¡¾Ö5ÁÒ "Ä)îOï[HÄ^ÄepAF”ˆ1ÞóÈù o¡®뉄ü#úŒ$Ã1ŸuðŠ„:ˆüŨƒ\Ö5ðuQ/—<¯ Îy܈p0"Ây¡/ú¸ÎPÐõc¼¸Úø£\¡¿"Œ!N‘‡|…<ØoyAÄg$ðB¿ñ£Þ ¾a>#Aá9ކ‚oŸ!úÕûb€÷r_#¡Ÿ†Â<æ1@Ÿ¸„Q¨#øùZÁç3D]Œ·‘à[äm„8ä~êuy¼Â>¤>ó¸¨Ï¸N û¦‚õòõ¨f¾/ÔŒÿÊÇQïø¼T+_ºzhò|¨&;§꬈õfð÷Ô'œWüí|ߨϸn2O}D\ª¼¿©¼ï¨ÄÕŽø•x¿P]üzªïÕ‹x»0^X×ÉëI½Àø^ÌÿŸóþ y¾ä÷œÿW^êâîÀùÄÝÁëB5ñý š‘w;ú[ û¯ÄßS±Ž CÖkãý@½Fý4°ï–Ý||êñ…ßWT®ëEüݘ¿ÏCô©"òmåõ¥¾ ÏïKÔ¡}7ù~Å|ŸÐ§ È»÷Ÿ:öU÷¡>îã¡x^ o¹~Bž!؇nŒWEœZ˜gúzžЏNñëÐgT·/åù¡ˆ"æÕÃý©‡¼…ïe<P×.Ô}ŒÀã§åû'àŒz~@?Àþêc?ÑGòïC~][¢˜Ðyô™fù“º‚ûÜHèJ«kÕ­µ„.[îõaähB'hö[8ŸÐ1%™vç:º§øÑ?–„ŽåûCÇD>¾ØµŠX¹Gnyæy‚XÍl~×3÷±2sÖ%K«!Þ“OWúî廫Â÷ºþ|è´Í×ÿW¿ xÑ÷³®:q%׺tУ¸:<_Ú[ã°Í”=„v½ø}~&‡o›³î¸¡=_œ:;žÐëN½òÝ;B/¾ð[ÕàB/MzšúÑ„ùýL[–ìä˜z>>Ÿ…ë¦óxi:¼ÝÇs¡K‘ÑÜä°ãËEÙ1„Î.ÿ!4ëBgà|âÎä÷½Ÿ÷ ½ãAžsÓ'BïAž‚NÞOV»ìçtr«¨¼ÐK¤ üÃê9¼ÆÑ+Ÿ"´ý±‰S%?ýg ê*ÅüÞx?—÷Mf”æ›eúþ“ëÔPBGbÿJÚÄ\¸DèxÔwM¶X-]‰Óñv¿¹™Ü#VG‘×3Œ¿}NãŸÓQ¼é ª Ãeš„^fiµªÕ…Ðãf¶M{Àõ_1dý¹’„Ë ¸‘иOÈg¾©çó“^òhΣõç ù]zréw{ A_‘3Ág¾Un&${澕‹º¹mså×jBOE=›¶ :“ü–«>Dô+^rçÎ’Ù7§‚>&½ØWµ;çõ^r:ð¼é'¼~¤ }›‰xcxÝÈCô›ù±$Íç„Ü×Ôi*¡ç¡Ðä›SÂ%ÄJèóh^«pÔm8ê)âì¹Ó9Œ×ÁjXÝþ[¾³‰Õ„®•gÿäôʷݸV؇,Ó˹Ϫ‚e¾*/x²š• ä¶ÛÂ2ÇÞŸ›ŸWÃ2…²z,sI¶Xæò¼?uMd™ëþaºX¦rHæó€O,s•©æÌ2,>ÈјÂå™-;XÆò¡ÿð¯ËXf“ªýúå,Óõùî5–)ou©Î2EÓ·k'°ÌÙ¾`™·ü½dpÄ׋ß°’ñýË­YÉ„¢IÆV"Š«T óa%*÷zߟ[À2¯°NƧ+Œãæ?T½ÜM.pcHM¢ùDV¢_ÝZóe7Fª+=Sd%:¾æ_vqutu¼Sc–qùdçËDËÎ/–‰A~×G§ØýnÁ2×:›b#ý8ž¨Kžlÿ°L:â¿…q—UÞ.ŠÖc™âì8íÈ2ù½£û&ÿÂåIYÚ8›eîó<˜‡  QÅ,S';GY¦¶—·ñæÏG‚X¦ZÖGV¢z áñH†ð}“ˆ6]ŒÞeÌ2ïQï?–r†âòt#¾ã²}Î2ßpÞõÎ)¤^W±öw°oA|&¹_~;–‰Ã>ùôÃueÙñÆéÑ€>Qí‡gÉ2m‰æª¶³ÌvŽw‡}rq«ÉüÏJ”ùu‚]Ùþf~_²mì_ò$ó=wþ\Íã”è Îˆ«’ç/Ñâý(ÑÃ~¼@^èÇp\¯Ž<¼1χD u‰Á8%|žÆûñÁ}ÑŒuàã%²s‘µëøsˆ• EüüZ,ÙoGM9æŠìû„û?±>‡,«Ùu·Aæ9¢è+Ñ€œ 'iÇwưwž“M’í‹)2T¿[ÑÓ×ý(…èìQæÄ<âóf¾t¸â—Åé8õ€Ø–Öè€ÉáëÛ9Ñl®'•Þ7çR¾íA*VOWêh«NE'lÎwº|–ò}¬³[÷‰dº¯^žúS=Ä9ª´-ñ5¤—¾·¨½4ÒJ£âSöraê¨j ȽºìêF (X½í–j×+(È6«è|_y72”­¿£ »~Õµ7C*mq~[ÙHÞ¸Áùô³<(4»:@ÆÔqŒÛ )dŒ¼`ýÌFò¤ÍQ¾ç;!/¦0ãžZ äv·œ\¶ºò4ÝÚ§ÄO…ì§Ò}Ì$ð2­T%WNƒ—kÂW >6ú™gʈמV±‚ XÛ$_›î&µRœ’ä–Û7Mš¤‰Î+$;U®Btè·/‹~£ <¸þe‰Ÿ%„é¾ úígˆ?æ;Š®«©h–ÿ4‹jº7…-ªÉ„¤…¿Ÿ©© Þ}c/O%ž£j ÁáƒÎ˜sÖ;l]×+ Èý³÷÷Å>ÈýÇ֠סò*BÇ5©í€ôš‹ƒîÞ€„Ý¢Ee{ £¹ù•øÖ Ø¯Y޽áÑk¨‰^Z+·@Èè¶-æÉêIÙ¨–܈Z ¿jAÉ%Šà󾵿¨ÕtÊÓWz Ôw/Q= V1G!yÓ¾q»n,ƒìÖuv9…®`eç0`9H¿!jRHæ’Эz’L.8©=r ÒuOãZÈÞÿ(të’Ór=ò´G//¯Òé›dÿzmÈ-¸?°æò@8 ¹§l4R ré'K#LµàÀÙŸÆ—ÄP;%76NÍ*ƒÜ¾Âµk6ÀzæÞõÏ!ï&w¸øäî-Ò™mª yÖæµ!–r5jR‹êÊ^/þ±Ë”à÷ÆÜusä<8ÐÝ3!‡Ú4¨íÁvw`ªï…^uÚ Ùž»ªK,)ðj:öìø•½jjwqY">dÉÂ[”g³~ìEÓ48¨wóç£?SI—m×Òê«é}vE•·Âxqõ«EuåÀò1ã¦CžÉˆÚ¶nH?4Ÿ>3ëopÿÓŠüávBŽ#f³jdÇÛS”Ïš0SÇ@wÊ£nÌÄŽ•Ÿ(gǰ©6ƒm(¿ÕŠJN£üZ¬ÛR‡…S®ÚÖõÑï-À5 Ò\⬃UoOÕuËãÏ)Ãý®/ÃUÀÃÕ¾6/}6•A‰ÅuG(éó–£Éj)©ÁãZXŠŠ­îUÛU¶• V;­Q;ÿP(¹ðpŒPßòõè[Qo^êûO}Všå_š¾϶<ƒò"#Å?H…°± 7ºA`†YYfÒÕZ_®Ú¤»õÕ.¨éUBD³ÇçC&&á~ÙµvÍ,ˆX»18·Á¢GìYš¦y"Ç/høEÏbrÞÙ>ɆX×Í̇({—£IGPëî–l‰ÜOÙf¹Ùk×À,ט¿þó9ÂÌÓ‹Án´ñ)[Ó›0¥–9­»à2,vó,™¨ÞɦGè· °Ï§¡fË6ØR¬r[RüJ®ÓNæy›[]7„+L/¼R%b¥ÉZCa¿n‘_·Vì³zÔ}[üAŽÓé[ËÑ”°ÎºWd³Ö v¦”×T…ºA䉪•Ó%%uê¼×mUj‡éë®ÒŠk°É®hVéIMje£alÖsp­OK}¤ç{ÌÒ/­·I¡b«,W¸@E<÷6úx¶„Ê7žev~šW˜;ÿ?Tð_O×ÚÁ ¿òhÃäñ°Iiìg¶©¶Í¾{ôœ[DÌÿéÞÚe²áx‘¤|q2lýeHÖ:þÏ¥EùrÛ}òõáaZja~/2m÷´m €ŒÆM=‹!s¦“û‡ö9«a?h…ÓcÈÍJ¬ÒÛwœ;Wâ‚ëuMñ@V¾TñÔ‘“/þR;©»Úm2Q,-‹ƒœ«“ŽKC©ÄîûåOvA³|ã®"ȹãUÛòRG݉yc/…d©ÅÁe3¨•b‡ìâT¨Úë¿ÑIF†3ËŒƒ%Á)W„½µº“§¯Ìm­wÝ^EBÌœÛM±o óÖÚÉGt2!2.9+bÔ(¹ÿRÕ;OU¸R9o“Š™‰ÃgÕÄT–R9Q[ÛWwBÒú°5Ês!i±âº|ƒð{ZøÏëi·¨øóÈÓÅTâ“î+| c¾V¾½»àÞ¿~JUvõÜÌ ßÉ~måþLåÇÿ QãB¼7»ùs׺÷{–]ó1ŠÂEпV«ºx9ûûc¸0©Bûÿâϧùÿ`¡Î`ÙOºü¤’¯‡ÖÅÙK¸ôrÞ*¿ôñònpóÙð¯œê~>Û& yeP¥ï_à4\·:Ov÷ã– ÓoÿȘl “gss/data/ozone.rda0000644000175100001440000001234612545250042013624 0ustar hornikusers‹][lUgvÞ!T:ƒÚÊJ­ÊVu„…B᳃íãËÁ>6çÇÆ |=™d:“=ašÉ0„q&Ì4% ™!)JÓJ‘ºÕJQªŠ‡jTE}°*TU}ˆ¨”‡<Œ¢’žïÛÑúØ‹í Rf±÷þ÷¿îë_ÿ÷ïÔ Ö-;°,‚%ÁãK –<þà¯K—<øŸÇ‚¥ÁwÐ?8ýâéS£AðøŸ<¸øzà?xÖæ‚ÿÿÖ m­ÊûÎýzç½Fy¾\žçœ÷TžårMÚºBø­”÷á—˸¯úåûä„/åYµHû4ˆük@Ÿ]+ó/VÞF¡ ŽÞy±i³Øo“蕹ó2ž÷WËý&‘k¹Ã_çóì·\äªþ+œ8ÔøÌ9÷›Ä/¿O è:ÑGã˜ã6€>%vo?©_(ÇzЭ aT£›q½]äÙ$óhž4;öJøiÝh’ùZÄN-2ÿj±ÛrÇOª¿Ú‹è¿ZäyRÆm®—ëu2¾Eâ«Už¯½šå=òߺCü´IôѼY%Ï7Êü”³ðyÊÑ_çÝ"óêsÍÏÕGêW­SZ—4ÞÖˆ~«D¯Âò†bGú—èÝ"tØIí½EäÉÉó§$NrN^çEŽUN½ñò§ÞYëDn̓V§þ4Šþz›Ø{ão¯®¯ÌXw´>뺩ëÉJgý\/ü›yq½ý¾c¿&g}_íØOëÓj§ø¶´ÁÑ3—ÑGÕ;üƒŒyê¾9g¾¼Ówˆ}“¾òN©öüNùyçè¡¡çe<ߟýôsлò¼ÙyXø==þ׿°zÜiÄõ¿€¾"ã¾9"á7'ö{JýJr¿$vþJøË{‰]›­¼·Wƒ¾gýÊyû|aù$v€_o‡âŽï´öKôŒÄd\IìVµöJìý„è«q<.vivÞ¹˜o_Öèo–àú3É‹§äÄŸúEã¡êÄÁyá3'óªÜš'’W·ÿщÓÒõ¾sÏ©?÷D®ÂÿžŒ×÷¾tî*öý$}>úã7(×jï?4ïgr­z*õÕ‘_ù>'Ÿ‹üsbŸ+–O"·¾?çÄMÕ©óÃN\}™.obOê“]Ú*Tõ¾'öºáÄÕgrÿžcï"¿úiΉ;ͧó¢Nè’¯‘È!öòèCñô©£ß ¹¾âøUëÈ»^%r~â¬'7Ä^U‰³¼ã·Än\7þ\êrAÆK>$öPÌ9~ñê`“S×>ú¹Ø5’::'ãõy5#n¼~¬QÖÕœ³¾”dÝýÊé[ž0ëmÒWÖ-÷òúì|FßíõÏuývÓ—ç2î+Ÿ|Æþ ÑÙ‡(þ™Ë¿>C.•£ÉÙdÙ»ÑÁßš2Æ{ò-ÌŸ‡üPïìSê2ìåßgÖàŒ«wüVïÄÝgÞFG¾F7hÈÀïë93pú,ü:¿H¼<·Hûy8¶‡Ô;8qÎy¿!#>òŽ=þ TŸ‘Yúç2êLÝ"Ïc3â?Ÿ!OCF¾äýœø¨wâ Kï¬øjø–¸‰—Ÿ÷ë3äm̨^ÝÊ;×r7dÄC½£GÖù_ƒ“_ùŒxḧ£ºE®S ‹´SVœ{òåY/sö¯“uIâ ¹8¸ør'ŽêƒÔ?*—;áß¼³žÎ:8òԥ˳X¹ÕnžÏWʸß#çmrÑ<šòýr˜þ|‹ŒëíuæÛ&ç"¼ßX}xÍyöP/_Êy‹ {!O)²óôR^\D¶ÏñìÁñ{0¾ ×í¸î,¿2h;íëݯ›÷Eþ’È_’óRêÑ)ï—D¯nG?Ú«vï‹ísÊ˸¡ÛD¯¢ø¯7¶×´ãvÐnѳŸqZþE‰Ç‘¥|¿(v¥ßz;o¿ÌWˆ¬?ÛÅ]â¾O»Ñ޽âÿ~¡eŒÀ<û$®÷èxµ[`ýÎkÊA}ûcɯØÊ7ÚüÙ¯ã$î™ç½2OI棜=ò~2¯Ìß«ùÚy“¸’úÅsTÆ×.É/ú«_äê ÓõS;í•ñŒ•‡ó–%ï8®¬×R§÷E6Ê’ýúÜÉŸ.ÕOø1öh„6¿{$_ÊR'º%Êò~9tô¥ŽJ~=4Nâ¥,ú ˆ{ãôyúÅ?}:Nו0ÝɵäÙ~±KŸúAìÒï̯ëMYÖC¾Ç¸ìÒëM¿/"Yý(va]}Òé Xwɹ¼®í¢?ùuKþ’/çß,çú©ïý’o¬?{Ãtûô‹ë{”n•:ÕéŒ %o¶üžüZd®{ßn±K§øùµ7´}eAüD?ìužu¥ ý€®ëE™§Gø'õ>¶útéï±^¥Ïé‰Ò믮ڧí”þ©Uîï–>» }ŽcÒŽ,»Eéú¥oë?vŠÝ "ÿf¹¯|:œ|Ü-rw ߒصOÖ›—Úh_›ØCÖënÉÏ=boʱ#Hïû:„!JÏŸv±Ó¹OyBéë‹Az=ï Óã‘ëB‡Ø§[ìðPŸ(}6íX;ôéýEYú„½AzÿÐ/ëBo”®×ÉW}_û Í¿¾ ]Þ^‰'Ý7–Änýg¢wœÞgÓ\’¾8–~"”ñ±íÏH¹Þïsö¡}Ò¿³/Ù§_ï Òåï—>f@ûÝODVþ½âw µË^éÛÊâ¿^±ß@˜=Qzœë~^ûº²ÄC¢·ð£|‰C»Ù/}Ù~§opöò¼Óéói÷®(½%Õñ½aú¾^ã_ó©GêtÓ×j×'}ºê«ÏuŸØçì{ze¿Ç©s=’Ç]Ò·”½{Ež>§þõÈ:¶Kêv»ð-éû ­ƒjÿ’ÄAIú•ÒO´é:.×=b§¢Ø©(ü 2oG”Þ'tJþi_Ö!rtDé|uýÓ>¯h×ͤ¯¼¶¬vÿå‰ý¾s¸Œ÷Þ»P£?¬R8߆ûøNâoÏÖè3ðûb{ÿ§?²×¤gðÈw/¦?'½ŽïoNY>/Cοú]žÅ¸èr¾Ø\£ç ÇÍWÒçŸûÂ^ðá£å!½*úßúû½T; ¯}\£ß›_Ü|*ÏôxzV¡Ç¯Ëßn>Ò›Í~~¦öar8³ãûÃDÖ®/Áþ—_«ÑWðþKðãó­Þ¯ïs޾ødNäû>ø¾q¿F-NÏ·¿›~?ª<ú½wgýüuÚ¥và¾pv«ƒ}ñ}ч¸~ß±¼Ž¼yu¥3/ô;»žÛ=ÀoZâçg9ÌÓK ¯ÿ÷P'Ï®— ßÛëòö½ë/Öèû¸žÇ÷·`¾[ÿ‹û¨W7aï7`ß_¿øÇ÷ ×[ã—øÎéWÿ 9ßoý7ä@þ¼÷öÇ…·ö£Þg;PwP."¾.m“÷`ß ˜ï,Þ?yfël]|õóåÚAWø#ÖÄÁ9äË<ëüxqŒ:ø&î_¸oóéæ¹ ½¯^ÅwÄ¿¢–â>êË5øõ]<sÁÖÉ¿¾‰üZaýq>oå~ù êòuÄùuØïÖ?Aðÿ)Æ_üØÎûóC|œî·[Nž]†|?Ý_G½8}þñõó6O˜W绞üßKŸ©Ø:Â8aŠ"k×_â{õW¿´õr^^o!®vÛçƒ|¸ùnb=ùyqò¼÷Ût;L#o¯w/®Þ]GœŸƒ~¯€ïÅÄ×ýô÷¨ÿùû6Þ¹~¿õôüðü6ÿ¢ç¬ƒïüâÃáw­ÕÆ£»®"î¯tØü›‘úÏõÿû¨¯—ë¿uQ× ÖMÚóuøëêÓK¬çÈ‹Ÿ/}ô¼ï ¿Þþô°÷4ô{ã.¡¾¿ï¯ß·yªýV–^?vú›ÿº¸÷YŸÞoKç{Óú›}e œ+Þ$¸~/ã\(æ93ðÏ“ÄÄKñ=CÜ&ýpŒ}iŒ~›¿Š±ïˆ±?ˆÑ¿ÇÄy× ßœtPàæ1~¯7ʾ„ûmv~þ‰×YÜù('pÁ8Øsߢàq[í÷ Ä«“÷iâ„‚Ç·Ø÷cý®AÏÚì~!^iý“à™›ä\¡Ûâø1äŽåwÕñzkßDÞ>ûýAÜáÌÃýôˆ›EÄCŒï:âÕ²ïÛ-¸bYð»=²Û.úm ÒÏ󸿥]øûΧc»ßÜfí˜ü®p…색k´ Û™øzÞní“ü®±]öÇÔ{½Í‡W-X?'üä{ý®¢SöÛ‚+)ž¹]òh¯ø…qIý¶ˆ?ú弪¤ø‘ÄM¿ø¯]ü{²~1_¿ÁkB«[”Ž“0O›$õ¼i¹žÑ.×|Îóž³o”¸ëDÏó»ÅO]‚ïtIÒs‹Pòh›äÇ.±o»ð- >Ö*~èVœNê•~ßÒ)ùº[ÏÁ"›aZï¿l²ñžÄ¿þû¤>êï¨W©~«$ÿÅN;$î· åóµ2ïN‰«uÎyÔ.™g•¬_ËeäºÀ:‹ºç¬}âµb—Ub¿&Y÷ž´ëkÌñ+åý&‘ŸöG^Ĥû'ùXu}£¬úï\¬ù‘/ìc’>a§]ç’úž³ë}bŸÎzˆ¼ˆ‘¿IB¾¬S¨GqQú®m2Aú¯fé 8õˆLßo—çE™_íÜ"öÙ,q$ë3í–Ø=X¼’ç<B~õà ž}6²ç7.rÅû§"áK9c[_YçvʹË©¼ÏõŠöÙ$u’òV0ßphë.×çý"ëÒð‚µã±Š¥lNúéͲîí’þë›þ; ÌÿØ÷ÆÐ¾çì~,°þ­à½cxo|ÞÚÿplÇÊyß³´g`¯G1ß¡ÐÚqëï ¨çs±]¯7‡¤~ë¿‚þ(©Sy±å;yŽÃG¤Âó±ÀÆýpÞ®ŒÃŒ;…çã¸? { ǶO«`Ü(ýçc´?®§ðþ®'æ­Ü”ï¸ÄÝмåû4ä?Œq㛼?\±vbž-X~£7’·ú“r>ÆU·œ÷ÐÎGòÖ§Ág8̉ÈÚådÅÆå ú‘u*´v›ž0ŠëQú9²þ§]Ç%OÏ„éùq ¶ñF>ŸÔç4å‹­À¦0Ï žÏTìý)Œ›X°þä<ãRÇh¿ ®G‘Ûx~¢bõä:ʺÀu‰qJÊüf½Û/ñz¸bŸÓ~ɹ?ó…q!qœØ%°uâ¸ÄÁ8íxŸd‚õåP`׋ÑPòïÌ[¹™ì?ºä¼·OöI}Z°ö#æû“£wlÁúzSŸ.Ù¯¥ ¿!Ö»Šå›Üÿ³^‘}øXÞ®kŒ{š}T`ëí¼_Ö_ýþ»,ýý9(u†ñÈyÚ¤¯d¾ʾ””÷9î`N¹qŸ<&ïÉ}Žç¾o(JÏqCržÏx–¾¤ r5ȾoPä ž³ –ÿ¬¬ËJÇû¨ž”Ç›Gé°Ð™§ ¸ŽÊC;)”çcb'OŽ H·ûZ‡ŸÊC»h<©žjÏ)ñ«úM©Ê¯ñªzóZí8èØUå8¤×«A¡[ÅoC·ƒÎ¼תÇAñÇ€\dÿ°Vä(:ï{zª òþ`ÆûÊÇÓÛ«+^\ɺÑ*ú8õ̳³Î«ò 8ã²ü5(v/8v(eø'ù=–#ŸÎSpü¥ó)Uûh= Òã®ä¼7æ¬ Ì³¾(½þðºÕ±×Z‰ó:‘§Õ‘Ï˃¡èÑqRtò¬/£îêx/î½üβ§Î_tò@ש@ì×(yäÕýy®}ƒ>/:ñ8•_º^h<E~o]sü¤v­ùZ…*ŽÝ¤Ç½öYþÓ:¥rOÅévÔø–|s☴äÌ£ë¡ÎçÄs ÿ.:íéýî?/xØ Á¹ÿ^-xt³Äù:9_Z/8ûF9ïÓsú­rŽÔ*øb(çú{âVÄ)w ÎW¼j·s^£ç;<ëœEwÕ)ûª.Áõw,ú;9ýúC¿G•ó4ýιOέôw¤e9ßÔß êï ô;÷äwtÜg‡öÜT÷Ýüî~Ÿƒ‡'ßß Þ{ °ûâ‘ÅC’úÄýë=q€Àîçž\Œû>âÏ®þ,qÖÐîß¼ý9<.²¸j²®°Žì9qCr®@Ü’¸÷«ÜWxn x1÷ÅÄx>‘¬‡xohÁâ¬Ä݉Kr;,ø&q*âŽ<_ Î}8q‚Ãó§8¼ 8&qÍÐîó¹¯'~A|øñ5âºÄ?¸ÿ'Nœƒø*qâMÄE‰Û©X<’ç Gß?J¼*oqkârıÂE‹%8—àˆÄŸŽ LcŒýCEp%Á‘‰_%øghqâ’ǯ9ûã‚c÷#®=.çÄ5‰7\’¸)qPâÀ'ñþÉØâi§ï'^G\:9¿"[÷4×ÅEñþéÈâá ŽY'8t³Å '*ž¸hqiâ w-7q¸a 8bÞâÌ“ÄÁo²bñÆÉÈâ÷“à;y 4¶¸í$qËûçœ"nŸ·øüThqà©J:?uQpã[‚Ü•óðŸÿiðçw§Óà3ùùýù4æÆ¼Ówí¹Â4æ ìyÄ ôš^3à3ÓkqïèÅïÏà ø ¾ïàø ~ßq ôÀQp LƒS1í{ôJ¦ù*ìêvïç:¦íùjzhŽß?k—×É<¯dü"kšÈzî+‚>ç XUžCöµç‘y'8«$_'~®÷ ¥Ïë”ôy;.}ΓgCÉÏëd^âóàÜà|îñhwpM™ÿ`OYÐtxtÐgEYp·Tr9ò<'µ9X6-Â:uóõ¤ÃSK÷&Û7¶¹æžôv4þ x8-³R®5¸n˜á¿NW6ùöQå}õ³ýSËo™¥¬?}ßò#hË,çPö&¨®´ÐÛµ˜Ú¨›‹ßTIuåÂ…~3ÁyÇ™»ÇÆÇ‚ºú–³ßO¸žs;ÅúŸÏÒ'Wï2œOfj\¼¾—ëÿ$™¦;ƒËôõÂåÁcråÀøQy|~ûØQÒÁ£\•ËG½Àá_w‡áV{p½}óï¼R³Á1mùý³ƒçƒËüv÷ÃVG€&…yE³ Üo¼ÿ1ïQ3°ßâc š¶}þ~=ç5Wã*ÛÉnážY &ƒG÷J7Æ7ul¸±ÜÄ×à=¨ýoŸÒjƒËÇŽWÛU˜Çí¥É¸ÿͼƒ±  KìW¦ØÏ^ÜwnÜ—}v¸X¶}¯²à<ûÛ×Ö7µ÷µn€óÆÉ¿–»¹ ~˜š®9¯»ì¾ŽO>.ùâ1¨_f›.ßðçÙŸ— n£Ovè~œ#V]Sº4ó’êŒ?4“¯K³zdÝÊðñí«t«Ú ÊÇÑø¿æ„‚vÌÛ&n¦Sà>þòÄ¡/7€GÔÓÈ1‘:ðÜñK…¦Ý¶‚ÖÍÒÌ6óx¬XÑi³ÊÚ®AÕ]NµO3‡¬÷Т‹‡wæñ`7¤®jþ™·àÕåý⻵ö‚¦î» ²;€‹ÓöâÊÛ+Ç­Á•VNe¸¼y˜ ãèÅ?7oß ìZÙËP%ƒ[~e‡¤áàú£¼oç;G—¯Ï“‡öîúýwp~tÑ3âÇå ~QÇî¯ö3y¯kΕûk'T‡-J•[úl§ýsºX·Ô[¶J êüa{Û½mÚ/E…ƒì,ï5ÝßÄÄG¦öç?œ½–<~³ÙR Ôþ– j?³þÊ» )•xÿmŸàÞðÏÒ$€Æó†d@Ð 5ÿ3KÎÝ&§·Ü2ÒÚ–zaî³\zÚoxên÷‰9V 4Önó»Ô4öºzV8N;ƒ¶vx 4ºÔýÐ8ŒÇ¯ù]}äW C$8ýQ»m•Gù¹ÆþÐêý¦à<„¡ÀiØ_ZËÕ4eÎ̺÷c-p:’;0«Þ:Žç"™Ç5þù*À¡ÍîÈM-Ç}á§­N¬²Ôí«þ˜Íö•%ûÁiá­1ë‹:C‚Œs·ÌYÜ6ê«0·%h¯0ús hšµèúO’ܺ™N¾*j)K…¾§J’ûFƒsïÀZ3Òþ™:ïµä|ìðSÆ‚º—ÚƒÇÏ5ç³cë¹.ãPýqèÉ= ãÀqßí¡#~­©ZÛGà¼ÏýHý +àl»,·öp³oð¬Îk8ž]ž7*3ùãççO›NZ ꊣƒGNsõ¢óŒH'Z>-úýQ±êð0gîcµúØß5ß§ýƒª¾¶¿ê¶iY¯z%çÔn~ÑÓW€ëÀZ%»ß‚Á€§Ý{{ïÆoÁix“—ç]á¼LüFöWïÝçUª÷D޵kCÿòÍwó|ª>ÙgáŽ0pkRjmzµ] ™Ù±Ëà‚xp.…]ep1·>Ñ{»ŠãX=õøü7XœeŒiª?\ Ôcn¯c ^¶ N=n‚fEN™V ûŸwôvhø8b¾u9³¤§Ã›… _­ûÝø ùÐkÍÞçxܹö¾'!õ‹ßcâ%ÆáyÌû¥!êìÍô/qpqYóž­î‚[—sŽ=3.ǸM?Æ{ýËýKñEvu‡ºÇÃqÞ1?êFžx;â ¨ߘu*³ˆó éu®xmc#>>á‰xÁ;°\ÆMKqëÏVîªÊ÷ë~4ÒÒ¯ð¸Üó`Œù%/FÛt¨}ý¸Ÿ«7Ç©µ¼'­ªÂ˜¼VÙóÆg ¿Îyº¹ª`Ç™{`%Ÿkí:^ÔYÇu ñ"åuݘ›ö•êlã:ÍÓõWä­{LûÂo;RòG?n>ÑqgÍ;Ör£øÑ„®°àå<°óÚ\¹FL-ÐL©u;¼»šò¨/|¾šVzÿÆ’ÁeðøC3µvå‰rGnƒKýEUË„î—êW{0gBÍs;ÊéAÝ4¿ø—‘fp|ËX¹J0¨#dÞ¡|£î^3‡…"84¶g ̙ǟÝmúâYáÜ_N3ºŸIzÁòx*‹ª®ñ\Žp_\§ÚŸ{¿—ÖÅ—]9îßIDÉãÝó„Cè¹eÁàµkê¹ÌFÅàh’Â;–ó]L­ÄQ׿إS«^wV=âúÄó·ÛE¥<]Dã{ Ñ–âkoµ{?¨^WØP4Ý“¦²ÈâùŽxEkËX£É-Ð “ÒRp_Ñ2xýˆáàå$ɈJ mSwL?`Ë«…Ëb;ÿ…ó¿ñzä ê·¦zåƒ÷ƒ6\¢‹hð›´²Gûà™Ù5sö­pÙ±©Ú”K'¹¾pËêÖ¹ÙÖz\¿‘?½&gÞ;\ùh[¼^²ò…/¨ÿ¨æüqòp¶†Tìô!ìÊyKÓc¿¤¸À½ÒÝìi«+XŠ~=׺Ý\¦ÿ÷§„g¿d:n©›Ë…¦Ë¿ðú‘ò¢ºè;¯ËËÁînjbdåŒ/º ãÈ£RÁ??Û$€CÞG=Mz”âÇËmhûÛEŒÇ=þñl²ûhêKpêΩë%Ájyý™ŽÚƒæ‡÷œŽ µae¸³AÜŸ„­–=Ön=ç?÷çß5Z\ûu] ØëOn>ØÂõ®{»½fÇ›!àð}4òASÝ~£ÓÓàuš©F['°ûóØ:iÇy}岯éÈ«;õA='âÇe|ŸÓœ65 ÏŸT7‘nA½šÝ®wn]šž3£ëí{·Ô·[ÝÙs×®KenWgç?eë&ƒæîoÖ Ú Žâ]Ò{¤_\ÔßXr"œ/ÌÒg 8^“ ·R|Hm’oÀäÒ†UP£À¿Ž¼^\˜j¶d·>ø- r¨uu߇pðYøüZÈo˜RÅÆ­Ý~0Îù½ƒç}ºõ–åÀ5²X»H0 ŸZ”¸ÁŒì,büð±Ò¨™µ:˜Kïñì»>LîÇþh0¹ ˜'Èãût’ÏM¿„ÎÉv=þ?×v©^q’›<ÀTÚ.uhû;`Ì~ø)®Q4˜3÷Ü5Ü FsèºM‡cÀÄ@ëîð °•I@s\)Á‚ùÛ #Û—i¦U¥öõ½枇Y ¦T‰˜Áøí &äN‚þ¥­þ¯—‘`zÉd‚ç0¬g²¨û0m¹ÐtÙ¢`J`2æîqŽCsšþ°ª ü–Éqã,ó¼ï¹þ h»ðh›#î`^óR{u?˜"^õêuz#˜';9² º|YwÓºôaŸ qð2\”6>¯GøŸã纇‚:÷_ ¦Q ²Ûÿäú·Y%ؼæüüØóÝ@0…ù©€ÏU&.’V‚Wý»+WÁ”óé… ]þÛáùRðu“ùCo`mÆÑR¡ú]¥ç[6‚±ÆÚ«.M³ÀÇXúÁ-Ýoà›5ð™Ëƒz`[?'+h+˜»}ˆ`|*•UM!°Ú9)Aƒ_³g=Nº±ø>S×q ‹ÓZ2.?{çœîßË|ëÅÔÿ˜÷Ì,Ý|sL›žOL|÷üç,÷òéÞüã§D¿¦õ¯<¾}=LRÙÔq˜â²¥2{¦Î©UúNÐZ÷a‹e`ܺQv`ì)û1 Ð,%40¯eeÙØ©`ÀúÛ`#×ï¦çÉ!ý@ê}ƒµÕCæU“”-jöã iRÂãn©›æÞ,û6Ò¹eÍü××CàÞKR# Œ~®eÍ™9 ÿÜ^èÍžËÐ%ÎÓq>3a¬˜ÚLG*ôëäS V§f‡ßÇš†¨A,ç'SAë±þŽ?óØâMã0\·«ž>~á2ø„|ל¥‡g@à¥ÉÕ»LcvM’ùÙy×g^øõü‚cà¿™¡¡M+0e:ŸOÉßÁ,í%ä‚©ý҇ܟ~‰Ã>{Êöìš~£Óí¬]‚ÀôD®ûL[¥ö!³çŸ=Ÿµ;¦+/®x Æa’< ï= [zÿZ†J %‚©ít‰@ pŒâ|0åU¼s*ï2î8±v‰ÙÆgënŠûôWeýç•0¨sAf>·kàåM™ ÁTùeÄáŒÏu…=\Cµ,¾+®¹Óó¥)óÊúœ^³ p1S…#Ô ÿu„$|ÀTëÅæâ‡iàS<÷O­¦£ß‡°Š ¼/ÈxÜ6nÛ_Ó@ÿ£ñ³«À»o+4X}w±¹¹›5ŒŸÃ©øÚ¬Ù{âìtž· žr}bî-ÉÓàÝñ]w–iÁìý™øÀÜZ’Õ p«»ì£×ŠÏ hm¬K½2%ùÆ{§æ÷þͽ tÝfðoñô@—›¿‚1@Öc'û.õ`•<¯Œ¥²¡øäÛÑÛ¡ÓUr=eÜ-µã|AWoaëAã®^êÆïéň3¡E3Á$}v(7 ŒÅÑ«Nê>Î+§6^>g¡ìî¦Ùàò{CëžÏLû$9Åt‡dƪ3AÿL‚9Ów©Rû¾˜Òä:ØØ]î { —õ…¹ß+V1ä€/cË#A·"®\7Ûx¨ÏÔ˜ïU0«d}gØUØN»dŽKåw?0ƶ…»Y«˜ÿå>¤ ûýú®SËo™½ô£äþºÙ0M*˜À¤}7ÅòþWÐWî×ËãÑEð½ÍÌÐx6¶–ë@sw©Mdú›þu“é¡2ûë´ü=´ÙïãÞjy¿Â¹ºo“ÁÅ`ÄàÌtfÝ¡Ó~óûôÛe½jš%¥ –ß×̾a%ò×!VÝ ·såK7v¶î ~\˜ÙŒífJô~²N4Ý—Êiø6—ÊbøœÎƒ!õ÷-ê;¥Áаv÷²ß·âxôi%×7Í{Oôð S¿ä ]¾äÑU—¯u9Åõ¼O-9þÍf¹oH8ÖÝß7òÆs0¾‘d‹Ãr€ô€1ã#+DY½ 9¼`÷†`.×W¾u{¼ø÷Ö!ÐÖŽXüC;0†Éu½¹ôtCñ‚éà³%uu“. ûWÖ;æò’¹ú‚ÙE*(]ÀØÿÏ?f1}1¤D úmØ‹ Át àÕšŽO@³à¯ÝýV¿#«J w‚A-É=/J æ&Û:üv8¯ŒË÷5yyþ;0®eÕ¬Óñ÷Þ8n€Kr}dî,÷OLú‡,]êÿc÷ªø‚á­¶ŒÏºm“˜–å¥ïÞ3&á:ÏØ«ÆÆ”\o˜FËø÷Yš³fè-0ëX˜>Ÿú5“—ÔÕÍ¿÷Ž»#7…0¾“ùQóé\Íðë÷! £œÇ´ ®Ý ^ÏêÙçU Œ÷¥ÏPÉ`reê©ÒnðÛ×¹Ò®±/.åþš׹Ÿ®¯ªùó7ƇɳÎ׹&oÖWo€±K¿ßþ<|fIí˦`œ'ëJ›üÃ`ãß§Êå#àÍ’ZŸCkÀÐfZbÓš¬¾Ø©Ïï`oëóÜÅÉoÙ'§·y z|Ÿô¾ßd™73‚±ÍÝbÙ¾Þ‹¿ïòò˜c¦×*lçÅë?Ê[&÷V¨/Ýîò¾‡Yúñ‡Yâ¹ Ì·ó÷Ÿ²Lù,ʺ‡±ú°zõ%ƒU\WgN¶ïo< uBÃ’¹ýÈ®ú¿m_¦¨÷iÏN¬c½yã/ý«QR'Ì}e=è"Á¾˜§Œb‰é¬†KÙ¦oŸ~˧+ø¾»°a¨™Õø=ÌX|,®w«²|„oCŸ3˜¯ó| íl“‚|´šð¾Z~ÏZI>æ¾ÃëNòs–çªÏ "Þ/’ÏsŸà8Ax?jœï…<Žå±|dvûüÇr ÇWáû8¿¯ûà:p?t^ÇqÆ#¾:ü~eÄùËáxeð:=ïFëÄyÉNNòukeÜïœ÷Eëƒ8Ž=kûËG“<íb¹,Ÿ[ ò‘ìiA{@ ù=²?]§÷ý¾¸¾@ï[>(ý®øž' åqý´ï2h\'¨ðÈq‚ïáõÜ|žüoKëC;¡_-wp5͇~ñÀñ¼q<´¸ J£}rp~#·öÈÍÇù|w´<úãý2hw¼oÅy­¸NðâýNãñqÉÞv´§,ú“ðFxÆûhw í£>~±êq<3ÎW¤Œ+­×kõÆ#ÙS‹óâ>Áç'œð÷ðœöï¦ô3ß7‡þÂsGÜáíoŸʽ¬¼¥•øµ)ñ åq=¸?¨ÓQžïsÿàºׄgn?Z7úÍ‚¼Ã¿[£_,¯ð<@‰7º®"¼›ÞñTî“Çai|^‹û@\[G9>]•ñÏãD‹v¯@ßו¼—[Œ×ÑoVâ•rx¬…ü‚øäâwZO.Ù͈ûry푇ç¸k|ý“K¼‡xÍ}¬¼Îý…üÉýNüLq…û¢÷)þ¹Ý‘— Ÿ¢­ø¼µ4áß'^ñÂ÷Ñ/–<¥Ý¬”'0ŸP\r¼PþóÃqéˆv²¿ o@5œùžì¥p^_%þ¬U ÿJœX1~y^AÞ@´åÕ²8n%<'Àù8.½•ñKüGù4ø¼“Ò~ âðM¸®@ùÄS„3ÔÜ^”×TʼiÅõïY«`¼ €ê8®F‰WŽsŠKÊŸA¸OŠ› ÂáT©c8)¯¿âóÂüÄWèOî'Ú¯ŸÇ&Fù’âÜŒ~'ꮌKâ-«–tœJñ‡pk)t!í§®Œ?Ò-PžâT™g4Ž5ÏÉÏĻĤ3)¾Ð¹•ù‹ç{Ò§„{²é¾>Â_5ôo’?r?Äw¤Ï¡¼À?>_"_ê;Î×u”y“ë01?“ŸÑoµÑnäOµ¿IÇ.%þ§8ñTâÁJúƒò»JÉGäŽ⇠´/呸âŒt‹•tò›µ®¯&®Ã^©ó9.H_ù)ëž×é>ퟳºëÃç8®I¡~‚²J»r½FºÂNણ(ïaüSá~¯EõÚuÅ é-^ÿ‰ñ+ÄŸµ´÷¥=YQ¨or”ñÀω/ËŽ(Þð~Eôéo¥.#<òýV@{àú8>ÊøäŸGYQ>âvsRêiÒMTOò|ù—ëÍÿ]pû /¸OÊK.ʸ¡ùHPIþàvuìFqNvTÖMüýçBœ8ùËG‰gîÏwJþ¡øâu†›°Ÿ@¡/â+ð3í÷‰2Îx€Æ£<(Ôƒ´Pÿ*ý`¡|øX©{8.\•z“ãÚKð«·²Àý^(ð€ öæu‡Òî×vJÝÌû8—Cë$ÿ¼ðè.àÿ ·5JÄíY ø›ÆsTÆ!÷ûå9ÎWèsù :ŽüòFÀý e?†Gq[FÙçû{ļïEv¥:ÅSÙ¿áv!½æ.ôå4/OP\’Ý …þÓs—Ô‚ÝÈ®4¯FYñ}“¿h²§»`ïR%ìƒò áŒüå¨ìÛЗáñ¬ðI¼`/àÕKÙ'äþ)¥Œî:~TîŸÏ#®ÃA‰®CUߟݔu·›Và9'eÞu4_³ç>ßÒ{nJ¿ó¼AüóD™ÉOœÏ½|k?«•ñÎ÷m/ä=µ’§x|òÙUÈËÔ§øŠß)Þ—:¡¯Cû¢¾Y™/¹]D¾tü¡òáD|NŒêóQŸÝ,ô¡í„~º§E¾uŒ2oñ¸S‹ûQæ-Ž÷'ʺ„ÛúuùÊþß[ÐCöŸë„:ÅNX‡Ÿ²OËûöù‚žP ºx£¸„û^)ùò‹ß…¼Fù@'ð­Ÿ2þ8¾=„ø¡qµB?×[™ODžâñP$àP+ðñЇ0ž›²ÀùÔF°“ïÅù Ï®Jþq©þï:”â×"|×á| úéîø:UB?ŸxB'|g²Uöox|¹(óσžߨ qDްÚ?ÿ^,ÚíŽò:Ÿ?¯„} xáGÁþ„ Þ'tü™¯ä~þAé/KN ßAí…û…Â{"¿ ¸/ƈvß/!ˆóÒw›JüÝýÎâÔÇ—¥„8ùôŸ_ì¿•Çi|>ïåï×Äüü•½)ϾRþ~è«y„¸ãûê¦\á{ é#•зó Ï«d/!Ž¿²{Þ籯ö—W‚ßKÈ“|ô^ž²^u‹Èëü;•2/Š~ÏyüŠþóQ¡².ä¿#x_äÃóÑe_å+¾ò$·£ˆë;Ê}}eïáws§”öåëºóß|À×ù\àK7e?æ+}RB¼ï‹|ÌÏ]Âë(_¹Bžåó:Eä~ÿ²ò{¾ø»6®k>*ñöU~êþ>Å7ÙËV™W¾â­t×?Â÷áw¶_ñº˜…õ[JŠç’tÑ©ÿÆÿþ®R®C¬#¨^à8¾Ÿqÿ½ðQ(èò†Ë?8ƒNòV! ßpßCÿGÿ(Ópž òó±8/ý^1+\>ÀqÕÀqä_ÆAÈn™'Ãp]Ñx½žwÅõ¤àüÉÈ«Yäó^«åc$>Ÿ%ÿpšï?÷Ñ qŸüA^wì7òú¢ð½Ž¸¾h²Î;ج´[¢^~?÷¹Y'ßÏÀë)hOŒ¨ÁïÄxž~DÞ_'¾ï ñpþvø\^E;õ[!ÏÓ×× ¯÷G{¥à{ah‡Œç¸?ôù=ßoçÑ8OßdyÝÑ©¸oo€U‰ ò[úAù¹Vè׬òûaø^*î¯?â¥.^ïƒï‡ãüpœ!rÃâp=½iÿ¸Þ̹ò±â1Ç‹ F<Ë>HEœ ÊÄõâ8ÑÔ¿‹ÁqÃÈç­q=¸Ÿ Jœ ?ø@{|¿—Y‰Ç8o[šO­ü>Bׇâºbÿv„ë@ü¦Fá~pžódû¦áóø|oмÞÏCñwçQ8kÂçXåºSW­Üäc§ý?`(âã=çK§õ£_ˆßÓ“äû‘´;Îé9šý—…¼‰qÒ ÷ÓWNìqžŽ×ÖâJ;SüÆày®/çkN|ƒú£ÆS&®7½ü\3Ìo1¤›§Ä[ýˆq½Y8>åSòoÔŸY¤cp¼dŒÒÙ‘ˆûÒ8o_Ìs¸ÜépÊ;‘È“Q˜/S(gãü™Ê¸OÇ}§âxVů5UJü‘n!½…<Oùã–pÚñ‰y$ uHÂ3ÆÕ!„S²k â»=>?„Öƒó¤£É¨g’0%£}ã(/‘î WÖýQ/¥‘N ýÏ©”ü•‚öí…yƒð‹óµ ý®äНè4´ËPÒwÄ‹¨k31ÿ‡Uê˲Æ[Gôí“ó:æ3Ò{ôþ•r=¡O&£þθâù8Aσqß5Hç­C½ˆö‰4+ù°Ù?E¾O|‡ñÓY¥Ìï1xT_!?Ó:£Iǧãzzá¸ý¨>C¿Ð~£…<ÂëdPÖGÝpÉÔPü¯àíÓÓú bQþŸÁãÿ>=£þÕ.)qà úûà>i™ô÷aÉé½i é:½`/ݨ%Ìâ<0cX5šÉ]ú?ÓK‹ýô飛¸œ¤ÔÄA´ºèÒ;qpbµ¾Ùûìì£ôÏÿÑáWàä^gss/data/clim.rda0000644000175100001440000001267412545250042013422 0ustar hornikusers‹uœyŒÞÇYÇ_{m7NÇG|Ùûñ®×ö^ï»ûîëÝwÞ½¼÷í=lïzïP)i«¤qDMT‘TP« D -HEAŠ"Jû¨…R ‚Т¨ ‚J!MÛ6iüþžÏwÒ÷•xÿðxæ7óÌs3cO÷-´Ü¹pg*•Ú™ªØ¹#µ³âö_wí¼ýÇŽÔ®ÔÞbgýÁ÷?”JUNæ¤Rûo7OÛñß/þþÐTg­f+ùÙ‘ƒÅß»ão‹¿çlÇ Åß7òÿühñ÷Øö÷’ï•vêÙâïOíò+·ßÝi /þ~Ójxi«JàÁΦ’Ÿ~ªøûŒt¸Ûoõ3Ö|ÂÇ/ÁxÇj8¿lµìŠug®Óaã$ëóï÷åÅpØ¿çßñïù—Z“ŸÆÃÞï;ÃŽ¤¿vÐ?Á¼ý ¾¿ +NèýùíÏ%óömoûídý@þyÇkûÍ„ÞÃyøùþÛÿèóóÿšŒï·³ÎïP‘ÀÿJØë| §Î°_t¹<òßIæm翞ì7çÝ‘ÐÝŽú¼po¯_ •ÎçP =•ɾ÷„ÊdŸo…ª„Oß 5À©æûEèxÝùh;“öuKù>¶Ûù$:ãø.o#_~˜ðëÉü·í/9Ü?Í·º„žŸ²Šdþ‡´ïö«Ì«OÆ7·ßLøõgv—óËö%t~ÒîvùÙÌßãr³{8߱㌠Ýí|¶ƒèÑû_»x¢÷.ÇÇö¡Ÿ/úúí·“õÿ³ý£dþÏåÏßñ è¥ÆÃ1ן¼è9îò‘ÞØ½èÇÿÒ?äz‘Ííaû›ÉúgòØGØáx‡Ã ÿj9œ ÕÉúùP—Ìk u œß Î߀†óÎÏpŽñs ü¿ õ´•èÃ}ØÉÝØÅIçg>i^ù~Ä÷4tž/ôÙîLök»]>ù¿JÚÕ€ÜCûƒ¨÷ð=œÞ]èíIìäðëð' ø§Žß)öOXÓ_áŽ[:WÜÿikOúktº¬%ÙÔÒ¬kNô /{ Ùÿ5ëJöûëi(¶Ÿ·« ÂÁ²Àïuû·üRïÿ´ždŸ_±¦/ºõ&ü}ÄÎ;ÿ­¿WÞ5ngÖ@¿ ¼ÎÓ¿„ßlúº_½ÀË| ˆçËÖ<êþ° zÚ?U„{ÒÒ/8^mÕΗægÕ®'v?z¸ö(ëáçÏãg‘«wþIÞ²oÙoô¿‡ñ“§ÐËSȯ=<˼û܆Ӹ«F÷ó¡>Y÷7¡ ùW3¿ñ á«ßçó;^q}èHøq2tº=…¬û‡Ð ]È=Ë:ÍËÁ,òŒòr:±óZ÷ÏvÔó«&¿Aÿìv—B^Ç?ãve•Ø1qߎ0~”uµäMÌW^•ÿdÿíN‚ï9÷7¡Š¼ 2áçÏ俉óáü$†ÈíýFìªÞó¿ÈÏ vÓ\Ô¶£¯íÈMm ü“¼Ú™ŸE.²'ì·Crb~–ïíw»Î°¾3¡ç‰ÃÎÀóô ÿ,rë`}ôµ³_â¿yYÔ[ôÎRg(žÕcOÄ%ÅÝãà]žÄ »DÏc…<¶ô^øwÛIü!?žëå—¶_æûåÝÀ¯LÚ¿èÓöáÓqêSâ“‘wؽÊ[ø®:ñ þ‘ú.~ÊÇCµïc÷'«À‡|3Ö¡uŒŸp~Ƽ]uy®ê°hZw¶ ûjô¸eG©~„œï¯iì3‹ŸÉ’§(ÎÉf‘ü†ìº]}ùòù'ùÙ+òË?Ä?¢OYü“òùÑ,ð:Á+ƒ]¡ŸûT©ŸÌÁï~(Gü¼‚ÿÄ^¢ŸêÀïfWÁ[øk<‡?ËÁ‡è÷´¯àâO³ÀmOÅ£Nù{ùWø(<ÛÀ«ºÚá›üµÖ+¯hk-•_š8!ûU~Ð ^­È7‡ß—ÜÒÐÓ^mÈïŒëmŒ9æ+ît²ŸäÖª8ÈüNå+à? ü¸üœ8ù%9¥iÛà{üZÄgæ+®%îv*. Oô@rÍÀ¯6ù9ðÃ߆6éûF:e7ÒcðËŠ/Z‡¾f¥Ç²+õ•¿€¿ìQòï`=ç!S–'HŸ3ðWëUˆÅóŒô½i¥¯ñ ô] ¥.Œ|P£zê„ëEþUËïñ}•Ý)O‰|,Ëce?Ò+ÊC¤·àÓʼVøB}¨‹Ãeà6Cßò-ÕyèEFùŒòá ŸràÕE¿ |d÷WX§VùQ7z…~^ùz¨ü©8ÝÀíR¶U*éIôàÙ ½Ò_éO‹ègÿ óÉ3t¾"ÿJUìO¥vo„)søS+ÞN–>|ŸôƒÅ0ñ¼÷Ç?öí¼òÁ0Éøë'ðŸcà­v:G;‰~Ofý'¼?Á~ãÁáCÏø>àÒe¿QæÂç‘Ïû>ÃjÙ˜ùÃÌbŸ‘E‚®æO/¶–â;Ãà5„<áïUà\«à}xƒà1¨ujÁg>Æõ´à9Àþ¬ë‡Ÿý|ïg~?óúÛÇ÷ðQ Ãðe˜ñ!à Á¿!ôS|Œü„Þ¡T]À?«6Ò‡ü¯¢'WÙgHü¥Aæ‰Oƒ¬þ’û'þºp„g¹üêà;ó"¿™ù ü~èô€ïÕ­28jù>¬¬E~}j±·¾÷¿xô¢=ÀïŸøY`~ŸZÆ#|õ¡¿—ñ^à÷Á§>àö‚w/ôõ"^ø¡VøôHÿàOìÇÑ“ð?ú›ÿÆñ[“?‹¿‚®qø0œ¸<&¡c‚þ„ÖÑNÈîñ‡Ñþ¡g<凡cŒõcØÛp¢ß‚O#à5}c²'ÖG)»Ô¼2ÿ*ý–?é—ÞŸÚaÙÓó¥ö#;Ó<ùöé—>H_¤O’tà·ô«Àú€žøX¯óØß*=+¤J×åùžgŸ<ë»ÙçŠò åïÊÛY§|º°¯t}Œóð3ž‹èóe7M’ß/Ñ^fÿ‹‚Ï8çrñœ8ž?Ñ—Ýœ•ÿÀ¯øÒÁüÖ²}.´–Úe íYàrß {Ôt+¶:ÿIùüü·Kç‡Àѹ÷AÆÏA߯ê<xušÇ÷Ê2}ÔýÈy¾ë¾©ŽyZ'}"žM=Iüù8ñqœõèç¸òlåWôßÇ&gî4ûÎÀï©FogUg|¶4Î GþKq'æËŠOÐ9ˆ¾*/T\S^YG•÷*?Õ¾¬Vþ‡Æº@y,|‹ñ]uû(Û*Í+fY?ýða€ïÔãÊ/—õSú_:tŠwùò? {WÝÙ¥{ ðì‚_Auk™Ÿñ[v¾¯4®GôƒR?óAåà'óQô(Æ¡²øóhù7å5ØqŸê+ÍSû€Û¿ú¶Êò[Å˲àªß£<¨Ï ?j½îß ?fäïÖOŸóÎ;Œ¸ýÞ}#ãUerÕ;'ò1KËž¤—ê‹øZ€Nò¾ˆ'þܨs&ã|ÄˆÛÆ9‘ Hð¡Fïé §>UjçÒ˽O‚ŽVõ¥Ò[½_‚>ékZvÎ<Î÷-GË9u¤—ºÔºÁ«›uä‘ñžµ þ0Ÿ8fÔÍQd×#ðA~ÈßÇýqÀÅ6ÄÿNxýÑòãà﬋~ßýÎé˜ß*onQ>N«û>åí-º¿×{ü{Zõ‚ê^å ˜ÓÛ‰¶|Ä<ÿì6Ï{ŸážôYüíîUÿ:¾CñûøÇxÿø–ßÃÞ†s ¿Áû”—â}é™ÎË„Cɾ_öûçÞÊ¿ž´?ñ8|ÏÛ¿Ì{„GCU2þÛæßßïÑ$/Å{Õ=çËê×Úÿ¯_ý0õÖ¯Å8ìiýAîEVã9ƒÖ©þiRü¾Î%Ô^¦Õþz‡~HZu.B¿E÷KŒ·k?à¤õn@çÊt)»ÜDîÏÄw}1Ÿ>Ó*oIë~6§zVz®ó„ÑÒºYç@â[” ëõÞA|¸„]V£gÊktï¦zWû*ßÒ}»ê}廲GÝGåÏVz§û5Õ¹ýÊÿuÞ«sâºÒûín¿”ßöøÉó–áXOÄscÖO3_çŠ:½žCà3Í=ÓœÎa©ƒn²Ï õÑ¢?ìËÀ]Î ø´’ñþ&óÖ¾åë¶àß:ùôôâÇc¢:nTçÉÌ=Ô³ÔÃóªãXƒ}¡ë:uÚ-Ö­~›ö×}Þ ø¯ü‚ÃYýx¿åýuêð^ä0 _t5 3Yî+tþ Ü©™Òs]Õ=:G×ùœäÙ[vž$½(@OAú’ì_ƒIwJøóÍ0¥}97ÐýáüšÖý¡ÎØ7ž»Ã¿©¥÷Óè×´à@× íçýÓà?£ùðix3:ßôzº¦áã4÷3èë,r˜Ež3èßü_áÞc¾¯À·wÀáút‹ù·× |\@îóбÀüè^„ï‹èÕ"ô-ÂW/ ï䱈>ÄõŸ¦ßEè^„Þ9üÈ,x^CÓúž3ôçÑïðX@ï:ðo‚ï ç\ËÀ]b|üæ¾êp®Ë°~9ŠÞèéMøwƒv?s“ý— ÿÆá’sÄ<ï¾bäyÙ›1oT^@Þî÷<À<þžŽuç¹F\‹uƒêƒ¦dÛcÖ¤_¥:‚|\ëµ®¾¬ÎW~ seù­0ZúN«[çTOyÜ×}M^çèè‘ÎQ«Èƒ”/בç¨Õ9±Þ(ÿQž¢{½G‹ïuÁ‹¼ÍÏ3ž{"T$ýáÈgú¼¿û˜ÿ;®Ïì1ÿ÷WFýþfÌo×iW©ë6fhÝ~m#Ë<êÎ5êªÍ!ߘsÀëw ;¶[Ô§Ø¥-¹Ýúo®?6•´ÙŠû »åï-l‚ýÔŸt»°òpÞ“ØŒ'ô6‚ü'{ì4î+{R#^çÁ6ëvcsÐ9 î×ì:ßéßÎ2ü!žØÌ“¥ôÌÓŸ…žkÀßëÀ[€Ž›jÑÛeêÙ•?òñ•—àü%^جûÃoØ,õß5ðšƒosà3\¨“àÂûM»N ¾M3.~]ƒîyôFøNÓ^ƒ_ä16G}N>÷]„Þyð]ÀN—‘ï2ð%ßiÑ œð˜ƒþyZñs9]§½–˜GܰièœC/„¯Z¾/~}Ÿ%Ö/}±TÄwòP›ßC+ºÁGò^b| þÍПD^Q~ð\ö~cI¿MQ×Ï$ûÎ<_zÈx¯`“ÈEûLHn²+ô”w*¶Îºõ?' ÏÙÀŽ7=þÚ:yAÌ+‰3¯“/¿Ÿ8ÿ÷ä ~‘¶ÈK—/SËÄéeâí-õ‰;ËÄã>âO|ÏÀ¼üñ~sB￈‹3ÄÕZÝçèýëtO£wKù²ºQu‰òUÝ‹äu_Gš©õ¾@ïõt¢~SÙ½~ùý²àgŸ*¹Ï°qßá/xc¼ÛˆçvÐõŠw(æïIm =LôêŸl}ç]JÔÞåÙÔ§ñ§À¿!=Æma¯[ØïVö _Öñ“kj‘çšç“¶Fþ¸ù‡»‰la›_qøßÄÞ6?IK]²YØýyÿx¯³ÏÊMêüÊ2yë-êÁ5êò5òSò“p“<| ûVý üר#Ö¨›—TWP§¬y~ÖÉ£oRWŸÂJõõÖ*ö¼:Éú—¨—°×Hãò—/’ç».û¿ *6ŠÿµAênÿ¯ v>ímÉ”Ýë®>òÈí¿øÉÿ¡ðÈPqìòÉX}hS“wjò‡7úþþÀæ([´÷á>zI TŠ6öî»oûÄŠwËv¿scõë—¶¾½ÄqH½ó=I© ÇAgss/data/esc.rda0000644000175100001440000005462212545250042013247 0ustar hornikusers‹µý\ïÿøŸsŸÝ.B6%3+«× ‰ŒeeWd“ÈÙ”YF‘½g BZHÚ›´µµç©ÓÿÜçtßýÿõóQ½¿ÿ<Ó9uîë¾®×õÚ×<½EÚ2‹d Á`LÁ?d☠6C &Ër»¹øßâ‡|1åÅ?fI~,ý&š}7žù—Ÿ1ÿñ³¿±-—ùÿxó?~møñ—ëeþå³3[qÍÿú,{î_Ÿhãuÿc¼Ûóûþ×g%þqíS¢÷–hå½hÍ\#Ú1ß[;~ÿºD;ß÷_æ9ó¬Qfæù·ÄX¿D+®ã­ëÖŒI[Ç”hå¼hÍ:!Ú0G[sí•GÌVΉÿ‹yØÚÏA´óï2Û°†[+£ˆÿx­•1­•ßÄœÛm‘QD+öûö¬ýÖÞâÏý¯¹JüÇ}¹µ:ÑJý µó˜hÃ>ß–1ù¿Ö©þµ–ˆVè›íÕaˆvÜÓ¶Þ;¢•2Ÿh£Îñ%[ˆvÞÓÖÎÕÖÞ7¢2øûÒ¿ÖÑÊyÖ¹Û}–øzñu”¶èú­Ó­Ñ¹‰è„Dí¾ÿ%ÿÛ£#2Û1wÿµßµÇî%Ú¹´æž4>þÿqp7Zî´Ü¸]üHIò é³ÌáÔƒÍ^Ï1߸j;õrú—¬Yen³ÅZüHÔ —C[Äÿ¿Þÿ/u…h‡zB´rûl­‹£-j3ÑñÃl§jÖqÛZµó_K±5ÛE[ÌÏÖˆ ¢î©Öl­Ýމ6ª<ÿ·ÿ«¹Ü×LkÌú¶¬…Ö|öÖÜ»¶¨õÌ6lÝm1eÚ¢¦´Õ•ØÖëh*Iüc&ZiÂm˜DT¦ö¸§ˆv¨­ý›­Y§Ì6üíÖî£õ.G‚Ñ~×yk÷ÛÖìSÌvªtí I´ö3ÿQ­lËóm¹—De ÑÊ5@ü˜mD+Æœhƒ,%Zù»[k"ÿæT[\yí ‘´5tC´rµÖìlnÑý¶=nfõìÖ®‘¶êÓmïÖ¸™mÐyZ«¿0Û Ÿmœs­ 7´VßmËgm˰=:0Áh[(º­n!fö­¶èÁ­•‘D+m¯ÖèÕm]·mp%“.¢á_NVC«ý ­Ñ5ÚRiÏ}$þþÙ]µ5zr[Þß–=ˆh¥|j«k¿½¾™¶¼ŽÙN»³-i £}®ÊÖîÏm•uÄø\íq—·UWi‹_ÙŽëlíºn‹±5ëµ-6z[Ƽ­ûkíì¶„Ú–n‹¼j­.Ú–Pц=«­6“Ñza[ÂÌ6®÷ÖøQÛâ¯h¾üÿÏÔ–¶øJÛ«ë´En´Õ¯@´QOimÊD[ýxí Ë3Û)Kˆ6تÌÿ°ï0ÿôýö¦Ÿ¶vÞŒÖû>Ûb_µ%fA´CÖµUž¶U/m¯/µ½imñ±3Û¹Ÿ¶5Þó mí=ü/zr[|á­õ#´×WÒÖyÞÿk{ýÌí•YíÑåÚºGí·¶ú¡Û+`¶ñy¢e*Ãõ+0H¿TEMÿ¶õéä;_ðöÿsÑfr.'èEt„ä Óä‡SD^ðÇãë †Àç•‚ŸÕ úÒ°N›g©Ïƒ‚À¥£êf@íÑ2r  LÅùöM͉üæ_ŠìXéçhå› ™ƒÈ\9åâý (^gT·-Ž‹¬1œþÄŸ/àô ""("ã̃0Eÿ‚愘m;Îô¹4™ü´8ƒ9Æ¡2®Bï]×rh`î¶ ¸QOs;Ìðì½›&ßfæ=ð0š}ï‹ÐKú²–ÛÆª¿4GÁÙª”› ¡ÁåGØ—¹çšx«Ûl¨xö3û;k>TÜw¿§œÔ­™k™»„ƒÂ½W'L¤ˆ ÃB¾ü>C>OëøÉòv<¾ÞÚâÖzTÈ}Wüs爿üêHüä ­Ÿzº'ÊNI×>{cZs‚(º¯Ûk¨Öéé0Ôß~†fUá¤_Èé•ìà¼|·/ü½5ýʈžŒÙ£xž¦¬¹Q”ýúr$²ædç­8J“¹ÿ„jÆåލþei¿@2S§ÞîÉÈ,xSP©Ã€zçŸ^—®Ó¼"™Vj4̶®ëùÀ ƒezÀïX ¯Õõu :xwÏu­šgœZù­ VͶì[-*Îü}ƒ“ù•)AßceA´i[ÙêÕ¡Pš4ÃkÞXvs"ïU­½îP¦¡ºlÅ‚‡Í‰lãõŽg;þ€x¶…J¸ÊîÈþyñ$T^OŸºàÒïæDæó' ߟ¨¡ìšËÏ“ÃöA@ÍØ3éǬ‘8:ÂEÃ~üˆ_a¨7åÓóoïÉ}¥;t·î,"rwl`4$!Thí¹½ìôH°aL·‘£è~ô‚fçJÈåæ,„àÃ#뎅ù"+ÃÕ3P^b2ËzéBnÝžq‡˜ß!Rû½ÿ¦°ñP¹ÑF›É–£Yé™u¥¦€fÚâèi§¢dQn§›º÷Å!P;ðȣ駎£¬>sÌʬ üâôÄ*¬yª_k8ã¡nx®ìçW+±zËÊÔ|+d›âš6‚ÊEãçûdúÐ ¾º·$ç7êwOîø† A–Ë5OMÓ_·6Ûif EdŽ.º¯úÎ%0_0ê #WqPöÜÏzÖÎ*ŠÈÝîv¡Òí1MŇ!ºû:#ÛûÁ1ÿ‘ÝÝfG÷ô³!½^¦Ðõ[ˆ(Þ0öX _þä–/ÚÑ–¯¼# fDZAë´ bÅËÚME_Øåâ™êC*¯îN””@ñþ„9#ÏîAÁÈòG-‘éºnÙù'´üƒº+£ãöÞÖA9í6‘àºiöÈ×ã´[Pè9Ãøá:¤)ré–ßEy vø½P[µÎùsÂ>txKËU¥Ü€é9¡¿ îÓÅУ†Cõ)õÚ²÷)¢`Ü„ñV/®Ðd¿,¶ õÓAη3gî¸Íƒœãwïž½”†¬Ìw·´–ÏGÙ%wÖÕ•ýlAâ†û”]3/ÐdÞ¸©00µî§?dX<†ªáO†vrö£™r[þ窋úP›zðÀç•vP]pàí·)')"G5Ê sîÍæ„†Ù}Ò¢:ŸmNäìŽü,¹y©ëË×ß½¬OL¥õ;X>Ý,R)"!˺^\²…&—뼯×ï¹(3îcÊ~ûq¡Þèu¿qWÓ,3ÿjuAW‰^WÜNßæ †€ûå¼îóË¡R4•./÷ÎTçW€¬žùCdúéCÈ7¿eó>m†‡Ï¾Ñûù²OžT}¿‰AœC#鯗«Ûý*rõ&ïÚj2Z± ø3iÊ÷¯wHzSA“oèâúqñt(%µ-ù43®²­ôNUCmŠï²\?uš•á=tcfA‘ÿ]“_ûï£lùãËSºR„ïš1 ©›.PDÖçÇVå^½QQNÏnx4„™“Bó4DHõ¦Yéýc³¼lÁÚðœ's×âmña Ävг_}®jŽïK°.›ô7"1¼—Ï`­äy».O ¢çÏùa †nÓ¦ÙGcVLõV„b¯—¼×Ê w•ŸžÆœzšòþ†)«úñPf÷÷]¢"¨€Oª)– (" ¶å‰~ QV=fÀÇ)BÃÞŠ-Q½QÖÆö] ”Bi·uÚùb½©ºë¯‡—Í[P‰\…‰,áiè25"ˆÜ‰ƒo  $uÿ’]¥ÐP:|ä]ë ͉lGæ1åúÅ ÒªÚŸç —¤}ÏŠB¥ÙƒoÍx+–».½í¢ùŽëLÅ¢—{O³ƒº—3õ>{ ÒF½ f؃SäþÊd݃ÓêChþ _6æûBEŒ‰ª–ÌV(¿âklr 9‹²“Cf©Ðë€èe~zÛ&dFï 'd¸;öМ9¡>fܯ½L ‚yUÆ3mÊÞúž¹ÏJ{ˆ7Ô PsÞ»ó¢t5ŠMrW» ”;e\s"W_!A¦ó d×9×CM*Oÿ}ô‡-¼Ù¦6=üöz(‰ËMÞ ÂCqËõ¹4óT-ý£vñ ¤×ðì†Eã‘—Åý²­Äf¿L/UŠ({†;Ÿ±HµÙËEÎ]vªA_#`ÓÃ=PøvN§‘-2~–©U2åwŸ:øÔ/ìg3ÿLÊÜ­ö­(BªJ ó”µGÿŠHÏ‘kùK5dãM”Ëþ2kY¨ `ˬœÑ)¨<á^WÆRý&®¿4&bוŸ[9š"2{+áÇ züÊþ?ŸoI ãúµ¯q½þúæü­PeRì9¿glTÜø$HuÆZä•^H¶³Ÿ¦Ì~ñevqDÁ"vdo5ŠÿõÂõª™‘ù¬‡ƒÉ!dOp>ùº7l-mç÷x¥OYòìß]†Д-f|õ$T©X~¤ø"¬\VÎö—ø¾8ªzÍÑԵ˒µ(¢g£‘£v8”ã¾Üµ¶„"²®Iå Ëm³‡w€TÉ+ŠÉ=ä{ß+ïZ´•¦œpû™MªÏñÉéÁXe¨¨²,â¢;r'tÝ´îl62 >Ÿ¹±þäÅeî Ø£KÙ‡4{½¬ÝŒ S3}Û——§wz?a±RÕQöDˆøu]= üú™þ vɨñxëüŽD.Ëpäº7 Èð¿{×ùtd.².›x§'Mù‡_µå]Åãs ÀµäùЖÌê~új3Ê=öh|Õøæ4^ó3T ²–*~ƒ¢sc¦žÈ…¤Y/ÜÇw ‡k¬uS)ñ$›³¾êòn;zÜĬWýV,IÑ®ˆÐÑa]Ë[ükçš¼Ã/sïW¤¹E«kBÌ)"1Œó€_˜io^Xq­‚"r}ïõ5O õöE¤#9£$ò¶9!se‡5 ÆQÈ6ºZ<¨ÔïÍšÿt.Ed*¬â>éXÅ7œ6î¾™G½î`}¶zûáÙ\dì È·{'–û܆ÏûĽnά}æ4åÇÿØ{NÑöÕ«¿=‰ óãö KEíátO}¨¿ñµÁ©ÔëoDÎô«£îÎÞKSp«wZUü$d¬òN}ºï6ExðÔéÊmñ¾ûý¤ãÐkÈçÞåXÊašL¨åÉÍTЫõ(Ÿ¦Ô1æ8ò“÷¸Ö*?¢)°L›Ð%ÉŸ"D¨Ýɸ2ÛÖs.Œ£ùw2zlƒê}ÆCƒ}s("3.zø…î‡PƸfÀç¼ß¡Æn?ÓuB…Û‚Uû>€ÒΉ?ñoSDþÕ<Ù[åžaÿótÆxsÉ“ n$ÔÙŸ}ðШÍúNWnÅ/¡IèÝdGHšä«>b™x]º¯–äæŠLu<ïw\"-‡*ýÔmߦŒ‚€ ‰!é4¡6ª_¿Û;}7ÒLö£QÔTŸñ š U/Ù¬+GQDαV Çæz=rÓöi|ëIa'-7݆hUÇCnÝjÁ¯î¼ÙiuÈ»z³çŸ„sÈÝß]U`w"ÄÕ:µ#ðá?ÙP}êNväh”ùU´ü‹œ òŠû’we¿LÔÜ[;.ü7´§Ønß¶à†—åýüRù9B™Ð¦ãݨ—ü‹l?š•Õ֛ؿ‘¡|IñÖ²—¡¤Ñ¯do?óS—Aôgƒ‘ÑŠ((¬_7;äMy§ŒC]«¢)B…phJ¶Y ü¹½pÊÏòÕ­fºªüsÝô}ûýyªxGñC~¢×çÑQ´pº‚çÌ ßM¬°Ÿ¦ˆ,«Ô¯‰ÑúPɸf`|è1&wåɨ𳛉ÚÒ/¡rØ÷?£êV¡œòáa!_²‘°5Ï|òûõº3rç\ŠÈ8iò š9ê*ÄfdÂÐϾ£œ³"¢9Q&SeF|êä=ZBî\È<­q*›åľ…»Í]‡ Bô ND-Ê”J)ˆvºÃ™?  2üWé4ÃZPPæ’»uÛ!šÜKªùµg÷#Á‰±ÛŽ™¢Êl‰Ã‚"?^ßkÿ(í}½Ñ5*7 fýj>üØÞc¨Âp=ˆM:~Ó:ÒêÜ£¯^~…fy ¹–PDÿ™ÕaÛ.!üyÇ=iÓŸ#[+nµmà2Šjó¥ÁÇÓ¢VèôO›€ÞÎ[·xÅŠÇ?½Æ$„zO7&•?‡šõR½¸漯.ߎÜǶJÌ8ÈË4~3|lÔ¸«9Ö½GÆ2­-jÎs)BME绫¶ûÀŠ•/‡Žg@ÜÓŽÁ+o3¡š]|Q£äü_íìº}‚´AÆÈý©Qáv)…îÕa9ͺo2|‡±øz|°0Šf¹ÚàSFl!„:õ¡\€Œ«½žïëßêw¿{ö ù_Çå%/–ƒ¯EK.:î§™Ýal¾F2Çn˜à3± ™›}ñôñ~|¹¸pÒÑkõvùh°ûƒì¾“œFϦ©â½íëÖª·È÷[ªo\–‹L™èÜÞ~ëA4HlVªÅ‰÷ ‡U­åi*^ÓîŸ{ƒ¦²­Þ–«®†PùmKÿç2ñº¼Û÷äå@d6úë ê÷tð7¥ˆŒÝŠ Â"ì±2·»"ûwåýí‡ O.“Ý…Ü»wÎL©¦Éì¿xë«ëÇ·M7þE¶ëº­ar¬Uë>ïI“{$Õd|EhxV;U´Ô ÙkŽ­z¾õr7õT:ºÍö®¸7R‹fU8$ŽÌXJ3Ü6ͧ°[5÷(nï€DEnšÇÉ›(3ø÷>ÛÚ ”[©00µè tjüÌž)=Ū0rej_O²P¤±yUÞvÊ¡HÏ“³‰õcª2‘8J:¢êèç“|ŒóöôA"HðÑmõmdYHýøad4hy2Ê W¬¿ËåY‡sn CæÈŠaþ–½¯ßu½Zr¼<.^% ŸuG½zñ¼“«&xKS8eÖȤêšÕÑ.æ:¯ìûÁ|õ½ìc*q€uÅpûŸ#!áèqçä˕Ș“þT»¯xßjNžœëõ=OM¿u`2” ·>ã»ê?Îty|̪ Ä·1ò$Ê­îDZÆ4¦.ß,Ѥ5—”ßN|`Dï_,#±TïÙÛË:el3AÂØ8{þÊdÕI 4r‰!-LŠõA'T ì Cû^·y1E”÷ºµ*³j *žz /¡¡4ãcõòÇÈU­ÿ^ée™»½íXPºtÀÏŒ«ÓhþÑ”‹QO+µ â«ÏQxí~¯zÈE‡"ÏÇÈûìÞ;Ïl>ä{HïChw‡=“³öÃÏÓëÏc7ÐŒ­_™k˜á ¢#¿fC]^iCmåŽä¨çgiÄŒ P½€ÌeÑoë/oák ‹;n†¨ãuý† ‡²bƒG—'Ý )´_ÈïwÞƒ"òC9² {"ó©Ï’¹Œ"(½Yþî"”š?•[…rõ“gïŒlNzž5˜y{½S9E–Ûøö Ds"WxàÚåáÍ 9¹ZŸn¢Yv_}æñŒ³È±gõ7ÜÜeÙÖ~Ù¾iÊÌœår$ø.*޲ѽ4)•‹?˜0%¹ËL¿Ÿ/Bn?‰ÑBŸl^tg˜Þyð¨•ú'kT{X;U>n9yã‘Ó«£ Ç—@9äZö‚×%c­ÿ‘©-¶ëŽþ<¬>ú,Íξ¤Ç¹º*÷zjwEk¹æµ( £"{z#{ÆGÿ¾†)Á¥|XNÿÎÙ‘{àWõŒ½WPfi÷ß~ΉÁ¡äĦj­^(ï¾Ï+‹%D9'û’Áï#ÿÄäµ–¥©X¡ˆYw–¡Ü¦ý{Ϭ¡)8¦Tœ+ûÓ³œíÊË”Ä Ð¹½È€O”~Üq騊:Ed3=Þ æ¦L°XÒƒf¥|†Ï-·kðkpqMÔGSšjÉl r„¿#=)»ÂWž °¦ˆ¬‹±[´ßûSᬾ¼óoš9çë—,PkNˆy#?U)²ø’ òê‹|•Y;+ãWÃOÑoáì‰jÈý^¶]3`²Fà•~,Õæ„ %^‡bÛïÈ·i¸ó¨ 8o”æ³ðùìKk_—Âí­e'úîŠDާ$pB“‡?ßîr„²“QqHȱ©Ân9 Ú{@eîã;̾S~!ÎÞ]¹F}ͪ‰K·½ÚE3±æ8Ô~ŠFî‹«d$O_¾•4º=¨ ©[gùïá vUˆªÞ¨Œ1nÈ´€Ì_Ãöv›O“Ýèo/Ò=j ¤WgÜ~šú~ {q}{,”¤¿u ãÂ0¢|sÔ´—ÈZ'6oÞx!ãÉçW+:@v°aØ•ÁkA$¶JŒ²wÓ| x h#÷¶öÙz1 ¼8úXÈÉ:dL×^Ü妌xÞ~ÙçùR¼d:{T>Qé–Ñ¡ˆü•½>¾Uy¥ùDC»_ÿp ªî¤sÝ ¹ççΘèùçw{ði/THÔ:yŠ”™žO¼ÊË%5Ï ÍñeÞÙ< ŠuùdÆ^ ÖÔLJ<°ÚXã§«?ÛK'ʽz¥÷¤ÉL±üQ—¿‰ñ…yZꙺÈ{óɺ¿÷Ìæ„RKóº9Qþâ½7«O½‡ääÓ: ;ÌØ ³†=š"Nж3>‘±ãͽ‡W›(+¸_= ð Ï9z¶j±„¬üVê9î.òjŸý^ècU÷ÄVAwäÆ:Í7ŸO‚’.Œ~ê0–"rëí<9~áÈÖü~÷îüQæ°ÃþíwÖP„ª’ÝdÀŸ"ÊY Ùk>çE2”Äš‘X^…ÕÞݹq3ÍÚ•Ò¼•FRù)Mq7Þ®+ÓÎ7ùY×vXŠïšîŸÚò´1Ù=ýÜxvß?SPéˆP…2Æ´QïwþA÷øå½õ?Cám¿žV7£‘uÈÿýãb]äŸQD–smùÀ£4‰ãìÑE÷;Á÷ÆøÅŸ|Þèýk±pùýýGÖS„ŠÕ'/ÄèêNM~©nÊÒy¦Š¥~¨FBƒ¾SeŽæL¨QË[Øg.yÓÓvDNÚ©ä¶võ|óÜuÚcá,ä˜ôê3ÄVJzž6Qª™µÂFr ¥¹Tç…A}ǧš;iÑ,–=×gf´9EäþÜu?)ÄúKíîÚÄ[õªë*hŠ\«ªCº6'ò­Í”WCÔ­¾µqßæ#±.Ðd‘~.¸-öìRôîoDvdÏ£õì;È”æ#ë–¦Ä]}Èo´Ãy¶GÖh=g‹íªªâµœ¯Hfç­8ò­‰N£«çQfUgk¹SqàmY¡4K ¥y¸üñ*7 l(BÂÍø½v»ú@mŸ…Vn·N¡ÜŸázÖý€z-ƒÅ¿û›7'2¬I±< Ù¯¥ö ENT®¾}g”ÝÓS×ÝJÆ ¹Í šÊœ´Oâ}Üõm7µ•µPkÜáðúÃbý ï’ì–ß@„éûj\ aPa‡ #ö"{è¾Ë{!g½þ’…¥™Ë»X ¹; ˜ÙéÞ_YóQKýŠNÍ´ w2QYòÙ?A™GXLæ×©/ëU¸Ö–e/®Ø5’ß¿N¸¹ÀÔ6PlŸ 5;dD“{#hºØYCå!—‘_vv÷ÑÝ©üNdÇŒRË`¨Rdüã e"â<5~ºPþDÈ[²}Ç”ÛÐÐ`bµy?‰ë‹uÒoBü)µý ¦¢Y9ÓxinV:”v ÓªL!šœE Ë¡²7l]´Ðƒ¦Hs拘ÿæDÎÎÁ¶ çZÓëÿñ,rÃÔ‚ ©KCOzüA®‚…VÍa¨*'Ñ,‘Ó‰ ˆÙR¡ˆsò©ï)”]|› ÿ½ô:)²Ž¾ì\”†rZIòõEG)Rñäyˆ^Õ΀\^‰â„fCÞ˜á“ühÆ_ŽØðþÃDd«Ž0•»Žò®«ì縌£þ‰ÁóÕÃßž 7Ž#ûå¡ÌY›AôLš¯ÆBIà‰"X•„ê_T‚ÂI^?Ê SdoZG\I5§ó¨YòãðŒŠ‰ðM%z²YGõzZ‰ªUNï߃P`¢!“Æv¢õ?n¸xws„Y÷Kf½}m¤dFø¾æ„Ú.A_ï̾5ﺋ5æj(JøÆ‹xžD³šÜ6÷„þ‹ÈxJ.äì‘æ—^­¯Êa9@Þ…ó¥?µ¡!ù¬“û•Óº~þJÙ•]IÏ)òÏ[[EkŒ@ÞÓÃkŒ7½ É½3úìPÎw½<7dŠ;EúºWm¼»™_Ú‰wÄ\K—4šrŒ÷èwžH“ë)Í7m$\ ¨›*¹`CHãa­eå¿üÂZ=Ð,û,çºa'ÏWTïòfÔº È8}v®³¯ Tmd$uuÖ¤ˆJ½ 9úçá^Ÿ†¡3r@½á5ãW¢=Èßõý~öŠJšT=qLiý C(›&—™‘_ó®Lr‚"²×Yye&Ç›ú†TýUsðÉÑ ^N­‹ÌƒÒ:‚ŠÓUw³Ÿì@r‡•¢ ×A~ÔÕ\Q>ží·¹+²gÝ9¾¸ÿèäZštvR£æb«èí‰(“:Üž(ÓuK™S6NpÚ§AÑžWºÝp¥ó["yý¼IÅ­!£‹³ïú‘}yX}ï[iÊ$V˜˜x&#ùsÿ€_9È<Ö?÷ú…'ÁOKáÖaël×­|³:Ê+dŸÉ4k’ÍOX^ çr¶Iò0àÉž¬Ýê"ç¡™èê 7Õ^+©¼ïŸÝWžˆ‹¡™@jýjS§GÇh@~WÓ gvCVªÔ¯n)ñ‹´àç^V{;¸]áÐ×ÅžG‘§Ýcþ÷äÍ¡º~UŇe×!2Äï°ÊfšU«ìº%wEîã®FòËOCÕáz£¾ §BCG÷¹òGæ@ɵV5íé>@ãÄk}ŠT9Êñvu”Ë×Úy&Ü€ÌÎ WhODCP©ÎÛˆ„®Ì礞A4eN¼;g±Æ„V\wýÇ|T~½þ}†ð=ÔÇ“åcZP£ìw\o°=ETÿáÙÜÅlŠð¸^YgÌÑÈ8¾Š9q‰{äð.aŸ‹lK‘ˆ‰½Pº¾€"ÔŽ¼*^¸®È»3U<±W!c¯d?ƒ$r4—Ä¢ÌUÿ‘ªñEˆ¾÷zxXL2¦ÎØÂ¾âJS®Ëc†Ú í Tzüõ†ã‘U=ûÙBß©z3”}ŸP3¨æTÿQ(ë‘u‡L ͤÅÌ}½ßÒ¬!T.,¿ß,™¯ý ®7ê]¡Oú‹7˜4”þ¢ÆÏ:u;^¦MµCbð‘êê»þÈC©¾ÛHˆáÁÇyBšQs~˜öþ£É‰ñ’΋óÂüí[;ˆ#Åǹ_È^ÚÐç¥;Ò¸”/R½¹w´Ôe¦ošÁ¬‚¤Co—°^ÑÔXÛKãœQ‘?ãÃkÏX”»d!³Áù;]¿ÂÖYb(Eî\`å¿jÍø>’ü?ÝD˜/™•î1:‘ ÷P0ÍáÍ`nˆ•„­P ˜°ïȹà­i?Xf&R¥õKÈü3j§æ<r¶¦/ë¦ ¯î[.®,@^ÎO2qˆ"V½°ËRH·M5E o¬wTŒžä~ºêý‚ï¼O AùóÊų»¡Œn¿]Ggÿ@A²lmEˆé›§(5P‚K§ ¦ˆ‚ûŽjwUËQ~™Ýà[3ÞQÑmÒ,ä¡ê³ûÈæ¢Rð¡½~Ý!M’mB³1ÿÎãvéÝ]¬J";ñ’Í,-[(™pùÝvþh(3 ÕÈ¥(cw@ü å¨}ަ‡” <]_täø[ºÎµa–•øF½DvÉèËç^Câ{dÖøƒ?áÍ,Ç"±†KóJ?9¿‚¢9=Å[—E”) Rhr5k¬§OCæÑ¤õz“wÑùØé~¥:—{OEÖrÒa?¶9ç$utÙÐò#•לt¾tsV ~_º½™&slxÖ1æ”ÑÓ÷ºæµ•MnÄߚ؟&ÿó²eZ?‘gT<÷‡ •O„L2=jØg”M“ÚoÙ} 4<ï¿ Ù`³fó×ô±pgnÏYz·Jàžÿ O³šì^æ²!L¿ø:Oð¤Håë#q§̽±½¨wb‰þây#ÝkWæ¯õ?Vy»—žõC"WnNA÷Px%·_éÀ¨Ö]8ÿN ¹¶!]Ñ÷±\ÛG¹ç%¹¬] ƾ˜É£M ÿlƒofŸ}¨Ô1æÛõp Mê¸ìh'SpÏù³á0'‘"òŸNNîÚ'•T$yzAX¾îB£ÅP6)—Lƒ:Ï5o &:@åÉÈ-_}m¡¸Tê· h; ·j»°hŠÞ­6Ilß¼ ‘èJ.Y³Þ¥ß\äýØg»u C:½9 žÿ‹¾ô¿Þkzóƒq »¬Œ ÏþŒŒÇbsø…äöÖ:¢2#"w'¼’•MεÚ5Hl¯êÙ6¨öDž9ñJqÍ=äNº\©µ>¹Ý¢jåm}hRu„!¹`Ñû‡ dU¡ÜÕ’ÕÏg5Õë5Ö•BÕ¢Õƒ§ëš³)«jÒõÏ 6ˆÌ­ù ¾ŽŒÝ·Cìʋ巘@ý©ž¾‡m¢ˆ²f…Þ½’WX’zèÔXšœ³Òz•ǽ¯ÞË€Êq¿ç±t¡^,ÅN–Ë@¤Ú±7ìï4"7\ɦùžÓeÓkÅÉðIRn*€ÒAî£3”~‚ðx¢Šé¦®4­Þ¶nÈO+jïPÉe™·Ø²@ÆXI¢,¤¯z ¬Y ÚlgP¿§c V‰µ\»ûPçL&€voNäÿQר)ŸµÓÖ}ªëƒL3­·.…·A$\®x <°kîIë bÄ–ãHò6ÌņL¿ý©î+¡|¯ÏÄÒðKP·çâ—ùŸ0“æå7JRÖ¬õp?$Yœ»ce%.ûí¸in‘—qÒš­¹ä_„ês —ûÙ˜@ñ”)+4Ž"GÒ^d¼aKüúP×É$®Û ÈT±I4Xê4N“ $4Cø¤Cø7Íuç?Ë CQ^[×ì誨þ,­ClôÓ@‡LHÖDm¤È¢bD)½å‘UÒñ§‰ŒM¦=¬‚¡n!xß+ïF‘žwÌ∵§âÏkpzúÞhP~‘¨eO³x×ðe“gÓy¶a'ßYCüê·©t¯PD™ã’xMåsKOnŠÛ?îvwœ,†½½ž\*íµ‰f-ϯÜxgG¸ùÅêMýûá͉¼{lÆ[؃0€%¾“/èu^¡zˆ4 šû‰‘÷úèØô eÈ÷׆w‡r§kbÃ5…ª[€U‰/¼¯»õÝÎþZžŠŠ Ç× ÎDÞýDÕ®S›ª%܇"ÊÔHÙÙý=²v[÷q~ý!ì\‘Êìj܆"c©Ñ ÎçÑe*À®ð¼Ehª»‘1xê–O‹„â}Ï ×ÿPæP–iDÕÅPyiÍ ÂýJ\ž½¨‰?*oþx6ªWdMÉZ„üØ{#…{S„i}òã.­˜·£ÒH3gïyš¹÷ò½·ßÕœõspžž)êöt(_O —™5éƒÑ–ÌôEb='êÅQª/P¾¯$qg · ƒRhf”ÿH9;}8rOëW«Aî˜QIѽ¾CõÖŠ:‡4]‘;Yñ"²2•'Z­é†r1÷óÏ¿,¥Îd{Žwo¡r¹×8¹ó|”ó.ãvßýù/n…!QÖóS¹–×Z˜~œ3eEï>`wuò¸c#iVÔø8!Ï %åqû¡ÜJâüWœ„oo/;½;JõXW>Ž<åÕ{"ì½lhV˜Ÿã€Ü¨K[Õ6E9Y9¯Ï‘Ù£–‘¾_±9ÿ:¾{Ž`57¬ÉÙ¸Ó`¦Ë(ý0¶Oì$*?œ&Sª¯ÓŸ3ó–ÑgÊVˆ~Y˜à¥Ø DŽüäž&Èéhïé÷ùéxS#‘ð4ݤö+Œ"Ü7>«¸îoDÅ1~dÇŠP$K+("ߥǾ3ìirÉò”ç¯ÝqÜ"¥Õ†4¹Ó6ÆùÅP„¤cå{רI±Q”€,ñ§Ÿÿ°'|xÔãj·= L¨»®obSÜ[iÿµ É(ðV¨Xc ƒÌOGrF upÔX~òº=ÿÎ;: Þ¬XðàéÁdëe6|ÝM×-òQš7ÏÜG¶_X‚?Óû–Ü ÂI.væÿ@]Î'“¯G‹[ä[f›9pœÍ÷šòn ²ºHü-ÈÛ5Å{ÔëpTZ_‡2×äì'³PûlJÀ×?¡È$V>w0€"}½ìc³Íú G ûJòg)"ƒ³iiíÓ$Ñ#oÈO¨Ÿ@¯yÓnø?<æÖ‚”êcAù#âžYjøzë߈²wG¼Ï²‰ë’ÄGˆrë÷î–2äÈ0NgäL•äMBõ΀² P¸A`¾@é9Edtž(×ëK”ÞðÎô)™çw^9¯´œ"äù{R¦³ ùF‹ºçéR„`ß«ÂEÈ}7æ½Ö–®È9³ðÒÇc-êŒ(Rõ’ž(ЏLe¾Iì\”Õ%ÕÐÙÈÜþ1ØD¾ýÛÈÑ7÷éï}àñÁXÀSüuëͽN¼„‘Púw?dœøðÚ3&ù2ÒñVYÝÛWgPd¤Þ}øÉ”¦`“zLÉò}PnøcØš^j4ýûˆ2M8èe؜ұüpˆpT÷Mwí„ÌÎ ý³6Ae·n»¥`šbi4t;T ïзt»$îµôËqÄ7æ”°$õÛûlëïÒ?(--&A@4öõó;ºÒlúµ(Ö¾#ÓS:ÒÜ._ó>øÆ)¨„á«>_M³ä­í ÏBE$\>›ïàrE¯#Fp–¶ Õo‰Iš[ï@Cšÿ2Þ”Ž4E¿Äfg@5åW†Èns³¯§¢ûû'/öû•‹Ìåd¹© ÊMþSx’]ESÞïí½C?r †Ó“¬D„ɰÛ!¿ãcí꽨ÀÈ3›/Wø7¯ ý·Ô)SD¦î]Ë{;§#£X™¬°¢Hç÷±{FÛ:~ÉŒÓÍú“L³y>\#Qé몀u;}A$ýpfwT&êÖY;¬¢5âÍ{Ë:=šu>dYª2²].ž¾º‚"Ô‘m’œ6CåÛuï6 R±4¾ÒH¨V"ÛQŽ@™é]'t|ĆŸû~Þ}Ñ/’"ÊÄÏ­¶ŒÿF‘Î',Ë»ÿé¦ò£¯Æp÷Ѥò\ø7‚“ôŽB©¼}·©ó,‘1 ÿ˜#óÊ·/~aNá¢oH•À{|ép@'hêFäØûžãN‘^/¡uq¢+¼PѰŽ9kI ýµìÑÔ%_î€óÌãg<´iŠF¥°“_Ïa±û»‰‚†“÷· ¿×‚i_¥}fßðê0;nú .š4žfƒÏÙ¯c`á?YïßpƯú0rï#QüK0Z;yϰ»8ï@^ÙnTä­8k‡Ÿ§]ª{: Ûiú4"ñúÉ ™«'SJ³|áȾ'8¡œ©òâÀË6¡rϼ§;t·BYضéë«Åú‘€Ë𠉩ºš¼A.ý Ó)ÒãÚØªÕ¬™/'s7Õ%ò,ßn®‹¼…Û»ÔÍ€‡N'“R^ó `Dƃ¤»õQñõ…#‡1!í(çô¯=6ðEuóëQá’ößÍ/hrt%†8ÊßöxèÄùP™[08ÓÂeê=¬“LêîÌy6¢. „lI¼òä¾'NÔOhAÑF^šCÔ‹ÊÝ*6?C¾ã®“û]ÍAtÔIIg©ʪ<š[L,E™›.çÍ’wB©Ùn@¿E!EŽpMÖu£CáóÞ `ý€ŠK”°Ã ²­€:EH¾«×Yl7åI¾´s}î±o™Î}ÿ Jæù ¾¬ ù–^“t ‹iVáªÝȤˆ|ËÁ‹…=Õ(‚0Ôñëw]9dMRPɯÜÄÄò9z ¶AnÔù² ¨x=M¾€,Û×dÇ‘£¤ur4&‰ ´EÈh¸ÁôY“ Ñ}~³bw!·Ï{rペ'u—>®£ÙX'ˆÌ·Ò<˜’7œzØY»ð¯zÏn’|ç&»yl/2€OYÓ`\¤ço(jìûF±®›NœŒùp¨úç¢ÍÖ|ø2KŸFÖ³µõ`¶D²—w-Ô| }L‰ÌîžóÂXCQ!%ôú£;ѨøFZÿÃÖ“èóMõ“Ò:Bšt¼nðËî}®{¡\VV™ÂJdÊ“Šòc†„ë«GÒT–—5;C¾¤Ÿ‰-ÑyuÛç¿ò¬½ Þ?Ã×,›K÷UiÞí…Øz_~þU/žr~¹/´nmÞ3j¢69öˆAùóBEŠPùH·ûÕÉãé~ŸDÆÃ÷bAøYÜêgý׺ÒT(´«(ÏœJ“ßãÙe}×Uû÷ìBÿ—D•Ö4äÍ’öŸ¢È{‹Ü€)ÂÛ/7Dy•BEÇÝ1 £Aº¥†”@™òíe3—CUÙûðë:âyhqÏk†œRóŽX[Ùч&; 'ù®£%Ez>œÖs=Í^‘·o’)Èá.³óLäBåt©¼f$Ù¾KD÷§|tž ™Ù¾Í"ÒèþIUŸmOÇuª†ºÓî3[ÒõÍ¢„õg?!Û1aïŸítßâF¢¬r÷2ÓïN4‰Ý3~*gEÖØ8Àõ ŒÐ¸•ò™Î®[mêßYý|§¯ûÂmP¥sœÜ¨µ“l¯³±9!íËËN?p×;¯yâÜk8¤õ!äis"#WR—Ñœt}$E7­øŠžÂÍP~NÅí­×L”¿=ý„ÉwŠc=•ÌôF¥ISÏÏr£–Ë*ÿÿ>¿¾W–¿kªãò–öÏi$rï“í6€×Ó¯}ôoÝ£ÇïN²ò‡Í–:(·|ÔHùíÇÀÜtú’w?Ьï CÎb}DûÆâÐÚbøýjf/>‹¬÷Ò>: g7…)w¡ºÿä„ jlÙ»e¸BÍ,2=cs“šØ<Á="r^¾ì=Ý¯ŠªS‘}¸juÉšTØIvGš‹ Ô%`ÅúµqÃ6‹ÏƒPöÕú®Fò+àûãm‹FO¢ˆ2eìOZB÷Q H4ÖÙ×ÛŸÈû#‹ìŽoIÉ€LíÇé—ljíY-Û}нh.ö!ÆoÌ Yžn÷x're¥}ÅI÷¯NüöÇ~ï;ä¯8Qçlü5wÄnI“÷uSóÛTŠ îŸ{ý"ÍÆü1Tæs7úv J.Ø÷Ú¡495’ÄI±ÞG¦7rhr–’…Z·àû²ñsÏ¥ˆÓÖw©û„<†ÄNiò›Œ—BšÍòä¡*Y’ׂßb.vä:¢‹9+Þïчú!wgèRDÞ"±öÖ©¸™ŸOs¼ñ•Kûó4ËW ód¢Ô¯¯ã‰ì;Õ.ƒ=•èü€ÆþCTüD»¦o´d: º¾;ÁÈKÿ7•·¥_Ý u¿œ¯?‹Ë—:—Û}c;£`üº±‘"K8ÐéE÷M=•‘«D¦gÒ~2Ö“tóT$&ŒØ/’K£©Ä]’ì60yed»@%(×Vä™ Þ}†ØŽ8Ťø[ 7KìÕ¦<Óã ¿¬•>R„pAç8¯%W¡àèÂ…±òáÙöÁá ʆ¦¾QùqòóÒ” FJFz½Æ’Õ_6é…ž·¬ŸñÕc‡Y¨û6äÞ뜽oÞ„æ¤úËBÎ¥`Õ¾÷Ë‘ˆÄ?‘˜6@qùäXäÌ]Ìz`² ¼$mOõ‘¸üD{†ñCšÌÿisÒ}‰.µïo¦¤ÐdÌ­ZleÜÞ‘í{«¾Ñl´ëhû®Ñ?ܲ_Ô 2Òf;¼w¦:2e·i‹EEø™îpw¤ÑYš¥C|×Ì™P•Qdš‘5rÖæèß‹Gþ`Á›Ëb¿qÈz·r¡x¨4H±¤dÂ穽AèVäóÓDj½, 4ù§Ó#Vh9Bõ%kÎ&{òeŠGl¯C{zåý‘%d¯“lw[ªÅÊÛÊOª¿ EÈÞ]ÜíØf½æ}†‘БÔ@ÊÛÌu‡®èÃÎ/¯Æ-¢ò9­üOi>h“\ˆôÏ¡:^ç¥×5Éiçô8õÓwQÐÐy¬É ~Èêà`ÀŒBV¶þ´åÏÓ›‡¨¾¹e‹„ËQ2ÀÝ‚TÝ}ÃiÞ±ßÞ-é¿óŽBKN½ö…\ n»£EfòCöIýØ×¦ ïmá}•üH/0áAçé|w@:®)6ÙËñè×);»û†kRDÂm…ÝÚÅOþEõJÎO$àE–¤9U‘V’ü ˆ¹ºe©û{ˆ^Yhk¯"²¦t%=¸ábmß­›Œ,i _¿ÕJ]t„{#–T~†zi¼}vñÉåíÇm¬Ï>\¶¹š9[ã´Jz9A½ÙðQlǽ1ì úk©zYºn6ˆ<C· ù^’ËÍ™ ½43nIúc ãv†nƒš§ãäÕ¡fÌÙùÎ¯Ž‘yîU…Éå÷­ ùå”ÔÑœj¤y¤ÜœÈ 9ëpœò4Ù×çßÅöÏPßà YáÈŽ¸ùâ]øÜò¥ö¦õùCæ5nr>h|—ê'…Ì8³Þ>ÜÔùTÿ^d ”ø¯›Ø׫ñ<Ñí#Ýwõ¹²üÃáå(ó¥O©«âpH/í6þO.Ô8Fö›¹ºEXHò7àÕœ7ŸÇ8Ä#÷Ùì÷R$ej= |%ëÉ1-,Ú8¢S߃£ãY÷ôŒU&rY=ú?~E“?Gáç„XWºÏmõDZ>Ñ%GÄ¿_2ÎÍù×üê\®Žd_„gÇŽoî‘÷ꃎ2.½»ÇÖ6ñœw€ÑlƒçÝ›ô`ÐÞ˜Óà[3û¸‹â¨ÝÒ˜§(eK¿¦ÁX2ш"-GÿÆï³g§<½³š"²ìî’Á4‰ÈqS;? ¢É1 ¿5Õ æ†Ùl|³–fü¾Ÿ~0§ÒÌ™/Wh8ûåEþ°µ/ü˜r™6Â()‰c»õ' G6é3Añ߆œ[J_cß*džð›±D6‹ªGÖª¬}×Þž§óÎdŸKëß µ¤;(ë*Ed‰ Æí¾>V[ô)ÒuÙõa{‚Þ+Ð,ͺ@Ž‘Y0&éøÍíP3L¶ä^È šÉdw‘Q;)"A†Qs½Ë’¼ääU»-ßRÜ©nšîØ×²/›¿üÍ„ÉÈçIã3„è/Ï;Y 7ViŽiuHÔÍî´˜—H±)?@lçÜ“&Õ”ùÍŸtüÓätd%ÿP‘ú¥dbE”®ª­sdìA–¯Ä®hêÛpéŠLÂ-¨(‘$2¢€ýè»ØÂD¦¯%†îÊk™÷Â]k›j„â0•‰Sî£Òz2ÍÀ"Ý_˜=… #Èò›ñ(¹´ûä¢D/ZÿfÉJä9T«;¥mÿD÷‰¡Xêjö.g—°Åß—=þnXÁ‚8šÜˆþvçgu‚|ë·×z­ì ’4vŠÈÜ„ój_· ëgµsm¹$Oî|lÕsdíNrsÕ0ƒýõÊçÏü•e® û>ªû §åvAž³HmGé7”¹ä•5i.r; ü¸ê1@ø~‡ŸÞP×_Ò¿fÁ¥™‹ý,½ ô(y|—¼«í6jÿiŠtKsK=ј(Š êD6ô‚‚¹#§ÖëµË~]d–ŽÄëÀ¾¬•¼d®"=œ¨¾h4ûÇ à&é6°E¹EÓDÊ*-ØØß >]ðëÄéÏ‚‚[7û0BÙæç×3—ކéyY¾Ç@òx5Æ!ŽxþobBYe¢Lõý€:±ìá`ú7"«ÿg‡MOŸÒäúur\ú±,í¾çCïº9#•ªh’sãHñ¡{§•ìMø5…Þê©J¹5=Ä´y!±Áõ¹ÇjF.ëwÁ[ŒÔÊ>Sç'P¤×C´ÔÿЂÂÊÊøÕó8ð'lJç¨#×éúø÷—*S:î 6ç«·¬sö%uý‚X5‹Ÿ}Ÿ@õý®ÙrFAå3éùG«G®¹pòìÊl¶Û€c—7|*ª©†SŸ¿ÝCÓ[°¸÷a—û&Î((’œÛ€Œ Ó”g#×PÚ‡–bcH…w×¶|–„Œk’~T¿~ª.³yßP”í£ýzy‰D»mVöÂ¥HõMhÊûPÊ{\4x;E±œ'~ùÝ‚2…,ÂO#g|Ü´nÎ,T~<Úhj–6MÞ‡“ü©Ásøñã3–ë¢\®$Ï™fc|™ÊÒ:¼F§ÖÉê ¿Qî»ô<"ŠT?,Ö¼«Ïõÿ@™â$?“"}šy{kg¯JXM3Ìð}ô¨ $ä_bl’7¸ˆ\E©üj$•?¢MRù. &Ó‘wR}"[èWGJë¹âÙ6dçýƒ"d¿ýîÞ™P—ôâü/*KüÌpYXÁëPLYd÷£Þ‘¨ ÕShRùú1Òs@téôŽë9gZ0êWcÞ¥¼ØÌIÌŸ®E[β;Ò¬ŸI›³þŸl&æ £oï1âBމc_Þù (]YÉܽŠ…Õ®ófÃEéþNcˆìƒtLqDf%éNØHDV²…6r“Åvæµ#‚¬¥ÁGzþ=ŽL~©á•@‘ŽQdɯÖIšØ‡"|””AôÄN’~Ö­%„¤/6ü.ßNì•™=f­§Ï5d¾!ÝÁ¦ðñSØFÁ¤KQ¥Ûþ9>·¡â«ãP·oû r ‡< ®³m$ˆüf“od>¢µ}–1”}›U]gOÞÝ[Ö}Íì1K®Ø¬ê.¡Q# .IÜ S[0_sn1a&„ã;|:0-Ž ¬ûkƒš û]×IŽ{™I*Þm|ŒFý¤Nþmô}v:ø6žÇÔŒ(¿õÇúž¿Q„ˆS‹¬v¦¥ ÃÑ/Ãa¿ }b#ÁŸLÙû¥Ir#ÍtY(~êÔq}Wˆ\”ø:×l·øú¯’pšüתÎYBšœ7Û ¶2h2,:xËÔ¨…þBõ9Ÿ‘Wyø€Ô¤HãýDù7²G\ìÅëvˆ®lŒ+2/‘.7@Ù~µËk¨35Ø®äy}Ò³&n¼œ>„‡™.ê£I³¾³6Ù¸ü‡“|JßAVÖkoîù¼¿çûKÏ¥ÿŸ¸[Ú_–bÖƾŽõ’ÄŠÈy&ɯC“ô^¶Ü{;s¦qõŠ üýä$áN&Í*7»Ï<”!ÔòÍÏ}EÎÚ9n8ÚÔ9mt¿éÇ›Øð•(¢‚½yç§G"󢤯9*Ïjp8;þ*Ô=Ô²ä92Ö KùäÖ™¦rº´>£‘ðäNQZseF~¹·Céci>³›¤¿(䕞‡D1ÄFr€ l»î‹vä¬XºQù– ¤÷üÌ`øÕ†™7Œ× ™¿y°K–î+¨µ¾˜›æá@‘êcEweɃ ("»³Æ}eÛ>¡–lÃq¼†ŽËq7J·@®4š&‡µuú9Ÿ™!¦±l­ªd^B¬ãQµòðŒŽ æ"ßVr>c“ž!­óEžgá®I @±Å9?=%zí‡ýJ–U~;"%éyS¢ ±?‘·‰m²÷l‰ƒêÞd™Ù\Hšfà5Øv!uî\Ï>x¸¦§ò:«UUCÙ±‘»†èLoÊû'»³Ú%Ó}ž)f{\è~¨S0͆¬¼'ìþây^E6 ¾‰#M>õµ¹²d4qõä¦õ–T±k^5æ¿uO'@œÄÍ,¶’홇AEb?˜Q7©sÇm8æ,_¿7E.—Æ{‰¼¹§g=£ý¨øœtoõƒ×êC´P„7¹û¸ï~dÒl¬ÏïóµdæE¸¾TÖõü˜žH$uð7¹Œüîæ D£BWi¿5ŠÌ¹ÒøwãyÞ4©>]T_i‘§^¯¼ƒ êA€³ÕÀPöýAYøVUŠÈ6yÒc®[oHŽ•ÌŠÈßy\‹›ÙTï°ç•÷`c†‰ÍÞdäELºrq M¹ž½õ?[<§Éí*é+ÞœPQ0Àõ³o@s"ß3œ´\i{™bíµkNäÉOÉ|E÷Sàæœs:™”Ú‚Ts½…G—U½â –<™ ¾$²v›ù?¾‰ÿ/ÿçþ_¯ýÛÿÿ×ß þòþæÏ·åµmù{­ýÿÿëùÿ5nÿ¯ÿ_æÿ¸¶öŽц±iÏýû×g`þãùÖŽ_{îukîñ9ÞÖïÖÜöÜ+¢óöÿõâóù—÷ÿ×yÇüÇxÿëm¼ÿkˆvÌ™öÞw¢•ãF´a̘íWm½.¢òºµ÷ÙŠµEü¬w¢Ïÿcý·wÍÿaìZûz¢ ïû×mí5·EÖ1[9—‰Vìÿu.ükj­,#Ú ãÿ—\%Ú9/ˆVÈ¢ó…hç¾ÎlÇÜ'ÚðÍl¥,ÿ/û+³•û!ó?è¤í½¿­ý ­ÑÓ‰ÿ°µE–íUD+×YktäÖŽ ц}©­ò•h¥œ`¶AÇjžÝ–yËlã=þ—Œ'Ú±¿·gOn­,'Ú¸žÛc·F>¶æwµG†¶UÖý¿Ç?&Ä•$ϳòymêÁHé+XÔ+˜?à®Yen³…<“A$}ýÎæU›,·7¾œßø$±{ýH›~4²ñ{ÃÆ5£šÞ¾yËZê[Ìm¨°·oÙE½U`¾qÇvKk½f\`½Åv(õäÉ?b/þ§¡AXÿ—ë±Xe³jèkñ[¤×Âý¦°ùÂgss/data/ColoCan.rda0000644000175100001440000001637712545250042014020 0ustar hornikusers‹í[gT˶î!#JP’1 »eF@A°‰¦f`‘ " "ŠDAP ŠŠ¨Gí6 fÌ9 * £˜#¯ðô žsß]÷½?÷ÇY²Ö¦»jWíÚûÛ_UO¯ÕÛ•å9¹Ÿg? ä0i)&%ne¤Ð?&ƒ)¢«Æt[ž¶Õ{ }z®2½¦½Æ8Úöz¼"½¾6}Jc¨BãÖ;n4í×@z­^LÇÓŒ£cëÅd Ý'Ö ¢Ç*ÓóÕ~ɥџ¶½ë8Ðãç£v-­—¡ñCǤK¯=ø' ûpV£ýêåNÇ LÇ:¶!‡dý/¹ïGÛR¡ÇIÓ±öûIi [LûîHû/Cã£Bsoà/Ü£yŽw`R±1¶é¢¼ýŠaÈm 9Ã\¼0ìW ›ŒÚ3‘Ÿˆ³ÓÂ1Ì a6ÁÃæú`ØÃL ›³ cø¶ : 0lÂÃà¢èddc†Y ûh ÔbŒÅˆŸÁ×1Ìæ<†Œa>!VºÃì¹h›lE)…ÒÖ„a3Ü0Ì<Ãî#ý„]ÖRDK5L:³õÝC>†¢ˆó09ÏèÙ”ˆaviö Å7ÛÃV¦¢­`‡ì#Lû]FÛõ!ЖCü3F{GKch¡}o†ø¬¸3{$ºGq¶"¨”0Æ»Uˆ"Hæ#\G¾@[rŠ?]‘Oj÷0ƘÕ6|J™ưæ û7(dÛfJïn óGë››!,¼Ñíç‰f‰úl˜ÔäOÆs„7òW» mIoãH”ç5v¼w.²ÉDyt ÍC9÷nG6ÐxgÄ¡7¾wŒˆ|6E>f"¬ QÌcQ|£RPN¯bØÄï™×1F0ÊqèZd qõ\†ù"v£¼ÍA9wÙ6EóQŽÐšˆÛmèÌs²Ax_Csæ`Ò7P.·¸ðhŠ+MÅ4í1ˆFL HÛh]?W‹öhÃönþe¹ÕGžj:¢ÐÃŽi)/¡ëžó\å> ²R·Ò×VQÝæ=ã÷C×ÊÒÔåÏ£øÓ®5‘y6a»tùìû¦v åkÉ[•ðôÓ Šô?f¨"¦!cÁ0oèðÞ£“üLDYUº[Æô€h8¯A¦|7Ò-K×¹ò¼ž«sñDëñ•±&YÐ¥›^a/¿D›jò£Q^ °ö¡o/–mœ_z^ DyßÚÝö0áU®¶^Yš1âTÉ.÷„NiÝh2RD£ ê÷ßFýÕ—7¨=ÑDF<¡¬¢ÂogöÉ@gDýøÅå Zj—6x=]Këù›n·ƒ(V½ä‡~ço~ÿæ÷?™ß’sÜÛE®¼Ð ouÆ_:öršf_r\èlÿAn‹F^·kU ¾«ïýÇuÛ-®;õ¬ËþÅñ°¾¾fÈÈCú¢µnõsj>ˆB²'8CȈð!¬­„ ÛÍAàÕ9î°gm"_L¾ç°b¶?ÊŸ¸tâ©1/ÁÍí£9­¡vRE“ÎÊXðгÝòÍì$TR[Ýä|A¶Þé„©ˆ¯; í½ë2÷Á<÷JÙ‰{OÙÁËGæÉ‡#õnÆÔ\ƒÜBî½nØÂ(_e1f×¾py-—™ÂUÌ#òOhåÊœž¼ø-¢Ö+«Aêý½ÎæùÁÊ,ëxüd;ÔœxWu×E Ö|Ú¼Pî3,Mˆ=£<ŸC»˜K§ƒÿ®TÃëÉ/!£ÉÉ`ƒ© $”ø_šyô#$‚ßìJÈùž;nâhX¶¹ñóÛXô¹…7>!.›/OµÔއú×FU ßjPw¶àépÀ„ šsßÀ%Ñ-uªÑP®X·¼ìÕÆ­’‚â“I£?ÛêAñó§†CSa…WäÉš€‡`Ÿíµ Õn:,vn¯CÆm;¼×ò‚¬DT¾‹›}0bžX§µ5Æ‚Š-{`Ãç#Ï®Õz@FíÄ×gO7‚KAæmÝäfH¢kYo9+æOÉÎkƒ¤çÇuªôîAqÿ&~ý1_ðï\þñ€NÀU6þÑË„ïrOu‡£nûôö‡¯à<ðT[ +tΈ¬ùÁ²ƒƒmÊÇ€/?ñùáìî8/óR l¿=âMw´<ø~a0&ìÂóCÎÖmžîG„‡å¥nïÛ))£wñeg•gYt†ÛÃ<¨z9ÃT¶l1„mÓÔð ­0Bï—CJj–Càe *7šŸ›¤•Ã6÷äŸïºt™ˆã$x‰>H€Ã"níʦk¿ùý›ßÿd~KÎñ¢Qwcð‰†°§!ðÝPYn™ÿĶd¥½ÓSÍõ®—ø´ÖBv…Ì®9µõf3ò¿,_¹¤vUHí?Ð6 J’«ž5i›CúœY™oš=a÷tþñç¥1¥}ÃôL6ä5Ï:fk£ éÏ Ù‘ §“yäÙÇÇuŽ]ÑcEºi{/̘Çîž_0ô( ;¢ïk«ï´wSŸX°q´B–ñ«ÑæøÉ'î¼$GToúà%ØYÇBmä×õÎ+¢DØêÚ¶|t9¬5 btŒ„òvÅG%^Aaž:øâžJX³óe°ßcÈwÒŸðô ¤w¸Â¶Aº‘E\ []u2d”þȦέ­†l‹pÆåm§aCá»/šOÀÆ!½ºÃ¿GÚ¼(…|‹±Óáä˜ëH”»53š¶dCIÌ=Ï× áÀ—G^¸­+b1Æ1 Û^¹ ߯ù5µZöÃ`÷B'ߤNؾpÐÐjf$Œ§ž—…Ò7IDVTç{8+}…Ó¾¾în‚µóÛ·¾ÅP˜ßž2ÄM öÔ«ÔÞJQ…ÄãŠÆ;5ÎÁz½ätÈä\¿øÑB2¦ØS!gɘœ(ªgµ4NÜv¶™w«=p| «;ìrAo5dÖ»”{òãï¨(Ý ÙÌ.×#FAV÷Ë3'ÈNxR]·s Tï½óÁ{·>¤ß™½7¯èä9Z07»&A¶›­õƒ»P ç{j@ÃFØøé[XÐüÈ*^¬>T÷9¤³í¡}T§1yóá³Ï S*>qg=¤JÚÑf…'jý+†ÀÚì›÷Aé“—ó¤u—C~9S†8é +åÍZžîê†ÌÅ+ÂÁ÷ õ|ìÅW‡Z`‹c©Y눣©9§þâÍÛ°óÔ —b¶dì}Üh36ê7¿óûŸÌoñ9޳‡$\×^гÖV˓ϞàÌ¢™'EU18Ëi5|9~ gYÆÏÂq–\úc¹¯8³P©éÀâ!8ËáØ’ÙŒ³*¹Ât¶&ÎôþºPZÕgùó'·&á̼ü#›Zq–ìŒÈyÝ8óèÞéKæÃY1ID¯Î÷û·¡83V-Àë ŸµbQÊë 8sgGÑ “4œÙjë£ògöôÿ¡Á™“Ûú/Ú?gW—ÍŸùgJk=ûOÂY)grv5ãÌüÆšewp–úă•áž83£_¶[ Ê{³|FÎס8«y@ŠÃgz¼  ŠãÌ“X£þƒRœÉð.Þ'Êo6ücŠ_¨e òg® WH¼-…3¹© ‹%m8kREobqÖÈ]óõ)äOsݾêA(Rov}}Š3;çnT_½å÷ÉK¦ ÎâñSO{ÎgÒlkxgö/9.ú‚3çœÕ”ÎÇ™]¾f ÓpÖBÝMÚ1ÈîâZ‡,;%œ•M=×kÿÍïßüþ'ó[|ŽS„åÓ»Š&SK{AüíBŠˆ‰Wf„"®Õ¾èŽ^IóËßáÕº±¥§dõk#ŠX_jßÂÜJåú¯jfRDþø¡ ¨?ôî‘w>E4y5˜~"(¢8ÂnxŒ š÷“×qêÎæcÏ(Â:{:t E,Ñ/J‰Cóàëü’¼Uá?û{ì Š8hú’¼EK?ݳÏÊ¥G»]O>#¿.8œ¾XMÍå†]‰§&‚ÿËFŠÈ:òÔÎêE´; ._MÜ'žÎsøqôêÜÁÒ("ÙýãÂ"Š÷\o‘‰Ö_$»õÖDŠ(-0·tDW¯À!CÇ þ°+_L‘_‹7º†7ܧˆ$Ò¥ÕÎÅS'µê•5EàVÊ= Ÿ/ß>OAf.ÜòG‘:R=W¥ˆ»WÆí}ðŽ"¢ÕÙ÷s;Ð8Û‰œÏ^qÛªèã,ETWÉ·íDx•ô?O-t£þ°ôñ'ÖRDÚõÎqǶ£8.Mr¹û”"ö£ãC…D~k]·Ÿ"Ê–»ZZ ¿ê\KöQÄæR~Éë qçè@ÖŠð>XX¹$›"f¼)4¡þ’ýa2‘w)â`•³)ó E\d¹‡@~ïšlÙÀ¯¥ˆK]3³‹Î |¬2èP¹N‡/Ñ,@óöDZ”ˆÖ=øí™íy”GÜ{ºÂ´tŠp©P[†ð\$=¤Þ,˜"r}•Ÿ_¡AÙ@ÓGc)B¸uaF jSµ×Eöw…è¨ÞFóÔÏÒC¸$¾_ضž"f’G_g}DqLºÚÒ*ƒâsJƳ#þ©®¨”qDùó\YF¸Pă¼ø/ƈ_·¿LÝ©ˆìo(öu· ˆ›§\vo¤ˆ+‹„z"D xeòô¹úscö­ÊdÜð+Ñ‚2È´^:ΛiBf§®J1ùöÖ¯<÷2Òi"™rüÄÃÙpýú#~ä¦kU£<ÛÊá ™{çû¹/ÓÈœ qÛOÕ'³'W-¬Cî®6;õ–̪÷áÙw©“™–'µjU\ÃYÁ'ÈÔ P|z"¬1s(˜»á™üáR¿ê{°2x‹ò˜äÐßüþÍï4¿³§¼*¸ò´ 8çòÝG’)Å9,†e΀´º; +1!DXUÙÕoûL¦¼×ÏZfhëvµ^ÖìÁ!;ÁÅ3øÌ²ÀÅzÌ’BG2®d|j€»$%†*¸Xh‘Edë¸yZd®ã¼™‹ù\2µÀΩuG.¹r`P®Õ—#°ùÆ’{3 `EÝÇI^sß“…îyù9ÚZPj¡°Î7™ô£šgEÜÏ"‹ ªwl Ë|6¹o›àOÆÔWmb³{ ?cVD¹fÖÞ¦ éÓ†…Ùž¾L¦—uïû¡&‘µ'­®š »Ô=ÎcO!7Ûe(`/'Çß|«í½X 8ÎÄÜ{Ò)°Ûñ"$E r¸5u¿{KfÚä§6­c@þ”¦¨ÁXíìS d•̾ô–Ù5‘ × î笡JF>»?ºþè2wELuGÉ(Ò“?º=à”/]Æ 3†b–ÌØráq(Éý]|X™Ìºv,ÎïÀˆ³^qNªFNÌoØT}éÒ)ãqd®Ñ©}6>ƒ!{ë‹165dªéqÆÞ?¾€0éFãÞ÷ödT”ÚéÆï ¯­*õ|Al¾í2Ï<…ÌØ”´éÜ2ßÞ<ëû•L¼¤þ¡I~g ÃY÷;Yì׿ÓbñprãQ·Ãy,(¾³::“9ƒ,áîèÉæ™@¾À|í¬\r [ÑþÓÂGë´(êñâådš³}¿%aÉÀ4e¿a»< 4`™Ó»OçÉÜœ°§S}ג¸´ðåý‚É’‘ýÞë¥@ÑÅ{ÒÒ¼=PºM½"kÙ2íø6YÖó(2[w ©Gž,¬ªØBžäAÒÃ!eÆ $N…(+\&KøÛy!»¦ÃüÜûkeÔO‘1ð|÷½ôo«ðVð¶½Rô&nS{[Óz¼Séw>¡ÓÿF^ŸÞ·Àjôgÿÿ¼Þ Íq¾}v[îßÜ3}´½¤ý(¤û{‘Âåô×–#uòp?wBw`Ûx²úÙ²É&кcþ7ßÌÖk¿-=IÐ?.EÒ~1³âÌÚ’Ôÿ7ο>!ÿÈËÔ°ÿÏkÛÙµïÕp£>;ÅOãvGOú?ÏD™;ù¯voåªL Mï³›s$ˆ}rá¶›?gÆêgÿ9ÞßüþÍï¿©ÿ`ÐOiº.J–®¯’§kÌ©¯êO?mÄ5h¿Ök©Ó5VtM—&]ç¥E× iÓ5xºt­ÛpºÎ¯·®Í€®Ã2¢ë{kàF"Eת¡ëúÆÑ5€½õhè¿IHEbÖ[HCפõÖ®M¥kãzëß,éš°H¬ÿ¬üY_6‰ ]#È¢kül‘ÌAb‡ÄÉlº¦­·~Ì É\ºvÑÉ<$®HÜþ¬wÃ$îH™’àæ â÷©eùñ¯mEGA„7*"D ž;‡ˆÂG,3‡ÂéÓ鹄‘¿´£…¾Ÿ¸-ïÄöÿ%z9'¶ÛçjE±%\ëÕFJò!ëÄEÈJT¾P ¶Úµ"Ûû€sÙ’eær¢û@“+ðåIœw⊓sþKXÎÑ’ %낈.a‘ G(YHÆ…+QÈýŒ\(&ˆàHv„K"qß%*½îˆãveóý¼° ±Ö•Æ“L•qŠkdÝü‘Þ¹qx¾’ÜÂzqJ”‘¿¸,ïɉò•„ÓÏ-r¼žrO²¤‚[Ç]*ALÉ-šËògâIó¹aahgò%°Ë¡ž_`%ø}©TrG9Bß(a x‰~î!Ú¼¾A2îÜ@ öl_¶$NÔ %îÊ÷¶¸’-ÔÏ üË6õ`Çô^O²›<‚¸2Ê÷6zýù†ø× :ñ˧êÏGÝÉYÊ‘ìré0A˜ø6‚#ÞÒÑ’³FÚ·ïVÐwËc÷ÝöEÈŠï#ü$GŸL¯sMÆãÅîý|‡NDÿzzzìÿÍS£Ÿ?;’=>@øÓÔÏwáÿŽ(JAgss/data/nox.rda0000644000175100001440000000212712545250042013272 0ustar hornikusers‹VL”u?ƒò¦„ÄA/½±G°ð*fσpj–ÚØ5ÅfM9+4û5gY3gÙ•ZÖJÖ:ç˜s•0š‘K›Ùéê„ãx½;xß{3¢ Ö÷Çó²vÛ;˜·½ïó½÷}~~>Ÿïwïšro‘Ýk·X,VK’ušÅšÄ–6+»M³Ø,Ó™Mjðµ°ûý|É®Tvyqyþ¾MMí 1/?µÚ–¹íÁu¥­î•èVN×Ãëp#sÿ¶3/½‰OÖŽú—ƒpùÈ5û’­_Âèç?tîJ÷áC]ÓOUÀ¥=e½’‹•Çûk@µˆ ÃÎè¾MÏ:tö•ïO‚ª-èúÓ2v–ËÀ9¬êg­ ‹=<#>SýñûOÿ^‚PÄš‹™çZÝ+º¿A÷=[gT•êŸýBÀѱ:¼ûhéÇe…f͸ø§çòîœß‹ÇYµèïú䫾µ£í]™¯«fÞ·÷>ˆ¾Wņ8{;Ò{3V‹9°|¦Ì3«ùkðh)97 ²cNzo—Æ»¿þì&ó)›Úqþ;â=DÄx¯ÁÅÞë³Y)ÌýMÖIá(®[Šž±À Ö´7m=âöxhóžrt³òøÈ8Ë‹«n°ðE ®z^ÎsߨŒO¦üÙ2onÄÙOsÌâSÖceƒÀ'z B\þ¡ ®Ô °Ò/èé”|”ö â`Dæ_¹÷ÿ`a!'ð;P)-WÇþÄ4wY£ÔƒsøYˆpYx¾@[4~>ê‡? yà8.<`ã `Õc»¾z8ú;‡@ ™Ÿ ݸ2"ãÛæ‰ùáážíãnÕ†Ž!*yAÉ'h”O-úÞ«69·.h åWEúí st–4Bôü^ôˆ‰r%#÷•œ`@È5‚:éBâZzDls@‘|ƒÆMi+¨¼Cg!Fñº ¹b—øïG¸EºæÛ)ç& Ê}ªÜ‡‘û´ÇšýšjºÎl£¢^¦™©Þê`í¨ÌŽñ*üѽd¦Â?ÄÇ[ø zºž™zÞÃoÐïõ€úNŒ:¿Á¾¼r|DÞà¾fŸúºìã²w_—zã â=æåsåýõòõ/Фˆ‡oàyáêÈç’¯E¾6ßÃ0Ïã{Ôë2ÏÌëðG}ä'3à”õ yꌩ;&¯¡nïŸï̽D?ˆ»äršõî+RÀñBh× œ‹.gss/data/eyetrack.rda0000644000175100001440000001323112545250042014273 0ustar hornikusers‹íÉ“GÆkº{ËX 0‹ÙÍn6£u$ÝŠp3D˜ ãa,[ ^X 0˜Å+Á‘#GŽ8øÈG8ràà@È´ÔÙ…=¨§+3ßË|™ùsÄçjI]]U™ßûÞ—Y¹|îžûNÞzß­]×Mºéd£›Lçg“ùÿ6ºYwd~¼eïñ½ý+;»vÝôöùŸ7çx]×m_xéé;ºëÿ½ôógÜñ–ÅñgO,ŽOýÛ¿¾8þôŸîøåÅñ'sÇ{ÇÿÙûÅñÉ?ºãñÅñG¿wÇ;ÇþÖ-Ž?xÊ»Åñ‰ÇÇïÿcqüÞ_Çï¾´8~ç‹ã··8~Ë=Çãîþs÷ý¨»ßGÜ}~ÓÝß¾»¯«î~®¸ûø†»þew݇Üõt×yÀýþWÝïî¹ßÛu¿³ãÎÿ’;ï‹îû_pßû¬û÷ϸ¿ÿ”ûó‰îUÿõîϽû÷Þ}¿wç÷î÷z÷û½»^ï®ß»ûéÝýõî~{wÿ½{žÞ=_ïž·wÏß»òè]ùô®¼zW~½+ÏÞ•oïÊ»wåß»úè]ýô®¾zW½«ÏÞÕoïê»wõß;>ô޽ãKïøÓ;>õŽ_½ã[ïø×;>öŽŸ½ãkïøÛ;>÷Žß½ã{ïøß»xè]|ô.^ú§Ýóüâ.wtÏõËsîèžïWŸvG÷œ¿¾ÏÝó>sÚÝs?ó§ÅñY÷üÏÞ㎮žýËâøœ+ç>\žûûâø¼+ŸçïwGWNÏÿkq|Á•× ûîèÊí…ÿ,Ž/ºò{ñIwtåø›ÛÜñÞ¬qð¸Tþ´®›cycD§²•sh\Ö¾_„/ÂçµÒâ>ÃçÃøœ+ï–JÉ·C9TÊ[üþ ÿF¾ ÍwêõV K¯çUüM­Kèy™¼L^&/'ßÊw-ï›òˬž¥Ö)sà~¥ò‡ºîjó7PÇð/øü þ%Ø¿hóžÂS žÖª»Rõa…‡Ë+0^sçó`žâÇðcä9ò\¨~À×0¾ÂŸ,qK¾#ß‘ïÈwÁùþ¶Éߨ<'õüÊñ!Wšá·1ÅçàsÈøœ`ŸC\—µÇQi|mE¿cy%¬kêñÛ˜O©%â?ñŸøOü'ýlð·þjóQ‹?¾q'«ÆÃŒÍSø|:‹O}¯R*_Æ>Ÿµøƒç²<_QäEò"y½΋ð¢.^„êÃH>%×»Òã‹yäoò7:­ÕÿMÜ7ð׿Zóz¬ååP–¦Ã´'ðQø(|>*ØG+xÈãRx—KO—ü©<îÍæëõëÏ®¼£yá™_ƒõ,6Ô%ü ~?ˆ nÇææõŸ×—Eæ +:’M¯Wñ=÷¾Aø|¾€¼ê à“ ŸJ­ÿÐz^?•ò€|K¾EÉ·Áí°ÚâGš¿•òa®FëBiqo¥Ÿ*öyVÔ_¶¼?ÁŸàOð'¡þ„¸+;îj7©r\êR%ñ[k^øp0ž¬äŸuù`YßõÕ×wáçÈ+ø9ü\¨Ÿ«•ïðF÷½uÝÈ­wËüD~&?“ŸÑÙÐü ¿á·%~Sχ׳oܰ?-¾ÝEwSû â™xn9žµúE„ë³”¼Ì×T:¹óÌòù–ü\GøBòy_˜m=+ëÏ—8ÎÌèñZg;N)¯­‹÷Rò~?„B_K›õü†wmñN[?Wݯuý]Á#ëyxm9X‹×Uõ¯ø0|>Œ|hfßcê5®^K‹ãƒý€èAÙýÔ¡óáð!ø|ºSÚúõµò¾êò5·N§ö¥èôš¸Ìí7b㟅ÏÂg‘·‚óV©ü‡º¼X‘7šÑáz×Ο©Ë©–<‡Â?áŸÈ“Áí`xW6ïBË×Z9…Ö¿Õ¸[ï«tc™ÇÈïäwt–ü;ϸÒý×é˜Z»Ë˜NXÑÅäz%ǹâ´=ÆÏàgð3ø™`Œ-ïÀû#ŽVÄQmüe]=òyŒqwüÄ—ãËñ9ä‰àñ Ò|“â—uÞFþúlTŸ+×#ü~¿€_àý|>”Ï¡~Rº>V•w,¯rñ`]=Jó]›—¡ç£¯7×WüþŒ|†?c¿qâ«„ø*¯{ĽŸßËßÐõcñ%ø| ¾$Ô—Twbñ–zÝKkz0ö÷¥Þ+6¢SâydY¯è³I}ÆŸáÏðgø³bÞÿÀ·"øÖºÞW;_@:_ié’;ƒ¿!ßào‚u¨CÆmeëa$Ó¿ÜzKŸs页¼JçCóКü€ÄâñƒÁy>•NO~ñËç5<]ïÒú[ïJqšwªÓÑÆu“YK}o$õü¬›K|Ñ~ ýPJû8ð‹øû*þšÏ ¹ø™Š¿¾¿³Ôñ\º#œOð?øüþ'ØÿÄñQíº¾ZùS=NK‰+z`½]œ(¿XÕw|:>‚aÜ+:P•Hó<ïÆ®PK½¢§iã^øùW®Ïm,oãsÉoø\|npþ'ÎꌳÚyÉÏàúRÖ¹`žçâ­ô¸ÈTñ›|ý$>üOçYŸwU©NˆÇk,ÏSñFKÿjÑ+­ûËœ/ðø ü~#ûü´T¼„?¶øc•/‰ë],O$Òaòµ_¾îºéѮ۾0ÿ°Q &žÐ¼†æ}—Šœå`‰w%=[êòª]{6@¹£u­¦lÛÐjbÀ!8ž²]c¥Í§YVèDÜA[ì÷É´ªËø úõH;‚8xÐR\µ\vp¥Ž2G/íó¬–ç·ø¾ž<ßžÞâ»òò¡õýÖÛ‹¹ÆÂSiËKë÷ñ=ù˃¸ªß·’i/Ús3}ùÊ =«[Ÿè£k{SÌõjo²¶nã`­óƒ\’çµ—¤-F9‘õë?¦¡A¶Ú­s“¼–n0«k/±Gù ä[Ë• ôeäZO®õõGÑ.PKLkãùZ_´'Í^3µÌ³ÉµG»åùûø 4¯”œŽ?+c’Të€Ö´Þ{ ÓΔ(täÚó°ÇQ)ë½×Þ¾$¿¢ Ô}œÂ¿¥)Cb”õ[Ÿë·ÑLêHíµÀ4 p½Í÷VöžÀPxüÔ¬­¥ŽÕÖ#gi t ¿ÔR~¤LˆùÖû`àÜiõ} `ã–øÜr ’ Èm­p°Æù÷µŒsF»Ð™’5°ÆõÝi_´µÆ VwyÕ¼ßq‰mH4³œw…ø<úïJ^{e‚ç2[/­Æ9©”÷^ÖùH¬ƒÖû6‰©:rq /ÆðεÇG£±0›còòüó±žuG®_çøòÉÅ7¦Ëol¸غ¸³»ùÊüÓµù¿íºí ð`[P)nT7€Þ…ã€ä¸âc‚ÀÜRÀ+ñ€ T‹·€a¼ Ç{`ŽŠÃÇ@S¨·ªÁë`Þ »2ãÝP0Þø0„#`·šÁÛ@ï¨âý€&q J|@ñ80€Jp+€"ñzÈŒ7@x; j|ð¨w@"l@ãx-p€Lx3€jðÉðA¨O|ÊÁlÒu“—Ý;‘ãÝìÆþ[“'†O'‡O§†Og†OÛËO'‡3NgœÎ8yzø4œ{r8÷Ôpî©áÜSù§†3N gœÎ8=|ïôpÓç‡3Î gœ®qf8÷Ìpî™áÜ3ùÛùÛùÛùÛùg‡ï¾wvøÞÙÿ}o¸ÆÙáç†3Î gœÎ87œqn8ãüpµóùç‡3Îgœ_ž1=qüô¢Â§Ë ßpÿ´uqgwÿò•ù§ksíºí ×ÿÖV 3[.õ5=‡éHl(Âgù²©&‡`##&#ó|cpXùÇô}ViL•ßP>¦Ô’àUW3m˜„$g–Ï9Säúä\âRòžÆðÈZ~ÈǤ°U!Bræ,àû³@žÆæwi¯&áI—÷#­±9PjŒ[ŠÁPõÍwcsO¨?Ùð>=…ço݃HrV‚ã>\;F?vü”GO=>d¦8¯I»ÏZªÏ>Æ£Vv>ÞÐg~Gl…F]©»ibM«ƒïŸS÷yHút‰¾°Ü}w©ú9µæ ÄæZí¹mHm½iy^¯®h¿Û—ê[Õò¨¹Çľ Ï5¾!f\K,¶·gbskh~íŸóõ„>ý~VçKçü˜\òŽv&˜[¥×Hˆ `ÝKJ¯p³¾éù’ã¶Ö­a0ƤžZFÓÄ~5÷wI ™½3']Þñ¨Z4MÐ×±î^kž3#ñ.¶¦µ?Rå›ÐwƵ¾ïÛ& Ñ•ƒ×a.œœþ§ìOÙ‡-í¥ÖûÒXÿ*Õø¹ëŸäzÿ›{Ž€FÍ‘{$ûàB×FÛ1Uò9ë$t,J®ñqÌe‘mË•òÞÇ'kôM]×jûCcþñ:ÍHÕ^O‘cJÊ…­Ï Håkc}ÙaZ¢U–ç‹iÆŸÆZ¯šk6øzCM­Ï¡Q9ÖªdîCš>)-]αžxŠyL¾srÎOÎéaRÄ­õrÐôûfu5¶}»çÀ¬Ó[›j.c¬>ΔtJJSíe“#/åö=cU5}MŒökpVc.yζ¡Æxý1çäêƒ;Ž:tžUÎ6z‰sG[˜Ç 9g2´_84ÑɃ¹@r<Φ€WÊåb½Ô=¦ðIÓNLHεÿ%rïü¿k»…”ÑX¾I·ç4ƧøìŸQâ;hÞYÕ¹~œ†_õ6!ëÀÇbŒŽJI°´`ª˜¿ÙoiöJ¶ç´ÆDúò8ÆCjæy-ø¼3 ÝP{.L®}CȯúïQ­¾¯œvùÖ7”Ïâ»/ ¥•\g;ç^Í¡¤½ÞªäLíññ«k¤~G•â½™…5“$81étçT–6Ʊ±eù´ÍŠÚöôYBz‹í6I]^Kø¥ýv–÷Çö]«iì^˜9Ö õ(¡ûƬ±-UïÞì•ב\G\ª`eLŠ=KµÎÞ˜µê|Ûðëö¤°©uí|¸¾U@[ÊÒ‚Ø÷$>ý7¾kKä{KkïHhw Þy+q[U;OŒYçaLì„jAHû4tý ©1½–Ö+›ç¥´'¦¦½>â©g™Hå»÷Ÿ YOC»È¢OÔÜ÷q,6»ücø´cÁâž|ô ¶;—Bb•T;G’ë©Æq¼òzšº”sMAÉuË$îOk,N)c”Çò*ÕßZë Iæã™±6ÔD¸M•jžyj/bqMg+~!Õ¾a³ˆ¾²œk£§7`yn’ÖÞD’ûrK¯íJ[ÆFrî8–˜o©µFuŠ} Çäg©6Gªõv¬ké´³¿ÞXŽõ+|7Ô÷Xõ¾í _Jùšó=Æz–ÆcÕ Íù>«8šsŸx žOûþÖ½7Z·ÿgèºp1¹=uyj÷eÅΗŠ-ÿu}ξe$áw|Ö‰­ûUÿîã'}=šÔº&c®×r»’½ÊSaiœÃØu63´#BæÇÖKHߥäû<‰ýÉ5×Ðëæ3W¼•~AÍ~¯”žÓgm5‰½±KkçLºñë\®Ó ‹Þ#¦XºMRZ?ÆØy(©ú|bø2¶¸O™ò©Æ5rÌo‘Ò€Y§¿_f~_£íÇÌ—ðm[øpYb<]H^L¡Õã K_«ÁZëA­'Ÿº Ë‘z¿Ñuz›KSϯŒyZ}~ÔÔïMK^)dŒAª5KcûÛfþÚ´¥›L¡™ÖÇ)M3{M/”ºßQ:§åÖf—fŽà´K¿_ða{ÑK¿Ã)p_r ŸþGI}°´Žaÿ5[ÜÛ¬;r=&ÞyhïêüñºøËÙþí-¿°{ùÒå+î[—¿òµ½Ý}÷§É÷»OÓ݇÷?<}ÙýÖò·Þ¿³¿s÷Å+ó˸ô‘+—½{yù£×ï‰îúÛæÿ»vÿ„x“Tgss/data/Sachs.rda0000644000175100001440000056632712545250042013550 0ustar hornikusers‹ì½g”Uåòõ»»{w$AT‚# ŠE÷R@QTÀ( ÁfA% "*¨ ˆ‡` "IAQŒœƒšœázΞ¿¹®O¿Ž{ï÷#gŒ÷õtï½ÖóT˜U5«êº:M«4-H$™‰¬ÌŒDfÖ_ÿg2ó¯ÿ/#‘Läÿõßìëo»£õ#‰DÖQý¡ø_ÿ¯d"q♩“VN½¥qëÔîåŒmsK£ÔþÛÚ¬>ï™[RfV~óÍѧv?T¥DÁ)w¤¶ß¾­I½vƒS{x}áîq©½3öo»æÖnQâ¤-›»&µãìË~š:nojÛƒ‰r¾¿-u`óË»îìy]êಳºÞœŸÚSbÌC5é™Úõð¿¯ÜòÐ}©}gí«<¿R÷ÔÎOnùdy‡Î©=}Nÿuz›ÛS»&röµº¥ö•ü°]û!kR{š?bõ5ÅR»Ž]¾üò[R{~ÞùpfñûSz»)µÿÿwG£ô½®WjO§ãz¶ú1u KÛ^•;oHíyÏØ¬7JíùjÍœ²)µ·wòªc[/HíMÝóxÿ =Rœ³ªNj©ý%?>¡øÅURû4ý–NÓRû>©7¥Õ—¿¥öGU?|'54Êx+Xƒ‰ÅR{;·œ“ÿÕó©}¿üøS»¶óy¿(qõ{µŸ­[9µ³÷±y«Žî—ÚxìûKÏNxè¨c_ü±Xjÿ¤o&´x¡kê@ƒÆ#Î)¾&u0ÕªS£Kjßµc¯=óß-ãçÐÏùïõsº—(³ÔøéK{]í÷Û_éî‰ôýwêਨïQovLíþùËK^:%u°ËMU.núi”¸ôeެ’Út[«SÇ”¸6µ{ÒÛÏ–=q}jç ×fïý,Ê—(qúªORûÏ^xɤß?Mjx×°s†$}îûZ–[\l[­ÔÎeµ7¦–4Kí;øçÓ“—¯ô¹s^¼§ž+JT¾«~ßKú¦öê2«ÉïûýÛ·_òuµ³OHí]²ùûTΰÔþ›ÿj…Õ©½Ÿ|Þö†÷²RûºþúÙY½R»KuŸõå7¤õÉÿñÇ·;¤öÜ^ÿå1-£Œ'S].}mj[ŸÔ)¿ÊOuÞ‚O|3~ïÉ5ºqyoÿþ®N7M;oèUQÖ¼˯3=µgä M~²†åpïàg½¸çûÔ¾Nû†vXubj_¢|ó ºýu¯›ûÜ:ýÃY©ƒ¥¿W/9 9à}£Ä?ÝWµ°xê@µÁ¯äÞÚÖò»ûЩ??ñیԞ†•>º¤cÍÔžÂÆÏ?z×ÑœC”1½Â+“–e§ömÎ^ØæÌv©ƒ3Ï~µòîÅ©ý+¾6í¹‚ø>+ÚåîfŸ§}5dÌ5W&|*ôêóýöõþþ½_­±{ÂðÔ¡Òm¯šüzf|ôõùüÚ©C]fÝöè‹u¢ÄÅU{/ï~¹°ïÊÈùb˺­_œ纷ňÉçž^Áú¼·Áà¹CÇÖIí-ß«çПÏLl¾éš?žïž:tög¯6Ëy=µÆ—còOI¦vU:gi—ë -§»Z̽÷µ}5¢ÄÿÙÕmØ,Û™CÑàQ_ëe¶îzïQ›kY^t/QÆí#Ÿj÷ê=ȯõŒç;ÐüÀQoU>Ãúƒ>f6~þ¦Uu†ùÜöo©~í°ú¥ÍhÐzá­xî(q'~tç%ê<òѳ¿LNíúÑç“Ê*òv*õú¹ËšÚ>í=²ÔO“¶7Im{ræC_.ê%ò~gwïßkÞ7ʸ`Ŷ~JíR³[Û“ï¶ýÀNìîR˜ÿÈ-U-èöê`ƒò·”½¼njÛÆÁ£ Sm‘ëÔþe½Þ]•ûK”ùû¿Ž~wŽß9°Ñçîï3&Ùâø–+=G”xõü¥£[MñßsŸ;9«Ë†I»ü÷اíÕ­ßvÄC©¥®ÏyrsÛyîaoÆCÿèÿ˜¿oÛʧß?¼¸õcë›g?öý+[RÛfä·½¤ä±–ìz°³úäFÌßêó—úœ÷,­9ùϯ3Sï»üŒ?Ö¦%ŽœºàˆM©­wœÛ÷…Q'"_¾wìïg}ZÑaá°£jÙì¼ug“Qµ‹ùü‘˃§•U±5þ+–çôóG™…M¯9öŽi©=¶=˜S˜:´tTý¡ZÆ–žbW8¯}½×½öÌy+}Ÿè+v9åûåï¬;ÿ³ìü·¾íïûß]Øþ®5;R¶§;n?yàÑ¿äÅöTþNïŸÚUbçˆÎå!×QÆËçέ}ÆÏQbòõKn8²SjÏeÇŸ]­ð,ü_”ñiï{«D£-àìÇÁÞ_”{cà–Ô¡‘Ûݽú$¿'÷_±ŸÑûj™_þ’+nô÷í[²¯ëûÏw‹íz‘ÆœWjÇæU f.ª–Zs`W´gzóÔÖ¾;Õ~öãîÛ]åç4}ºuüyòÇØ#ÎqÏýý—;l—ÑÓ]+šŽpêžTá÷æ6[V&Æ“sz½ðtËÉ–ág•©ÜdUj_ÅOîܵ|‹Ï©ð¹µ7ÔÙöœUøúÕ= žoâ÷å~xnpçŸuÚÜz­3¾0>Ál«sTÃ!O¬OH½0¾ñ¡ëâç“ÄߪøöÓûMNmYÖdñøAóS‡6ÿ±ñ½Iw`÷¢Œ²‰m«“³8§(+pr³ûù¬‡½ÞÍ}èàÛ>Oä{wŪOv¹¤\jOÅ-o]\îAãìÖÞ-÷ÚpãÑøõÔîK“›žx‘å}—þE‰ÂÊ›ý²!ÖÞG÷†äÜvE?|qÝâ[mOüï²3ÜÇÖ¦­=óàJã=}n”8îÖn[Øã/¹güƒpF|Ü“ð xVŸc{±»Ñ§¿pà€ýéÖí´~øc÷Ù½qÿÛO ØOô=ÛzÌüE}3KÛÎ ŸûÐOáCüÆîÛjïywp7ã¦ËOyíÃ3_ó}ï©Vóžnζ]DÑôQö7J¼uÆ·[~?ÏzŽ}Á/X>„“ÀC|x½°Õûžj:Õx†çgsŸø!¾?oÙWá¸ÓjG‰GŸï±ð‡®QÆ9¯ÿpyÓRÆÿ+†ÖnÚaop’ãüƶoÆ?Ylã^ÿüöÎ'Ì?vð”(³Ñúý‘õˆçòyøIž“ÏÙXkç ×ÿöYjçìí7í¯iûb<(ùľí­VbÓ§ç>j¼…·GÙ›;N¹~Ú¥>¿À~YNôÜ…Ã{µl8­i”1oÇÀw'}Ú7éñüjÝv¥¶WxäåÉÇ ŽŠ2³çÍhœÓÌ8Û¸OqòƒücDZsÜ?v‚xûà÷JyÂù_·ä}V+½¦Dåî©­.}§ø¼1q¼ ¹ïüðDÝêS$¬§à¾;¾Ré´9 βžñ=»®¹¼ýycÎö9[8Ÿ]}î9¢ø»+¬|¿ñq:.‹²ós×´x²ŠÏö·Óû_û×_qAãÚwo¹Îç(ûãvð­žË8]vÒrC<%{Çùmlùôé§]¶ÇþžÇony0jòZÆòÔ¶ªŸ•ßj…ãyüØÖYu¸ÿؽŽó6?ºà+Ç[ž­ÏàÙwÛ9á¨]ß|"·÷JŸ3熟C~l¤ÏÄÆ³²Ž“%öçÂÄÿaœÚÎsûýwœßþò^–KΉ÷ؾb\ù²ÿåçÀ®]RlÌ‚V;Üq¾wÅ×è¸ßÃîÜøÐ¿sßíhçy‰×lä¿ÁOØ1žÿÆ=ù<£OœÛ’Kß©S½ÿ‡1>ŽÃÿð=Îäý…ãâòΧȮ7¡‡Ø¿M‰Sž}òTËí‰ìr@þ€çæe¦ãˆ%ÏÿóëUÏ¥¶{=:»gKzúEŸ§ü öBñnjçÓg_>¶ïGö¿Žô>àtìì)þÊöß¿/¹ÿì˜uóoVÜëçÙòFùSŠW{Ùïi»!ý þw>C~=‡8¾•C.ÀÕøGò!ÿZµ¥÷SOX>È’W‡;¿%ü‚ýÞ8ô¶S›lùÉï‰ÙyiÝÊ—5‹í©ìöû>gèÞ£ŒÖo=7¦XÇ"ñþ˜xÿú<ð+CK^v׆—mŸÖwìùèäã’ÆY‹’å67´‘ŸÇr®8€x_ï%Ê]Õê¤ZÃÑcì»q-v;~Ånmùç¿ëwìn„|9zëù“æWÝn»²}ÿ–A ªNsž…ü Ïǹ7îzëÊÕ¯îx4ŽÃ…°£ØMpýüÊö~9ºæÎ8ÞM?§åƒç·ì,ñÇŽ2§Wñyh=q½q(ñŒ¾Ïò¤sç^ŒÏe·É9o¢÷'/‚üo™=¦ö—G6·=B^„[ÀÓQâ†i£N¿ý#Ûì!yÈ7ƒ{Ы0îÜݧÏËÿ®~«ó±Æùä#•÷n©sý‹+?½Çqçä8G~'Ôü&úæ|¿pþ€ûÛµqòš Fä9îAιgüø ýžáϸoü:rÉï7Ùï*/»ã•aå'^~„ã4ì>u Çcéû‹?÷>²{™éqž;ˆ'•÷N­I\üå¹s/nK3áß /Ï_À¾£à0çkgá±ç¼÷öÉ'úÒ:üI”,}ìĨB ãdÎÏùÚ[fׯU9;ŽË$ÇøuçK„'È{qØß­gg¬ý!ÿm?·ã6å59OôÂñ›ÎÑ÷+;h»Æ9`ußè%v‰¸~ûÛûn<ýŒ¦q\ sužPùqì#ççó‘>ð¼ÄAØC>¼>v\çfûŠÜp~È—óˆäÝeìïÓyœ(cÅ-³w(‚¯äŸü=øËSVüþýCÝâ÷•þw€gpþªÛ8o®ü$òÌç!§Ä!Ø+û]ÙKç•Ó~Õñ~Üõ ÅyÆq:/Ù(ó“#~.h•´Ë®FÏþ4´lQ¶c‰ÿÅ“myÏ8Ÿ¨÷ÒsG \´êûö±ŸŽÕ½;þ!Ÿ…Æ?“ïü Ø•­ÓšïÜ|êì(£m¯v­î弋ãuê,:Wò`Y]ºÝº{{)ž;Êx¿ïõUªÍŒ2a¥QÆÎMÛWë¼ð{”µîÅ+Îz´–|?å}÷É®ÿ§í±ãwð¸ŠûR]GxÕïçx>À–‰›ÆÜÐÝvkË©m&·žÑÕß';¿>Ÿû#b;­8•¼ ¸s ÝмÒOåšœhyâç\—Jãq×…8òøøuãNùgž½4$?Bþ0íß/ŸŸÏ­|û•×|×m$Æ:ÞËý‘——á'ÍÑûb¶_üÉ £ú•Œñ‘â~Þ~¸Bùç3¿óûØSç}t¿²OQæ“në? djÞ¾eúígþ x*´·Ø{çÉô¡½2^’=Ö=D™Ë¶Ü¿jÜT~?Jxw㢣ÞLíX6j`•ïzš/C¬8ÎvUïE½"óüsÞ¸øäºÔIl÷‘Cç]À‡z?é›í–ó®Á=¿¹_ô8ËçÀù ßYÞU7ã{‰ïOì¨y=œÏœþÅú}¸Õ¸†üˆùGøeÙñwW8¥Ó"ŸÏEýÈuð´¿6þsþEzãz$yG½óPÈ•ôaWÕ5Ⱥ'ÆY²WàÕÌa¿uúጺQ¢CƒS/*áúµq ö|Œ×J¢Œ‰­k,i›Šý…¾\Ê=9¿/ûKü‹ÿÃEEyšPo\oÒçW§(¾÷yú>e¿y>Ý{ŒW©'S?Wþgf~C©æoç[¯ÁaÔç±ÖKêåzOã ä$ý<ŽÏ©wrÏøoÇ —TœsßÂø|‘éÁöYÉ9§-y® ña”Ù©ý/åK÷ëç žwÝBzèü6u;Õ™œ•ý´Ýƒ¯žÏQ/.Â>K~± Âñû«Ži?B=FÏ Ž²?—Ý"N·}Ðý¿€{„ç¥gŽÃ•wü°¼ù¯ms/[×Ù$7ȱã2Åõ®K)γ^KŸ]§ ~P^þÖ<"Ù/çs‰Ãø|ì=y+å…lÃ<8ñ­ñ˜ê¿ÄËä?ÑÙoëµyØcÙ=ÛeÉ)q/ö ÜDÏyå±·Ê£Æü8Ùòá–›´ÿ‚ÏeÑaþò^Žó¨ÒOûOxgú¯Ï_v;‰¿p*^~Š:‹ëвSàHp¨â>Γx6Ê<Ô¡Ô+“Û:N“ÿ޲J6ßÖõÀÍþ\çM%¿’sûoãCü¥þÌû g“Ïæ}‚üªõ; ¾îrœMž›ï!® îæÏœ£ìóÆØ=ósà‹Ç8_…#¬s–²ßãžÍ£Pþ¹s|ŠH>‘sð×¶§¿×´ÅÐØ.¤y¢ö—!¿ºü,ð*ož¯pø^!ç„ý'‚O‚ÿ/kx×iO¹ŽB>û••?1ÎÆpÔ‡°çØý÷çÉ®’¿£NK½Ìñ~€¨—ÃÏãü°#ä ±sä;ì/;ÝÇN‡E™=ŽlùÖ:Eþ¼uiâ\âÇ»²?øuî9Àþ÷ŒÏð’cîƒü÷ùñIoîÜúææøsÉ7Jo‰{¨7IßG¸^£ø;s×Ö6­Û–±ÿÓ¿‡¼T¿î?Èyš£ü†ñyBÎOyxã0ì³ù·Â]ĉ›+Õ¿ÿq]ü¨òÚÄËæouQó`$gƇoYÐäç—Šð,ÇÔ‰”¿q>Üúåó¨‹ç ÷à1ü­WùºŸJÁíºÏ(ó¡[Jï|¤õ =0Œz¨puç#ˆ'Óvžºq~ÙvÜ ½G/W”ß3oVõ7ì¼ Ç)ÄÁªËs¿Î7éy…›‰¯Cþv÷Âþéù„¿â|œòšä—°×a=Ûu!âHÝ“óîé¼q”ø¶ý”oª×‹q¶þ8Òò {⼕äÜõ ø-‹ôM ïâ-W5þ ûmŒ7© ‰æ¼¹ä®0ñ¿ÿù^Í#Ï_‡ø¿,9t]žñ‘þüªó]ªãÇd¯mÇ2^û½û¢Ï¶ØßQ7ÿÉŸ‡üïÄåàŸ'ôPøA~8®WÉÿÀ?q&»j Ÿ ]ÿˆÏ—ø>ÊÛðÞÎWHO9üñþ$s@¥»o»¥cÌëNË•ãkäÙ}¢’+ä…~äžÚúJ÷çMº`i”Ñ¥`q¹g~.óBtŸÔ‹Ì¯†ï/|„=àœø^Î=6/MÜè¼–ìC˜ßÙþò;Ï?vÚS1>’~ ·Öð>üÉ}X×q~Oç,[Ñ´ÜÑW}é>VúUÈw‚ð#¤ÊTzuý¯Ž÷‘ÇíÔ¥àAÑÿ)¿¿Ažà—/Ý»´Ç³ÇM°?¯ï:8~}òg²KæÝógì*~Ìõfá‚Ìz³ë^ôêĘÿ!{®¾ûòÜœ|@òKîþ»>!ü$y("‡þ\ø«äS„§À È!~ÜÆóš÷OŸ¡äkgƒúÌÌzÜz‰|À–¶Ÿ&ây̓„秸aë•߯,¿«BÌoþ‡¾Ió‘þŽ·â:ìIh?Ì/“_·­¿-ã­‘Ÿív½š÷/òà!ÎYý–cÛ‹€/Æ=bÍË£WïkoÚ9¯mÞ·êëàRžÓõ€ÿe;¡ßã¿aœL¿ýÜä—Ð?ç•'?ØüäÇùFá÷)èžÜ·ÄuÄ-îâyÒùçEø<÷CЗŸöq~Dv?Y§Çx—øZòîz–ÎÕ|ùÎÙvŽ~Má{ÛGx&ôÒOMÝ>êtôwºN ]yê äìïá?ù3óë„K¶.>vÓc?÷é˯â'×-qÁ©©9©M—^qãË•;×Ò?‰¿sŽú"yè luoÅ}Äkà]>Ïö†¾_øNÄ]Ïà_œïu‚êUèÈïæ{Á»Äùü=ýñè5ñ„y³aŸ¥ì#ñ ÷M>”ï5¯öïýñ¶Ï– òÔ¹õ|ä‡Ð[?‡î ð@O—ƒûåÄ;v\&?`AÉyuúÌÉ“óóàÑ寸íÃ7!áÜðÚòè„g~ü=Ç8ŒÇ¿¢Çæ5§w¾ñíª¡¥6Ä}‚Â3Î_éó“^ÿÀßKÍ/Åy:êFôÓÀwây‰óÈ/8oNß‹ðˆóת³l¸xíw»ŽàžˆŸï‘µ<ã‡t¯œ›xÑq~|•ÎÏqyòKŠOÀ½àZžßõ©€ÃïÑ_·eã’MçµÛä|å–?øEîÊÏ|_ä+9wêQØkx¤Ì‹Áî’§Ÿz ñ)þ ûG¿®q’ì/vkC¥GôÉÍv†ü’q¼DüšìögG…Fc®îÞÆõ„ŸÇó€ÿȇ4O8˜sôGçãþøàsÎKg¶³UÁ‰ûb?¥z‰ùæi\`¡û‰·ˆwè'ƒ¯§8™ç…¯䉜—À?¹n'}Ç>¯ù_ Ó¼ÎqÃòáÓŸ{ðnû½°®IüмKÀwäçÌ›Óï­_qç †^÷›*®Ç¢/Âÿ1ß_~ÚüúTàûÂë–½DÎè_$¬?Ç8Ž:%õ5ÅÇæ ¯Ñ7 >ð|âZåùˆ<ïFòﺡð ú$»÷óÓ'«<œùÍÊw»SòèþPxCô­Òç@¾%࣓_ ì\ç OCïýð¾…G|vå– 8oà¾HÉ-¼?÷3GþÑ}ð:…ã4÷#®[Kßé“vßs.„KÀ_ŽkÞ?o9xØ5ì®ò&1¿…z¦ä ÜM]{C^sSÅEý:W/÷K(žS]Î8û*ûÇ òŸæ=‹À·ÔÓ™£¾âóˆ°ÌÁ‘¯»N¸{á9mØ/ùg÷á)Ÿf9¤KϽîÄ›k”m_+æ*Î2ÏJñ=öØó<$OÄKäÙÌ{P¾”|÷iy×¹â÷6/ýmá5^ë=’ÿU™½/ý­Z‰¸ÿJ瀿5ŽÒy­²gÍÀ ŠØ-å5¬¿~áAÏå9©ÕGݯh{o~|rÍ¿3OHx û…Ч"~¼ýŽçé}ìßŃÄÏaÏœG#σ]P]˜÷$%?æ|™êÎË(oh=R>»Oœ >c_íçõœ&.zã·£·¤þlyÏçkÖö=b?Éç{."ñ.çF~Z÷É÷â×8p<¸×ùCÙUúàœ¯…ïîbŽú”çÿdoyϰÿ< ßžü/øÎÁ×r^IñŸò±‡o¸‡þ8æÑŸ#;Nã¾Ðÿ >×#³ËtßuÓqÜ7F*§l›!-îÿ=ÊZ:Àñÿ'³îã»föéå^Pû‚·:–Ý~|Ýg>e©¿"kr•žB"Jv~õî/ÿXå•ZrÄù£œ·ßZíÛK­¹C4-]ÿ’(¹fß…9çÃÿðó$ûýRÕ,â úû¨ÿ˜—L~)wÀMßÜíójˆs’ÝÖ4þpe”÷U±ûp0ʺöÁãÝqu”]ªî73ïîg^6ysúp²¦Ÿ÷\÷ë¶Ÿˆ’5^ËyöÈOè+Œr×¾?ºÍˆ>Qòì7÷Ïžqx2Jn´tÇò§™cå|uAÝ~“wúÏIÕGÄoŠ’õêÕøúYž³ôFɦ¾Pr{Tæa1+Êîqã_6Øî&e=>n`·Ù“|¯Ùßm¯Y¹‡b~úd²Æ—{g÷¸1ȱãÁä°Òs+\2ÈŸ=´ÉE«†ˆò[Œœxc(+gÇ“½ú–±œpßÉܯ[/9úêˆQ±þk®.̾Ù<.úˆÅ ‚·×àiK^é7Ènùè¼·ÞåNO®^=kù´(kçÒmÇÏKFÙFQqŸoî‹_¼æç'âŸK÷¿EYǵ˜Ûäþ'¢äÝK*´ºÜò¡9œñù©_ŽçUý/Ê/]uJ•ÇF™‡”“Ûø¥œòÇš/œ=nøðõÓ¢bÿ³{ÿ§è¸%«Ï€Í_Ñž9iQNÓ¨õ‡Æ|õñç44eìŸE9ãzöº|uwò1Ö?~>/ºþè1þu_}ÚÏ*_¢F”µ¥J³ÅGuŒ2Ç_ôõÀ9;¢¬×¶5þ)ct¬§:‡œ‘zÎ:¦¯ûdÅ#1ÿ•{Ïz°ÒÎ!›«Ò'J~ÔzÀ=j_,WzŽüÓ}ö£‹jFùÃ*^¿ou”Ù{ØÂSkŸ¿Ìv(ç»9U†¬%ü­Ù˜§ã÷ü™-^>4óŠGéÏòó(Oåê\òºœ¹ïË7£ø¹$šK%æVª¾³ží&þ)§ð•oìW;%§}Ϫó?±Jî®\÷¢êÏÇç×â¡ågU>/Êm1èô ¿‹r£*¯•¯rü‰(§â±¿Í®0Ór(œI^7Ê;=qÑu·Ýe_Ñõ”bçµñŸñKð_súϸ2kÄX÷ÿØ^è¹yÿ¬Šoõ[RxV”}ÚŒû6{Ë÷å9­zìå]þ{’<ý¾—w:d¿„}įç&*–ë„Èõ%ûGÙÍìVŸxoÄTÛ­¼¦‰Ê­Fw²ÄŽä}·ê»ÚŸwвšŽhZ8)в×Þµ¦æØû}¿¹_µ5áò·¢ì]]7ŽéWÓ~?ùf‰ev—‰òZf7ùᙿÞûŠ^ɇ ê;N'ß\PáÇÉ5Î]å,í¶æêÝGÇyJÙQËcš÷n¹Pß§y§Š ì=gŽøJç—ÓþõÓn(yUìtnàÎýÏÙ5}ß§u†ÇÏ¥º_þÒiKºßb9oa7³«ÍkñzßÒQîƒÖM©štÿFÁæ/=ÿu_ãÕ-‰ÿÌSC/ Ì÷ÖowGÙü´qÿ->Gã§ô9»_ŠûUŸH”ß²þ]ßž»ÆýÈ?ý ês·|r_Ògpj”ݧé§Oî¶_Ëo÷çƒíZu‰r›V¼*æ¤gÉç ÙüëƒùÉÿ”†_vûnk,WÞ”ž:¯è¿Çê>éPž€>:Ÿ7vÍþSïO¿™=¹ãÌK.åûEÀ%È=v…ø=uØüÿž™“·õ½î¶Ÿøã5Ùµœ-{>Ýç<Û+ümrrñ¯wŸ»:¶{ÂÕ9뎙9sAÍ(«û¾&©¹Éø}dð#yâ­åÔ¨üâ÷½·™—Éùû÷¥·Æ-iœ%Ö7«´$¿ZT¢aîúæ3^·]!7™CŸíPÿùMQöíV évƒív—RÕŽŸ²9¶ûü<÷ã×y3wÁó]•LVìÚîâ_7Ù¯a7}oØÞƒ—_Æ*ÿ%£öÉñ#ÎækÞ,yUùçØ~ÈÞṇ‚Ü9¥ò7/òì¯Ñ«éå¾ûeÙÁœ÷?lR¶û#ØO×]ð¿ÜcvÿŽý6”þÚ÷NÂùô<¾?åeÍ;ÀÞèù²G•hûìžÁQî®ÿÚ¢:zçuñ‡éøÅ}¡Æ…:_ä\Ž–ž;žƒÇ n*âçWadzfýkë÷{'D¹í¦ŸµêÆõ1Ž—ß‘þx>.scÝ ¹@_±çþáöÜ2Ï=’Óïkò`q,¿ þr¼þ×Ï!·’?78>÷¹ NiñÓÓà)ǧœc^îî2çiÿä~}ù'ûW q_qßಶ—ï_íþ?ü#qŸδ| §iž²ýkAëÒ=¿{÷JêP~OüeÎi#¯‘ºÝv?ÈŒÑ?o˜ë¯âûâ5J.ø¦W­8Ï*<.}ñ\æ6à·yN˹ìö¼Ë÷à‡±7ÌÉä?0î÷v[ŽŠû”Ô¿ŽœòþÈ1ï‘;ö›ù7o8ÉüL~ÏrÐjI³ä+]ã:–p'þ'§ôgÍ»ªœï;·uÙ+ûí Ê®Lûj×ÜÇzÞìC}µ´Ðq¸q1ñz£{p]TyãUá Ï“ÏžÙøæ¥¥8.æˆW°È/¸”x…¸ÿÅs+ßá<7y”ÜjíNÝQ·¶ívýË™_®Í/Í"Ÿƒp‡ßCöÌ÷„?^Ã~t9oØ„‰£ä²GòÞxe—ãð³ãÒD£ÏÊ Úî±%>³þêy¸7ûEì&þPñ:r˜S¯YfµFy­vŸ¹mY5ç%?WÉOLŒ,>Ôs„9Wìq yçÝ¥ŸÙMŒ=óúLËQˆ¿±Wò¿ñ9sÿÂcœŸqaú9ÜO…¾9ŽÕïç­Ýß{Ñm¢ÜÒ¯FçV]è9”Eü÷AžÊî@× áóÑ_¶hìÀ1-KÄóì=¿CõwêhîËU=„¾>êîS¢> ï3Oyw×-™;Ì rÿ?{§T‡ô>"æS²¯ƒº"s5ß®ûãTïu?·æy®™~^ ÏK_@8¯Ö}r̵b;û¨÷PGÿØï-~ýØæ1‰·C]c…Çÿ}Á¿gÆ{<˜gÿƒ>ñ¨³Ñ¯M}%äAQ'2¹…ây_{cÔ'B_ëLAÝ‹?ûè‡ æßQŸƒ7FýÚs×ÀËÌ×€ÿÉÞ ö!Q xŒÈ|ï]QÝÏ}MÌGf¿>Ÿ}R̃O‰\™§H¿ªøl|ý楨ï/œsë|¸êÞO®ŸÆýç«›Wë9ª·ò½ìSp_ºxlðÜüùâÀ'ó|yÝuÖß.ÿpg£+g¹žÏ÷¿à½Ì¯ÏùÇè¹â> æZ‰ê> øjô§‹ß…<{¿—x&ôÏÁ[õœ$xLâºIóÊÑóMé`o<]?zí>ÕácZßáñI/Í[a>žä ¾Qøþð]÷Uÿ¼d~ŽýGÔ‰©—Ç=‡~/x«ð àKÁ/Cõþæ½2—J<怇­wØcöÀ‰h5s|áÀ£âT'6—þ~Ý+vÏvP|.ìöŸïáý:óüô{ô y.”ÎÁsl˜c'}ú3±øØÆ‡–Ç|ɛ瓈wIýß{lè+TÞýóþ<ñê\Ÿ¦¿‡<Ñ-;½ù’Ë Ü>ÞWì7r}Aâ] çÄ}wzŽ•Ë>>zÝ÷ûÝ/ãþFù)ñHâyMVp‹æ 'îoa^™úÕÿ\zò¦ïlo^v\y¶x/œì$ýßàän>œÎO¼÷[Ù‰„Ÿ5O–¹ë²›ž®ÕòÒª'Ä÷ªsÛòÍž± O}"æŠGNþÝs¨Ï3 ¹b¾gú¼b>\šWe¹ ûÀá‡ÙþÂË€ïL_¼ü„ìªíýCð)%ÿÃÏ-÷c‡¬%ÆU…èzÇÓc| ¾$s7˜d»~úEõû’gÏÁð½êÞÝ÷,ûºå¶ ó»ïm÷Ïéx>ü¼wîÙv» ~‘}£o'œ»î~Ä´?ðùÿY«ë©9Ñ;ñ\U7ç ÷1ÏÊïKŸŒðü]pú.ž½ëlæg §Âÿ4Oˆ¹Éðµ¤ÿæå± ~<&}¿ø‘Öcø™î{å÷ôÞÈEáøw^{²q±øœuþÞ³ª{g`ß}îÒÇ}ëïÏöûZïÁ…Øxµòœ»ç®Á/§ßWïÇχs<½Œûûû^•د2˜>>öͱTù$òÈðŒÍsÖó£wÄEØåµã~Váz÷3éùàãz>*s‘áÁWÓ|aò¼ô«…{Ð<ïž9.éø!îëa>ûfá¯1gHú^ _š¾j÷åÐW#\cý~ð<È ¿Ýq{§t_ø÷CÉ^x¯q}}<'}œì{¡Rq¼?ð¶÷W"£ž»ÎÜVâPÉ5úï=ÌÌÑùûÜë˜N¿‹â^Ë ý:øÄO~î¿ãdׯŒ7ًȼ únèŸ!À|gúöಷN÷`ü¯9ÌžCôQ1—š=pôKyü>sžÜ·,|H\ïùŠK§åwquÿãÇp®àoâ ægâÇ™Ó ›}®~æ‘Ñï©:…ûšÁô7°7ZvÒs.¯¸ÏG~Ïs(凼Š=Dìí”ñ&ú{¡|zÌù:B¿‰ð~Ùû†dçUhøiçÝócC\Ì^RxÔŽÅ¿[ÃyCÞ ÷ ÞZÖ5Ѷ#bþ68NÏ."Â=yNöï%nÒóyo/}ØùÛ}æu°¯@zGÿi(Ë—þøó7Çûð$'ÎiœûH±#àäQ}Džw.yBOÁqžÛ§üžôÐý‰ÄÇÈ©÷Í€ëèã×1‡A}]ž|îÁCæ«{Œâ`îÃ{ªeÏðËÆÌ×þ{Ÿq¯‰ÀÏy^þßñX<“Ê‹{„ìó«’'ò äÝ­‡š?ïy°Áü_ÏmÕùç—±ßñ”ë“ðPÄ_ò7æÄ¤ó7®ù½5/×s1ØÃ _^üXêoœ‹÷îè¨ËÃ'‚'b~…ΉúoÎooù°óðøþ¨ÃÂ?Q>$9ïƒ*µNp}.oéø oLYoÜFž„óÎ/Uu_úþ¨ßšo?ͼOÝýæá©nL]Û|FÍ)aoý'ócUg垈û8ÏÌã:oßóÜø˜¿-þdÞücÆ_±0ËüøZâãYßÕO÷·èþà=¸ž,^ üx4ô™Po6>àÓR÷„Q¬óâr{Ltß ó’˜«&yóuÌ­Ìr"~€ùˆœ?<ñ…èGaþ²øö+ä—Üÿ2*Ù»Âɸ/3˜ki¾|¼bíó̼óIÏɇgÞ<|mx\i9ˆ÷‹iV>û|Øÿª¹äí ÷x{B”uorY]êÄñ>}.|óÿø>ý>AÞów—+q}œG ï(¿^£ù‘ªÃ{d¾¦ñ]z~œùW¶3ðÛõï9Ÿxžg ïV|êôèôÃrûKÿºy×âWˆoè}gðp±CŽÿÅG€÷ƒ=ƒâþõ`GÅ#ø¹á‡{?’梘œ–WÏÿa®=õï3ÿÇï©z}»Ì6Fü6÷aHàó\œ“ï‹ý~ÒËOš×ï ;ëx^ªps”×nXéË.÷›U¼ÿš6‘yÞ(¿ÄçÂÃÂÓR¿“óÞðéÃ2?ƒû‘? _&˜sãþAóùè{S?½ìC¼?Wó³x?óO…ÌsÒs™ß,9¾ƒ/Ì'uÒç»Æ/¶¾‹ïF¼a¿/¾ sRà‘g³~‰gäßÇŽÙ¯©Ï9gà‚é•zv}qšybðäÑ{ô[u)ó"áÃå‰G.~¾ëTœS0?<æþ‚q™o?»°Žù»Ø;Þù7ß\Ax¨ÎWØî輑'î~XþÌ£þóÐÉ"OÄið­Ü/¿^NÖk™Ï¯U<5Ç+ämñî+*á~H½·ûÓ|NËýðñÛËÎ|²ñékŒ·˜‹è=iðŸÿÞGà{‚ÿJEn{>é„2æ›*»œÓcø3Ó—Žtž?ó/1Ï„|onÞ÷½“Ù"æ5¦û7ì?Ùg Žó~_á¡ìͧ\?íÒ(wYƒ…§¾Ó%æ_I±àmú$î+×{x#ï?ËñƒúFeŸ¼/}óü— >„=â~™âùH‹î£ß?®ýb1~Ocßñ—²;è™ûkÒ|]æ3ÆöUüYìþ—¾ó'á ËN˜‡‹<Ñ'þ!¸Íý à'Íå^ˆ£Ô7fü†ÿR¿˜çDPo7ƒãòûïy9ÿ¼.žWE†q5ý êa¾%|<ËMúsãy2ôç ß²_ Þ5ro×ü_ú!eW|ØSú•Åku?¼Nú>ôô»R¸;NÍq§ú…Ï¥¯ØÍ0Ž$®ó9ˆŸÏW}«î7á¹ùyäÏý­âq³7¼6xÔûÙÀóô=ÒÏC‰äübü!¢~¼Ø¾ÓÏ˜Ž£¿!ß«ywq´øÎ¼GÈ÷6_˜~DÅ‹Ä7ð±c–ú˜ÕdÞ~šOã6ùMú–èç&®0–'Ùpu;Û?ñþ š¬y½ì¦ ÆÄ­æ©‹oå}9’[úî‚>Uø(æõ"ÄøM÷;ƒ×ÓþÄrC9qªû%Óý²ö¯äAÌÃgþ‘x¾àmúGÉó˜o-;éù¡Š5_Ûý>Ä÷à†‚–É]ßçñ6öŠ<óMêÃ!þ¡ŽD|Ä>aã;ù â9üav~îšOVq¾ÏýzêOa¾¸ó ê?AΜof.‰ü™ŸSñ‰ëÞŠÛ°sœ§õEqrNfžöÎx)è7'^÷|Ù_·þå«â=Ú†¾ÑOäþOp‹žÿ­Ÿw~þ=æÿpþØáÃ{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïUùÿs¯ ~™<=õæ™G=@s ÏëûK§®wü‰ýã¼ÈW±GÅsØK"<Éó+~±<"ÏøAü÷挷¦®/÷¶ó`àpâxü~…9käµ<_Mö8dÃe×$~{Ÿq u,òoö_·µ:uL‰k¿b·è?uÜ-?ẞðî–ëýêÍçû\Á+ä×ÀÑôeº_Tö>¾5—Þþý毿ç ‡ðs¼§ßGu!úÉ‹à?§Åq¸æ`çå÷½'†yGê«ÃÏ"?Üuð zHŸõ6ð'ÏÅü)~Žúç ^G/y~ô…þ@ä;Bþœ?›| ñöÙûs¨?pÞ²—”﨓;Íu<‰}àùxî_ú??óÔ' ¾&žçü·<5y-c9õ ã+ÏQ#Ï+\`<)y >q¾HþóÁîqîv*õú¹Ëš:n·]“=õ}ë¿<7r‚<Û G†v&Ì÷»oWçÈùñ_pŽç1' }§ëýÐK˥梬òÄýG^¹Ðukæ 7ç“GÂNÐO îG¹Ÿšº&}³Š3¤÷ÎaV,[¼¿s›_\_å|6tº¡F›ö5ã<£êþàäÜúD\¢ó >kœ çu?8u6Å×Ü?ïÇyy~£âqžyNžSIÝXýÖüñvœÏEþOQ<í¾xé9q§çdHÉÛ¡WØsì›ñƒä<΃¢^ÔÍãx>íwmg\ßÒïßíø´^åë~*á÷ çô¸n)ýäžGôEïçüuÎ?èy‹è!ö‰yCàn× ä?B_Ã9>È?óv,ú{ÛAÙ½-ÞÿrØ¿öǸF÷î9-Âk–;ÉüaûCÙ]îâçæ¾”ÏÆïb'°3|ã'É5ñx)´¿Eì1z/;à|?Ç9èy.ü+Ï~³Â¾âœ·f®Î‹¹‚È•çÓ!WÒŸy¹½Z2m½ããRá æà®?¦ÔØ~ÉÃ#P~š÷f¾xÄú­ûǃ°ïæ_èý7-=ê¶ûFur?yÎÓõqå÷B;H‘8‰{'Þ·ó{àžûÅù{n›üÒÚÛ_î:ã‰7]ïò¼Vå¯|Þ³ÇÔþòÈæ~â\ê…¯_Ý£àù&–SÎ{‹â>˜ïiü&{NœúGô„9›¶Û²_š“e9Ñ\<û¯u/­Ú«ô©¶ÄSØ¥-Ÿ>ý´ËöØ®-J–ÛüÝÐF–oôÿFÏú/üéøB÷±¬B‰·Û_7Êz=Ý4ôdžw\r2ýŠ©K+~ñr“Çã|ŽüFˆÇ9âbžýÏ„üb¯±7®×K.ÌG‚¼<Õ¹ÿɾco¹ü¡ð¦ù‚Ü'öýg~yV>‡xÏ~R¼8äùc^«í£þì<Žîƒ?wÿ'Ÿƒ>cÇø/~‚|Šâµ¸*þ2sVBy¡K\Î績¬xùÀž‡|?îÛsœ”/ç+m„÷ÍßQ½ÞñsÕe'Ñ3äÙqŒæ#O®‚”Ïãù w¾úÑr»ã9ÄoÊÏ‚ç°gÎ+‘ï#^Ö÷aw\ÇÕï#¿Ô}¹oû{ùÇéÚcF‹<ö=£žŠ@¯ø{Ι8ÇuhÎGý¹È¼k®ì>zDÝ‚{&2Uv\rUÄO /|.þ¿Éó›g+}FnOÿí´iÓzÆö¡9Úd¿‚ýqü ïEïVÕ*sÔ¥ÛÇqºä•ïªÞ`o¿&»B\À½ ÿÈ~ÿŠ^ãÂóô|VêÔÁûàøEzC>–9]àWâ]p?/ûjŠÏGqgpæ½=—4-ñþlêBznì¸ûÁÙÛà¼p ùŠÄéx€¹E1€xƒû–½—œÚ_x¾¸êƒØǃ:GŸ7r yâ{È·ú¼•ßåùùü‡þ[ü|ŠóÝÎßÂNàs™ÓÅÂGa~žžüâ¹ÈžË&ùÂN:ŽÕœ3Þƒ÷^Y±Ñû}ÌïMv;j;%ûÌmÚþ“6qݘù Ü£üø»‚üãO‰×©Ÿ`·ð¿ð—×yƒSñ‹æµÈN#·Ø×9d?Cœåß.p|ÏGñ‚ì‰ù9Ô¥ˆ“8wp7xÛr¨ü:ó(Áü—óp}O÷Îï3gÜŽ<òþ¶7Ô•¤§ÈüâMòœ?õp ñòâþ& õȃ?¾åöã–:Àù_ /b·C¾ZÈ«¤nÊ&òðàPò†ž»ª¼ç¸äÒwêTïÿa,_à*úžç3Ç™ïq]JøÈy’ÿqBøÑ¸OŸnQ·àûÀOæÕUªtÒ½wNuåy ø'ý~œz­ó´iy0ÿœà¼±>ÿÉùëÍû¥~…¼Jÿ­æéPÿ#oÊþå᭗ʃ™w ¼LfíyY¿žá:0ùjâ‹uSþpOÞ"ë ü žƒüqòg^}i;XD¯¹oÏ¡Mû•xÞ½îÍñù}¾õþÎsǺ~.;„ýtÝ“9¬òSè õ‡ƒýC/Á›òK~O×QÅoã9ÁwÎûüî9uøðc‰×ÃùµÄ‰ü×ç¦÷r]+}}á¹WþÏ?í³˜§.¾4ïå8P~Ùr§¸Àó<…?ð¯î¿TžØç ÿC“:—ù‡Ohùí;Žéöž¿þüŒoŸ?½W˱Û|‹.X0þàÈöwœ·ï‹:u&ɱ÷,0¿WÏÁ¹78ï¯:òA>¹Â>óþžëOYõ7žÇüÓ ~ö‚„ƒÍ¯vŸ#ýuú³òæi 7Þ+'œé~^ñ°¼ß/èŸgQ¶êó<—_ûL©a—Ð3롾߼7ô†º­ðq8g‰÷räé·SüÈ<œ¸OJûqÍç–’à^Í3cŸsKÕ Ÿ†ùSÜ3ŸGëyŠo°³æ³Gx2m|¿Øp¡÷8(?Aý‚>E~Þyé©ûw9½ïé¦ë“ªŸQÏ@nÃ|Ÿçʉ¦û¶õüoéøÖú¡ñ7ðƒÐ›0¿d^¬â òæîÏ€§zò¿•?›.Ü)?ê>7ü”í¶~|áz˜ôÁv <.ÞÅÊIí:Ï{v_Ü?¨{¤žE?°SäMÃx?õéÝ w¾°sýg±_“^WÈgx®¾p¢p_§ò‹Ø òdÆ•’SòIÄiöëò»s¯ú䎲‹ì×Züïã–Íž¿³Hü ŸØû‚¹ëÞ¨¸ûá}”:OôÃu^ø­œÏéó¦’=Fò3¿ÿ4!ëÓ}ãº_Œyâš»B~’÷ÂÎag© ¡×î¿ÒKï ®Y½bu™ùÔ´¼aˆ£ÉÏ™/¢~/1ﹶÆ#[äþjÉçš÷H]Iú¸,ºyG¢Ã%Æ‘ü=8Òó è—Ó¿{/+r¿Kv}"Äý»ïPz0õÚew»4ÎËÐïe½çâ_˜[Fß*ùúÎtÿÜ‹Ï?Š_LË•ónàUü·ñ­pz輟âîp߀ëÐô“ŠG½‚½ÁnðùžÏ¯÷_áÇÑ Ë¹äÐú®<“ûptðomÿ¾´/É|~Í{ Uÿ¦¿ùð>ì»ð;8]xÅ8üÂ<÷‡1¯A¼ï\/u¿±¿ÓÇþ ö˜èüÈ+qþÄGàCþž8ë:¸2à™/D¿v·9ï§óç¿äé¹'ïmeß-÷¯s&o?ÿäúQ°·¿‰}òÙ p–ã4ɳåÜÁÞc½~‰ûð\x¸Øoêz>¾‡|¦óO:gÇû:ß§ÿK¿þñÄ¡7ô»â‡ÙsÂÞ2;}NÄEøuâ¹5ƒÚþç†{Ǹ®à¾]öGÓŸ.¹4¿ˆ¹%ªWrÞÔ±f÷ÞxÃÐwkš·kyJË‹ûëÀ¯È«åSvÏ|oòäÒCïÂN2ˆú”ΑçÅ. w!Sßç~&æÉ€kÈßÀOÅžÁ2/<è70ß üû÷=ß1Žör»®Äny~ÿ½îÝ{OèË•¾ƒ×Íß&߀]ïJÿíGé»ÐŸÑóÐ8G½ïgMŠêT³už‡º€ë¶²3öûéûóÆÂžc&;„œ£ÿá|óíTŸ#¯`«s$Žt=T8=ùæÕ’WÇŸ/J~ý¼ªÿ9þ!ÿä‰Ì÷æç‚|yâðuç›$¿®CéýÝG¤ºöÍùKÉ¿û\å·¼Ÿ ¹eœ>ÇóذçÄ Ê󹮊þ¦åÙuvòöÄ“ÞÃ*y¤ÞGݽ1Èy-óÃ%¿î³.õÒ~AþÉrM¿„êFþ\øÖìS_#þŠ:,÷ëïo£:9rä¹3úäÿfyNÆßrž3@U¼ƒ¯¸nAþL¦溈ü‹ë¢Ü—ê—üœõ޾ä?†<á?Wvsu=ƒ9MÊïØO¤ï'æ±0wNý™à5ë¯ì‚÷’é¿ØKó[…éß3O”zÞÓ{étÎ)oI½}·½Ç¢?û~tŸÞ+>kÐWb^!ñ–ûóà—*ÆU¼—ó?ìc.¥pãè¿Ïs|iÜ«ï1ÿ_ÏO~Âõpê—º?óIá£Á ãÞ‰£„»±7œ§ç)ÈÀÛ#¿¾0o=°3æKé¾á+úÏÂ펧…ù¯ûþ˜GBri»¬<—y?Â慨Πžƒáy;:óÚ…Ÿ±çÄ«Ì7À¿ÒçÃùñ>!ïýí6~{ëy(ôá÷¨§H¯ŒçõÞäåðcðM¼7]øÔ}¨Ø'ô;#‡¿Ä˜!ûïØž ­º>ó´´OÆöÊq oܸÖùò¦Ø?þÌ<§7[/‘_òoÌý _ˆ|Kî¸'ävU§Ù«=V)î—þ:¿$= y æÅêž=ç'ȇÛêyÌ3¦>!|Nþ’ïó¼éòMà±"}«šF€ãMýœçé±?JóeÐGÙ'×»Íû×@ž¹ÄÄùäõéÃ¥O˜<«ð)òå}ª?:>æþy¾1}©ŠÿÀùøá/æ1;þO§Ÿ79îÚ›â½7ÒøªÞ³Á<ñä=ŸQs`=”>ý=òï9”²ÏîcÐó1…xÃþFòaÞ‰æäÿ¥õÌ{ /Q‡ÑÜ!óÚ©#hO§ùUð T_p\!9à}œÒ¼Kíß+ÒÏa¾õ/Ù;ô¿íyÚÚ·Îv^ôï«äÄý劋='Bõ_ÏÕ–Þšw©¾|ç+ÉcQ7ÐûÏÚ‘/a^$8œ9ŒÌÍ£®)9Do©“aÝ_ˆ½šçm¾¦ô~dó¡…ß¿t/Ž3é“ÕÏyO{伟DóŠWõ^Þ[$Å|Gó!Ø/)¨»c‡ÌŸ'Ÿ¨x¼m>õSôF¸“8›<±¿GrˆÝµüÒoš¶wæ‰3‡Üï¼&ý0ò3àlâ Ïo”}ÀϺ߹–š3Ç\Zò@îc%¯#yÂNaB™k˜¶ë~>ÏéÔhç}™ÇÈü?úºÓ8Óç€0?ÜŽûsˆ?œGHÍ£¾Ëœ ü#¸›y˜ôŧÿly4ÞÔ½†óL°ÿÈòjÞù"æY ÿy~³Þ ûk¾?<æ©îC>Ìuú³¥ÇžGýAÌ×ÿÝûÈ»áÏÉëß}Îñ\dù±0¿å󃃗ª{1NÇ®€gèë×Ϲ/•ÿïÃo¡oyF¿©‹“¯fûÆØÓ(|ç¾pÙwq:r«ú7{Fã<°üpØ÷Œü;·Á~DŽ©¯s/Ø;úÃ/1'NòˆŸãýÌ»NÛ‡(#½/7æŸêßÃ}*ä'è‹Är®® Ã?@ÿ˜OÌsŸ2ò ?›:sшÅ·×üð(ãý¾×W©63Žï˜¯ôe/Šœ€WÌg¢_‰¼K0Ÿ’z?~ÛýNгV ©õñ¥m»Äñµþ»ê¿§? þ1}XØ#æXÈîq¾Þ¿ÉTx]Ò³pÏçíù}š£¤ß‹ãoømÁÔpÞ2ø•| û¯°[ê71?›ù ªW—aç©Ó‚ßôùø+ð¾q?|9æ­+Ïè¹Ì}e®œp?ñò츎¸¾u9é§çåê~°sæ© ×Óæz„ò¶ž·Eþ”:’âöÙ;žÕ<)úõõžìac¿\‘¾ç³%ç–W塼g@õxðî¿Rüä= ÂIžó®÷ûÝŒwÙ󧺮y5ìb¿‘îÁs ±ìO. ç ›Ç­|‰ç0*ÿC–xŒü•÷¡Ëïy.ú<×Þù9æ Q?‘¼z.¹òÖž¯ ;äó%_Æ)úy‰'ô^æOþ=ïÏ}‡/ÎóøFŠwñsÄMÎKŠŽ=#nó¼0僌{ÓþÛös¥ïÆ{«˜?%â1>ŸsñüúPÙ{¢çæ¼Ùÿ`¾6ù,Ù÷C0Gœ<Ÿ.×ïY˜‡Å¼ó Ï%œ[Nþ³BÃO;ïžó¾é׆ï_Zø ;à½ÂK®ý÷<—í xçä·æL)vnÁª –wçØ_AžO÷âù)êW%n4¿Bý*ØIøÞ£s‡_=ð>NÍ¥Äî‘Ç"~vÿ){ÄäÏ™ ézœxÓäM‹Ôed·Ìc§9Ø›ìz!|9£ç¨ÁGdŽ>s†‚¹úž÷©ï³}€·ŸÆáÖ òCæã¢¯’ çÿ™û@Eq®ëWú|æ†y.˜Î¾öÞŸçwS/”>ðÜø‰ÐîzN5õ"êàu>‡z]ZN£Œ Vlë×ù¡¸‰¹ÌðWÓŸë8?j\ ¿Mx^znÞ2¸ÆùdâÅO+›uúöVñ¼iÙ+÷=’OÓÏ{¾RZžÌoñ¼sìŸÎ>2q8úÃ9zž)óàÝêÜ<ÏJ~”<¥çöë{ÐwòrÔUàÙrOøçodg‹øQÕ_Èó£×ž;¨ó!]4_@xyET1>`>zíþô¾:õPâi='¼vÇÇôRÁ3‡Içèý/ð×x}>u#ô–sr£ó‚g¤ü’ã_Ïo”|xÞÖßç£Ø>†óªÌ÷'?žÖwç‘wú¶y¾_5È{x•¿/ÂS æ¦yÏ ü¶y|œ_÷Û>²g€9xŠ'¼'žc0ÇÄþT?çy ìVÝÜyú1äÖ.)6fÁ «=§ƒzõd䜼3øÄ} ’/ôÓý‹Ì•I˯íüKÏ£ÎyŠÂüû}…o©÷€Oáß›'Â^==?<æC›ŸÈÅ`¸÷Epžð¡‚~Dó(ˆsØGFÞ‹z u5ò*àXò}Ì3 úöÉãÁc?*ùzð vÎ/òäÑä©Ëøßá[_Ò/¦}Æ™-^>4óŠ8v}Qïiþ'ò~£/ ^7{›™—@œôÕ‘wxéÓ¸¾Î¼Fü÷Mß÷N+8˜~Ðoá½dzop£ó€Ô=Éÿ`Ï™ÇB¾Šúsk˜'Å|oú»e7±k«þUáõŽëÞûgè·’õÜkxðÜ$î÷Ö ×u؇¦8Áó#ØçN<ôÁÁ·²? öõÿÀ·Ó9Ïb'5¯Ês:=ïG8ã9\à7ü„ü(û0y.ú)=ÿÜ$;J?!zÉ=[¯Tómêàâ/x4мg•ú#¼ö².œ;¡{uÜ ¯ˆ~Lüøˆ88˜;³º|^ß*³FÇó¹Èë0IçÎy¿r<¯|®çlÀÐó w?!'ìÛ þÃÞNúô¼î¯…_ÂÞ;òŽä Á7Ò7ôÚ}vÌ¡V^Êó®‚}±ðòÂú <§q3ÊÖè^¯xÜ?->•û Å››vïûÏÝ]¢0æS{>Â>œ°¿;ïž|ç$ Q§ÛÒ׃¼ÀÏ–¿¤®E=ùt?2õù;ﯢNHœôU˜/Ä0½7s䉻Ùwî~ExŸ²ãÁà"}¨a_‹ûã$ô¥8ÈœnâSöRg•¾€“øžŸ89«NvÔÓ§8Îò¼=ú1ØO<—Ž/Í“5¿òïå?<§ˆüDÐÇ„þ˜ÿ@¿/ýëìcU¾†sã½8OË/u{åÃþÇýÔéS£ÞEÞ¾³€gAã9úÏߦV÷ƒ½$ΦÞdÞ†îßu ¿ósbþ‡ì©ùøä»ˆgá‘‹GÎwñÜŸ`ÿ.òi~ç#ýp]ÿÏ>Uöš!¿²gü¼q }VäÃ¸ß ÎÇôžú韀¿ÏüP}žç£õ¡™?zÿ§ºŸÅûÈÙ¢:eÀß4.S>ÓyêÅžK¨÷&^áó×{ÛÙC ¾7îžqŸx%È7¸Ÿš<s(˜ÏoGñ-ñ+øµˆþ‘àü˜g&{ ŸÝû½¤W¡}@<Ç•>¶ ®t} (¿¿n~3{ˆƒ}ÙÌãEΉó¼WXõ;â:ïñ†ï•~nö]Ð/ î‘\†sŠÑp#ö>¡ý$õ?ð<_öÐÀû‚ìó3?ÿô§zþ¿ø­È…>Ïý$®“€+™?!ý'ð¼Qůž»¤ç¦/ÕùqÙ/ó£¿ï‰û…»ÈW°¿?½5äiR/×¹Ûý¹Ü?ûDÃ=~kNl¼iKjB‘}¸Æ¿Â1Ô¿/+é¾ZÉ q©ëæàzxBð&™3 ÿFrI]»d¾»äÁûõè³. ï‘çòóÁÇ”¾¸^†> Ÿâ9{îüRún™‹¤øÔsàï³'Œú²ôËûk7RÇx.žüš÷W*ÿ@>ÂýÏÁ|.äÜueòëô¯’Odßsvdo‚¾“(kr•že>Yá¶þJF93Zö|ºÏyQÖisëµÎø"ʺ¢Wòá‚úQ^ņÿùíê)Qvûñuwžù|”\³ïÂŒœó£‚y;w=\ò„(«û¾&©¹É(g~¹67¾4+ÊÎÏ]ÓâÉ*QvƒËÚ^¾5õ•(§â±¿Í®03ÊùëÊ·jÞå>ØiÝ”ªÉ(«ÅCËϪ|^”ߺ`äÄ{D¹¥_έº0ÊÚR¥Ùâ£:ƒŽrúϸ2kÄXòQ²ûƒÆ>Œ²rv<Ù«oê÷Q~µÑ3kù—=8çõ.oZŠ:—Ÿ#kçÒmÇÏKF¹sJåo^ê÷Êòí-vÎFxNQ²ýÅÕ·=9$ÊU¢í³{GY³þµõû½¢ì¥5“ý§ìgˆß#û»íõ/+÷yµ(·Ìsäôû:JN?úžUçå]1±í‡Ÿ\%ëÕ«7ðõ³¢œ·ßZíÛK£¬éç=×ýº-ü>|Í(«éˆ¦…“"ïâ=Š?Wú¶Kß+ ß;ʽbñ‹×üüD”™Xtÿº¯†¹•ªï¬%'ÿz÷¹«£¬ÿÉí¢Ü.ù·µÉÛÅþÿ7»Âè/ê/®ƒ}õçæ44e쟹Ÿ&wYƒ…§¾Ó%*˜yLÝž£‰’o–Pfwÿ~Nnã—rÊeOî8ó’‡KEYKç8~ð”¨ø®í?ô=v8ïoÜç5ô®[‡·iùK+=·Â%ƒü÷ÉŠ]Û]üë¦(÷´Þg?ùä(_¿Üf—ªûÍÌ»ûE¹Q•×ÊW¹)J*®ÈO4ú¬Ì íQæ²-÷¯75ʾ¢ë)ÅÎkc9ÐûE9õšeV{ñ`”}ÚŒû6{+JÖx-çÙ#?ñ{À£Í|è–RÅ;ôØuӋ甋2Tºû¶[:Æ÷|ú}/ït(ÊpÓ÷w»&*qvAÏÌ«j[n$¯Qv¿ø²Á¶(¹ì‘¼7^Ùå•ùô’÷~^e•l¾­ë›ÙóåîÚñø¯-ªGy5²Ž¼àO¢Ì) ¿ìöÝÖø¼Žk1·ÉýOX¿²g6¾yi©Qö¸áÃ×gL‹’-M}¡äö(»L÷]77ÁïÇŸó†ùùãŸ]ßÇîÊu/ªþ|”9ôÙõŸßdýÉnuð‰÷Füu~ï7{ÿ˜r£¢¬Šoõ[Rx–¿/ëÁJ;‡l®ÊÞúÇ-ÏÃ2^»bé{QÁ®­mZ·-%›Œ^øôÌñ¾¿œ¯.¨ÛoòÎ(?¯Þ·“Û®‰ršF­?ÜpÐv"y÷’ m†.²Ö½xÅYÖrŸPvËGçu¸õÆ(³÷°…§Ö>?Êk™Ýä‡gžˆ’}ÚÏ*_¢†å5Yú؉Q…Q2jŸ?â/{0®g¯ËWw÷ý£çü7çì1[^vßezì«¥…[£œ•_ü¾÷¶({í]kj޽?*Yaó·-me÷iúéS…»£œ¥ÝÖ\½ûhŸOÖ=¾l×éDß»ìY”½¹ã”ë§]jýËÍ»ã¾w2[Xþ9×b­Ï¸µ|Í­7Ö·Ú­Òí†({h“‹V åŒìÔsÖ1}m§°Gù©ƒ‰‘ŇF9í_?톒Wù÷’g¿¹öŒË¢œVKš%_éêÏA.‹]0gæÌOšÙ /šß%Gæäm}¯{”]m^‹×û–ŽýîQýÇñ=´.{e¿ýøÞÑûÜÍóO™™:;þ<é[~ÿ=/çŸ×Åç|ð·fcFœå”m3¤Åý¿Çö\犽ËuÒç»Æ/ŽN÷‹ßóûÊ_Ù./?á)룼>猙zÖÐØ®ŽýfþÍN²|!¯ü9¿ÝŸ¶kÕÅŸ‹ò\âú¹°C–KO2÷ëÖKŽþ >¯ß>zÇ#¶WškÆž¯(÷«Ö£&\þV|~ò‹ØAô'¿É²âÓ¤|¯yÒç¼µû{/úá/;xíƒÇ7ºãêø\oÏ|¬þ„(§ð•oìWßçÆ{ªÍç]PáÇÉ5Î]kœ;*Ù»ÂÉØ~"¹Ó“«WÏšdûæ{Viôú}«í§2e2Z¿õܘb£b½w¼ÿËÛDyß­ú®öç¢ÌÓv¶*8q_”y\çí{žo}F>ÑSüvPý°QrÞU jÀÞ<ÛuìK^îî2çŸGÏð_>7¯Õî3·-«æ{ɘ^á•I˲£bø%Ù¿ÌNíÙxìJæ¬ùóóÒûKüïÅS[ îøó[ÛìþÏþNz^\v »b;)““êSÿöo²‰ÓmßÀYÓ+õìúâ4긖SÞ“ïµ?yÔ:ùQðšë•9뎙9sAMË_Á¸Ì·Ÿ]X'Ê›ñQïëÆE–Ïœ]Ó÷}Zgx”_xAí ÞZh‰ÿ±_”à§Ä‹’_½ûË?ÖÅöO÷Ày Á#™=ŽlùÖ:±ßÒùó9à7>¿ ¾Ë­ÖîÔukÇöWö¼¨~›(¯i¢r«Ñ|¾Øsü¨ý®ìe΃ugoÍZë{ÄŸd§FÝ›\V—ù©QÞÍ¿>˜¬õ‹÷àùø¾¼RKŽ8#£ýy²ÿ Ñ/UͲ>⟰3è3¿§ùÌÖìbnÓŠWåÏœ¿4Ö᎒3sšŸ>ßø€óÎzm[ãŸ2FÛÞç®}t›}Œ{9Û­]]7ŽéWӸϸ\àsÕÇ“Ñ3ä:¹yÐÒËŸŽ²Æ—{g÷¸1Qv—RÕŽŸ²!þyž7½wÐú£~œ(ç´‘WHÝNqT¶;À닲æ•X~íœéQö?mÜKF”÷U±ûp0*Ö>ïÁÌ;ŸŒ „C»—Sú³æ¿]UÎ÷ÛnúY«n\ïaJï2nÏé=mú{³ÿ2~n㱇ø/û#éz‚ÊùnN•!«Gùéú|”ÛbÐé~/Ö¸{ÇœÎyAo±óö÷òïÂÙðª}^è÷‘Y¾é/=èŸ+¸¦tÕ)UåûÆÞ!ßâ ×Á¿ðy ¯Æã]ºÝº{{)Ç_è~`½^áWá÷„«¬¯Øùkâð¨úµüùè%d‚Ïòy‡xÃëg8OÀÏ‘'(Ñ{ÿâÑ×1Êê3`óWg´Çn1Âï‹üã/‰—ä×¢ÜDÅòoEùõr¶\Û(~ïìy3ç43nä|À#çþ”ÑõÝ(óP‡R¯Lnk½O8Rn@?Åïqaÿèñ§_,²?à ÛíùÇŒ¿ba–ý%ÏcûË}è÷ó%¿àLür^»a¥/»p8õ‚8.’=Vž‡~9ß—øÖWäJ{ÛãxXy⟓…|þ:qàÝ‹ŽzÓx3¯ÿø1ïó•ññ¬ž?Žëƒxƒ{°žÉžpNؽĜþÅú}¸5*V˜Û°{õW,ßøgp;~¬ Ï1ß>8ù3¿y!þž~qì-¸‘¸Ôþ[~ \¡½9ñsê¿ù‡ÕèñËÙÆÏÚ·k=Éî߱߆Ò_oä«>§ìŒ¿pbƒu ¼7<¶ÓäÓ”Áa¯ø|ì'þ¹pPv–ûÉ·÷ÚÏ~Ù瀽á¹xìpÁkΙôã¶+È#þ•x˜ü ß«¾IãApþ ÿ‹^ÊÿÆñ'¸TçMü‰Õ}Ð?ŸùÙ…‚²·¶ §q¯ún¬ï|_FãÚwo¹Î8Äy)}.úο“BŽÑ3üAA”=ðÎ{ô=òóÖϼÝõª·_ÿiŒÒõñØÿÈï7poœç.~­ó.ø9ÛCÅÉèCñ »ú}¶úû¼¿­Ì|´‡íþÞø•¼‡ž“¸¼ö|˽qŸg—Ì¿¥öüx{9˜_M_˜ê Λó=‡Y¿G½*œÓë¹ýª·¹>É> ö߉wàú©ø÷îÛ£n ¾Õ3©ÿš_¡:5õ™ÿ ÏÞ}¯ÌÍeNûè‡ ¾×ü ÕÃ9RÞÏ%>ëð²™/OR÷ò!½#˜{Î0ÿyª#Ô‘‘+î Þõ!êÿî7„(þŒ÷FÐ,y‚Gì:´žÇ|yø`ô ±ç þ?u0Õõ¼ÏÞ8ùÍÃw}^6sÙkÌ©·<3?ˆy„ªk2GŠº´ëVâ¯y.û¹Ò<ÕxŸs]T_ã^\§Ÿ¾—ž—~ïù¤ÌþLøâÕyN} gÞ‹®~B÷ÓI~Ã}:ß·ÐæÇTǸ.ÈþA¾—y…z/Õeã¾vé›÷dÀ/g?ÿ½€—‡ÞÀâ®ì9.ð³Ù÷©¹È}‰Þ[(>‰÷jéïù<ï7g/‹Þûì½âšsê}Cð[àÑ?Ã>CñEà)ºO^}i̳„ÅBöÇ{/òC¿.ý[Ôÿu?އ˞wý õuôž°÷6¨"”óp¾ çÁy™'ÿSõeü…y[ðT‘é÷ÐÊ>bGÐGÏ §þ­ßs_ì`8_}ò~Uæ¹ÁÛRÝßó˜*~­ùÌ3¯þ±÷Pªï?¬ë{Ïúñ…ûb¾äðg­®§æDïñÿæ÷s­u?qßµüv9^žŸþW¸ß0ØCì½Aÿf¸wËýºôÍj$}$ô7cÿ¹7ó×Ùû o>¨ü´çSÁS öƒÁky¶œ#~Ûûá˜{N9üp_Þß÷Äýbì=§½&è‘ä ¢÷°ð½ð:é`Ÿ ûÅé÷§“ùîðB™?À^沿~L°—ÏýòÌO£ß(}¶cæíÉn{¿ŠpŠqM0oÞû:áÃÇÀ ž ÀþW½/çŹ0·Ä󌘿¿½×’'îÍýCð°èï æç˜W ÏMóMŒ+ø}½§ý„újé ®ZneßÝo«÷§{îÙ„ßlHv×|_ök~¡÷¡1}¶Ì9–¾„ûèÃ1o‘}-ŠøÜ"ýºœ‡ð©ûøé×bÿbš_èùN!ž7o‰ý;ôŠÏå¹õÁäÃûħc®Žû˜ÁÄQÌ9לìƒùFÌe•2.ÿÑ}Ïøñ¯ÀoÞ㥹֊³ã¹zÌ—•\±¿ÚóÍà53WJñ¤ä4æ?ÐÇMÿ ÛÏ=æâznžâxäýrN(ì ¦_‚< óÆÇ0WsÅ®²'Éý!Ì íù3æÖû\|_ì[î5ÜWƒõ9ÙχÁÓgçây¾ÌÑÐó„suÝ­óp*{eäWÁËž›Ï[úÈùsnäéov¾Eöå·Ë?ÜÙèÊY1¯^~Íó˜;ÌMòmòÅMÏÇEOÁ3ßãç§ïÛþ‹½µÊXnƒyxîã–}2¿_þ(ì;5žcO¤ú«œŸÁO*_Î òs3Ÿ•¹A^2ÜâUp¤÷VÇ ò«î÷!î ú錈+‘ɳû¯eW˜·â{!ÂÞÀ`óÌS ßXx3œW˼Ûué%sì‡ÙÇ˹ÒGÆÜøÀ¾ƒ—Ü÷E?ýöÁù€ÃWÏ}Âîê\ãtÌ%sŸù=Ï™•ß|sôãÜ£ùáÿÅ‹E¹3ú¼úÇiýc><Õß©ËdžÎŸ\×¼ê~Å:/.··ÁD×—Ì›Q‰ú¼êµCËõþM9ó4àÁ¦®l^•>?¿Ï*Ù2®wéyü}ªCQowÿøUÄ“žS¬:˜ëŸâW‰‡Á\Ÿ(㪧®}sê®Ãà ‚Wï ^ïI]^ ¼ ø\¹5î}ø¤ÊDùëòê”jåU¼ÿš6s¨]/†O_‘º©û/T¯„Gêó?‡çï»ås¡.O}’󿽍ËÃO†Ÿg>¼ø:îhº`ì™×g:Ï¡¹ñù ÇgžóćïÔœáº!üZêç™|Ð÷èâ÷ƒ /MõaÍ]„ïáxSñ»ùÙÔo©'Ãë1_T|(ø°ÈuT×;õóðJ‹OÞ~àÒãÎqŸ‰êÉØ÷pô5+ogÞ#zÇ=Â_4Ÿ^¯øûÜ›ÎßóžU¿'4‚:K0ŸÁû Äp½B}ýæïÂ[?ÇûxoxOá9ÀGÁÁ ?Êy6ô7¿ÂÔ×ÜY+ÊÚ iéú—øüàä?0î÷v[Ž‚è}Nð4ͯ^öŠ> óÓàɦùæí©»óYÓzèýSùÏ•i_íš›ÍK5¿\ýæsIO J_ðÂ=Gž/ ÿ _Šy$æçVèWòøæ9~/ÅÓæ‘ÀG‚ç'»i{?€Ïˆ|˜.=/–wÔ ÅgßÄÜ:Ûíü]³¶<›2狟2ïX¼“˜W™¶ãÆQš»o~‘äüê=…ÌCoáÍÐçæþñ0àáäŸ~ì³]T3–'éö˜§‹û†÷žÑpÀE«¾oÏçƒÏÍï„_G¼z÷se|@äχß'½õ þ‰ùK⡘?,ž ÿeŽ8Aû?ÜObÞ’øëøø0œ‹úïÍãu? ütx`ðJàM¥õ4Êüý_Ç ¿;Çï ÏÈ|Æô½‘O3?[ŸG¼´.Ýó»w¯ôóòþâ ‚/ã¾BñóÄb>…yÔðèÝŸ'9Â/’T:æO‰¿†ßBØk‡þ¢ßàä‰û‡_‰ß2_J~»óª¥1¿O÷"¿Ë\ ãË‘ðEñzÙ+·ý§üj÷+‚ǰ×ð΄g˜o`ž;÷ OQüGó²Œ+„§á¡›w.;Oß¡yÍéç6pßý ïؤl÷G<ÿ^°ÎÅv“燞ß`^M/7^ƒoFßx>§ô–xÎþŒó§Æv;½g$ö‡ò_Æ[iyŒçœËŽƒ£±GàÆŒ.‹Ë=›ðžõMGyÌß]®Äõ~?óléÛ¿Œ>5ú£ÀßæÃÑ×,Ü.<@ýÇ~-?ýÖGú8ÁõØCüòh?ÜdÍëe7M°ŸÀÓ×Î5ÞLûIïi1?ÇÈ‹XŽ„KÉo3—ÃþüV°v]•VÛÊÚÃÇ%¾Ëø¹í¶•ûzZ>ìßÁyð¥ô;з&œJþÁ<[úÊè·ϺÏ$èoÆÞkÿ¤q‰û}ÕBÿ~œÂ¿cDZKÊ;E¯ýÞ}Ñg[Œ›Üß&üŠÝ´<‹7ž×åÌ}_¾Å}†òcð|éÛ ŸÌÏc Ì÷Öow›ÿN_ºæRÆ}4iùŒñý¹ô¯è~±Ëôç9NÑσ‰ ÝϘ–Wç+É#Ã'pü®çv¿9|uÙSôÎý;Â:êæmÃ+EþÝçGrÚn’¿2Ãþ€Û¥÷äŸÝßÂ\ø@ª×9Þ×ï~Åaî#’ÝÙîÀ³†÷ /^ïO~§Èœp1ý3ÄOö³’Í+6®åÜÜ×cø3Ó—Ž4Ž$nÄ࿈Sès§_ø˜øŽ~-ÅÏæWF¿ðcÅzlýì¥æÇ³§ÅùîW}ÆÝî3LóÊãùi{÷’I÷­¥ ×Sjl¿¤åŒ~,÷‘HO·Ì®_«r¶ý‰í°úaÝÿ–ÆiäÅ¢Ìñ}=pÎîyÐÎ €Ë‰{¹áPãcðƒç`è{ég /Á~ åï­·ÄîGáÞoWè¼™ÿNËÏ–Ügû’ß²þ]ßž»&þ³òôkòïø?ò5î?×}ÛŸªÀvTö®ØÙÅkmj³Ùýî—'/¢¼!øÂy }¾û¬%·îË‘¢ÃòGþLù&ârô\¨>ø –Kû}½‡ì$<7k?§|„ãûát~"µªV™£.Ø>æëÓgªüƒçE(Î n »ç½kiÿk^…ûÀÅ·!ÎvŸ‡ò¥îS¥>^áGâCúÜw¥8Âsä'Åÿg.Nì7å}Oô­*nÖ¸žæg9®(¨qäƒÇÎ1.¡OÄþGzJž•>Mä¾qž{ç|‹âÙ/æ8±‡Åøÿ’ "» ή3çÂqýoi;gܦ¸Çy#÷)éyŠÄ£Ê{yžî•þáfãmp†û8™ #Üê|8}‘é÷4ÏàP—Y·=úbËñ½ç½ÐïC‰ä™|~^týÑc.Üçi…×èg$ÎÅ߸OOyp7}žðd”ŽûTÕÇì>›ôù9γÿNÿ¼ã&ìzƒRÎá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªüÿºW»îþÝÏÆ)ûÞNŽN™ƒBß­ý8ù]òЧ‰ƒÂ:~=±ÿeÏ‹âòW|yêõ+îÔð‹]7ð¼ì¸ü.x¾H¿­ì ßo=Ư¨ßØþ=ØãBÜ‚\mn±þ¢Ÿ¨cû‚¼¨®ÛGá1ò˜Îw¡ò÷äݧ­8ÈsDdç¶¼Qþ”âÕ^¶=2®d^ö„9gÒWöÊð÷ä·ÁßÜ/òº¾cÏG'—ŒçµÉßÓ'Í<%ôÉ8OöˆþIìöÞáóˆc8ÛCáü‘ý‡¾x'ô‹VhøiçÝóãs¦ÏN¸CõKútŠô§ó{Ô9Ñ#òeàû5vE{¦7÷{‚ãÉs8¬}<œóhzOÇu’{æXÎuÎâ÷Z¯ø>ì8v.œ›à>fùAâWì1ö ¼MýÉós$÷¾gæêé¹x_ñ¦l‰ÛÀIœù2ú©þ1qïiuÇþž{Ãn"|ïŸC›Ô®Ýú{÷¹#ßÄ{è-çŽ}Æ¿‡þÙòžÏ׬ Î6ÿùsÝ€þbå× žX}Ü.ñ|ýxL~2JäýþÎîÞ¿Ù.ýÙ©Ôëç.kŸ§äÄsàÔOŠœñïžûB?¶ìñçˆýÁ/£ßàãré!ñ>õmî‰|)8x—¼~˜ü9r ?ÍòøGÏ‘”õé8/¢ø½ .æyŽúÜÿ÷ÿžÏ/¡ŽË<4ð‚â.Ïï”\Ógî¹*äËõ9ØâÊ ƒ/wö íïq¿´êÔ!Ã<,yJò¶Ø=þ|螣>Ÿ_Ûü‚"sÑÏâ79?ç‰åÏÉÓ¡œ+þœ94žGÊá@׃‚yŽ|þ†‰‹ÞøíèØó_ä–<?g;(Dž”8Ïùòñ’7îgy¥J'Ý{çÔX.e—±wÔQ]¿ÔçÎx×ÊüñA/1 ¼G^XçÀyØ^€«ñ«ä³t>®§+ÿâäüògbñ±-wdÍÓ·üùJ×{ŠÌ3ñ¼áß÷àÁ³ÆLhãñ*ø9ôÁü é;ççù²øgá=Þ½7xNCóJ?•kr¢Ïypßžc'ùÅ^x®*óOÀ÷øoÉ¡xOÎá/à? _œS8'ü‹_Â>…8Ž| ú€=Y?ä‰û¼r¡çѸ®Bþ9"à°ƒ>=yùJÏÙ@>±«ÔSÀæ¥(N ^Æ^ÁÏÂÞ‚=IþlõÓ¿Þºå±Èþ^8Âu3âœpþ—óÅzNä‚9&ü=q æ|˜›â¹®Âß>_æ]*ç=â×µfUÍ»g^jí¥7ÝסÖÕ¶ÔM‰s°wž'Èœ8ÿÂú;V~Qø²å <€|xšîƒ:õBûùÀqî܇焨ú=Ë•ôËy4xÂ1àúUÍ_|çÝ_¤6 ý±á—œ×uU· ¯eüÎs‘?^9þÆ>)î&¯Ž]%nãÞÔ/g½—q,÷D¾Øû"%ü=òèys’'¾ÏuâE=߆åç?÷àÝÖüþ ¾(q÷N½ }sƒ|&þ#˜Í ò‚à"ÞÓu¡Áû.?ãµñünê!z~äŸ8܇%ŽâûÈ£8Ñûòsž·(ûMœƒü-íyû’uoŒŒó. ç"߯éØwÅWƲoº?ÇCàNìšy7䇘çGÞKzh}P|Ïû!ÿžï£ø …}Á0çsu½E|Xû;½—óºzêõü¼öuÄ8¿À<p½òežÓÄüjò½òÏæ…R¿ x”æùInSÎeóa£NßÞ*ÆïÒOê­®3J.ûunàtü zÉsÀ_rþ‚¼ùôT~¼`^ó”eçÈ[8¡z ñ4ö {ÃsQ'4OA88ä+€7Àè%qx½Ãw✻d‡¹gçù¨ç)O®CÞña}ÍvSrà8›y¯ú<ðù ç½¥‡®J¯¨·…<5äÏùŸ˜«Îm⾑öѪ¿ÁzÎm^¶¢i¹£¯úÒù*ð%yÏ‘•¼xþ?|Ù·5ÿˇeZNˆ›ÏkU½•¸Ûñ¸ä”ÿ‚‹=Ç\ϳ1ñiÓöŸ´)r¾Ì¢€¾¢wØ-ÏßeNâü,ï.´>Pi^»ùh>#Wè+vš9òöʗ퉫ØÃ, nsžŒ¹³èüï}âó? aŸ­÷ÌÏ òÁÄ£Ôõæ_ðáœ[†¾ìŸ'Ÿ Žð<9ÅGžc¯d~š÷•€—ÏýP×ö{÷mÿ-üg^¹âô‚ç¥þD^³rR»ÎóžÝgƒ÷ˆ0·˜¹Ù’òÎàYûÙeüß¿äà7_-Ú1Õùçs¥w>Ý+u^üñ¢ Œ?82æâ_ȧØ?ê<±'¼ϵvâ®ìGï÷ý`g|à/§ë’3ÎÍ{Ø“ »º²b£÷û,˜óפ¯àYçIu^àÝõSÊÔŸ^j„çÿáWp’ïQy>ð3¸ ýv>üy9õ9áGˆç‰ãábï±çèþ†x?í¸z‚êÔÌd}ú÷èC³õùHOgúž°¦ŽBÝZu(âª0OνF_ÈSÛ>ê‘êžœý=äåB9$~õüOÝý'àeä y§ŸX}¼±üIîÖ jûŸî÷e¨H^É{‚ˆƒ„o9WÏÖ}a'Áߨ[ÞŸ8“óõ|hÉ÷úKÚå,ºüSû%ü%vŽßãýôœ¶wôÿÌ}ÝŒ“þµ—?'‚ÿùçÖX×ÿäûǦV¯X]fþ5ÿð¿ÔççÜ_Pöã_S¿%+¯¸¥Iÿ>ÿðÊò‡?ïØ¶È߯ëÒ¬I½Îw„ÿÏü{‘σ'ÈŸ?¬z\ö7Ï/öÏ¿Þ+3®š¼Ýæyû]á×÷úïÇÿñs¼·ÕþºSµ ›ìì^äûøïóÿ…}#î÷9ð÷ì‰QqjÒâM+¯è´Äÿ>yôÄ/º>RªÈûŽ®[cIÍÓþðÏÍ™RìÜ‚Uþñûÿéܦ”ùù¥²Ó§ý¿>ß‘G}ÿR·+Š|>ïÁ{þ4wó%©q;ýœ:¿ÿ§çûznÿý”µ/ÍžtßÒü¹—:»øŸ O½¾þ»%sÏ^–ûÇS?t½öÖÔœ G–zyßÿg¹ î!õÉ£C7¥æüþçĹ®X¶xç6¿ùwÉ{Q½Ûßû`ךŸüãóüÓ9.x¤Ë‚^åºúÏzoÿ¾äÜò÷ÕˆoW -µÁÿ®?ÿ“‘sÎuþ?ýâŽÑEžgî÷?®ö=©wÿ÷} RÃÏ-÷c‡¬%©ž¨[}êÿÃyu)uIë? Ï;õíó§÷j9v›^ùà"÷Ìï-­sï…¼UÝÿ>oß²ýöKÍÜúí£×^¿%õÍû£ÿ8¡rã"ïÅùÀ–|ùßg}òÂïËË=’š™³|p±¾ýÿ?ÛpWøï+ßYsÊ)É"?ÿ{öÑ#v=}sêí3ú,otõ–ÔÓÿ]¯ðã‰ÿ(Ÿú÷ÔÏoú Ù†/Ss¯ú䎲ýóÔ]ÐOßSú|S³{o¼aè»5‹Üv™{ÿÉŠ†S÷¬æ¿þ|ý¾ÿ¼¼ãg×\Þ‹ó”ä#øwärNÇ˯~Üþ"çûY“b£:ÕlÚÝ"?·`ÚÃß=»åÔ/íë?TøÀ!þ´ün#®î¼ÿL\#üá߇·÷ãé;ßú¦`¿¿÷×ÿá›}Ø¿ø½ÿÏúêǞÓãûOÿí´iÓzº>·xO«£gw‰åüû£jÝY}P‹Ð/¡?þÅOþ9É·ÿ¼tÌ¡KÆÆö»l¿‘>ï"ò€=Ñyúó~9åÇ™-ø0¾ç7ÚwÓí=Ë)ç´Xrˆ\-|ºÔèCO\aù$n•~úóxž¸g?'ó¾çåöjuÊ´õ©çv{qÍÊ»‹œû+N­zükÉÔ¢±Ç´,ñ6z‘úý’OkG%^NMÊî¸ðõ%CS«2{_ú[µ©•zþeJ¼ÝþºQ©Y½~¾µÒ’v©uËF\pjj÷â<;Ÿ#¿’ê÷é»?T¸âû½7=¹Ïu#S«†ÔúøÒ¶]Rß®ûȈ¦Ý‹Øx2øÑeS{l«_«r‘÷^ºwig›€Ýð}É^øçÉˬ»mLÇŽŸÝ’š•ú¬FÃͽý> öõÎè¦ÏŒ+9§oq_Øé·üñLý“ŠØŸåË üù›Ñ3?Ç>³oÆ¡Ôïí~o>¥x>qh‘÷ZvÛMçÏÿà?ÈWj^ÝûÎz晳ñ³¾Oäˆ:çE}™8`ñ¿[6{þNÏOO塚)ñyü„ûú¸ÿ¼sW—?S³/åŒ9ƒ«Û-üü›9åû}輸psìÄÏâ=ðG’Gÿ=¼p |Γú!?Ïüô„ßC~Ãó'Þßâ÷BCŸžü˜å}ú'†=_ùƆUɲ±Ÿ–_ôçϸG§÷=l{®qfxß<×?ùÏ™¹|ÿÍïùïÉ#ðïè1ú‹¿Çîó\ ’SÊ-¹®ijÞäWï«ýà#ÈEjÉ¥ïÔ©ÞÿC÷aÁsÀ/­8þþ¯9äüéoϽÔúúý÷È+þ‡ûDþ™OÁçÛÏÿ4!ëÓÿ»ýÓ}(ðßãÁ]¿}?÷„¹ï÷ð¿/ëš¿h[ƒ©¹Ï®*ŸâÏ—=úGÜðGù÷Ž:¹ÓÜÔòƒ× Üöáþ{øè÷¸|ÙàÇ2[]ûþû„‘·Eyÿ_·}Û®õØ[Rß½½;ë:ŸÁ¡Òä!ö_i\P$þ_׿dܿרH|…ýÅî‚k°Oü;~ðë%*Þ=q‡í5òÀçSoG¯CÈßI>~ì’˜ýÒUS|?+Ÿþ餶õûyW|YöäV´œ‡zEç&Ÿ‚½ãÏØ ìPø=œ;ÿŽ=¦ž{à9Uôs,ü ¼ɉúëóËÚß±{ý.ù<áßù4ò“žk";®ó å"µüëÛ.÷zjÅ¥+ë´?ïÛé›ßÏ{ó„?+=2rX‘óå<°Ø ò àL>WøÏÿN~Ÿï7ðgâY䀸…z‰ðCjõ÷.~u®ñv’üö‹¸œÚ[xœà¹é‰g kØÆúÈC‚|cÃsŸ¥õ<ÆEа›ÄŸà¾±Éì'Zžø˜qÏœ¯à{ø}ì–ì\ü<ºì9çÍ{Èþ¥V.ûøèußï7þåç¦^Û ì®q—ÆqŸüŠür{Ççàáï ýø¼M]CÿîÏ%ŸÄ¹ó^äuø ÿ>kÿ#-o~ò'ÿûŒã—üyW½-Èo‘8‰ú*ú)¹(òžÚ/ãBÅ1à„Oï^¸ó… lÁ¡èÿŽ~€stÞ±œÊŸGàñÿÈ»ê8ÿèÁÇØ_ìüMgè^8?ã$ÙIñš‹Äq>_=v‹<çÃs„y6ùÓŒ¿9·0o…}'¿¾ºVþøã·uI­ZzîØ-–÷ÜXOK&'ži^ïU¯€:/õ-úˆÜçEýOvžz•ù4鼿?ß¼*Õ…‰[=~‚ü <+¿‡~Ÿ8’úu*âןè/ êQœ‡÷U²¯ ]úùýÜÔÓÌ÷'$¹…OI]“ú)õ1øÄÕÔwÀ¾gñŽÌ§E~áKˆÁûÀ¯Ô{z–ûÉá3_Aýcàú˜‰C¨wW„õó»‚}Sž¿ þŽ÷óêóxŸ?§Ö¯ÚøÆÇõYömÓß(¹¥Nä:^ºÎçûðóˆ O »`~–ø–3Ý7y4ú5Ð+÷ÃÐð܇Êü$ñ*ý÷’_ê®Ä-àBϽïaÕä[;Ýݰaì—„“©ßqÏÈ}-Ä?è§ûP¨cЧåýàÌÍÐsš/þ‰õNr†ýòÙ}-ðFððëÂ>]òáÔÙU׎ýöšy˜êWµßþ¡ç¸³_]?ï¹’óáËJÏ=÷€¹:žßýÖàÉO¸ÿ^"¼æ xî§ä¿Ï ¹…A›<ïËç€Ì»£_ŽþEö®Š¯ªç‹ý$þIï?áùÝgB_µžÛ|zxÖú/uxϧdîƒü¡ç4‰‡f<ÃÞ[õ1q®àlxæ!á_呞ƒûvÿ”ü|¸_Üz"} Ï×û)ÙCîƒWž¢?Iþ†ü@|ÎðTò<Ù=æß˜×«û¤ÿÁ{ÅÛ™ï%ÿOÙü?ò·zþÝó è{á¼ô|è%~Ùü}Ý+x»&;T$¿¡½TñÜK½¯ô.Êø´÷½U¢ÑÆiî‡×„þ㯥§Ü„{ƒé'Æ.zNK°ßÓ|Výzj^¾üòAÜŠ|‚?À½k¾ú÷„2knŒç¹èÐó£èO¥S~{ï¹Âiž+»Œç#ãùÍò3Ìéá¼Ýo&Þs+ज़‡N©ì®ùÖâ{Þ¡Î{4›9øwúåôÜîW>@ïg¹±þc¬Ø;Ï…G ‡€ß˜; îÁNñþÄæ›É.*h»^¤û/„=>­øáž×î”ýÃO‡{ìÝWÆži#8–ßóÞ\ÙìzAž×ñ„Î7äaÂC#_‡=Á¿Ò§Î¤~€Æ/š·-Þ3¸ù¦ÜÏýb¿¨ƒ:þ÷ÊoâÏlç°ÒgâGÛwݯy÷è?}6Šãl÷/¹O”~"x­º÷óÑ÷­sñ\Q摟rÎüqe‘9éÊ«¸O}çôIÁK æ`8Ž£o]÷gü ¿›ùÚóe‰3‘×`î£÷?+à¾HxËògÈ5vÜaû§sp¼À\Nú>É·Àe~?sB™7§ïå{<ÇXvÊýNÂþð¨âGxÁÞ+ŽŸ—‚3'8Îý¥’¼:úÎï¡o’ü öÞó8É[ÈžáÇÉ+aO^“ý~»i¿®¼óóÐKïg80/«ó×3ŒëW4|vÑÆIž§Ìœâ¸`.çÈIŽ‘Gä܃ÜáG8'Ï› ï>ÐŽ´ÿ•=$Ç9@>H8Ä}‡¼} Ìg>þyœz?úôý–7÷¥ñ¹Ì;dO½â÷‹Ë¨>_5ž£-¿áþRÅÞ›Eÿ¸óϺ¯›÷×ó—x/Œò‡è=ñ9û0Ð ô>ÏùcN¤ÞygØ/ò\ÚkÏF?å—ÀCž¯¬¿ç{ÈwÚ_W×ù2oÅùº _ ~¤ÓóB˜7Å<3ŧüÏëyJÁ>äÏÏ+ù¢o•Ÿ§Ï÷¤ÿÛy0ê)ìÝÁn!’+â^ž—¸ÍýúÒCúšÝ_G>Esj-¿Ì¡Á¾ó/Ñ æ>Ð?å¹nA_ñ°û·$/GE}z³£ýˆç‰ÊN"Çž­{EO™gù“òüàì­÷sÀ¡Ø—÷¹~È|–´cÿ[‘þ!ìúÂçz¾ö,íŸ]' çE±ßÂùbæ‹èù¼7AòH¿£ã7æÜ)žà=ÐKúÐÙþY®™K)Ç÷¸/0¨ky®6{ Èï2Ç[}äÌ›óDÜ?ñÏ3è/öühúL%¡=çtsößò7îÃ%({Â<+ãfæÑHþ*{ë:{,ØG¾ò4ø ýqè;sºB¿íxŒ=FØ;ý>8ÁuV½§ç-¤õ!ö»ÌUeÏŒòKäù\Ç"ž$ß/=£ÿÜ8ƒ:ªîøÎñ*8Zñ¬÷¤íX”XÑaá°£j9/æ9IJSÞ¡¼v€<„q*û×è?¤Þ&=Æn¸þÌ­cÞ¦ç1¯\þûä}VìËÁŽH^°;Ž÷™ìr¸üZ8—Ñs×™{+Üç:3s>ô=žgƒœ‘çHŽ9Ç©šIÁ¼Pçi‰äw\7~ð^%åÑуµ6Ù"÷WÇ%È£çGk¨÷ð±o@ïK7úιƟ{¾uLƒ÷%1GN¸Üñ1û’˜ _‚<®ü÷çóe.œî:±q󚙣-9cï%ûyíod¿ŒïÑ?æ}PoÀ0'Bþþ¼çð连OOž‹ùè%rÈ|*æ þŸãsÙUô9u^‡z[Pçó£`"v3œÏÎÕö>1æŽ0¹ðä1˜cŠŸ¡¯û&/íø†}Âßáþç¥Èo±¯Š9ÐÌïGîÃz#?Ï}1ÿ<Ø«èù¹ÌÍ×°ŸKç½q]—¹JšKfùa¿¤ìïÇü%ÏÙd~ŠÎ¾kž¹Ã/çy^ ú@Þ.˜§ãy–ì ã|˜k ‚„ñ2ö9 /ÄóÒ{Ïõ&¾gŸìDX‡g^?o;¬s4o&¨ºÞòtߨ7á û]Û[æ¨*¯e¾S°Ósý„¿™?áßW½~c¿ ¾Ã? g‚ß9gÏG¡îÈüjÝ3q¼ÎÉùòfÁ¾ úöñ+á¼_ì³q¤ž9"Ïî¹!’ëñ:8šyúÔã¤WÆ1|>skƒùôŽ£ïz/¢þ ØsT‰#À»a<Äç³ÿ‰½KÄùðväG9ä?M>ˆùožã¯s²¾J¯Œ£‚}=Ö{ô–=‚ìç ß-{@œÃ¾Ïó"Ìpõ\ö.èÈÏyŽ­ôœŸ#ÿŠž¢ŸŽc³ï’{·ƒú—ì>ó‚˜?f>!üNøø+æª(k|ÍþGí ñÜ|é'}2ž£G_ñ,8#”sçYØû¤<“ç3ÿ[z¿ áxü*AÄs¨ƒyšæ%aô½¾¿ ïæùQðƒõ_Ïë¥Þ†½fþ‹ì³ë\ÒêÌmöÞ5é õeÏ­ xµæ‚Ÿƒy„Ä…Äi¼x–yaž«nc—ä9ä#xÿ1{šÀâYßà¡{%Øk…Ÿ`ù¿{áßJŸ¼‡Œù¶’âYêfŽ‘kö§ë=ÁÞ{Ê~Kå%Ãù‚aÝÚüUÝó*ð¡dßm$ï–Ë žÞ÷I½)­¾ü-ž[+¿å½É’oç5¥¿à&ï’²ÿcï+<éøü!»×wðëàIòÛºwç3ÁÍú9ï“cÏùä´œE‰WÏ_:ºÕÛøªè…Ïý™Ì ‡%ÿɽÃgôûJã3çÌ_”ÿ€){Ï}¡Ž’¶ þ}×CØO®{ÀNÂ7ö¾xöx G9î§ýà ß'ûáysSé·óAŽw¨WésèKuCyAÏ-–]qÜÅóKŸé×fnÀ¼®S[VþHÏ+3>OÉñ < øÿôý3ï<¿<¦yäÁäïᣠßÌIïÒ‡èü7|qW q½S8ËõYùEø˜ô‘Ò7Ëû¨=ö?²¿áœ^žŸ~Vønðãáïá×È£¯Øn©e3žr¿ýô‘?“]â…oÁSð¨!çôóºOŒzB°{ʼ;Ηü*ó㉠ØOÄ÷ÀW£ÏÜû˜/^¤çïÊî{(þˆ}¬ìÁ“AnáÏ“ï Lõñ"}Çœ#vÞ1õ'êØà#÷ê¾é7/‚¹†Š¿éƒ£ÞÓ,ûM5ø}A^éû€À|çñà“Ò‡Á~Í9d> ¸‚{Gì—ØÓD?˜x>ìG@/¼GB~Íû'TW` q;üüø‘x{ŠÇoy^³ìù ü4}Òħès)ŒŸ$¯à"æ‘P'çû™‡á>ò%ªË"Ü rÍû†sññßÌÿ„gü‘'à}Ð{ô˜>Tì-ùÇ"{Ó¸1îWÔóiŽŸ¾=}ñÈ?ðù ä†~(ôÅû¨„ñ›¼ïQÏÉyìrS•‹›~j;N¾–üu(ç $ÄøçtŽÌ» Ïåx-¬{ëó?ð ù9ôcÃSJž?Iß9ï…`nŠëÒ’'ðl8÷tÝe??uãé÷:oÅç;ß,½ðkáþÝ{ T0~f{ècß»Cž?ÃçP7Ä¿ÀëÅŽð=Øwâü}–=/òIßw=ƒ>Týæ‹ÈïÐGâ~}Åõž/¯ÏÃq¿Ž§$7à|xøàî•ú9Ïk>?ñ;v[þÒýªë¸_+çâ<%yý>ßãz|axàìá"ÈùV÷å²wDræÍ±“è…ûº¨oÉnÒ¯å=kÒkæi!OÄQØEã;úqˆt¿¶3ª³‰Ç\¯/é¹\ß x4àeöìêÜ<¿_u&Ï%`ߺòÂÔQÏU}s?y|å-¸gêàÄ_È¡ùrÂÍèøë>å3ÀAŽ;”§bîx…=‰ÌÅ@îù>Ï—}#.,ÂßT|ËýºR¸ÌûøÈG²ïšþ湫Þ.á<‘{ü"ú—’'äù‰“éOs~Qz·vPÿ›÷y‡óòmO埰cî{•Üð¼Øqp¤ûoèçOû—"ó~¼WTúG½—9xæ})?ìþõ€ïí}в7ÜóT\/’ý%.6ÎßÁŸQÞÀsä¥è¡Ïù—=dSØè=JÂ×î§Ò÷‚sâ5Ï= p úD¿x ?Ž|pÿôU;ÔW7ò¡æ_Ããgކä‘{'?EœÎ7æM2ÌsT¯wžL÷O<Âüü–÷ÍÁOVýù$k|Ôy™›Fn™gîãû©Çãg¸ì)÷„=4_ìïõš8¾×\)äÁ}½ð'd7Èoð~yáKχ^ñ[Ý›ó ú/þ}çri.a¼çG÷ì¹FŠO‰‹ÀÏØað6÷G‡8Õýv乄/9oâoâ ãIɉ÷´Q?ö¡óûî÷ú0¸?ñ“ìgÃùAœ#~‹ü~Š|•÷Ïrï²3a_ù.Îßu0ÅàXâ$Ë­p }B¿ÎÜWü˯nñÜ x4Ä;Î'°wœ}®Â£îëÐùP7Áþ 7Ì¡òþ(ùIð4òî·zϦì¡y«ìÕ<7p¿ø ü5÷ïsoç–sò¿z¾ˆ_Æ~é>â8P~;ož{ˆ…·¨÷õ¹°ï=åò÷è­÷o0Azî9§šÃ‡žP'òòŸz>ä?Æ÷.{«m£ãöm1^‡1Wˆ{áü©·ÛŸÒ‡¥Ïçþðk¼7vÿE¾‚8å¸DöPz_dîsú˜_jÞõRöÈé¼™ïæ=ÞøCæÈžxŒð+~ {‹?ç÷‰3±¶:ä‹ß'ÞDyOp çÏß“—‚KàWÈ¿Çv…ï 窒Ç~säq8/÷éÞØÆÜ>ã3½ç\ÉÑïE~9ï~àÏæ‹ê{Éka÷½wþmЋ޺O—y:â:Ž^ ë|Øä{ᱫÄÛá>t~Þñ¬ì~Î|T÷‰+®à<8O÷µùOìö›ySÞ¯#œÇy2/¼aÿÊù _y.‰âBâæó¾ü»ë^ž3'û‚÷ãÝ?¯¿÷9ý:ø!ê/žSìí$~³ýƒïÈ<@â^ö$òûôËã?±GÌ'"׿cϽ‡½ªâk0GÓ{ž„OÈ {~BEÿ‰ë‘7âzœ#ú^dO'û ¥¿è=?þSÿÅž˜/<ãy‰Â1ä#¼wOòFý|F¼χ:ù0ìø ?Á}P¿á{©§¡WìGÂN çš³וäÿÈ»PW6OPxØxÿ–|QÏÓïsØä>Ü_f{E}Mrüd籤Ì×2?<ƒÞ‘7—üDɯå<{ä'QƸD‰ÓW}e6½æØ;¦EÉöWßöäú¢¬Šoõ[RxV”_/§a˵¢¬œOöê[&uhóß›tG”ÕtDÓÂIQ”WjÉgäoŒ2¶LÜ4æ†îQâˆÿ.™e•l¾­ë›£ì¡M.Z5t@”¸aÚ¨Óoÿ(Êzm[ãŸ2FÃC‹rjT~ñûÞÛ¢ŒŸÛn[¹¯'|²(»TÝofÞÝ/ÊÙ©ç¬cúFÉk6fÄéQÖÎ¥ÛŽŸ—Œ’_½ûË?ÖE9ïؤl÷G¢äæAKw,š¾±(Y¶ñ5cÎeõ°ù«3ÚGÉî k ÿM”|³Ä€2»ËÄÏ]¾ýÆÊk¾c_v”{Åâ¯ùù‰(»K©jÇOÙ%ï^R¡ÍÐåQ²ô±£ %¢ÜaÕç”Ñ5ÊÞÕuã˜~5ñß<'}EQb\ÅÊ?& £Ìñ}=pÎŽ(³ÔøéK{]åôŸqeÖˆ±QƼßôu”ñdªË…£¯ò†ùùãŸ]ežóćïÔœ%¾m?å›êõ¢¬y%–_;gºÿœQ6±murV”×4Q¹ÕèNQÆÚgÆVÈ-%þç—ÚFY-Z~Våó¢Ìuß5³OǸß'ñß'Gæäm}¯»ŸK³UÁ‰ûü¹YVÚ9dsÕ(ÙÐè—ªfù^3?9âç‚VÉ(+pr³GÉqt®°°}”X߬ҒüjQvjÔ½Éeu£Ü¼;î{'³…ï-{fã›—–jem©ÒlñQ£œ]Ó÷}Zgx”5¾Ü;»Ç‰2ø ïÑ¥Ü>èîÕ'Ey Ö5lðÞpËIf½Ùu/zu"x6ÊLã}~Ïçžÿ\™öÕ®ùKþÆ ¾>cZ”“êSÿöo²£Œ†.Zõý_òûuë%Gåë<Õ—å¾òãýê3o0¾É r™xôù èeîÚÚ¦uÛ2Þ×–Ý~|Ýg>euß×$57å|uAÝ~“wFYÿÓïÿ Gäe¢ìÄÛ3«?!Ê\¶åþUã¦FW=uí›S?ˆ2[w½÷¨Íµ|ι :¾}ôŽG¢üþ{^Î?¯ ùB?ß—7ã£Þ׋Ð_pY”õø¸ÝfOŠ2‡ýÖé‡3êZŸ,:çd½zõ¾~V”Y¾é/=èåë\y¿¿³»÷o–Éü?â¤-›»Æ÷"9‡ç‡‰ÿ+¹È»bbÛ?¹0J+=·Â%ƒ,?9§¼zDêvßwÆyƒ‹E™Úÿ²ñØ•QFãÚwo¹.Ê]Ö`á©ït±þdÜ>ò©v¯Þe×yûžçÆcw¢œzÍ2«½x0J®ÙwaFÎùþwì“ÿ^ò”Ñú­çÆëèïÉ.Ó}×MÇMðsXO¥Y§Í­×:ã‹(µOŽ‘°žqþþýôóÅçríƒÇ7ºãjúέ÷Y³þµõû½,_™*Ý}Û-éÍooù°ó_÷5¹ø×»Ï]å¶.{e¿ýD;g4m_a¬íúš“Ûø¥œòÇÂÃñýø9eO3³çÍhœÓÌßoûÌûwk·- ¢’Mv•þdÓ ?ú“ùd…Ûú( +Ê2côÏæ‚w¢ì+ºžRì¼6¶ƒ™ßßPªùÛùäü}¹£’½+œüA”uO§/Ûu:‘¼Z”˜|ý’Žì%—=’÷Æ+»¢üv>Ø®Uß#ö,ë¸s›Üÿ„å÷ÊlüüM«ê ‹2 6´½*#Ïv7gÝ13g.¨‰ :¶W‡š¾}–í çˆüòyØ5ô=£m¯v­îeêPê•Émc=êqã_6Øf½FÞ²&WY1°á)±~ ½ëÖámGÚOK¬ïðçÐÞ»¯y6QÆÄÖ5–´MY/,—i^Ší~ÖÒùŽ<Åv'¯Õî3·-«f;‘Ýêàï˜êŸã=xÿœ¥ÝÖ\½ûhó˜5¼kØ9C’ö#:Gø—öï¹c¿™󆓢ìͧ\?íRß[öäŽ3/y¸”íxrúÑ÷¬:ÿÛÉD‡§^T¢ƒï»É¹èܬè‰æƒäÌ/×æÆ—fE¹M+^•?sï/3*ÞI£ÌÄ¢s§<ü<ý±Q¢°ò¦E¿lˆ¿Wú”ñìOCËÖ¾¡Žky•ß4îJVìÚîâ_7Åß#;Œ½Î^{ךšcï÷½aoóª ÞM›(Ê­qïÃ'PÆ~5yú}/ït(Êiÿúi7”¼Êx=àçKž+ûÐc_--ÜêÏCïÁWóvîz¸ä à÷(ã‚Ûúu~È~{ þ‘ÞYžeŸ¸üûkôjzy”ñ~ßë«T›iû‹ŸÌ׳×å«»Ûîæ-?á)ëí§²ós×´x² ù»(ãœ×¸¼i©ÔÁÞ_”{càî-Jöi?«|‰þ¼ìÚ­ÒíŸ+ø;˜ÙãøÇ–o­ã÷ʭЯäñÍs¢dÃÜJÕwÖ³]ÆHï­—|>ö’sÍZ÷âg=ZËçšÝtÁØ3¯ÏŒ’-M}¡äö(û‚Ÿ6î¿%øÿòœœ»q”ìO&8N÷}ÚŒû6{+J6½ðé™ã­wè3rÄs¢ùŒû½Ý–£Œkø}îû†!®à>Ð/ð!çžÛbÐé~çó‘Ÿ·ß*–ñÚKß³½rüÀ{+^ðù·xùÐÌ+²«ÍkñzßÒ~Ÿü¼zßNn»&Ê8¢Ãüå/¼å&*–ë„(Êì=l᩵Ïr:?yÊô…gÇrß¿c¿ ¥¿vÜÂó wú¿–›ôù¥l~y×=¯³Ÿ@ñûàýÌÔK÷kÐÒr„¼ËÿG~œ\ãܵQNáÏL_:ÒöÄþFv_~Ó¸¿š;=¹zõ¬IQn™çÉé÷uï­¸eböÎEp7þŸçFnW¿WûÙº•c?¤ßÞ§Ù¯¦q0|~Ë%÷•[úÕèܪ mWr š2öˆÏü|ØÜ¡ 𖮉õ‚{—Ú¯ëý‰×—â¿ÐK¿G:΀¯e}¶Cýç7ÙÎ(~"/e<‡~ZN¾Û^ÿ²rù9ó+Lq͵b}NÛ3÷÷Ï·øÏøEë—põ]þÌò/¿Kœó`ÝÙ[³Ö7Ûn¦ãqûßb­Ï¸µ|Í-—ö3œ³î¿åxAçhùH~ÑŽâÙá(«K·[wo/ežÎŸ\×ö1»Âè/ê/®ãüö„øÅöœ'»"ãþ ÕbÜ ü}E¾´G;*ˆ²ÞyoÂrÎÏ9ÆÞêyôsñ}M?ï¹î×mA/S‡Zæ—¿äŠ-wÎÌèóê§õg¾S”ݧé§Oîö½eþþ¯c†ßãxT¸É¸Q8ÚþÞùÅè¡q¯ð%ò¢8ÖzÐïÇsõÓý!þ9½ó9œWIî®\÷¢êÏÛ^à jyàà±sl¿Ð'ìIî¼½×~öðËþ^åÉìrwíxü×Õã÷IŸcê@µÁ¯äÞÚ6> >&¯Ãûc/‘³ì÷›½L¹Qq¾H¸‘¼v˜ü82÷´Þg?ùdÛ5åÅ¢ŒK*Îιoa‘8€|‹ñ˜âä|O>-ï«b÷=>à ÏIžÐr NÃ^rÎÉyT)¨u‚ý¹q°ü ø ÿÆÏñgß/~gX¥Ñë÷­¦?Áñò(ý´ža/³—ÖLöŸ²ß?—ß²þ]ßž»&Æ«’[ìz¢¾ˉòÆØ#p÷–õÞÛ—kV6Ê{`þîr%®q¶ô;"ùaîY¬W½§M¿sïc¾üù@ü‚ó&ÄÝŠ; ©tÚœgŸã¯ñä‘üÞ²¶ß Èò­¼¿å û$y·])([pÛi zÆùKòQÒCpP~¢ÑgemõDþ ¹Á/ÛËÞ…ö?ä¸jFËžO÷9Ïz…?üÄ÷“Þ$vnnW®æ®(oíþÞ‹~hc¹ã¼ñ§yÑõG¹0æ‡Sç‚ ÿ^¼x¾©xDÔ-¨?ªï_ŸzuaÕ-â=–ÑÍ;.q} ^ûcàƒÀo†ßG}´ñ¾+ñ‹à]QŸaÏÃpÞ³çT«nÃ0ø#<uqžŸ:ûZ=7_ïéþ|ñ°fž5éÉQç°Ÿ.Þ³™®?Ç{™u_ð¸à#пÂtêˆÔ9¹?æ3§^3¿·æÀ®hÏôx®¥ûVTòÞãt=)Þ‡ 2u3öžQÏW½¨È¾ZžÛóÛuìóóPñȨ̂S]Žú}%Ô¿KøÌa{H© QBÞ¹äŠçR],Þg%yOÁO]:¼ ÕÙþqŸ8zÁ=Áç€÷G½˜:{‘©ã›¡>Ž‹?{±]Ÿ ÞÊ·Ú‹ ß*ä‹ÃÿEïy/ϱ—>óœð¦‘ìLa æW‹ç ½°qŸˆø;ð¢°ëì‡å½ÁØ î}ƒß„>ÀÿÁο¨¿y÷`—àwò¾|>ü þËýãáÿðÜØ-ôžzlý‘]eï vÀûã%¿Þ7 Ðû€ [,ò_èçÌŸ™'A_4~‚÷¦/üÝ¢ÿ^ý§à-ü58¹‘øùÌ×Ô}á/~žûPá«!Ÿâ_Æï+Hx†ý²ÄõðÕ/àßg¿ð’ƒß|µhG¬_ðÛØ#Ìç³?9o¯ÈžuôŽ>nî>>çÃ|o½_<¯M|1øäÈx?½×Ï9â—ÙÏûõqÿyç®.ú^9ü*û›Áaàfæa/ÀÑø%ä‡ýÅîÏ•§ ÏðXµ8öGê{1?T<:íÙ-"çè+óòÑsøÜîö¼âÇÑ#ìþÜ@<ƒ}ä|ùᨘ'*<ŠýÄ È3¸;œ3ÌyaÏÀ1È?~yÑ3ßuʨÿFìoe/àÝ‚;á‡a÷¹7Þ>rΆ‡êù4:øSôuᱫÄ[ÄEÈïíø ½MóËâ8©ù¯ms/óÜ~Ëöþ6rD¿ ø»Áñ£ž ;ÁçñÞœ‡ö’‘3î›þ\ÄNx/‘ø•ôGñûô¥òýømøxô€Ì/•>ƒð+ä¸_ðø{ÃyÐåýZâáÇÀ¯ü>v yt¿Šâö„ƒ‡àûùÒ8%Þó*Þ£âê"ýfØô ?Áy GÆxCóCÀwÂ%Eôsg8z ΠŸ‰x ?…ÿ¥Ý{ºuøGÏ!‘ƒ«‰Ã™{à¾Å Ï—¸€{´žr>²GØ-âä=ôÞ?É=úòÓÜÍ—¤Æíôçãlj_¹_}n‘ø'Ü?è>ù ðç=ÂNàGØ+ºà‘. z•ëêçå|ØO~û;Wx–ßÓsû9‰sÁ¥àðŽíƒìz†œ‘ŸÁnŸ%ÞEoB»îÁÎq¯Üä Êû:ß)?оqnà{_ŒŸõûÓò»¸ºÿñÆØUôÃs$‡äÈ{Œý㩺^{«ízÃý¹Pñò3¥K©K^ýQ‘¹6ôY÷ §c_Ô½ ·üøŠç™ScáÈR/ï‹÷+ïÀyq®È!ý5à5ô;Åy/`îøÿ²Áe¶º–}÷‡ Wü÷#Èž*®+’÷"Ÿˆ^w#—Ìs"ÿåøKxdöþÞ»ÖüÄz‹üyŽ‘î 9 þuÿµð Ïá9BÒüç‡þpŽŠÇÜ·~ò¼=§òqÝ"­/q]Dñ;Ÿ‹ã=x^îÿN%q2öÆ{º•·ó~Nõzîó¹˜_A¾†y½ìOc£òž§Àœ{æ9 W¢Ø[ïd~r¸Yúí=êÌ!“]ä>¼ÿ»Å<Ù ÷¿)Ÿæ=VÌí”òóί1o#°7ø?ÏûS¿7q‡÷È3ŸAùTü—ûš‰ÙgËÜp-óèo úr<ŸšyÌmÖ÷a§Sú'™—…üÐ×.ã|ÜG®¾p~€Ïgn¨ûrõûè»÷ñ¨¿š>c¾¿ãyßìg^ó^JÉ ó¸ÈcOÝwÉöЂWUŸWÝÙ÷Ƚ«?+Jôz7÷¡ƒo{þ£çH>ékö^qá6îÃ{UÙçÈÙ`Ž1}Ëž_Ôÿ°{ä˽njy“Ìqæ¯x.+s„sð÷ôg’¢îÆ÷£ÏœŸ÷Uh“øwñVæP¤ÿìóÃq¯Ø3ÍÕ°Ã^҇繨ì›dþ2óý5·†û÷\䙹0á\pÙMöÕx^sçØïK¿—üðÞ#Ký4i{Û3ú§=·•¹:ì‰fÿ†úÎéÃvì·}>óþI=?vÆóaØÛI?#ó“Ø(û‰þ"à>ï{c—þK¾Ú󽃽‘Þ[£÷Å/0óÃnaŸÃýºžg(|æûU¾&ܧ?ÃÞ0—Ås‰e<_–ý$ê³÷<ö3ǹ9:wü"ýѳG_7ã¤í%.)‚;±wà:Ï­•¼x?ªü+8…}ÌIñ<Ù ì­ç:ÐïH_){DØ{ÀœSÍå·{šäØvF÷æ9F²³Þß&{ÝÅ?ZŸ$ÿ¶²Ôi9Ë9{]eïÜ×K±Þ‡~e÷·²¿‚ü”䏨ssØOŒÝ ô”>\ï=DïÙgÎ^pŠæèz^Q°ŸÜv?Ìû1?]ó¿87ïáý™Ã/yoÓË|8ÏÛcÿ{äô÷œ¿?ÿ"½à}<ÇX~üëý)Ø/åÀ/Èzl|ÃÜ6ü¡æM‚›Ãç"^Á®Çz>k°g“}èk8/Îs¨™ªy¬ž.ùõ>é9?G\ï9vì—–]ÀÎxާäŠçˈ‹T'¯à^¼'‰=3ì_a¯u p>ûõ<Ì“ðyr.Ò_æõ ïœ#ùæ£áwˆ \oa_£þÝóõÁ³:OpÏɼót.È7?ç}hè­æ%`OŸôÜÞû%¹'G¿˜K€}VÿPlÇd7™kJÝÓö^ò®Ô¼/7°«ž[$;ˆ^z޾×sµäßÀ¥–Gé9xyäÕ¸˜8;ËÜ`ΙxÌ{Ç„ÏÁO䃑ôÿGž?í}‚’[ÏC€×Á¼ÕkÑ'ÏùW?0‡IøÿÅy³ÀK+ƒyßìûóøæ&†ó5½/PòN=ƒ|…ëÌ»Ôß3ß‚ysó&¿z_íñü)üºý’ìžç—ÉÞ{=ûgð²g¼‘yYšŸ ~b®0{jÉG‚3¨C'ÄŸp®à#ß{eõþÔ›<ÇTøœøØø@vÇyðæ©b7àÅWé\Ñkï=”£®‡|§É®:ŽcΛìÂþ-Õ¯vB¿x î'ÜWéý첞Ï+ÿE½ñ=ókÑ_ïOfï€ü?s[˜{CÜåü޾Ÿ<¹Ï“|ŸÇ\i~OzÏózžšòIö¯zOòÍÄ̵Ó}áÈS‘·ò~nÍ¿#®äžÐSÏyÄ®‘d¸ö,¹þ¡z¸Þø½’Ô“”×ôÍ`_< ìø|çùPz_>½£츑ý«²èq,ÿe:öÁs¿Ò~2ž«+ù…÷æýòÊ °‡{#o繞âg`/½Ÿ^¹ìñ?G {ÆœWïûÀób»óªÄ‹º'~Îsï™G+;EýØó¬¤ÄgÔÐGì¹÷ÍɾxäJv3Îë1gKßO]Ž8ˆy˜ž÷O<Êœ\öÀIÏyøLü»yò»ØeÎÝ{Ä凉·Àgè çžòøôÌ{Ž™WIœ«üõ&ïÏb8ù,ÎKx»èó•¿¥®M^ÖvœŽ•ß×à·øQ}wž¿êý²Ô…¤?Ä=à&ø„ÞW§ü*ñ=ö‚xùãß‘ xVÈòþVïûѹº? \"<ÎïóÞæ/8;ÇW÷i¤íŠ÷§ãÃ>'î^‡ó~äݤ¯äyNûù5ǹ²ÛŸôæÎ­on¶>¬=0/«ó×3âý#òðÀqĹžÇJýWú‡ÿå9¨wŸÃ•_Ïó\ž«—Î'Çó~yo}uQâ4êyžÛ(}Çïáq…û<À§®S³ïBvÂù+É'v‘ü ïÉy"ÿðVÀ3Î籇ƒ|=q™ÎÉuFÉ<8盤WäU_Kþ°÷/q»÷ˆßo|ykïWÔ9‘_1Ï@vovï7 }7®s"'ÞÛD>UòÊscW÷÷“lqüóðàÁÒ7p"çŽq#ï‡&®Án;ŸÈ¾b½/uNô¾#|Pðv:òî=p²ÿäS°¼‡ñü`¿ ÷àx˜¼ù  .ç9ÏÒG佄îxPσ¼ÀCrý˜¼+{Œ¤ŸØ1ôÆsŽ…¨7òÜî ;KÞ¿ÃÏá'ÂùÜäÙßÙ;Cž@ù#óeåßñ‹|¯÷()‘ODŽÁ¿à.ôÿŸ|éúôŸxØû¶Ø_–þþ¸+œß¹…I\‰]ð|têÌ·UÐz®{³¼¥ã°‡À§e¯<åK¨O‚£¹ož‡{áóÉïö|vö¡*/n;‹} ÷'°Ï<ý-ü<ùZxqøkõgXž<]8Á÷ óOOÀ?ó¼~½sÁ½—€ý‡Ø{½ýôÎGâïá7“Ç‘‚¯°œ³÷V§ƒ˜cL^_÷@>tfÎòÁÅúöwœåz/¸“þA½'ñªç+ž£?Ðs©‡ —yž½ò¾ô €+°æ—‘Ô‰7ÎEò‰Ü{°ê?ä%½ÿAïÍ÷y¯½ò³ð°“äIÉ[“%Î"_ãx%¨ËëÇÿb—Á©ä˜› ç+²‹ïç`wø/u,ÎÉû„ƒ]Ôó¹ß‡Þ°×$àwRÇCωóù>ð úi^·øÂÆqÒä»ã:ü‹t|ïs`O&ÏN÷»‚S¸òØ!ü/q?øÜ‚Àp?ð6Ÿ‡üQï#.ö~YùW¿ŸpögOµš÷œpsvœdN8üEâ9ö*ɾ“ãß©O¢×ä?¹'÷')?Íýrnè!~Á<<òïðéT7/kΓùÔÈ9v =Á>ó^á^ ïQS½¼:ÄO¼ùêRðÁÜO(}±]’ž»ß7-/Ì?yÑð õÈuKì˜÷c°Dö€û yöØgäËó7ØÇž%ö‡¤õ6Æ?쟀§,?Jþ“óqQú„½àþ¯€W%}‡‡}Ë»&röµºÅñ¦ÞÃä÷àÏÌkK×S‹ìç ízä|<2ö®ëûÁ¡æ“HþÂ>Vô˜9øï»#!_¢|$ö=Øëäç—pà8ó;¿Ó_ÌçcOÐ[ü0|×󨣃§dÑgêYæÓÃo‘?Þžýý–/ùUä–8¹®+±'^þÜá¾6ýÙñŒâNó»ä½Ožp8r†œÂFo‘OðöŸüó»Êwá/÷üóéÉËW:OFÜàzœô=*|þ†¼Œq?r«8\÷ˇ>Ïymá>î‘>)Ι8þ1y"ì8v‰ø=°½—>Ã7Aù}~Žù!è—íô•<’ùHä—éss û,9…‡îaEν߅} z>ú T¯û?P7ðžá¾°?Þ톞Ÿüïá|žðøœŠ¼QÏ„ÿKÞ›ûBŸà ?ð7xBøyæúc%ŽœºàˆM¶ŸøòÙüvžÏ÷^c}ÿÁSŽÊªØÚøŠ¾Í}ö<=öƒjnnÌÓÒ}\v`V×›óã>á[êÉØ]žWóÚSfV~óÍÑû>‰ƒµŸÖy ø]œ<ê9z?æûûᯩnï>é;v’¿·¿ ÷!›o¦¿÷Ñ ¯‚s³ÿT1|Có`ÄÓ’Ç JþÜr%\¯×|=7õÞo‡ƒƒÿÿ;Èû`_¨÷°oÇýÊ«²§Þ¼vå9à÷ho‚õœ¼+y0ü¯÷±çWvŸ<˜ù0ðKõïî'Qü.do˜ûפϜ»ùâe€[5‡×÷»¿Aó×oé4ÍÏg~p°»Ã¹ÃCÀßrž<¯ò#ÌWô¹’o'INÝwƒ"Áy±7žûtŸ òBvIõf˽äÝòÂÞ5É ïå>(ÅËÔ”º>ÿåÉÍ}ŽæH˜¯Ì÷‡ùeì |läÐvM~Ê}/ú\ß?{éd‡Ã}\<¿ãvötIà˜Ï&{És’u߅佘ðÁ<ö ýðSù}Ë—ä ý¥îë}ÞŠ{Â=Ùð`¹øä9_÷ùG~ôýsžü|Ð_¿@ÿ°ƒä§x/ü»ò”¶ËÈ?zç½›ðvQ­:5º0ÜyEìrï>©ôyD‰Q‹ï¯Ýñbûž_ßãwQx;ì¾'É3zâ}qôÇé¹ù|êgøSä¾)çj^‘p÷㹋ðEÀOé8ßv8ç>$ú$Áñ’7â×·”Õž—Ô·ëÆ>2¢iwë7ù çcX~ô~Ä…îgÒ9Ñωý8za|ãC×Åó>õýèr@^ƒsßúü$äáY!§¾_Õ½í§Ù£+9Ñ~(Ÿ›y°º?âÞþ;öU{YœÚwíØkÏüw˸_Š½Úºo÷÷ÉîÒ§Æó“Ÿµ?'~†¯,;Åóšÿ©¸Š|v’ç5ŸSv¸Kç‰|€Oàãi?J\7Òûò<Ìyt¾:g‰cÈûŸ¿¸äÐxQrj?€½Öùy¯2øU÷d~½ìµùPÒ#ì?rç}öÊ㸿N~¸Çûáõ=ð®oë{‘Û}½×½öÌy+}®øoô„ß7¾Žr? î ¹¡.†Ü„<[ó#ñGðÄõ¼à*ä€óu¿ üöNƒÃØO¬sC¾-à3}¯öíÄý‚ÌÜ1w&Ìx¯+õ!îWþ{Oüç<£êqä#¼'ÞŠž¿‰_t?%x‘î=„? ¿;c|ˆ^)^ ÿ ŸËq´ì0ø…ïãþ˜[o€{¿9.Ÿ‡ç>"oÏ÷¡¿Ø!ä¼ñ!vÜügêVÊ[â—'í­‹í}Z?ã<®ì¨ã áãòpzÇôÝÑg_*Ç?Û?ˆWe½–ÿ²\ÁÓÓ¿Z:ªþÐN-­_a<Ï{Á‹Æ.¹ŸQzƒ<çÏaÏy_÷¦ý`Ñ~bø½²?îƒUþya-z¥½¶‡è%òýqþTv…üx > zÏçqî[Ýgá8¿*Ü«8Áóàù€ïÁÅðsöŒ¼¡éÑOÖˆçFáŸÒçÇž˱ûå$çæñâ—¤ïÔU׫®çxM?ソz¿Ð®‘Wen‚ûàÇð_üx‡|´ã,p$üÉòá¾vÅiîÑyó9æñÒ¯/y¤nh¼.=øá‰ºÕ§HÄýïÒî•ûçs˜+Iùs¿T0OÍüWê=ôýëç܇ xÅv‘ù"zêUÈ“qý5Á¾æp…Ï_çŠÒON”ó1ðBewÐ_p‰ù ä-°ÿøAé·ãp¼ξEÝ£ýu?ùx«àyΉ=Éæ+Ñ¿€?ßê9°ŸÈ·ûõ~Ø üú³*³÷¥¿U+a\ÌùR÷uÞDvØùhÙó¤áçQ¥ßMvÕ–>ƒ›‘Cï?ß=ç9ä‘þÕ0_Ãs¸_ZïCÜîøJvÜAý:ÌcWë¼ô9¶çäÉ÷{΄òXOÿwmÐ'Z>y^û)ÉþÆ}gz>îÇ8;˜³²»°ý]kv¤b¿,½!ßd;¢óôpé÷Bþùâ\À‡ì=÷ÜêJä”o …þ#êÄëô¢ŸÌï3_"ûÌœgâD×É%Ø÷"|oáC繈è¥G¿…ÎÍ|PÙ#êÜa~ »ßœ¼ øÅöOñq1ŸCüÌs¹~¬ôŽ~;ò*Žûå\¯Ô}7¢Ïæ?*gI0ïÉómwðsž³¡ó‡¢çØ+êBÌEÅþñØq÷% ¸’:­ðŽùú<êæÄQØêkà>ûùwž¿¶ï¡ë¯ŸÕ+Žkd?Àá>7é-õòÌØ1êÎGRŸfß¼ü£yÝzî¹pßy$ùmóJàåèß]¥Vuê"Ä1È¿ý)øŸ¿.oHÿ¾ã0ê¡Ò?ø²Î_J~É`ÍËÓùчj¿ >Gž…¿¨Ûù<‡sžž¡çAþ\'¤~€–ÅN`§Èÿ?r?Ä ä'2'¹FÄ›ÂóäÅÍ•u¼#í96̯ROálì’=§¯ÂòŒü1o†øT÷r³øÄÿžÇØkü«ói½w=}#o ^ržÎyçä‚GàcoÀÚgn?€?4®¡ÿ›~¦ è¼sîd7ì¿ÁÙ²ÞC¯_ŸG?ëÁÁû.?ãµ¾ï÷Þ§òùÄmØIçI$ØYÏ <â×ñGðvœ¯£Þ#¿â>rÝ»q–êùÄ Ø5ׄ·œ‘œÿÁ3ç½]?Ô÷ó¼ÖgüsÔÀwèñ1}äâÃóûô‘"/àBò–üþ½Äû=É£ ï‡ß‹ ·ð¬?Ä7zOæîà'÷ny¸×†ŽçÌ€wà“1LçÅ<[îÕuoæVȾ‚£ïÉÎqNøoòž›©÷'ngòyžãÅœ/>?Èσ{£"øHvÏõô‡üƒÎ»ì¼}Ï䤷øUÇGÈú«?“—E®ˆÛ¸oçOá%ó§È߸^FžF÷ Á:_¿¢ßóÜð$q›~Ÿ<°ã{üv@çÌsS' ‡' /ÐóôàKüQ¾—|¥õGö…ÏG~y>â-ä>¼1ß3ïO}IÏíø'à=8ßÎ=Rǃç"ùâï=*˜¯å>búˆ[ðkèP§ çL§x.óH¨ÇèóÜç^Þ!Žt÷“Ÿ1)½Ï7æoQ/W]9/`Þ‹äÃù|æ^èüÈ;Ï |ï:uFý;ñ¼çœ)\èÏÆðQ¢Á£*¾Ö!ž †ß”½s|Âù ¯„y,ÏAQ¼ÂsóœûGu™Õä÷ýq|©xüì8<èÃ7¿Œ|jÀòÜúÄé³#?G_'<ÙIÇû’Ï øåþwÙç°žÞ%Äç;¯+»O>Åõù;Ç…ðI$žOÆœWâøâŠŸÝ/“~_ö­úû\G`N/óô{ÄäÈÛïË/P³`òU®ƒ`±#òÏÄÃÈ“qð}ž®ÓÃߤ¿?¨ÂÿEð‡äY8WóÂÉsÀ«'?£üsÏÉ/aW‘oê ¶—ÒcòΛÿÈŸ_x>:õLéùáœ`^·çl·Ï£ÿäÙëêyŠâƒ _žû,y´¾üÏyeNŸÎÏùFâEôS¿ç9`Ìw|,ç8?ù[ò‚ð›œ?êìûs–8Iù2ì”ëþä¤ïΣ÷È78ƒz”ì¼æzpOæ¡ïØQÉ-8ÚùE½§y£:ǰo“¸ÉçE< þ¦n˼LùiÇ{ðŒt_ž¨÷q?ß–~ÒËùq>…ÁüÞ >)~`\,þºóëø}æ“ ×{î»ä\€'sðˆOÂ÷@^l7¥wž›Š½¢þ.fn8z‹|(> çÚ»>FÞFvÛóÓáS1g‘ü-óê$öszü°q°äÌxKq:yrë·üÇ·gîûÄâ~iâ5ôCvŸ/ÃKð¼Z>W÷Î} æƒ Ÿº.­÷6gn0s°dÉ߸.({ŠÞy‡êÚî{xà5ú7G2WTýaØ×ït_Ü«óZÊÏ„üâpßE¸O‰¼¼aÏí–\Ý''¹ñ æ.0×Þ¼‚ ÏÍó0¥/æ9’fN5õCÅ©Ø;øuÈùþ»l~õUøwÌ¡OÕsBÉg ƒ÷ÀWæ½Éß{.}à’SøºäÑ8ø-¶»Ì£c>”Þ?½ Þ“}ä½|ßÌbn#ñž¼•∸ï Þywå;y÷ƒwxoÉyøÈuò<Ìqu¿¥Þƒ~õÇÿõH%‰ÏŒý;û˜ó"9±¤qñ¥ëMé|~”Ù©ý/]Ï–¿¡¿„û4?…9P£‡è9êóùµ£Äw7.:êÍ(ãœ×¸¼i©ÔÁÍ}nþá,ð[”Q6±murV\‡KË_”Yjüô¥½®6~Aoè»Ý?é› -^è×¹Óù‹(³÷°…§Ö>¿H==‹œzQ‰®7Ò§¦úD”¬W¯ÞÀ×ÏŠoñí–ßÏsœGÜc<_+—™?Œ\ñü+ÚåîfŸÇq…úP²Æ—{g÷¸1ÖSì rŸ•~D] —{6áýÈç] îthFƒÖ o­÷/(òö¼ÇžPúœ£¬îûš¤æ&ãøCùÙ!çÅÉÓHo£ÄÕïÕ~¶ne×ä§¢Œòí7V^óý ¼ïÌ][Û´n[Æyâþ]ï%¾m?å›êõÜ‘=´ÉE«†ˆq{ZŽ¢ŒgZ¶Î(ËY²lãkÆœ9Øyaó)è/R>Eòk¹¤.Eý[}´QâþÑw–9²ŠùÄäué[°ýO¿ :‡åÏq$utõ9‘Ï1~ ¿Xþ’¸KvÜüoïwaþ8\vÁyêkÁUæÏ⟩ŸÁoaÿÉ3ïR³[Û“ïŽù\ieÜ>ò©v¯Þc9R!Êx2ÕåÂÑש3RTƒ{‹²¶Ti¶ø¨ŽÎ JŸ-äÝ”?¶½!ÞӣĹ¿öžøÑmàÒ(1pܭݶ,p~=òÜjÕÛ7Пe'ÞžùXý ¶ÛÞS |D>@ùŒ(㪧®}sêî“C>ø3¸Œß3ßT8¹ÉL,:wÊÃÏ[¿ÀÇØgê%ê0>G”Â>»ï {OÞÌý5Âÿê'·~)Î2¦WxeÒ²l~.JÌé_¬ß‡éáËçέ}ÆÏQÆÚgÆVÈ-%}¾Çºº¯û{¨âÛLï79æ+*NSýÔß'¿É9?ýQrXé¹.dƒ]¡~‹}<8ù¢F7.ïm~¸ ;ˆ¾À÷ó<`^u/ô…yæ'Ðw%?€¾8_(»%%îü龪…Åã¹úì×Hól£¬u/^qÖ£µœãü¸÷C›ÿØøÞ¤;ŠÌÓ?!àOî~Uòpôk*в^ÛÖø§ŒÑÔ£Äÿâ§¶©ËOyíÃ3_³ü„zð§}îŽ2Ë7ý¥ç=œ’<»~éùLé{²}á÷ðwð ÁSº÷(Y㵜güj”™zéþb âýKä/tQòÍÊì.ÏyIÇ5öCä”§Š2‡>Û¡þó›Ð÷(1®bå…à¯(cbëKÚ¦l_É× Gã%N_õIŒ›d'Í7Pü‚Þe6~þ¦Uu†ágŒ7”Oòyêûð3èö-9ýè{Vÿ üå(c猦í+Œõ"}_öòûQâ†i£N¿ý£x0ùÙsô¿Ë=é~lÑGøŽ‹•U= ʺ¢Wòá‚úÆ]à>ïŸSœ‚B¾ÁUâ%DÙkïZSsìýì9ë›UZ’_-Êz×­ÃÛŽô{*ž³<FYǵ˜Ûäþ¿äðç¶ÛVîëïë?E/ì…_ÑKìì¡‘Ûݽú$òaQV4àäf?4ö}“7 ó¶Ÿ_ sÍ•‰RÓùbW²G•hûìžÁñü£t]+Êî߱߆Ò_GIòFÊÛˆ÷Þ1ÞUe|ÚûÞ*Ñè¸Ix×ùtønä«Ñ'åºVÚÿ‚‡íg±ÂUQFãÚwo¹Îýà òjÄéÎ ãŒÇ5Ýs«„«Œ[¸hÕ÷í£ìͧ\?íÒ(Ùdô§gŽ·½Žˆ²5+,|û,>?Jv~õî/ÿXçè«“þ`wyoãÅt¾-JVìÚîâ_7E‰ÊwÕï{Iß(ãý¾×W©6Ó÷—±eâ¦17tóÌs–œKž¢ÄϽì^fz”™=oFãœfQæ²-÷¯7•|r”9ì·N?œQÜ%.®Ú{y÷æµ8É|ð¨ê‡ï¤†Æ{¸dß…Ðô¡H?›óŸiy8ßDOöÿhoanë²WöÛÿø+ÊlÝõÞ£6×r¿)çAå=2Ê«™/«<~Ž8Ãõeú'toÙÕæµx½oiûMæÛÿ+>•\ÄŸ“ÎÓ:.á…±oþùä¸ :WXØÞ¸X}~îÓ'a×Á—a?˜yµú9~Oñf”9 ÒÝ·ÝÒ1æÇËß`?8'xâ•aãçOë…ï¿ãº¹â-ìIÆŠ[&fï<à~5ò¶òCQFë·žS¬cØÿgüEýEöËþÖõ)ɇìƒãIú%Íe~HЬ<‘?—¸‡¸»þ!÷Q&¾u\z‡¢Žæz”ð z'ÿežóćïÔœA¼e=>n`·Ù“ÈëFóv |wÒ×Ö+ìƒ>?Jñ_‚û,ûwÇ+Ì¥×Üž“ü&8ßóWÒñ¦÷:GÁŽkž@œ¯€*¿Î+ Î0?ŒxŒóW\Äy±ï4kÖ¿¶~¿w¿ÇŸ£Ì‡n)U¼ó‘ñç+.°½›|ý’ŽìÏÎï…\âÿÍ'b¯™x'îãφ|‘ðªq"|GÅéöSœ?vIyÀ(;?wM‹'«à§ì/²û4ýô©ÂÝþ¹déc'FJØÏÙ^¤ñýX¼g”ñ¯U[z?õ„í¢øœQrrñ¯wŸ»ÚyDê+ðÉ_xŽ…òiÔ9ÜßF}RñßÃùãï½·7ùÜUÏßEÙ¥ê~3óî~q^C¼ïP¾–¼&ñ(8^¸Òyï»VŒyŽò«qÞHøœ÷7ß(³âø9_X„£œ°|ð·fcFœ^¤þŒÞfU|«ß’¿Þ{H^Py{Ç-Þ[¬¼5|PçS„ ‰+Ì3мâ|ä|¡ú³í9uSð"~;É#Ù]ω@o¨{R7@Èÿ Žç¿›G–¶ßÎ×ñy•þ{~Þþ_ø8³Þ캽:ÑñjâÕó—Žn5Åx‡ç ïþzáÞŸ{¤^μ2âÔD¹«ZTk¸ýþüƒ=FnUßsÞ{j{¢¸Ï{vewà “Žç$’'¦n/ž¼’òÄø#â=ç!蜢äéoô½¼Ó!Û-ü¶üþ/Êltàƒ¾Gd?Ž^ù{Èû§q±ýKv¿ø²Á6ã~î‡ú˜óýé¸Îxºrž}ÚŒû6{Ëx”øy$nÃ^8Žç½˜ËÀœÉ·üV”ÕtDÓÂIQÈw¼¦º•í2zdÞšpyáÙxþ‰p ùSüFf‹—ͼâј×Ä<øšÂK™=ŽlùÖ:Ö[Ïõ—=W<Ç1imÿƒ½SÜ÷±³¯0]_Œ’ó>¨RPëìqwìçÈ+Ó_þ÷ø9Êü䈟 Z%Á QfaÓk޽cšýz,yÇþÆyMùqÅ󮟉e´íÕî¢Õ½ÀCÆÑ汃[•?Ò{rQæø‹¾8gvÈyLÕu£Œÿúщެy%–_;gzÌo ÿ˜ù`ò·Þ¿®}÷ÔÕ\ŸK?¿ãVɧï%”÷ý+Þ‡à>RæûPÇ“ýS¼€0®T>Åx“÷â{œåüUCþ+:,vT-Ç}ä™<þIÙ}òþø?ùyð~”µtþ€ãã=hÎã‘/Dð³Š_œ??aWƒçˆ’í/®¾íÉ!ñüꪓ§Ô{ÅϗγÆýóâa)ÏeïêºqL¿šŽKÈ[«~eåìx²Wß2Ž_‘oòÈä”ò󃔯0ÎËnuð‰÷FLu†<*sv’ÝÖ4þ›Øn’ï—_†7A:»é‚±g^Ÿé¼ï¥ór<?";kÎ? '8O'\H1¾_ÅÕø5Õyx?Ÿ ù„¬ÓæÖkñ…õ ûLP~Þ8Çó¨Ò¼–(;5êÞ䲺q#]²uÝ)G9®aÿxиżeágÕ]|ÎÊ/™×‰~3‡šúrA‘Ýಶ—ï_m;ÆÏH×Û¯£ÇÚûáøƒzX–ò àxÏÿöœ‘t¾,Êþn{ýËÊ=d?o^–ü¬âXçßÍ ÏA|&ùsûÉ"ùì4_)J®ÙwaFÎù>ðzEFþÄr/½ˆýêÔ’>þœx3»K©jÇOÙ`«ûýUú<ßÉ¢>¯ø“8:ºï_ù-ì½ý>vB¸Ús¯ƒìge7ȃw'‘OÒ÷;¯ÃüiÏ}¡OEz Î)Ê\÷ñ]3ûtŒíåÙoîŸ=ã2ã<Õû£ÌÓv¶*8qŸë ÙFQqû]áá¸Î®Tœäy¬Â[äõ¦ã8¿¿åž‡êÿ¶Oúwáß7üp¤üf”™“·õ=Ï=uþÀù[ŽÄùØ=é ùiç—/ÃÇP¸ú­ý‹âÕ!£ÌCJ½2¹m”]¦û®›Ž›Ç'Â!¶?ì MÇyÆçž¥¾ ê¥ÌQ'Фž…)¯ã8WøÈøÌyBôUvÚ{<ɳH?ðÓäÏ\Ÿùû<œ(sJÃ/»}·ÕòËïyªê⪃».ãù'ú<ꀞ?¤¹Rðyd”õ`¥C6WÅÞÁï0?Èû¸ä°»à!ñ]ìgˆ#=/A¿gœ¨¼”ùaŠSÝLžŸW]J|Ì#åoŒÿÙ‹ƒþÚ^’§„| õŒ-?«òyÄùQN‹Ûo­öí¥Q²an¥ê;ëÅr©¼’ëĪóRßïû$°~Iïð?Ä1îûR<£úx<¿‡}Ú’p ßC^!y÷’ m†.÷}«aî·ó,Âwä9àmï3¿á³&ÅFuªÙÚöÁþ_y ì(uáäîÊu/ªþ¼ó3èÏ=Ã_dýï>þÏ“S]—sà\2ë¼}Ïsã]Ÿ¤žá9OªÁ—?$¿EÞ…ú›æF7:o$þŒùðkɃguévëîí¥à):®Wýˆ·ÿu¶~ŸzCXŸ¦;ž†Hœ.?áøˆø"¨[šOªºíxÉq²üyHü,ï)>ªë2äñÓÔágàÇÈÇÁgÁ/ÙO—l¾­ë›ãyùï?G~ü~æ¡1? ýy~N>Ï{¢˜ë«º¯ù\iÜl{çýÖ:wÕ]ãzuTÕ!œÇ–_p>“yQ/<•õÞÛ—kV–8×ç¿”:0øÁñ"þ^+ö"Ïœ?AÎ4¯üéºû½™“À"õ ˜O'Þgö¡Ç¾ZZ¸Õs$ÀáØið68œ<ò¦xÜyiÏñUŽz–ç3Ÿ>͇6žÈ)ýYóß®*óÄëæ9\ºwigÿ’?êÌ‘ðFÌ÷NóUÌFNÜO__qŸónéüŠåOù!ǯ™çŸóÆÅ'×µ= óðøìω\8¦zŽûÁïáçÝÏżFÅÙ®cHž”ßñŸÁáàPü;xŒz2þS<ÇçÄâi™gEÞÚsåÅ»æ\ÜGŸ›>oxIò»Âqæ…¸nžÆÛθ.8ý¼çº_·Åñþ„¸  oŒ{#ß…¢EÜàsÛù"ùv½ñ¹ëcä™É#‹7ï÷¿.¿ì¹˜â§’Oß9æ§Èî/k~†ýü3êPæ{2ÏQxʼ¼´r\Foþšüò™Ü­ô”º6ÎË*«x¹HýÁyzò§à á1øý9=†?3}éHûIóx”¿‘œÙËl>óv„OÉS`×Éï ?àJäŸxˆüi8ïÎü“tÜåóA¾àOôÜ å/<ÏHuAå9ã¸Vrâþ}õÃ9Ž>èyñêGƒ_ϤIq‡ä<Æ]Уċs}Þ‹qµâAò\¾Gá_ògÄ3Ž $ÇÈKXv>M|oxæ›*¾”¾ºÎ༼x'ä%È›˜æÔç@¿…ôÄ÷è<sc”_w|.Ü¢8Öõ¹ Î`ûI~Ì}«Ì%~ú ©ïg?ÐnÕn7¸â¾¿ê“®_ß@Ï{ÔÇO~Gña¼—K8Yö(öô¿ˆ'ä âz+s”—&ßJÜÎ?“Ï4.¥þ+yã󈣰ôSº_Zq„äÕ÷‚œ…óÝ™+'ûŒp?yrââ?é[œ¢ÿ€|i:ïæçg›GÑ¢ÑÔJn7îæ÷Ì{€Ÿ.¿)y!ˆr¾›SeÈÁê¶Ô¥™?¡º,y®"sÀ«Ü—ö¥ú¹…{¢dÔ>9~D"ʪ¼V¾ÊMŽWá}ºo”ù·Êwxž’ü–úGKß—¥N¥8…<7yFÿ™ú¼÷`kž…>'Ê׳×å«»Çy}á'õÕ;Ÿáü¤¾_õ(äÍþ›::ñ-yªÌt^~ëuðcáíQO ŽÒ'åëñƒ>铿<8.âú8òCžÛ{@Òù…({þ;-?[rŸí7xJþ0ŽkÅ3f¿•ý(ø*-7ÌMp‚ø*ç« êö›¼3îC ÿûï{Uœ§P]2Êüý_Ç ¿;'ôwæ[óÌŸ—ý`~ü+äûƒ7E^¼+éePí«žŸ<òÞÀ¯R/ .ï<´âü!ÏOÝ—8Qq08˜úžëªÜüxûéMNÙ6CZÜÿ»ã ñ.£dÿA£_ªšÅù;>R¼D>Óüaç¡…7™ˆüüθž™ÎGZ¯”_0^+|8xÐ>éýAħà9Õ3bü¨:¼7ò² ìs1ïM}ºø7ÿ=ñ·ò»ÜKjäQ߿ԭŠóÚðªÿÇzî{q^„‡ïï¾!ñ]ñ·Ô_Äõ}0·ƒ>xUÄ…>gÉ?ç®SßAç©^JžŠ¹îäËÄ;&ŽwÜê{Õ{å´ý´J^å<øÜsÚÈ«G¤n²v.Ývü¼¤ëÑè3yî‡:q‹çP¨^@|üvçaßÎÕúøŸy i7™*ÔnÔ`«]ïOµS¡‰¢hØ¥BƒŠÚMi–&’B($c™g!!c¶¡ˆ_ûû9_çu¸î£ãçŸçð<÷ýù\×{Xë\çZë\ê[ºîÉÊ«ó˾ÿ>ƺð÷ÃùO¼w¨7/<äƒÃ3Æ~ï1­;ø©ô'Ñí*îWçê\Çn×¾çyðaü@üèM®‰ßª½î|›Ôsá7šwÒ'xïºÞâ÷Às‰Ãô}4¾žâ<ýÿËk$~*/“ü^qPì•|Ýâ^ò™—þჽÌû.ºýÄ;ö‚& ·~ïy;¿îUx§Æ¯ÕL^B=—¸98¥/ŸI¿=z™­+ ÕÊ«¾´QóLòíJ?/~ïâyÊÉÊ;š“¢.÷.y¥ÖÅyžð×Å{ÁCí‹^ÔàϦû<ôä>Ë¿¦>¬õ±[í»’‡T§Õ>”ðÿìë¢óWßîUŸ=_>ðæá‡Ê˾ì]klú¦—4®æ—3ÏlXgõ1ô'‚¿ÕÕÈëÈDOžè÷ÅŸx%<~¼u úÔÓæ½’wl,¤îP½’þù4ç¡õ©³/©oúqÓχW'@%þ1ø³v?Œwagû|á÷¸ùÐôM%ÞÞK½˜uŸú£æ…R‡RÞ¦õ»ñlj?‹kÄ#á3Z¿‰7é܌ԕXÇà–â ö_+_#>ƒ;ᓞÿ©]nÝÑ‚ÅÇm³ì?jßrãí‘îgë\âwšïß×M7M–ìý‡ûÄýfþøÈSNßê6h|=õœø@õì“>Ev·~ÿf7‚Ûå_=÷¢Å¯þ좇=¸öŽ’üªúz#ð®þRö Ÿ×ºšð(êøÅ§ sŽÜûÌc”Çk~U=;™}©ß(.IˆÏŸÀÓìkxű^Êp¯sŸÎ o_ü‰Ÿ”¯­=OÞi4¯}µ©?ÞOý³¸hZÒ÷²­Ã¥’>°â88Ç=UG.Ïs&ï7)îŒÀgŒâ¥áÞ¼m×_ï¸ëC‡óšûî'ÏYÞrÔŸ>Ô5¨À÷æÞ„'ký™Ï[¯ê\ç~´ßWpìbuÒÇ Ç%ìGúRr¯kè,üÍ.§?ç=+7ߦÿ©ùúØÃô1Nïxâ¯|Õ5Íëd~ó‡ŽQ/X;a¿r=÷8¿Èïu~XpZú±Êâíø/y¤ž#÷zðŸÁ ú›Z§”ø >¬ž‹}ŠÝk½EtÙ:7õé¾gáÓN½þ®-ç–W`—ùÛôoµþ³ýI‰×äð,ÁGŸ”¾túMÍë§|ÑÆß8æˆ;tˆÃÔ¥Þ-u`pï-¿Š§Ñ?PªÔoÑ‘ÂGÉw;§âðö_¶Þ\ý=<}V÷á^4o’ü¬8iɈW†÷áÕ+ŽÞñCç}ôÎÞÏêäçðÍããÉó}µ©›PçYÝfº™éçÂóŠçRW:à½ð§ôó›ïIÞ¾:S©3¨ßLý= òáUÄKÍ·$žÒ×Ñzuý‰â0Ÿ£ž>ñ–sê¹ðY]?~.ŸÖ•ñåáMx‹ßâŸÚ·<òçü/¾VŸYýmúñLî]ñ:0ý‰CZ?“>õî3ü¤n(ù“Ö=%ƒê]4nT‡’º^þ\ŸZò@å9àöQ½÷À+Ç®©ÿH~yè§Ì½o~ÊýÊsê'¸òÙ«<à¹ûîÔ¿¯¿ß]ôÖe[,øüC=oÖ¹z ÓxrÈÃä}Û§—~—Öw„?—¹ø#'ì:w£¯unIí°ûÿ²h­Ÿsæš§~-q?OÞ#qS×£º:‰ÏÔsËê›éó¦GÞï†çl<~o~¼÷þЗR{rä\3÷øú½òôÉÿÕÏÈëÓéLß¿Ì>V$~})ˆÿí~NãÔÖ/:çò¹òzò¹ÕŸ¦‡üØ:ýð)™g7ð‹÷® n~·ñ4‚ôà õQø÷èy"v ûZ=&yƒüžz:WøÒòù9‹ö:þÄ7ÿý}ýüÅk~é¾k¼~Ñd…Îýò /ýAó ö5qéd…û=íÓo»ÿSŠÛÜOñßâCìµæ#~4ðØÁçîá’µý?}úðûÁ½‹w[ú†í–Ü>Y:gÓCWùÆÿÒ5j~mÑÌÞ½ñw 'KÞzÇãnYþ¤Éâõßþž‡?d•ò±îGßoÿ7[õc;ôý—²ò¥yî¥O:ìôs¶~×dÉ*?{ÎþðOûü¡>òÄ‹Öíý_ú•¿}néSvóïå—–üvÅw¼Ÿ»<Ÿ~L<$Ý¿%[/Üìä| q»»Â ¯ú£Où·Öèk\¸ÿû?hõCz¯Ü£Ö<å7ë?ùÏ÷ñ}pTó6ÁÉòþ~ÑÁ»~âŒ}±¼Ã’Íç¬óÖÃv¬øÛ­qž«ÏëžZ·~~êÀ¬ïâ%ozÇ÷æmU>þ/¹ãEëítÍÏ&‹Ö_ç3'íuËdñ>¯9é'~édÑ»68ó¯óÿoÈ'‰£sWXu…7<úÂOt?ä-àÂä‘ÊóO+>íìÓOÿé“ÅË7¾èQßÛ þi\³ðÒg.øÊ1wMVØìª¯®zÃ/믗œÿ _¼ð¢ù­ßàŸñ¾þ¿}¶êW_Eg§y‡%§ýx¯—9‘oª=Mÿôdñæk½xééG—·w~û³ÂŸ¯~ü[oYu²âÌŸþçØ—3àíÜ—ØÃÉ ÛÜï'|ÿ¿Z‡¥ßm–ÿÀ{,_k½SÎߊk^óæWoøŽòK‹øÝù¯½îáåá}û·Xq]ù‰ü»¹èE[Ì{Ògßó\‹o¿õýgmµ^ï7ÿ‘ß¿,Õ¿]+÷J÷jIâ|§ŸcŸ]ý ÓO¿ð™=g­?O¼øI;>êÖ ž_ë÷zÏóÞÖ±uÉ«ö÷Óg9ªã+îÀϸü±sQ»7g­‡}ç!“ÉÒ™»ç|ŸýÊ‹8êÚÝŸÞ›å;,ùÚço/à9ÝûžßØ«ð}î•8g¯5ßrÙdÉW~qø÷ôÛÞ¿O'gÅ]²úß7>ª8V=Ç’Ýw篿=iý\ã”É+xøÓÿ:Yºã_Þµã[w«: ß'¯Þ/}[応sü¯çj-÷w…oúæÇ¿ûÏó<é}Ù§Å{>í‘[ºûdáé¯~í¥+o<àóäYý;ήXWñ¡õ†kÿp½³W=íŸþäž‹×ÿø×îEö­ù”éûûå\Lë±¾#uýÍÏÇ_ÊCòïÎñ¢¯œö_ó:¢vaÅø‘ö‘äž¹—öŸç‡kÂ_.M=„õáWïÔõ wúÅ·=®ùþÖð3î»û³t³å÷9~Ÿ™ÞSqÆ}6»m•µžü’~.»"`GðÎIy´Ô´î5ýEpEó0ö7ÏÛûbš‡ ž]añÙ+/½ñÒÉÒß®ö¸õö:¦ïáó—ìøÃû=ïé´€8¼S»»·ä1sžñò7¼±÷°ø#~á>;þãÅ{ܲJûû¼ç¢K?|ÕKîxà°îâ@õ]t2rîœW÷v…oûì'ûâ€k’?‘…'Ü«~»Æ»–½p²bpö¢Ó¶þÄî{?¥ösþðìÐÒ5=è¥o~vñ£>éîsþ_}´Ïa/ìWírìWu´bÏ‹‡R÷¹tÏUvzÒK_Û{ZÜÜí¾.^eÏ}é¸úþOÌ.ùó]{]|òvÅkÍ'%n„§åçØmïmï·ñæ÷Ûè9õc+nòè™sî¿gï¡çŠNKyá%_½ÉÆ?8 ù“à”ÉâwùîoÝ¡ï»hóÉ6^w÷déýžpÌãßwHy¯%ëÏ¿ÿÓ¾öÓÉ¢uÿë¾Ï{âä>kÞþ¥Cÿô¶ö‰Ë‹ñgöÅÏ'oÝs—¬púƒ6øÄal_ÇÒovØ®;·~ ¸2÷Ñ:…Ç­½óóÅñÙÇò½©›ä7Ù}ðÎ]quxßλíö÷Ü÷!µïð·ýáà/çΈø‰ŸrÏì ?æÞÃ_Ý×à'ù4xŸi¿Up6;X¿:Êó']/÷Ëç:—ü@õ[Ù¿<§Ïóþü »UÜœók]{¦ø»ñRë¤ä_è¹¥Ãú;çÎãâ?ïØvíݺEçlVƒ— ~… á°%?çŠyïýødñVßxÌn:a²øÑ{=ñ>xDë‹à~†]µÎ‰Wßz>ö”X)ç­qH>Ÿþ{§^ÏúúJ‹oøñÅïÚõêcž° ¸ÝzŠƒ/ߨo÷jÅU®}ÞGþ¯îç ¿ý5ŸùÕëŸús±sî½ýI‹ÏûûË}ÏçŠzþá°ð“o³>îœèÞ³¯õóá ¬›x¶õsy~çïï½é9o~ñ¥ƒŸ§$>r?êwØ£œ3ïÑ81û1ÆµÖ ®e/­;ýÙêÕὂ'ì«óiýõq/úÖï·<ðCÇÂÃ³ŽžwéÁg]ñg¾¡8­½:ý_÷#Þ;äòêÁŠø8;ël“Wü{â~ö.€/í/ü OÀü7ÞC¼€wêzƾóË©ßk\_?´‚¼Zê´Õ©‹XòÎóïX}¥WL–n½ÑÿþÉWõóàõÖ¡Á—y_ø¬ø;¿/áiŠ÷ã×Õÿù|8Ö¾·? u‹o<ÿ‘§Ï¬;àµðì’ýƒCè ÉøžN\û{|æø!ÉzڗƯùqˆ÷rOŠÛԆׄ–|ëÆ³ÞµôÁüÁß¹Ï+¼ké÷_÷û;†ïÿ©ýÆG©óİ{x•ø©Þ8LKúÎgóë¹ßxöJœYi¿âñ´î{q3^nÚR¼Y%vƹqoüü’'}ó®—n7ü+\¸×­ûÿñ»;4ž?…3à­& ÷}óÛç þ$÷Y¼°ÂÖ n?iÑGgn¸ôoxÇ!»Îünÿî}È:¯ž9ç¤srîþŸùÇ^ó£-®ûu祟­}2ô¼/Ûå…+¬ûÌ gÎÙó³Û¼býµZÇÀ“W?eçùËÔÝ÷Os×ÎÏí__åÚÍ\|ľ‡o½Òwû¹W]þƒý¿·x~çmÒð™Ë&ùÈ),êº^ñúò˜ÿ}ëœÑÕ[ùËœKüê{.›ùîc÷¾lÓ—ÜÜzáì_þÂǬ¾ìå›w>Ù™wíu÷ÏüéÌE?ÿÝÙûÒ]×k¾õmïÿ_5î÷.ÿõª8yßµ:§øºç½tΩG¼£Ÿæ^׿r¿ï?sæô'ýÁCž¼ÂÌ_»îÊ«þ¸çh˜W–uüÏÕ–ŸyþmÕ3Õ‡äç}ŸÿÏ<‚YëpÔ:o~æ1\Ðzÿãv}ÒÓ7»møœ#O[uý½è>£êï£/B§lÖç:þ¤grå·žý“çn¿[?Ç>ÓÑÿŸÏíþøyçeÙ‘ï\áý?Øtæ²å7ò‡k_Ûºó«—ô´GÍœÝç §yö1+>y…+ל¹lîòû_uäf®ömŸ~Å9‡ÎÚç·u¿Gͱ`á¶~èûf¾ý¿¬½ÃÁ?œµ/9¿ý=ó»R·×¿ßýÿh†S:sĵÿsò/{ÝÌoúý•û­|;Пû˳÷xÔ¢É÷úÿçf.ìe_Ûi—Ã?üƒ™Kæ?îúÞ·içÙÙÇßvÔ¯öØaåþûf^Þù'ßý³_½é°Î‰MþqæÌ ?ÿس¿¹^ß3s×Ûoºì¹ß{Áz_9pæò»ž¼òòÓþ§ïÍžx÷idû<>êö…?ð®™«~ûŸ¿\åªWÍú÷K_ðö§ïðõj¯ÆûzÜj_ÿÞïö—™/ýìû'¯ùÂ?v]rïús£ýèߟõÿê€îìs°“Ë×\é»;½ü™s6<ð¶Mÿ댙s¬sù–›m¶çóò5¶½üýWÝÓ9a9÷ýü¾{Çü¯½àç3Wï¶Åf/úЛf¾ÿÛ®°êO.ìzýì-ÝöéÛ.œ9ã§Ÿ¾à²Õwèïýäáß¾í¯ß¾±û‘Ïï¿Öaü÷ý“ßñ^î~ú"ìÄ»Ïl»ïç×èû]ðœŸ=²Òçþå÷\õÜ7žtãq¿ìÃÓ.üÅÝÿ£ç댻vØúµ<µ:çæÓÏùu¯_ûÔÕ7{hí“ósÕ?nŸüíÄ×÷{ùùËÞóó]¶Ÿ¹j÷-ÿòù=ÞÖyÑþ]?çx=ÎÛãØm}Øý‡óõ‰7.»úk÷jÚÏP¿ê÷.|ÖæØûåWçÑ\Þñçó Ë/ß|õ¾ø×3—~Ï>ËŽø{?ÿúýÞð¨Ín>ufù±¿e£g¯ó¯ö­þÓ<{Ëý>×{vƧþ𺵗í8ó§g/ýÅ·ìV¿{Õßs.íûY·ü~ÇmŽØrø÷—?ƒ›.ÚèÖ+~uSïsû`YåŸ]õÄã‹?z¿G÷¾Nbí¼u¿ÿè~Ï:GöÕyóýúÖß®Ú÷—?7µWýç>ç»õ¸±ÿý¹Ó¶½õã»ßùž™Óÿúû÷¾ì7³Çÿ¯±ì/ÿý¢›‹›Å >aµ…¿ûä%í³ç¿ù#uVìšóÂnÄ. ñÀ7¶ÿú+ß~xë^ÿ…]ütüN~oÖ¿_;³ÊÚ_¸æ¬>wú_Ú/ 7_ò··>ðÌ݆õ^êÿç ¸*ýpîew¿tß[<¥v‡ÿ;åÜæª+ÞÒ?OzÀ³ß¼Þ7¶ê=ßkvú¼ÅŸzë#¿fÀ»÷~¾Yöå/Çnô„W¿ê?«“:ІõÍçó§ì6çÌϾø8föúNïÑðûSü1ØñàT¸Î½Ë{Îú—¾|ãvûÎNŠKþüÆÏíqÚ¾]{áïá?í~Öën~ßdÖz&žîÛÔŸ ÷$ñÊÉØ`½cÿ1<;Îïz.ç#8Ú¿ÏÂÁžïšçì¸èâ 6 ¯ÀmâøÎùôÑkh|ä½2ׯŸ÷óÿ‡GϪunƒWž!øVÜÇîù\vœýãŠÑyÎUö¯ñmxçu|.{~ù߬Câ‹™ewÿî·ßzìÌYŸ\¾Ó›î¸°÷/vkÀaÑ‘ Þèߟwçò¿ôOùûÇÝ~Äž¶æ¿Äոޱ¿óEg¯ÑÁ+îÎö[7ü|áÜ»Gâv(s–»üÍøüƯˆëú\ô2ÙëØóþ{øŽá¼G}ú÷º?ž¥þ¶÷(~Ÿ¿Öߣä{ìë(Ž/o•8©ñ‘‡÷ÔAÓ¿u¯øÉçüäŒn²]/??à߼=ÁÝü<>¢þ>÷ö_ážúëñÏy¯ëçüló~ºÝ,œèü²·ìŠó'ò¹ß}~çèÊKŸ|ÄÍïzØÀGÄá ⇫cqíQô ^ý„îGøÄÙñÔô¾Ì:üûpÆÌ¡ëorã^íñ9ðƬû¦Ïz„—ôöÿ¿ùàn:n—¿ÏòW>??ž˜v×Ìÿöý÷|ËJ7ͳÛÊÏÙä%?./âOŠŽÏ ½ù{å5ƒcg=Ç8¾plŸë¯ÂïØwënÿùO<¥ïé½J\ ó_#~·ÿ/¾È½üzâ6÷:u÷¿­sÜŸ—‡Çš“‡Oà'­¼yú)÷ìê‡Î²gâ7ßk=_úáƒ^ò•5ª³e~¡~AºRôëô´ß<ùas}éHë·2_Ï4kÎYæ±ÉÏÿù_Ùç†K~1ÌI¤³¤?ºïêèécÒ9ÐoVý‰Ìµ¦Ûe¾ÿ¬o—þ0]J}¤í7I]úØ:¯[?\ç$¯êƒ¡gÔþ_ýÆÓ~ªê êÓ7JM_ y¾c}DzÅúçå³ôÃë{ÔWg?«Óžï7g¡º°ÑÔï[Ý»èñ&®è{ܼʋï{Å?6æñ¥ï›î¼¬ ÏÆþw~cæQ»7©³æpEÇÒ\$ó™Ó[Î…Ís™?ß9¥yO:¡7Ÿyøó}ÿ×÷üèOd—¬côDÛw8šÇ;è¿E¯Ðº=ÕWÑ·š¹Õ‰I¿}õ’£ÓÖùy^:‘GøY–þ±Ñ\‹Î3Q7RèVºWç3íwìßÓóÓ·K‹¼JG?8¯}Ít§³ßÃ\¢ÔëG¤ÓbN P}óì]w:ÖâOçždòéÕ)íù¾÷ýéÿW¯ÃñèSÑgÕl]œz¿ú™{ÏÒOêþÐcé:Äþynóàá\}ÉìBç÷e½à:ö¡ýõS=•aŽTì%=ozDækáÕé÷ÒA§·Vû‘ùW™óC×F¿lß?ú!ékî{Ó§£—¢/Þ>G§£ûë¾G?b˜{¾çΊ_2§Í=ÒWC/¢só¬{ô-èàÐw½iÏ?¿fÅo|¨óq{/³NÎ?¿0«Ÿ5v­ó‹è¤ä/Ù[óéÞW¯4ýó7ïºÿ¯øï³3ÌÍŽ¢utÌ¥7/¾ó²NðÀÍïšlöå¹—uŽœ~fþ·}ѹæÒ¸_žÏeGÌ¥×jN;ê^Ñ[0o¥sbéµÇ¯Ò;pØ'ý¶êŸè¿Ñ­qoªï}vÔs[Gë¥ßn0WŒÎ„>rñxç[˜ þðœÆKü ýd~TÝ‹}°¾Î¿…oëóJ3wE?5|:ßœ·>9xÕ—¦“‘¾rýö?5øÈý¤ƒ{Ó¿ûí“ò‡Ú)ñzçUçýá³Ôñ™7ñOpù µ±ûÑ™æ]ä÷鼸¿î·õ¥‹M'þzqHÖ™n«¸Â½gWªkŸyœt‹ª_OÜ|çFùè纱ÿtH‹ó¾ôþÙ÷¿m²öŸ³Ë3Û·ÍΧ/ºó“ÍQqžéâÓåç¿Ø/}VxúbÖ›ǘwÓùªÑ휵Ôç›»À>xº5úRÿV{ÅntÝS:æxš§êfÐEÏ|ûnΗóÞù>飦›Ýy`æ„G_Ä=‚ëøIþ[Ÿ8}nøŸ>²yôc=;÷Ò¹.N?xqftï:ßš]È\YøÄsˆÏéÅwNHô:#ïÁ~Ó}QE—‰? ¿w³3‰=ÎàvÂywOÓ5k/½38н¢·g>Aõ·3G²÷!÷„ÞkõwèqdŽ ]uAtÃÒw]½uxÅ[™;à|wnhâ&8ïvιs0í‹l|F7_\Ì_»ßSé™#ü+®p?Í+Æëö\Gš«ÐùgéÇd‹‡¢#þfèWœö”Ï0¯'ç²zeÁ[»Üç ž²¯pÞÄ}4ߺºô"ò{ì&ÜF÷¼û•ïgW:#q&]aþÊsÐ qï:e4çÜœ,ñ}èÎSŸâ¶ò,t£ÕGÿí]Ûß=søM‹À»?ø-x¦û|ÀòO‡»‹7 Ÿ¹kÕIUí‡ûl]#ñ1n½ê¿ÌÉœ•âãÔóÓ}¯vžx>¿s€/WW)øˆ^ »Þ9ÐÑ™ñ|æV?4z–ìbuí3¿Ë|º7êäè6é«öüæÐXg~ža絘“σ+ñVâFïÍÞÒSt~Ý8œÎ=B€ÞUòÃ<áØ½èou_ëg¢Cn®Wö·ü>{î>ª×ºé¤}ÎÝbù*ƒ}ËsÓk¡£ŒG«ÿ >‡sáéΫ2,ó¹Äåì#»I§­º«Ñ7Ô¯ nßèç|Oãú̃ƒ7éVg3ø sœ»Ößȉƒï©£tnÍk2¿*so:ÛüspèÆ^Á7ìùÖ%|jqvç¼FïÍÏWGx¬ƒ“8°óý¢_Cç.}}>ýâÞê2FŸ4}%åSðÓå9¢÷ÌÏÐG…³àsõÅËMg”NUô„Í™r>á ù´ò‘9÷űð¿~ývø8ÿæ¼W§Ó\šøstø}úmþ^ ™>©òÅî¿Y‚¯Ýcç±~1û½öÆCγx€ßW‰[nØï”MÞôœGTÅüY:¤g뜹Ÿxóé{4neÇêà¡ðsâ'v±~6ów‹‹cwéÓÃQô:Ç > Ž+“yºîyþì½ìÜôèðŠßñLé÷¬]t.ê¯ÂxzÜÕ9 >’1Õü¯ž¯ì#¿->ìÜEºcÑÇsÉ“È{‹kÏù‘è°›s"S½Mú]áèb›KÿàeØ õÿÎþ¦<^!ý3âCõp*\á–HiN„¼:û7O‹ƒrïè®ó³xPó4Ľp°y…ÕQLG/—½¥Wg]à^:up™¾&ü_çQÂsyïΧ¤ëž¥s2cßðNì;€ŸaÙó;/5vŒ~%¼d^‹ÿw/åÏFs—§ãM£#>só×öÈû<©¹Ì.kÏ[pΠg½ÊÚ‹ì«{BßS>•=¥×wÓ#ž~ãâM¿]žœ¿ß§»qç]‰/¬\Q]½Ì²>_\ŠçÞ칇‹ ô;â9ä‘Ý;Ÿã^Ñ9¨#eÏŠÏ’‡wÄ#ÈÓá½àóKš Àÿ_¿ë{¿sàqëâê/;G+ú Õ)O^K< wÉ›â£èªÂ‘â7ý!ÍëfÿéÿáÑÙ=seÓ§6ä±3Ÿ„]6ÛùÏ÷Ÿº÷æúšç'_(.±ßãÞ±:ÚS~«¸¨ùxùìé~•K<.O×üyî§¼‡÷…ÓÙ'|œõéC6 gŒó ütù{ójb·Ì݃'FsÞwEgsÈÛFw¸sQôOš!ûÞ{—|5~ÌEygë`ÎRë’7æ'äãnúøhóÆKt‘à¦Îžö…×.ÃÍO$.££ GÁ{çÈîÄ™#-kÜœyæ€e^OÏmñqôeù™ú»ôSšÇÚyFÑ!dz²â÷O« u1SPÜ"¿ß|ax—γÎùaÿ«£Ž§Š^.\c¾œ¸—þBôÆàðAï7ù}õµâj¼‡ü ^ê&õ˜æ¯fþ˜óÕ9Úæ×ôž'NÁ+°Çô’ášÖƒ¨¿¾)Ÿ’|gçëÆ”W þÿá)Ô¥Ÿ¡ú²øNç¥y²ÄæªSm~/<«:Šð7þH¼hN¢¾7ùë!îÔg~UÿýÌß{ÍAwüò€ê×™3¿5Ìëmõ™3_Ú/þŽÍ/kþ’½í\Üðü¼Ñ¼WæðÀ åÓ÷æÇ­kçã&®Õ5¶ìUóÁÁø?õ(øtßËoÄ·×}óYG®ûé†y ©O /0èIãE¢ûËλ¯Þnt?Ôýñõ‹t´“G©¾wæÊÀÕmÏZæÄw•|=oÿή²SÖ-u¦ÍÛ±wø y^v±þ3øªsÕøïÔàµ|NÎIï“üMîE×A~_œÐ¸7<7n1/ÑsÑå¯Àíø…æå‚Ûĵõóæ­ä¹äÔ˱[Á=øS|#|Ó¹ÅâÓ©>óÀsǦn¨›Ê¼\ñ><Öç›ÚÃúÏ¥£óÅ퉓Z·—º6¸?ÿX/~Wÿ™ºò6áðv=ŸÁ'î¿øu_ÜSºÌâ Î£ŒãOøQ|…yòrð5}úîâ¶èT uaá­Ògйvt"åÕÔê—ÿèã„{œGu,ô"›Go&¦ž~gà]ô3ÈŸ°«ôÜgùˆÎ‹}⼇þ•ÖñLñÌwÃ/æBòS|7èeÄšSZ}ûì—¸Ÿå÷›/U߇ŸíœŸÜõð%{ GÉ‹3Õâ)éŠE_°üþI>_&Îõ=æüò/øNó§äÙ;¿(yöYG·ÝýÆÄ¾vžhqrê©Äâr|†ü0WtâšÄk›‘9Ô­h><öÁúáE:Ç;ñ¾õ†ìwý¬y;©K þ®=Ï•vOí7Ý&<< ?A\Ð:ÇÔ'fnüÌ?ÖÞ$Ï¡/†oÒ‡¡ŽP½:ÿeîøR]êÛfÍ%ˆ`ùÖÎo›òuwè´î6öÖ¼o¿ù-ùty8ù4¸ºq¥|wìvòÍû6>‹ÎnõPÍE’¯I>Ⱦó«™}Çæó3çÀüšÌg¯1ï¨õÖÓ{8Ü“œK8©yïàú$¯{&Ÿnº÷qNÙs÷¯y¯ðGâ’â½ì«¸™’Ï`çàyøCýªç0G¸ŸœÐº¢ìyÓü°:YvL¾„s¯ñåý3_çüÃqðƒsÚþ‰ø“æaÂ_tÞzÎ_â¸æðÍð;^ºvÍ\òÔ¡–oo¯xOû¯ÏOÔ|QâôñÜ)8‚ÿË9mžfT‡0œý‰s³/CžÑóڷحΩߩŸ Ž,/9¨úÔQ—ßNÞ4uMƒ|毨_ˆfãhøºu<±üœûˆUÓ:æœçÔ}´>-}ŠÍ3´Î?õÃò òšâ@z2ìsùó©ß¦/Y?*¯Òü~ž‡Ž¸û•þÒÎÿÀ3å=ƒÏà$8—ßeÂS´ž6ñaókð¯÷U#.ߨßiÞ*õøxÌôCþ.8 %?ß”—o]Ux4ö¸üzüGëÕãç{à÷€~«z ºbÿžz³è÷ý™·?`Î » ÿá'=?ýgy÷­ñ|ì<}'¼zOq»býÔ[™óR»”¾Ïòöæð†çIrç4Â×t4Õ:?xûƒ5/³ûÇþ¦þÖŸò¼GÔˆ¯Ý/}ˆùžÖ…gŽaçpç¾ñ×x1ùÞö/Ä´ž4ü¼¼<;뜨û_`höÞÈzÔî¶Î } â#ë Ž‰]ã׃C‡¹àÓúéYõÙ­ã6/0<œ&¾‰.pí„|–9ù=ºóµ;âÏ×|°zÉiÎÐ_0[Gß~Šð‘úÆ}£É§vÿä9«ß¿€?–—Ùey9õVé‡.G½z©‰³Ô•óãî|J§T>Îg‡åy«›z¼YçKOó‡íÇ m½Sü©ü%? ‡·?yµöÁu™ŸËž‹cœSëWž:¸½}7áÉÔŸã7ø‘è µnU=£¼8½8û>çæ'ôßÉóÈgð—ìÀ¨Î¯ûÑy£ñ/æªÑ9R÷¬ï[üm¨u•ï–¿áÜŸö+š×;ìçù=ø‘=Ãw·#ýÒp‹º%úéæ²ÛxFuðkyYüLp’<ƒ¸#}ät}ëä™å³àlëѺäàhñ^”_*߯×î'ßQ]àÌ-+ÚW˜}¾ú ‡ï²Ë¡[öüáoøgv9ükëpìoðTë„?ç ¿ç¹Ç|’üMù°ÜñþN4†=§g¢J¼ÛçÊ8žŸ‹î¾zëÞ“ä‘;÷°}è‰ßÅ}ÑWç_ŠÿðòðÖΤ;Î>á-Ê3éŸÚÕÚyñÄÈ÷<ÖæçÍAÕÇ×ú°Q]yÏ]pŸ9Ýì¦~$÷@¿œ|‘º5ëÕ|§zuêéÓ9‚s:7}:ϳó¤'ä|‰‡Ø«Ö)Ëc¤@½‹øl\oªïDþ+ñtuÔ½¾Õym}yæcâcRïRž}˜³“¹sõ³êÙÕwç\;úÈÔëˆ{Å;pMðUûˆÊÃÄN¶Ï#|º¼=þ®¼oìoýûT—½v´ó~cü?®þQã½ë³ZWˆ‹‡R¯Ú9àùý‘®½öîûcGñÎðµz¨¿¬¹ÉÏ>tÇ€—o…·,?ï|nï5;}Æ­òbâJs_ý»çRO©Þ.=ü%Žo]xúÃ/<;™z¡à¤Æÿ½ÿÉÏZïöׄG”×¶pEçÜÿ²cÖ-þ¡ýÖê¿Ê—gÔ¹•÷Oû0ô?©ï‘¡ÇXü¥0x©ýrÉÿÕÄï° üKý^ürù¼ÔeÈ;«·îýÒß\Ý9Úòž¹GÅM‰wô[÷ç:õ‡‰ƒÄ½xéÜׯ5Íó¥_³sö2Ë9UÏJ·¿'ßÏ.x^¸n…ªƒ2ÅËÃ|•ìßX?¿\&ýõ³žzñŸýrŽÕªo™O]}ˆð9ìOû¨S÷Ó~Ÿà óÆs.Ä ülãŠø5q‚÷1ÿH‡úñ¡}Ç7àQgôÜðûÑ+×_к¿ô+ësˆ.|÷·yØÿö­¥ž¡q|úä×ÍoËü¡O"ý3t®à,u&í— ~u?Økï?•¿LžO„ù8údøOy„Î󙿳†º¿äoñ«ÕÊÏ‹3ƒû:_.·_tóz.‚Gäñè¶ZÙ ñ”óaðtê%«O / ~¼ùøðdì”}€;ð§t øÇÆãé÷1O¬õÂôkòïÍÏÛOx1瀎dÎMý'œ އߨ~͹-?| ß¨¼`Ξ·:¬Ùo~«ù¶iݵ|Dù}}`æRÉë‰wœÃôµ^¥y²ÔùÂCêZè!¤ße˜¯­n3÷‘Þ¿8³óa§ywµo,÷Tœàþ·ÿLþ6öŸ¾× ¿½ÿ³vþìÏošŸ©_9vţΗ¾'ëÍîWo1ç§yµ©¿ª=Q_€—‡ƒá¡ê€ä½ý\ðÊPG—|iy u_É{´>mŠc;·ÓüÙä½Ìô TO,÷˜},A_îaöKœÖûŸøÇý*ß›{Øzöðê”íoëRõ}Mó(ÅóüûÐ~Ëà yyÏo7¾L½OuÍRßT|Þ•îžjÜï"¾©îIú;û}É£ñ_üku<èû…ObÚß•þ?¼3žΊýPŸ•úþô;´ZŸ|Õ:²é¹ìþãƒè¯È×釕Wgh¿ï½ûðÛ—¥n .Á¯èc•“ïi=Iâøúáä½é•Õžd~nû†ÒçÔ{œ]}ÓÄõÅQ©¯—Ÿ‚rþÊ'Â-ìš÷ÁGÄ.˜ûP<§NÜ!oغÃÜ—ÌýmÝ”8”þJ÷1þ ¯ƒ”ÇàÙ}q9þ¾õ±×™§QžÚü v¢ýÓþîþž8¬ú‡9çòî±üªó<®;ãÚïFÇ(ë×>rõ;ɟГ®~gòíx«öa…7’7h>/x›¨½¥‹¢n/ó¯ñ[Ö½ý«©j\“8¯à÷ð†ú¬ªã ¯ë~$¿Ãÿ6Oû#>Îþ <ý‡è0ô<gÀ«êØÆùîöW…'âÕÁ4îÎþÝðܾêsëì2è5DMÝ\uyW©§€ëõËàùÚ×–ºõˆÞ‡ýÓg¥^*ö¡ñ/|¦ºqAâ]øU½9ž¨õ˜úü¢Û¦­ü0f¼lâ::w야ŸkœžóE½«ÞÇôs] üSì“ùÑì™<èHÏ uXìNòõúKÔÛ°câ81~ }ßü:ÿÕú ù–øëèu}Z—˜~ìê.W”ωÝÖ^žArpaæR ñJι¸¸÷)<¿õÆÀyåõé"¨cŠþ‚~¢ö)ârŸõØ|7þ*ó¯Ú¿ ÷T÷8ù)ö•_ª^tð•¸Æ½©ŽGðž$}ÉÃ{¤nPýRçoçyÕËßð†·>êð•^ÖzÚÖ…&^à À³Í«$Võ'©'ßWÇ0}¨ÖQ<ÇTï<ç¨z‰ÑÓ‘j>›n\ü!¿Ö>Óèyªç,Î¥3}&q[ë/èî§ž²ú¡ì[ð…x™ÝÆcèO“?§KÂε:ëÝü´úˆàýð·Õù¨ýéS5® —9€ÃýÌ:â[ªÿD×B=up2ý‰êkØïð#ø„ÖŸÁÙñãâÛêä¤oPßUãë¼·sƒ§VÇnéÛ±~üŠu„·Å-x(çO(g®ù‚­6=öÓ÷ýßêÏã'œõ(p¡ºy:½âu ÕóL?¾ùêúåGðçÕiÒÿžºzöQý•üŸ¾ýçî­ËQ¾N†—PÇ ÇVw5÷¾y.ñ·Äßú&š‡q‚¯ÕC³ïí n¯Ïª›JüÑ~4ó3ràeçþeï:gB^\ŸÍ&‹×^ï¶Õž¦þ®ufö³ö/|Þ¤õËtf“G¥ãhþ~\_^ñž•>Nòâ^:FžÏü;ºÐÕ7J^²|iöŸ_§7êßé©ÐENÝ|Mëà#zÙò]Çzß9sú¸òãæÑ5·¬Dx=<_û¦ë4è@†_QQ%y[¼o]ÿØwyqó½áXxK^¯ßon}ô©ÙayËëæìöÁ=ßuOóIâöÞ\&ù„ö9„'ƒ;ZÏ|+^¬Þ‘z ߟþ«êÄ·ž#¼•yNczûª.×ü9óÈô«„“Ìíÿ¨;nÝ=‰¬ƒºØÖ[ç>›O¤®I_iñNâBñ6~?û1Ô„ïá—ì#ÿ‹5GÊ>Ð=ªnjø|ýŠ>Ç<u/ãºIuŽÕ» ^pÿå¿èpâZ¿‘s„Oh·úBze÷æõ‡z‘ÜGyTþ¿HÏÈ>{üzAëhý{Os¯Ê‹éËH<š¹$]'sæÝ7õÛ~OŠùêαýâÏèrñsέϗ7in샹dî|ásGó€Z?äÞ[Ÿú¹Øãòz±[æî©cW?ì{Ûó†·ràIqjõ•Ó·YýÜS|fùÛø|YÏEöM¯ÞŸY;¸/Á^w>Wâ+zí×ËŸìöåϽâ;=åCÞW]·üHÖÃ|7ú xJøCÝtÏ:!vºùÿðÅòÔö¡Ï^¸|&¯-ëêywçûå«ÍÍ”¿wÞ|®¼ T½æè±ØGõ†ž«u4á¥ÇÅ>:_­?”Ëz:ïΫùÊÕEŠÞ6;F¯¥õ$9'ö¡õÀúRõ•$ŽWd^díÿnázçHŸ»ç=Ì‘lÿƒ99¯ÕÁ> ¹tòØÛåéÕ¥çó›ðã½ú <å½»O9×½~íSWßì¡3—½þ¬í?ïŠAg ß'‡{ÄÕצû¤®‡.DÖ«ë§(ø€ýÄW‰‹èãåËæêU/ÿÎù”T×¢ŽT¿ ? ¾ùˆØÖÁæü‰{«Wšýñ~ìŽsÆÏó·>ŸŸÏUk?]ž¿zñÉÓznñ§ç¢wC_E~¬ÏÿÛ~ÙØ]ó¨ùÏžË1¿™¸º÷‰3ÃnUï5}€Á·“Å÷ûÂäÉO¸¨v¬8þ(çØ«êFG n©®HìoçÓ„ïÄw;÷òùú¸ý=ý¦Q½ÙЧ¯<|ˆþ;øÜû:gòtà>:t›–¾ÕÚ·äIàÎwK¿7Ĺ«î[æ½Fÿ­ým­‡ ÞÕ› û%žú3ö^? ž ^u/ËgèwW_£^!ñ?Ûó&ÿ•ߣ£íœûOá~ç¾G±ÇÎSø½ÚÇÆùôgÌqÕk¶?'Ï›9è}ßq½gûc_<¯ýŸ·ÿ*x¹ùÚÄ}Ÿ&¾ëùJ| ÿBËWŸW-ó*ð(¹_î=|ŠGð>ã> v„¬> :¡ügp¬óTœïãùb¿ñmç¾x¿Þºê«{.à¨ê¼d?ª{”¾z|@î÷0WÛÜÌØ x¶ºšáIø!÷klw݃®oÎ{û…ÍUÝÏ%…§:Ÿ.zSÛþ§óÔY¤>_dŽnqxÎÑËòÀ«Oº«õþòÎ¥Ïí{Ä®èÇ+tN‘yaîuxoz*p€sÂ/ø=÷®uóêŸé(èï‹¿?ÝgºYW*¿GϰuüæÓp8\¢ŸØú—ÿæ~˜C7v_âWÜñCç5ékN| ïÑO†[øwü-œ@?‘¿_»wæ!ógýõøô—³žÅ+9¯ñ‡½ûÂkX7v½·{]?”ï³âï£Öyó3ù'n‚;ä+‹ï¢è~v¨{•↓î¿Syrü6?çã‰ÙÙë·Þý1~Þßfé·wznëZ™øïêÒ9WÏ—óݺÂ<_ñ[î‘õðþ¾ïªË°ÿ÷ÏŸùÓQ—~~ו6ìý†Ýñ+Ýñ3¼V!þ”§wéÞ8_õñ[ÕýT§? /Vï#öîÁÃuß身1g38@ÜÀÏ_þ‘§n½Õòw–/,Ž¢Ã<{å®g^ÿ¤÷­]þÁú÷~Å?Œóøý¾Õ5G,ñMë¿å¯b§Êƒ%néœú¿9¿ôEÙ!þ Ó'Ñ}5™_7§!<´¸“ÿîùÒ7”ø…ÝåןåýÚÏ¢î*¸Þ¹un®;êâ¯óÀ›‡{h®Mxìkž³ã¢‹7üY÷Ï>ãµÚ_-žÌ>UÇW~$ñY;þŒÃºïp}lø`4×¥ú‘êâÜKùµè¾t½Ä…ö»üyÞ>lü0ÒÝuÅYxAº}>çwûvíCÖyuñkõì}®¹Œ¹÷t ùÕêç|ýÕSõ‡»×göòÓþïoþÎà‡áƒòZ¹·>çô¿þþ½/{ÅÍÏ#™Þ·âÞ¾—¹æÌO¶~ ~é²µ×~øÛß|ìÌòïl¿éjwÞ<Ì¿ oåòéÜi£wßôÎ{†y„á‘¢Óܼžºõöç>Á¡£yEÍëŒó5?}ï~7Ìœ}Á0Ÿ(þQžB½ây¿ùÂ;žÿ®Z‡ÂmåûõÏ&~`·G„ß´ßîü²ï…§Ø ñ@ç(Ë?ä<{~Õ¹e‡à»æüþôÞuÙe÷žÝè< Ü{ßç¹=GõÈïšàûñÄ´òÈÞß9ë9ˆNêåw=yåå§ýOŸ‡Àçº7øVyÁòÉÁë©ì¹jÜ‘óáOø§|qê”Ô%³³öùÂgmþˆ½_~pã‰Äù]ß?/[ñð _ù§á>}ó'[¾qµK»=þ¶ºî¹WÞ÷ªolÿõW¾ýð~¿>|çRœÙù]yë¯RÕŸ×<ã KÞvÞÌŸßø¹=NûÀ·‹Ã.ùÏÕ–Ÿyþmµ#úóå±Åxø×z²‹î[u àdìò5¶½üýWÝS<ÏçX¨€Ïð‰òâºΗ>w~©sHâñÍõ‰wÄOæ?Ñ“à¯HÞüÜh> ÿë>À/ðjôPÕmtHõ‚+¾ûؽ/Ûô%ƒúŸúÃëÖ^¶cóüwý@ð#{Ð9KáG[ûÏßÈSµ$xªüsâuvÐ< uÞ~®úTÁxñ™¹ânº_ž3ýßóo8ëô;ïóëßnÙ߯î%ü™übç}äyáWþÌ}1»zÐùw¼ôÜO>æS[qKçÒ°'? WºGp…8¡øo™÷ƒ®ÝêÙÿ~ß_žÕϳžß:T÷+8D|ëÞÉŠ;ظžÃ/v¾É—éPoïÂîë3‡®¿É{ÍœzîÏ™9ò¶âMïÙüHâþÞ?á»wÌÿÚ †:3¼«¹DÎññK?|ÐK¾²†>î§çwÏÇýôð™}*®Náêå=íQ3g÷=ðàá7ê¯äAáMñyuÒcí çÎ\“®‡u€'è&Â'—Í]~ÿ«Žú~Ücç_?2òþÆWö¹á’_ôº/“i®ù”'é{ºßö—õ>Ëžû½¬÷•‹·á¤Ö‘Ñ%ß8ë–ßï¸Í[Ön;WxuïÃ~½p—‹¾ºl¿úA¸‹=*žV¯žøŸ`'ä)ËãÜ{nGß—½Ð÷ªëÂ;÷Zúî× ý­ß +?Ÿ¼œŸSá\µ¾F]Vâ <Þ?<ÊÀ³W»¿üºx™²?ÅcÁñð_õGþr\ÿ×¾_zWy^ø”„gú\ðuø½êZš•ç«Äéâ õ‚ðÿ‡ßÜ·köƒÞïäÜ´þHœ“¸àü÷ÜþõU®ýQyLç_ §ÉƒÁQì=pý1w~wÁaÃÜ~Òœó–¼ð¨íüéÓGãIÔð?~ßýá_ñ¯â ñBõ/b¿Øë©Ã€¯ÜŸƒ§çOÎúäòÞtÇ…ƒÿçÇë¨sØEzúcüȯ´_\þW^eÔ—÷¹×¿üüeïùù.Û׉ÏÚÏj¿ùåœ+þ½üžü\ìíò7¼æ©çÿèëCž>çR^Éú×¾ÄÏÀ­6Ÿ¾ˆz‹ð¼âdùYŸ»oÑm¯ýÀSµ^6çPIñA΋ð=öG]:û&Žtàþ¶ñ1?œÚ~"sIò<Õ›É{Zgz]Å=á/#8M#þ²nìƒýtÝS}øUëZݵÔWÈçóKübë ò<ìEÎGï¿£®Ø:qnqOîŸ{êûÅ-c;,.„WÙ[öïȲ÷sòï¥^8ç®?Ä߯Ÿ_ú÷K?þÑÕ~Y\7îQ_wÊ+ŠÛÓêŇGºb­M÷ßûÂs{¯»ì€÷|×[Z/ÖzCõlò9op*<çÜâçä;äwáïÌ—ð·~‚Øsq³}òûÅ͉§ø9ïË¿œ¹×õ¯Üïû³ó·ø‘ö#±ûo‚౯^s²s×]t¾Nóð©+(®Í}ë<äÜöZ~œÔõhýÜôü÷ïÅï>Oþ€ß„ãØk÷Â_ðç³æ™Ê¯Ä±ÛøÜúÕÌÅûˆàu¸(|LŸßsÂâsùyñRýÅHŸÝ}¾j÷-ÿòù=Þ6|nì¿ú‚ewÿî·ßzìŸâÏr¯[Ïyï~‚®gu3Õ«ëÐo—õƒkg‡'iT>/sdz>àLûãœâÝ7¸¯…§ÇŸÀ ö•ýrÎZšuÄÏÛ?¼ÿøýÿÇ+^8Ø ýáêúÍWJ>ÞŽž|q&{çûðßêä1áù:u©òþÁ3Õ©„'Ä‹Î~¿ydõ«‰gè=6O¿×sšùÆxyûN_ªsàãÿËå÷[/“9ñúøñëÅû¹òpõÃêÄÃ/Ug$󫪋œ÷dŸàÝê2éÍùfÙ#q}Cºt‰ôÓDï³z­óÂsæÁ›o&?.®iHô…èI‹'ƒ#ªïÕ¹ 9ÏtXÔAÀ³òÚùõ±§—ºäê¦^+ó6:¿ZÞ®updprçØe?Å—êä­ÛAZ?]òÎåiò>øòλÈþóï©ÿªNOç‰Ç®d®qóp7>¦ùÕø×â•Ø+üý2zp˜ý=ø'}öÃ[]>ðþ±ûÕÛVwH‡2ë¬^gÙ'ýåϹu¨ËHß<ýÝ;'½ï¤ç®;«½}ÂѧX_øž¡;¢ßÅÇTo"}‚ÕŒÝì\½è:¸/t9;/;q~·õNÎIx-vºõ†êOòÜÍ«&N±¯þÞ=3Ôñ˜s«¯ïÆï© W««éùÉ>ã¥Í¢Sá¾;Ï­óÕ¡9‡».{©?µõÖ!ûOO¹uéê?£g Ÿ3ÎÇâáðÕ…º÷ܬú-öÉyp~õ§Ö®EïG=+ÞŒà÷Ô³T4çßú°ßÖU]ºçósùÞaN¬ùÓî[îEuB¢CS¼ÿÀNñÛt­ù¥òE©{Ʊwütç–êÊó-YyÙ¿=véõäcñ£ôÕ«ç»À>6nÍùVgî^wtømû,ÿ[âÜ;~Õþ·Y}Þîp>œ/xÃýÚÿÙ¹Qú@ãǽWçwëçÍŸ†û=¯óÔ¹&ú*³ã~ëñÜfç~¢ýÅ;;§ò¿î=>_ËßðåQ³?­6ûß¾~û‡xFù¸¾œ?-^/á¼ö3ÃMù{~°¼¨ø¿ûyÀ“W?eçù˺ŸígQž}eGåáE}©ø :EpHçç¹;‡;y>ñBëuó‡ÆoØG<4\Z]gýŽñ'øÎ—Ïäþã¹­\Ñ~zz±÷î§{¡¾v5vÓsáÆ}¤ö / o©³ÀKµèÞ:ä­«†÷í§}蜾à.õpeï½ódÍ•É¾Š«àH÷Î*nõsÓ{R].ú’æÒ¨žzüÙ˜'â—á|qHó±£õSñŸâ˜ò3Ñy¤“ßþǬ?^ï‚g©ÿp¯ôAæ¼:êÅñ}nv'ç¨û‡_ËÏuÞCì{ç@äþÓkáÇñ`­K6ŸÒ½§;H—$¼_û¬¦ödà?¬câ7udΫ¼½M÷ÒyÕŸf>ÝÐ%ç?è/¼h~q¤óVÓœ§ÎŽ]ê< }nñ›üû„?óÄíÓÉçüâ§—orìßþT{Øïͽjß~æ^ˆoÚ§¼Ïþtž§ùÌ©Ÿn<•}çºO“ͯþV§àœ‰oÇ/ÖÆOÄ®¹ßp\ëMÕw‡ÏåWÛ×Ü^I~0öš¿Åw±sx^~]ý2ÅîɃw.AΕýuÏÔáŽë·Å'óGó­Ù?q²}é\«Ô¯èÓk]dî±8 Þ,žeï㯋GòçxNkãòÔ}XïÖSå{Ûk^dú‘à+öµë“{Yü"ÕŸ;!¯YþgÔ¿Öø'ÿŽ¿i=¨:øÄû}Þ¬;~N¼iŸåO«ÛG_.÷Ñ{&¿P=óêû™K=b¸@^»øV¼ã½Ø•Î-¥oÿ,?TÿDGŽ®¶~}}&t5²¯9SÝoçÍ÷ªÓ¿lßáY÷$qYqFÎWõÍ:§<–s‚[ícqg>ÿì~ó‚ð {ä9àÃq_Gu£W^pê/çÿìÎ#—Êñ7~>iDüºŸSïÏïüÓéþ–ÇpË/ŠçÝ£œÇÎ!3÷S}aøMïÛ¦Ôkñx°öÇLßsÈÃás‚³ê‡ð™ïCÒ<_q§õÀwtþ Ý®¼oyiú%tã§j÷äïå•F~´vA-sWݺ©—²ÿâ‚>Op°8XžÄ=i}]>>®%»?Î~š£¯ù>yäöÿ¹Çx‹ÜÇêÈ$.ï¼sÏc§é»zÏ7®cgùMëâûäĽìpñ«¸o–¸0ç´sÍçÜv㎫?óöA(çE^©ó²³ÏîS×Û¹2¯…^ÜÈßÀíÕõ¤¿Ÿó-Úywü°|ºs ÏÇ.Ð-¥wëžGg.­<ŠuužÇsEÊïÂñ£ã|‡ûÑÏËú¹âdõ­£×;¢n Â/éï‚ëäEÌ{PŸ¢þ¾zjò€ôh‚ÃÆ÷™ÿ+.ý®¿Êyfgàw¸V47ÈsªtÌc€ûáuuôQNyÌmßùÝ wU'¥ý9±ê#ä%/ýûÏ\ÿ°¹·Ô…ÑG“§•—S郞@>§ÞV×û¨oQݺͬϱ/ÛxÕÛ|nŸOÞµ¸"øSÿpÞÇnsèÃî_ž©õêÞSwâÜXwûæçÔå‰Oá}ê õy?ŸçáÏÕÁâê¾÷T7†žAúîägåýGýtC_Rú¢èÜ´X½™¾¢Ô=µ.6yí­sv~NíF绩?êû'ß(®Î|ã¡6|"—:„æÔuµÏAÿ¸z™ô™œºûßÖ¹aÎχúXýjÉŸ°ÖUMûFuJìzëÒG䜵Ÿ+8ÛþÑ-§oá=­‡xQ)îêIrßO9÷߹ꊷôïÕ§Ëêo×´îF_ì†zŒöå§ÎÇû©gR¯ê>U'0vQý´{Ó¾uAñ÷ìûçûÜ;s=å÷ÏÏÉ×·øSo}äñ×T‡…]QçÁžŒëEÕϹÏê8ù+ç¬u^ÑC“d·Ô±¶ŸS=Pì<Ô>ÕœÃô£T×»õE©3Poo½ù_:öG> oTG)xA_^á÷W±ÃA›¬ç.d?­»ûù“‡û¶¿~ûÆò$ê ñ¢ð?^°x†.Iþžÿàœ?ºê——Ë—_rׇ¶ûcë.Ø;~]=»¤þïªÞ¯Õ~ º²‰«~Äÿ·1q§8òìõ/:xåÏÝéÞ÷>ÒÇ󪣄÷ØqSçúd½Ô%ñGü®{.NÕrÑF·^ñ«›>7ðÚÁ7öO¿Õ>²Ü[Ÿ£>‘=mÝ›:ÌäQáÒö¥ßȾujì,ÿ]Ÿ¸X]gæ'×óîm÷%õPî}¶_ì|Å^ʱcúIñ ¹·Ý¿ÆûÁƒâ9~€?¦ëÚ¾çœþ†Rߌ¿e7{qAìÿPo™õÏC—[Ï¡î_…bçŽÛõIOßì¶Í\ò¡×üh‹ë~]¼<Ñyðšû\ÝçJ¾e¨‡7w—¾ûhŽmçó‡Ywø¤ç=ëtĵÿsò/â va<¯žïÙ—®;}luÜÁ/µ7±#úÅØ{¸UüÇþ‹»Ù½±‚§ŽÙmåçlò’÷¼´Î9„7Øó1¾;}Ñeß\ñ‹_©^´¹qø§ö¥Ä/Ãap€úWù†öեΛ´_>§ºú5§ûX=gõÁòÚ­/N\$ªîYÖ¥óä3罸0ïëÿÙAy^v­Î¿ý9§ªã¿ì9œ7öR]ҸϽº„ôÌrÿœ8A}lí}þŸŸ«~dÎ'\Ú~ÇØWø__¯¼¼èß‹éùÇ_W‡Ÿî§¹Þ+ïÏ^·ï4q4>Ãûñgï²áë­v×Ї™û§?žÿëYÒ+ÃïÈcU‡.ëdÅIñýñ5< ·V§-v¿µÚÅàvJÜ&iÝØCxoà}Šû馛ˑçvþðßµïtXÍ;‰À+¶ÿ,Ÿï¼â—s¿‡8?ß›õœÕg|Ù×vÚåðÿ þ2ë5«ÿšßk|O¿ /jDò8ÎMõô;'Ùã>»òvðDp{W]÷ä·ª#ûÆOàûÄeøÅsN:÷!çîÿñò:¾Wß”óbÝàS¼ÅyÊé[½óÀâþ+nq_á¬ö…äT¿^ÿE>¿vgÊwu§<{ã¹ár¼‰xªy‘ðúåðÿîKõ(²Ïâ]~Æz÷ùð©«QG%÷«¿ƒ3ä¥üéü9ï]u*ÁÕðçoÖOä~ú}¸©qqö¾î¾ççé<´ï†aâ‰âƒàœ¹çݺï÷>®uÈì%®t~ÚGm¾Bî~K¼!ÿ#^`¯:G'v´÷#ûÀ‹ãáE¸ßJ·Û9oý}î/?ë÷Ê&Žh_ú4.¬}¨½L\Ó¹ã¹Î7íÜàÁš×‰ÿ.îbÏéuèÇÌs–ŸUçIß1ù3¿çoIòü–¾Šê ş臇W¿%vÛ>ÍÒaËù®.%~Cš¼}õ<¼'ߨþJÖ¥sµÔ-¦)yþî‹þpý§ú#ý|ûî›´Ý>Û2³Kë,ÚO›Ÿë|Uyv~UüªO\üˆïë\/ýô¦ïÓçvÅ[üŒ¼ŸçbÏœ?öï"¾ç—«óÓ¼]ü¬ýåWáàÚgÍ>UG?ùj~ÆýŸÀ ¯3Ò_…—Ûî=óïð‰{¥_°x4ö’¿…3ÇúBåÃñÞgú}}?:CêRÊså¹;¯>ÏYÝúb±c1öë<³Ê>»ê‰ÇÏòÇÕ0¿"çËù`ý<]xß>‹ÃÙ{~TÞ~ ŸO+Ó?¨Þ"÷7ó›—âZ‘z/Ï…gÀ/ʇt®œºWó_b[O“Ÿ·ÎCç YùfsÛS¿šþÓâoøÖ=öÜúivÓ{™u«}dÝ;ñwŸ;ûhß:^A깜ùÊ‹Ø÷ð­Wún?O^Ì¿ã/ð•ìUëàr¿œo¸’½/?öã·lôìu†ç¤œ}ó9ü]õVã§ðgÕÍϹàÜ#Ï{Üû‡‡k}UÖeÌw8/ü§ý¹äoo}à™»ÝR{X×\…¼'œ.PßÐy%£9;Õ'O}ŘOí¼Ã©½ô,cwš§MüZ}ô¼ouÛržñgôÄÚϼ[½ÑÔU±ôÆ|¤óo_ÅÝc;Uþ7ëîÜ·¿n2÷%ëÊŽáíW|‡Ïsþ=/œ!ž`7èÀ±ÃÕÿ5o.õTΫß'òWÕÅg:ß8øž_cbÿœµ|¥ß²ñAÅ‹c=~|³xÌ=i¾.çGüÊxî±.!~@œ)ÎnŸwòüîsA7³ú©ô½sŸÕWÀýòEìŸýê¾ãërß«^â7ØGy8 óðèè‹ÞqÆqsæ½Å?õ—9×ÎGó­9ÖÏ{Ø7<­õçÇ­{ç±ÑÐ÷{çݱ“êX;gÕÜÖÑÜ û:Ñž;}þü3Ôö{…×êÜxSŸ˜ù'ôÉèîå>áµ;×'_~óÀ⟬›xC>Œ½½ø#'ì:w£¯ u¸#}ŽæŸãÚWÿKljàïèÛ¯ÖKðô³Oλý`j¿rŽúÇõpŽ÷-ß}’òYÿÎNþ õNpO>Ÿê¨Gp>ÙÏêIç|ðóÕ ¦žõo9/ô}ÿìçàIçDzÏîuñQð“¼Aç"Æßu_êÝÃK~qäGGsn†ù­ùxØù¨²þRó¨ã7ç·À7Õß \ÁtþaÎ »×ç©Å!>Ïy•O’çfçÆz(ÍÛ$ž´Ÿ='¹Þ»8"~¥szÄYêgèÕÓÿÌûÑYïzUÇ)þ¤ýð#?¤^Â=ðïÕ¹®iœ‚§”—Q¿–8CœÊOá)ù׿ÛÄ#Ü*ÏÏïÖ>‹Ÿò~_“·ôó¾×z² pQuYØÿÜ£ >ð Ûwmëªø+çÕzðlj³ºïÅ5úЗá#ç£öW]RxºæcGú=â`º%x9çÑ>ºÙЇìúÌmúót?ÙãÖÁ‘tcßN?åžýOÝàÐÚÑÎQÿ Óêû».ynþšÎtõ®c_ð '.õ÷úÉä Ø]–¯€ÙïêršÛk^G¾¯óDsÿ.\pÌêË^¾ùP?¿^»J¿Ÿÿ伿åûñÕaži=NÞ£y}~3~½s—sîûþ{¾e¥›?:ÇtDáÁÜcuYôŠËàäÄ9ýû¬»{ ·Â'ýÜœ¿Yqœ4ªkQ7ª¦}µ#Ý‹q¾VÝ žÜý3¿ZiÖž`·ùçµs-ò¼ìXõÔc_øOó?÷îuïó—ì^솵Þ¯~:ûi¾YuµïñpþÙçñ‹îguÌãGåØ#¼¼Ø¾P}űÓÕÁÉ9WÏ ~¨ž¤¹@yŸÞþW>v¡:!é«’gs?¼wç!„ç÷vïðQÖ«záEÕ¥þ®ºxÿ䟇ºQsXøßÄ'=—9ÇîeóhYGû;¶gxN÷´:J¹?G,Xø­ú¾úg}éc›zV}¹paû†ÓoU†œ{ñžÃú¸ßå»ñÿæü×èï…G=o燷±>p™÷fç¼{/Ï¢¿±ú_ÑIƒËš‡ Ðÿâ\Tÿ,8Ö=÷ü®y$ã¼§}Áï²ã­ÛÎ=¨åoÙÏØGþ·ó&é3¤^oÅÞÑKbÔ}‰c¼Oý–ú¬à ß oÐói>Ìü‡Ü{~ͺYgqœº²ù·]zËç-(~©ÞoüWûçs¿/<þ='|ôæï5?*>v¾[77ŸÐÛ¨Ž <’xÀýfOœ#ö‹ýÇ ÿQ;“>êÞk炵nçœU=¡ðgú!ðÎìUuFó;ÅŸpÖØˆë#ëL¯›UOâçÙáêêW¥~ѽ­nwü­z<|™úÈ!ΧGÞ½úTSÿ?ðaæ­ÆîTg>÷ºû•óÏ.ðwò­÷Hÿë]‚Sš‡¿‰ó“§QgÕùñYæÛ³?í¿ O'Îk]yìÝÚê"ä9øgq…s Ÿ°kx·ÆC±~ž¾DçÃNë4's~ùÖ«{Uí“:ºAž[Ün=ùM÷¼ü)ž@EÎ!»æ=Ø·êyÅϰK­[ þ‹ŽádÉÇϹbÞ{?Þû[]½ÄÞSÿ°ú :vν|‹:0¸_< §t~kx}Nò)ÕwŸ€GÜkv 1~žÆŸSûV;âÞÃ_ìܧŸÞÄ{£ìÅx^së”Ì+‹Ýó9t!«“;P}øÁ‘~Ì hN.^<¼ þ€.4½/û8Ö[?TÏ>Fì'üU?NG~޽h\e>sø€êdСŒÝ,ÏK—d„³ØÛö÷ÓySü€×Š}À‡Ö¿ó/¿vnHü¾¾ïÖ'Óý6'1:'Ö›´NÕË5'vŒßççªó=ˆò‡±küÞ–íyˆ½R/lì½°âÐô{tŽmô9ª Æ_çyøö¨ù£à?¿ßû8ª'GõÞš/šó6®#†SôÅ{¿æ]Õ­á·²/ìkõûÃs°#¿§ž@#þˆÞÑÜ?äˆ5¯ØºçD>P~±ºâ“ü\ëÆGõ;­ÿÌ}l߉sK'8=þxÖ*ûÇç¼ ýgøØ¼Ÿû×ÀïUçýW¢Ïk”÷ ÝõÄk&ÿÍÀÍ;ª#NžªyÛä¯à@}&ìVçØÇþt¾%»û‡OÇÓ´¿Õ¼Õœ“Î/ß×ÏÜ>õÿøêÉn¾rù}‘Ö³óÍÓg×yH‰ÅKÖÝ9À‡V—”îuößù ?1ôçMÿ¾~ /ŽÏþûÃÖ9Ф‡®n3ù¢¼ûþÌ)+ºgÕiŸa>__UõôäÿÍi¾!÷޽ªÝÍ:wðôêcÔÆš»Ç/V_6~ÇþŠSÄ'[|‚w’?ăۇæå‘Õ…à;èô¨àVçQl<¯M}:»!ß¿Áx–±ž£u£xáØc÷¢}ÝÁWü¿%.¬îYþwª×i<§®0ë]ÝRù\|[öÏý0çdÁV›ûéûþï CI?ŒŒŸ­NFêpÚg˜û]ž6|©÷¦#о‚Ü{ñOç4…ßPŸ/Ϧ>ŒìÜ›ºáðWõ~ͧOãìê·Æ¾u®„{£Ÿ_ñó¢›>Ê«¾´Qû>àe¸Íœ ßC7ï‹ïm¿Gü®øSkÎWõÕªʹ8oƒw<ñ#Y·÷™¿ÒOèÞZ/yŸ Èóê÷ƒkñƒãsŽíûR;ç°}õò]á¯:¯5çžå/ùSë[]³Ø8Ùy­žWôãÅ3­Ÿ3_ ñ›=`‡;_N߬:¢Ø]qœé<â‡Ø/ë%®Ó—‘jþ]xìKûvâ§Åâ~ŸþLõ¹ßx}fìÞ¨zøèøïê²ßÈw97µé[úÇeüòûrý½ø°ùâÄqÎOýž*<Üîþõ}òyåÍ7õ\éÛmÞ>þLCõÚèü&nvÞ⿪#ç¼X_ùl}ÍcýéØåêX×߯wn»¹3Ùo~[=Nžs2÷ÿÎãQ+6ÎågÛ¯™øš?«nŨ®¯Ó¾€ìüÁŽà_:?üÞõ«ÕSå¿Ç:åâ‡Õ…â©ØÿêŠÓ?̾è+„»ðhì/œØº&z.¹Å©±êà-~E\ß¹Dá7[Ï<>û#®jŸ'¿àrçžÿª~Tòέóê^²Í«ÓÇ”'–·³¾ê+‡6.0!xžÃéÍo缫ۇcñiÖM~>«ü¬óåï;/ݼHyÁÔ7ˆ‡Z¯œïwn­[íTúäákúGì^ãʼGìëP—¾EyÆqýYûCÏÈ÷Š¿ÛŸ–: óè\¼`õOØoÓA0ç…ÝÔ‡ —ɯÒé¡cØúûÔ™UŸÔœü¿|?çˆ/øoyCëÙù±OøüxëLÕÿË·—É»ˆKô·ŽùiŸï^«7èüŒÜcþÂ=çÓÅ­ðOçJ¨Ç}|݇o¾pÈÅâaª;šx[œcߊ[õc_´>Á|õÑ<÷ÆYY§Ÿ°ÚÂßý_ÿIø,ñIóÏÑÿèü°åÿ8c×.x–䪗{ãÿåø›ñ|ŽÜ¿êÓ”/í‹|®þþh?"’÷é\ÛäÝÌGm}¦>ÝQ>Û:¶~/vk\ç\ŒÎqð‰:ëgØ1|YçqGØGzKΞþ÷+ÖN‡ržÚÇ}¨n.s}<¹Ox8vP>Ó8$ö’®ZxœÉÜÛNÛ|§5hž‚}ÕÇ^ªWè<zΣ< œ€'R_ /«»Ä{²gøë"nsË‹%.ö~­“˜ÚëÉœ7~Ô3VÚyà ƒÔ¶_"ø¿¯Nÿëî°Ø•Î-Ë9ÃKT¿=¸£ú 9/üFy ýý9ŸðNù48‡þiøÈꇪKÔ_A?#x/Hß]£—ì|ÛxžâŸÙÙÖᇇ†ñ3Ö©:)ú‚Ã;ŒçˈÙ v O¾ºõS>׺੪;œû«®dáþ[ìÿ ÕéHø“žbû%sÔ¹U'*ü¤üHñ`ìŒ{âKåíÅptÏ}ÖͺÃxÞÖ ¨ˆè¼)scÕŸ™CûèÞ´ïþnì°<7» ÿðŸ¿Þøkï›÷Ö—ÍÊóó­; þ«?ºñs·¿ù//dZog~˜º¯éßwNYëßb7_v_­¾X݈}åߪ眤¾¦ó%cOÕQ°p®¼lçý®Ÿ,|Òy[}õ‹CþÜ/Ê^ØO÷S‰û(îÆ°ðfu$éFá1²^>kóGìýòƒ[—ѹ±›Õ/žÎqhœÞzXsÞÂË´ï#q¢óËÿ‰ÇÃö3äÿ›G ΀gíû£®¨ýkáK:%v¶úf©ká§Z7¹NôZwÕz›¬sç^çžvžŸ¹Ä¹Ÿx¡öC'.€KØãίI|ǶnZßþIzùy®Æßúòr¯ø‰æ¯³ïðJù&u±êúá?Ï?;¯pšº˜öIÇÂYôÒì=¤±þ{ó ù=º'Öµ¼¥y¹—c¼â¹;ÿ2û(ŽëDw^mø1ç×>Ÿ|wúÚðÂÕ5;°'p7x>€ÿšwŽjÿdð<.ïg®ö­ß{Þί{Õ ƒ¢n:ueâ2¼?»Çø<Ï­ÎDpqnøCv¿õŒæLù÷A§5q¾=l=eâ1}Þ_'>(O-?çó—ã¼Oû•ó^Íïç¾xOüʸ>»ýæ`¤ŽH¾¤ó¼Í“J|ÅOªkµ¾üjëvR ·5>W‹:3<¦þ©ÎiOuïƒ>Kõ<êƒ[Äûü¿]½ðàÄæëòÜÕ‹½g¯­»º¾Öó‡/9û˜Ÿ¼Â•k6^Á÷·¿Ç\¬{ûRÕoš¿)ÿd^¢9Etiä‡òÜñçÃü¤àlÌ ïê>zNúcÙ¾x¼¿ÁO¶S¼м+ßÇŠÇÅyÍ?É«Mã¸Áα;ðMÎÕ0wÔìà&¸š®±sêœÓ_i¿\{/n‘×`“Ÿ꼂§èÇ÷=ò^î½Ûêû÷áÿœ—öåÆßɶ~ÎýØ>èäå.ÿõª8yßµ]ÎøM|hã²Øå wØíÂO­¾Gí:žþséZºoõçá£øø7~k¨«I^7à»à‘q_¥çr^ñÿÖ_lý_z Õ ¦W^nÜO«>Ó<ö…¾±sÅ‹ÿÝ õ߃‘‡=GãPú$Ó|P×I«ûÇŽµž{?¨ð=O>IÜɉç<úøã?Ñx«yœø“ñœõ-í.âð:õãñåÿø1õ ÉXv¯äܲ‡ö^׎Ÿ«õjy.8®:èÉ•ïÏùîºÒžâàYúxAxOê¼ÂÛìŸ?‹ßãOØò¤‰ó畟ë|ñVü\hž{Q¾!¸>nž8<Í8Ú9&±â]uèú*«›ŸÏéq_ápñI﻾ŠÄiÞ Nç$v¨qjó¹×=Ÿ9oìAõȲ>­‡S‡˜s;öÏÍóÑT¿0W†¾šü½º@Ï!þmdúÿàöòËææ„Ÿ:ÿ3ÏKGÃþ°#›’õ-¾ƒ“³ÃåÂ'Šä1Ô5/7ª_îÈ诲÷ë¤Ï5vHýRíx¼ÖwnYêÿÜg÷Øy«>oòäöU\ê¼ð{ú´üž{[Ý6ý{êÂG¤¿¦õpŒçh>}ÿ<=‡ög¿Î¸k‡­_ûÁSË4®Èû«ÓjßTø*ú‚Öƒ®Au@s¾’×ôƒƒ£àÑÆåòá)øm÷Aý‹yÍãÄ~Ãkúœ©7Ä×:OôIZ¯‘üÖÇþxŸ³`Ë·ÜlãÚ­ÎCϽP?%Ï/né>ås༖s©OXü!/×|c~ߺ‹ÿZ§|U>2ŸÏŸwncüFõ‚Ò7·×þg?á¼ÇW¯9aÙ¹ë.ïý©Np~Îù÷q¹wòPìû_ÝöÜ»Ë^Öö‹ŸwEóòâï¯:ŸüMï'|€¿K\£>“]õÞþôïø*õZæXâI:_2ñÊ™++Žj=ax 8©õaúSÍ1Š¿¹ûƽ_wâg õ¹cñÜ·ö¡ÂÓî‘ÏÇÃÈ“©_µ/Í;ééyð잟N¤{\}Çø[8‡½°nî;Ç~-¿|óÕøâ_W×¶sTc[Ï#ÞJíÈÓV]ÿc/ºOñ³sÚ:RºÏæœÆuXñ"êÌ+ûì}Z$.·OìàX/KÝÉxN?#Ï §ósxñPã‡ðüÛ0â±Fsû]W<{ö]< ŒõØ8RœÊ¾[wúµî=Ózßó­µ}öÆOÄC zyîêÑ™«ˆ÷¦­ÿ#ç–]õÜpXq$^V^V>ÏûÁÉøíÌ÷)¿ÆªcgØo|”8®z¸Ö38Ž}­^BìþYøÔùÛØ•æø)8=öþø¥>è%_Y£þí<@ýßÉËYqû*ÿ¿æ—ª?5šà^ó§êÄwüXë˜sÎ[/鹜KùÃäK¬¯<&ž /Á®WWŒ^VüQìDÏëv‚Ϫ3@'Lž'ýìWϾ©ßȹm¿vò2êêZ7šûï©#ä_þî€ÃfͯKü+þ1O¢}ÊxKx‘NEð‡8H½*¿»¬ÞbÀÿÁUåËâßðìbu»ÕïôŠÜk~‚}lb¾Äh®°ž³ÔËÉ«Knÿxòø|fq…>•àhø¨sÓP½Yö?÷A? |©Ï`Ǫۛ{¨o1žÿV<9šî{ùAýìŒó Î >u:?4ö[üë=äÓŻטs¯BÞÂ÷«W¯ëü–Øë1ίëo`‡ÅÁò<ø'ûê^¨£i}uì{k}¬Ÿsˆ÷R7ßù.Ùx‡}coË×'´?€¾Nì¾|Ÿ¹,âMõ8—@÷<÷À¾Ù/¼‹:ü§õ‹â/œgyû¦¾Ü¾â‡øIç_Kç—ðÿÐ>Îø!x³yÖœÓêˆÿ÷Ö?›fÞTÎõ%²Þì,;(O*Îò¾å¹R¿Rý9ý¯á•Ú¯Üäý½·ø/(>PwWýŽ)þê<ïq]sûàÕyÓõ‹ßNýάúWñ»_‹“š¯Uÿ›ó£¿GÊÏWÿ5uTÕ9˜ž·Éœk¶X{ÙÒ' yÓ|žýÌ=™¥ßŒG(N nI?¬¾ïÉܧ]~Ë—>ôîAÇ(~FÜÒ~¦‘.VêÏ&s.ßù¢>àÙÖq2÷È9+=æÊŸNæþaû[®¸óŸØ/þ*vd²øÄúÓGu#‰¿‚÷†ü]â鑞aÿ¯Ø:õ£ê™§ø¿y¾¬ßdþdŸGlqò«ëßZ/MÏÐü¬¬?/~kŸŒ¾—ðBƒ5µ‡“yïÞråû|èþ­+´ÎíÛ6wC^ž>¼~úاìÃdÞ¦ÿøÑøã™óî\¾ó—îœóÓ÷îwÃÌÙ :wñïêÞØqyûY‚³ä+ª{§ï'q?YÞn‰Q‡ç<Á¡Í+â÷¸ú*ágÙóê)d}ªß”º8»:at§“÷ïœä/ðÍÎKûJóycœÚ{žx }¦S{;YðÃû»æs¾1[¿bÄ¿ë‡ëTô=’gåG:Oƒþ,": o<øvüÂÛÊTg9éÔgãÙ·ð“9ßyìïo¾à)ïÚû«?Køœ›Ö¹áâ?^W{¥Ž£zD‰ÅÕ¡N¯ü~íû4Y=–êñÇ^àñ볉…›ÝÇÖ'Ê×ç}­+=:üÞÔzáÜ'çþp^œËÎËÈ}ñ½êœkvíyó“±^Xû²cœ·±nn×3¼ F]]ô”[7ƾuÊô|¼õ4¾(¾€sÙOùÍìS÷OÝûeÿÕï8gòÇüé=§m¼ÍE¯[s˜[¢žHþ&ö‚¿foúZ碯9¿_^š½Åì§ó\]}[9·=÷9oêL²¿“9ÿöõÛ?üÃ3Ê—µÎu êÎù¼!_ÆŸÂÑÕsÍ«´¯îMïkî\ë|éCt®áç„?tÏá#v>è<-zÌÑm–ùYòtÂósí Þó|+g.ep½x©z{ìEâÇÎû >.õLJš—{S8ªc«n¡¾ÔßâuŠs.àOûå<‹‡|žI…߬žpÎ5þ«u_êSäå‡F:–å‰r?ávÿ_VÌœz®¹_©;šÌùÂS/=ì­Cÿ.\‚/æÏØgëR2õå½_±gìzíJð-¼U½C:—¹ÿxëêö$®76®É=©Î¿:»äïféÁëÇ58ë§ÒSq>åÝíûÖ>ˆÜWöZ\tÒžýæõ¾±Õ`Ϧxµ:Vã¾9çVÿԘ築óù!uSòsxvuŠò%ò2ÞÃýw?Súöٹ᧛Í!oLü Î4xÓ½ÿÑIh=²yÉÛôsØ úéW¨^=ÞÊ|f|]xèöe$ÏBŸY^^êÜÔƒVÿÃ|îÄ)í×N¾]^­ó¦çûŸK~ß9sú¸Ú­Öwå÷º£ù]Ö£ó˜åsîªç(¿P]ýLêÈ“ê¼pºÆ‰ŸšgÊ{Xç¹uü“¹ÁeÕ=>¬ôHÇN°º ædß6oûÃoñ­ßO½œüŸº@xÙóY'|¹uÁÃ5?Çu>åiºOúó¹êàÏy+ÿâÄK?õ’æ•ðu§F·:ø sv7v~UÎy×;þ=g¿:¯Å‹Äƒ¾·óKååÕ©…/å¿;oS>ÄØ‘ò~¹‡t~äÅÄßչϥP/”{”ï2Ï5õâÑöùÇ_´o0÷î¼MñOü |Äo±×ÍO›“ˆ‡6Y_½üÔŸÕ˜KªѼ¨ü}u–ÍAuïÕ3Óƒ§œºhçmßQpgõ´cgð|£ºÚÁNe›ßP—‘{¾VŸ!q|ûÀSWV=Iù¢ð¯õãpº¼»Ó|_Î…}ǧwþˆ¸9÷”¿ðsêÿÚá>ÓõÍÿ„¯GùžïÖ£‡ë<qOòˆò¨ÎcëN͓˽rÕ‰#ÙoýÕW Ðþ¼èÅvž9›9WìáU}õ 7ÏürȃĞðoÕ%Ê¿—o§»nntê3šwÊ9pîÛŸo®zÎuë/㳬?<ÖzŠœ;< ;ÃáöM¾Ù¹°_Õ̺4Ž‚+cð™î\.?á<Š7[G–øÞùêü@ùLüÜh®29îS‡Cç};ß },ð9ÝÙαÊ}”_o÷'Ôßà9:/H?cöy¬ƒÄ{qÒ|@ô[ð©žÌùÇ÷¯¿øßò׉‹Ø#¸¾„7Õ6^OÝkëʃÿ›ÿÏß«cj¿râau¡ðrû‚Cñ\âÐâ‘ÜGukp²x¿:¥¹7Þ¯Ðú¥œ›æ/ƒOðãÕ5ʺÒg׬—¿w/–}âÑ_Þøœ[›We/øyÏq]fÏøTvSýou¬c·;WUÞ¯l®axFý+ì~nƒ¿Ü³ÖO'þåïáLvÎõùò@x*ÿ.OésÇ:ˆÞÃ}i~¯ÏÜV‚ü¿çúãN½û¦wÞÓ:¨±®ÂX_—ŸeïÙ!¸Ù|èóŸvàÙ[î÷¹òrΩ:«ú³)Niý«| <×¾¢ìÃx.jýFÎû‰«^ÖÈ?:âê·åïé9t.^ê_œO}¬ðdõ ènгÇ? zÆê;r/½ÿ,~ëTvgpCç¨kÌÏwÑOIþ=û:iý§ù»Á‹ío3ß~ŠøÂ<Ò¬wë‚ÏÜ«Îmbå¡rÚ’ûÏvýóûø)û‡×Æ×W¿VUŸmü>$uLÕ­."üÑü ÝÎìx@|€§ÑgãÞÀsXåø½ÎÓÊ9ï¼ÛØS÷¨: t¬ç×=Ïóªà§ØsWøè•›ùVõzþÌÿ¥£܃Ÿ‘ìœñ ¹²Á]ßà!Ï«´|½ù5ê)眾Ë7¼ëµ?h\Æ>ÞóÛoþÒÿš3èë_åÏÒ'†GôpRçAÐñϽÀGŠÓàwëíÄ/TWôŒŸ~ú‚ËVßaÀûáýØe¸¥q ùŽø ù|¤¹¯tlóïü«çáoÆ¿o]Õ©Ï-þU—Å_ʘço.NÑ'5î÷¼ú€ØÓYºêOéøçÏÅ>¶Þ=þ¬óèa›£¼'.©ÿ¿¢þÊ>ß›Çïg·ä.>bß÷^i˜Ïí=Ô%ÁíÇÐçGÏLlâpuùíK ÞîÜìÔƒÂuëÙÑä£:o#uQx»öeÃíê‘ðø3ýÁ‰“ÄG­¿Î¹÷ãÓÆýííÁW$n)ÿ_ý·ØöOÜìÔ¯O´>'øØ¾Wç-q>Þˆßwߨëà¾/äýðÉü¹{O÷¦º’Á;=7‰CÙg|çOäsbÿ'óïÙ⦛¾ûÄA÷R½"ÝuðFÞŸpÞðúð:>¤:ô_³ÎíV§‡á/¦ë0™ûÁ™Ýž~ØË†ýÎÆ3°§£e®fp¶úßò²ô­“/n\©~(ñaëÉGuÍíûNÿRõÅâ?¬£¸íœ“Î}ȹû|ÐùÍ»qN|ŸøŽìœIïGŸ%v‹Ým®zóñ$x±Qý£ÏõíÏ ÎaGÜ—Ö[°×ñÿâ3~°:aÓøt²â ¯ØçoßÚ`–¾au b_Ü—±žî‰s~rÆ7ê‹·±n²p¬»Õ¼{ž“ÎZíoð#«^®jœ<,œAÏüíÔ­V/¿¯/28?]ýˆà4ö^¼V}•<§<<;àsù•êÜæž‰Ïáñö/²×ô'ÕÚ‹­Þ4ïបҧ‘ó .>oc·9ôa÷oý—sÕ¹úecW;×cT—$^§v^«›k~Að]ãöQÝœãvhü…û-R}áäGáüÖæ}äiØ=÷ž¨n¾9Pág<Þr®å_ðßøŒòÿñâ4çYÞ¡uꊂÛìû¥_É>ê#çGªC—Gfþ]ÞÅ~:gò*òòã9¤Þ×÷wýèx˜;œûÒ¼¤¾ÊìG眛\3î»ì|ìƒývÏØ™ònæÃˆ/Õ¥ÄÑIЧ×þôœïêEÒ{ןB§Í<¨Ä™øGzåxP÷ºsÁÂó”Çs_‚·Çx6|ádÞ~Ýy£OÞÐ篮„x0¸ŠÝgÿÊ'¿ùýòäôâ·ñåΗw>œCÏÙ9ÐÁ/Ǭò‡Ï®zâñ½ÿú éÆ9'YïòLôiª“>bÜÇ¡nîoÅ1­ãó¾úAòüÕ«¦O5ªWìü zìòâÙ¯ÖÝæ}<¾Nh)xnaW܃æS‡*ç?«Ó»Éÿð?¾µ`˜ãå\U§#þ¨uGÁ‰?bN•<•yáSðŸ=?êçÔ£¥?K}"] ÏA®yîàŒ±}unÕɨoà'ÜWþÑü2q]^*÷¦s]ùqóZ²~ø€q ˆCí§>°Î¿É½‡¯‡—«î»zúäÿƺ²ãzpùñöͨ¯È{áí«÷D.vN'¾‹ßn~BVßoxñû–8g2çͧ¾ã 7ݧuˆžÛ>©#·Ÿ_’Ïã×ñÎιõïüiykùry§¼_õŠrŽõQvžpp—ç’Qç|±ÛüŒx–Ÿt_ñp³|›ï·oð¦:[þ½õ;úðÕ/dýÔã´¯2~$«ª.þ qSu€‚Gœ_¸\}‚ý*o•ÏÇÎ|AG©q¡úýÙ‡òáoäu[7­/’]1ß<ëÚº…œñ¦sNçÂ÷vîvöÝ—ó‹­oR7»ŽG©ŽNð:¾¹ýFÙïwΆÞ¶é1œÛø+}ì=æçþ[ßêĦß)÷´ó6œÏêõF¿7÷t2÷ò-ZxÛ?š)>ÕÇœõo>>~©õ¾üjâ”ܳÁÆUŸ7çG°óJã/}ŽŸk}[î—‡ŽÝ)ÿ.ÿm¾•ó™óU:õù9ç~ÁÈsãg;‡2ûßóÇ'Ózż_çÂðìFu>?àÇ:‡>v8~¶ç°s\¦¸®ýû­“Èç÷ÐS ¿!Ži^LYö¦NŸàOª/ü9Þ_ö¢õ‰ÇÛ7~¢upÓ{7ܳøI<ûÚ: uv±3Õ¿Î9êÜ­ð_üCy‰ì—¼¦ó#¾Ñ·ÌoWï3xßýÚ÷ ‰›Ïàßý<¼Í>;ï‡ýÕWç~‰/ô7´&ë VO˪̯o–¾ËHÏ©ö^gîçiŸPp ÿí=áÓ¼Oëº^±Õk¹·o×£zHæ8°gtrÿ«?È>Äž™óá<ÀòÒÕ;ʾÁ‰­H|T}ªàiv׺·Åÿ5?’uõyÕW5g+ëÛ¸öNÞãeƒ=mÜ]ÿo½«¼D¯¾„—èȱëâ Ö˜û;ÒKjŸ =Îì#¼&OÙ>qiîrþï?½|“cÿö§ÞÏq\wÍ·>°íýÿë¢ÉüÕ¶:w³m½&: î]u¦??ôÂ'ÁAÕáˆÄ·úùñ¹o q‰õ…ÓØ…Ö ç½ì¯¸¤ýéêÍrnÓïP]ŽÎ‰?÷©/Ó—Ðøï‘óZ>-÷½óUãáSõÅ…Îaì4¼Á~ˆKêÍkÊ}ócñƒµžþ±ßðSuïƒ_{îðUù½Ö›³gxtõiÁ­‡Ì}wÇ<éûù±qÿž¥õÏædßÝvÐÿÛ7vL>þê\ëð“žëœ=?»Í+Ö_«xÃ~T1ù=ñZu!b'Æó«õiµ/*u6Åi¹Ÿò©åíFºæ×³.åñõ‘å¾Óùh^xêsÐ¥Š®QùžÄEÎYóËê²²®­ŸË÷²gíŸÎºÈÏ7ÿ:åÍÿEG"ç¥ú³ú“bõ5•/˽„ŸÔu4ÿ¾©Ž³þÕ̳«îmxl:IðCýVêâ« ?¦®"ù­â®15žo\?•}À'°úP:g'û¡/­º‚Sÿ9™ó›W,{åýw-wÞù·ê²¿Îyx<çþÔÇÚ<¶zæì›º$üççñ(Õ¿Ñ÷zøêÏø3x$qIù¡êÐÇþܽñö\uà ÿUg'qÇxmópòØê…ÔÉMã¸êÝÀ…ð=}2:ˆÎqçÔÉ_Vï.÷¯ýbúêã;o|Ä›U_5}èøç]Ý¥øË¹.¾Ìþv¾A~ß¿ãgÿÅÞ‡(¾•—¹{ÎäÙ/X·®ßH/«y±ñüÜæ+ƒŸ}oë7cïÄKò‘ÎmçoåWß8÷¥óKc‡gïï¼µŽ8ü?Úü|Ö¿y™Ø3<ûݹît9ÍGSOû©ÎÁ<ôñ<äö_ê?Žn:Uñ2;-n_HìÃX¯¬õÙù\u˜žž¨ ^8xÃ9oÞ3q:zsušþªÞ„¹Zñ¿ø~›ý×IÀ­ûÓM/8„ýÇ?vβöGågÚ—éþ8_þäÇáÄÄkåÅíòïö­~*q2½ÊÖÈÃe}ñ»Þ«yÔø |s)ã|<Ï”wñ¼ü“þ!öBç¾u¾ª«¤Ï'ý í³S‡{ÿ9ð~uMÕÓ¨cÉù®®gâ§Î©N^Õ¾¶ž ¼@ç°ÄtžbâTu"Í·«§é;:§öùhýŸº’ø}bÕO½GëNõÅé»ÓG—{«Þ^~¾: Ét~rx |LŸ_½§ÜO8¡ý‰áIÂONæ¼òøCóÆs8c·k/ãÏc—ûóí£Š‡O:G_?ÒŽéçˆGê¯Õý¸¿êôò¾Õ‘Ë:¶ÿlTß6žß­ï Ž×/±ûü<ÙøJŸPâ´žƒàËê®ÒIIžŽ¿s®zOƒÇü½õdO«çÿÓ~ìÔS§yÈ›²sY'ûQ=¯Ø…òËÁ1ÞÃß—çOüæyÄÍìþm¬3_qsÒÌ;W·ÿ.Žo½‘º•ØË1WT¿#øߤÏÀºV¯x4ç½u;òóáϬÞ¾ú8áåªC̮ľZ_ñ|ç Ç_5o¾kÞKœ"_Ǫ¿gG›Ç”ßN¾Í¹Q$^…OZŸ/îˆ?u>ô劣ð°puóºù÷ΉŸäGgäܰëp œÏÏ5K'D\Þ§s²sŽè7ûy«Ú u~ôoT×2øŸ.»@Öï—ƒCô+†w*¿•ç`—ô!ÒCi}nì±û/¿*ߨŸ©uôèÏ6ÿK'V>,öµq"½®¼¯øÎ(OlþŽð'µ“±×=o£ùÞã8‚=l<Οã¡b‡Çü¶8‚_‡Ú§§oN6\”8Ñ:ùõcêðÕiÁGp…:èêGæùð ô øÏöu%þÔ‡óՙȽëeêï¬L|‚¯¯~ïH?¡zÛúÐboØ/~oÐýJ|Ä~‹ËÔ%µ./Ï)®tŽì »?ÎïãùØëܹ]tèÍßÊúu_éìæsõ âÝÛ»5η[Oü>o=Hâ™Ñö>¯}l=Ѩ?¦vdG°ìiçWé×OÜݼ­~_ú1±SâÎqžÆý°_£|Zç‘„gd‡Ý[þŽ^¼ykü¡üwó¹ÿøUëPÊðhâ°ÎS×ߟûƒÇƃTD?rì¨>}ižoÜè9[Lj÷ÌóÙ·® »C‡1ñzótæËÉÒßTjŽ^Îyë8è‹fÝÛw•ø»øJ¾ÆùÂ3ê§É½„'Ý?ç¥:ë±­WÏïóŸÎ3¼P^(¸Ì¾ÑÃWwâ>w$žaOÔÁSí#OáßÅì’ûV¿0}ïÉœ—üàùÝ`á¼%Éáù[,^M<粋î}usñÖùüÎצW=Ês™‹Þ¹ÛxŠøŸæóèîï•'4W5ûXýuoÁ¯éq³ÛÙ7sŽø%~¥ùõ9Ïâ×ê Ç³×ÕÍÁŸæ=ÔÓñ‡Î‘¼»S¿;š3"^kŸ­9‚±íSJ|Ëž¹pzÏeêqàx¯úª‰ÏÊ7ñpMÿŒ}nÿ§þzSœ>Ô½ÐÓÎyÃoºçÉ7.õðºõeçí›û /ûÈá&ëmŽrí¼úÆÄí—HÞ@^Jœ0æMè¥ÙvÞGõwÍUV÷›ç ïÓ:kþ ~ußí¾IÞ}qùûÚ>lýÔ©/·ˆ“ø«Ö}ßv㎫?óöÉ‚ßÜç¸;žü§™ŸÿǶ+¬ú“³ú~úûÜ·Úù|ÞœŽauHƒ‹:?ž~<+^Ó¿—¼Âx¾~¤::ù^ù…êä'n½ø#'ì:w£¯•O¬þtòÓpGûüFºÅá±ïð‡õîùð÷ÁKåïcïðLÞOžNÜRû*~Í÷–'şǾ¶9y ùwuéð‘ý±^íÃw¿r¾Z?¨þ;ù ¼Šø¯|BÖ žs¾Æ~.0/ϼÄö™è+ƒ7ð½øÄ/x˜ÖGèߎÝì\ƒàýÆÅâ<¼AΛ¹gÍ'%¿Âþáí«Ç}²Ö‡çÞ³“ø-þUBç°Ÿ°/þ^<Îþè7pOë'b«sjNMünõðщ¶ßâW÷W?YõÏ‚3àFý›ìHõ‰rþî¹ñÚëpô›zðñü¥¼,;ÍΊ×í“úŒÎ•ȺVß/xƒÞºyêØwó'æ½èÌ žñ…£=áØUqûa~ƒ¼Dãb:ýÙ'öV¾W*­O¿ó?™ó‚~üÑ?þ¦ëÒþ´ðºðnðëdÞ«?ùš+_ðÃæÕê—SÓ>£à&÷=y†âÍÖQš“œR^Û¥ìüÖüç×Mæ<üò­W;÷ªÆ_é·l^z|Ÿä-ð‹žS>—=U—¨žË>°Ö³ó=FóQØ=þÅÿWw[bî[ê)›oiÞ5v×>ãÄYt5vM]|кãÄçΉ}ȹhþN½eâçÉœßïtÌïÖ{Qß78±çÇySWfn—óç‰ Æõ¨­Mß³÷bÏœ/õªâóÒØ±Ö¿ËsÄts|»ª¯þq¿ø_ëÞzÜ©Î4›ž7Ÿ‹Ça¯º>Ùï{Ñs\û‘ï³OáQ'sÿϵbû¬¾ ïÈþ8¿â àçæU{¢› ÿTGhÏ´þ‘¿l„:øèCõyãŸä‹éBgŸú¾37åú=ð²8ƒÝÍyèùŠßïü2÷éÿÕÑ™³ÎoôÅç|±Ï•óÖº¨öq&>‘Gï|Û)Nh~¥õ Á¿é ò>ÕCŒ¿šÌÛês÷œþÂ÷Ön7߯;÷ño±?}n¿Ç~U‡.ûéyS'2™söWVüÒmÜ,ÎpÅ ìTuY3÷!ëßù*úz/ODŸ±ñBòhÍKÚþtÜW¼9™»ÿ_ñø'ÞþŠ„—ˆNædΑk­sÊœ›†97Á¥õ×éßåOŠ{¦ë5è%æ¹:?*ó`芲Gü¹þ>õ–ð‡õ©höÇï±ÿͧ†_¶¿Á õîEø­ÉÜMöyÆ•'í4àš¼Ÿs^¼èÏ)nšÌ›ùì¶+n¼uãÅøÚÕØ‹¾w×+ü”zQvAü÷Þçܹ/ž?ÏQ^>äG_öÍ÷u.ƒæµáú3p »V»•ç.?|&ï7¶Ÿò9k¹è‹Ÿà9vNtÃ' þ8ö[ý‚x§~98Á9ÍÝÖÓüþ}zúïü½sT;?Âît>Dìª:§Î½ ï;Ð{ëÜùüðA“y«}èÿ¶ç/Š›Æý&Ö»q\Σý²ÿλwÄ¥µCñ?øØÞ×UçÜò§gô\:ç­·R?Æs²sâëÆõÖ3qмܨ>Áýô„ÝûÚ÷äŠûs“Géú:‡s®[ÇûÅΘÃßZG|æ|©ë¥Ó¬^¬W_Nçöå^ZøÏŸ‹_ggOâÑ<äÉ+ôâÓÜ v™ûïWÞ¼×ÿ| ÷E?µû®Î ^Îû~ ÷Q?¿e]²~“¹_¾àczs>ñLÏ­¸Ò¹UÇ2^Wy þŽÿP¿ÞϽ›,ØjÓc?}ßÿí½¬^=¶ðVÕ»éÈg±7ô,ÍU‡;ŸÑõkæpÑ7–'¢&ß^¸s âÇáÌÖ»æ>©çù¯ò¾ê~Ôo©ëŒ=—7ì‡?RïÕz³¬sãÀð9â7}&#=—âÒêÌÄO÷¹ô:æá?ò<êàïçäo“ê¤Ð1ïë=«G’ý?ªwÁ‹Y_xÜ>àéÛ¿Ü7‹ßíüý^tGâŸõ§ÖnåUgO=Sù³Q¿œzs3Ô™‰Ú‡™s/^Æ»ÑÕ÷©Si¼’ý”¿w?ÙÙâçœóêD«—Qh^7Ý¿ôåÃpqu´S§ÔzmóÉc¿ºt¯õ%'oÉþÃéÍSô_«»Ÿ÷mÝYÖ¹ýYñ;í×MüY0ýmúVÍÿÎû7>]Q2îS¨ýËçÒÃiÝwž¯ý®ô‰—T'ßÛ<øHÝ\œæ ðt¦s¯š/5W~ŠÓ;W»º xÇàDÒ-i^7ïÛ¼…¹·xµð ì²z0þª¸ ëÌþëGo=†>Iugtù’G¶Þêñ¼í«j?Lxšê·˜_>gþÍßâ’ì2ôº?ñ¯xMö¬ºô곯p†õnÿˆ¼•¿§gfî:/ö­zXxºê©OP—-Ÿïð}ì^[Cý’9Ó£úŠæÙãÿÛçšýêý0æŒæ¸³;î«:$õ8Å-£ycíÛ°n‰+ù-xY}„øG> ߨ:Ðì?û§Ž~gïøC¼CýþhÎNû‘ÙSzdÁ½t}ÝÃêsæ°·ü¾äÿœñqv³úÆùžÖ«˜S1š;^½ˆô8‡áõÊg:çü}óçêuïTÿÄ|Òü¼çdל[}-Ö]?>‚×SÿcêOè#æ¾±ÃÎyëiôy7×®ç¼Á­‹£óçüÓwÌ>µd4NïÃóÖ«Ÿ£A½:½¡Ô?ª·Æ³{¿ò`ê#ÌMÏ>°sÖÕ~vŽèh޼|‡:lüŒûé¼ÁSî%¿S]ÉQ?)?ä<4o8o/ˆ»ÚgÈoæçðì€ÏÀð%<á^¶®(qnë¼ñ2±Óž£s«Ãµß2ûo}ÙWûÆþZöʽl?QxÀÚOõñŸÅ©'W?&žÃƒ³[x&~›?¬îTð|Ú8q¤c^}ÿàçŸÿ¥Ã¢?Ç=ÃÊw´‹ÞKøÒâ"}–ænÉׇa÷Õ‡·þ›.~Ž~¬zä𠇙þa8¹zÆôµbGØ{ý„üXužS?§nl¬ûwÊnsÎüì‹âºfù^þ»s®“.ŸÇ_ó3ÁÍÕñ Nnßý£“@O-ë;Öù¡WÁ¿°_³gÎYâ}~ŽÓ' ïyÎó6xÇ?ò‘u‡¹ñÕ#7ÿLDo‘N’9©;矪ÿ¿á¼ãBö©ë»1ÖÅSGÙ¾ù¬SýáH7¶}"£9HìIë´Ógâ=[OG_s絟£žžŽ¶úeŸ'þŠ]í¼—¬·õ™[]]ÓœO¼ˆý)N߀‡jž5÷¯qsü}ÏÑñcƒNpÎ1|§_iùäµ·ÎÙù9½ð7|&OÄΪC 3;Ðz"ß ÇÐÁt®Ô;à—z>ÂÏè7¨ž5û ï7~³ó RO0žï„?kŸ—x?ç¦ó]ô«æ´žÊ¾Ä¿šÒ¾Cs§‚cœïƱñCÕÔ/k®Í(¯T];zláÁŠÿƒƒø9ïO·Š½ä‡ªëK_ÿyÞ¿þoóÇŸtŽex¶ö³ë»Š¿€ËÏÇ_âO¬¿3ÆWêÏé½4Ÿ›óÀîZ‡ê„ñÓ‰ÛÙÝà’ÖÇxÆwôkÌ©Ä#š£–{âçÙ9ø¨ýYG}úxžÚSs³ð½Á_ú”ñyprÏoî±ýòüú8áQëí|V§º¾­3Óï^ÜMσý2Ÿn®:Mó7Í' W /Ð Ó¼¸|yøTþ*ç§u4ìüG—¦ó_áq}µô‰G¸ÏÄîšÿXD¿Õ½ÌÜÚ¹Û|gÏÃWÜeÀ/ÙöÙ>ØÇêDæœðûòp‰{gé¹NÞdg|û”â÷œsç.n¿âï²×½ÏùùêÕæœwà”_òû=óÿ¾]ãö >ð Ûwmí±þïž¼ú);Ï_6sòZû~äÎÓî™9ò´U×ÿØ‹î3sú)÷ìê‡ö󼇹_ì“}7‡!箿wô%7\ñÂ]—U?F/Rœyþ{nÿú*×þ¨¿—úˆþ?»,^r¾Ž[íëßûïÝþÒŸûîc÷¾lÓ—Ü\#}kýwöÇsÇ_õßÕœ•ù±Ñ…ê¿gneÿ_«÷Ç+Ÿ³`Ë·Ülã'Š_£›ù Ãú'·¯zïößÍÛúäÿ]·ƒ¶9ãSxÝÚËv”·…Oúó?yø·oûë·oœùÙ[.ºíÓ·]Ø{wÞËwþÒGÂÏýyÏuáñï9á£7¯~ ýЉôe™·-n<ã®¶~íOm\>΃žyØËO{ø¿ß§¯ëÔÝÿ¶Î s~^¼é9£ÿª¯,¯ÉnœðÝ;æí?ŸùCt/Ì7‡/NþÀëû9tkk¬ý¦àÕ~Ÿýs?ÌËé|Áø º £ó:ëùÍï¢?`>‹<üQæé9èïÃG/Ü墯.Û¯ý}Ç¿}ÿ=ß²ÒM}ŸÌ-èﱟô^ð6òÍ?à¤Ï~x«Ë«·çeÿå¹gèüenÓp_ó=ΓóuÒžýæõ¾±UÏaú{‡{Ÿ>_¼žý1¿Èº]ù›×íú–M6úh:¾ŸMŸÿ¿Üöäûÿo]/„Ãgý\ç‡wµn™ÒŸûÍaGýjVn|f{Ðï¯ÜoåëÆë:ÌÍeVW Ÿ,œtÜå+­õ–£ne_†}‰_²ïôkú^‰cÍg­;”¾Á±ß™óÿó_çÆðûÝ÷諱âÈÎÏœâŒù¹ôÐéß\þ‘§n½ÕòwñZø$ñŸûxØë/{棯í¹Ó¿ àþ¸ÓFï¾é÷ôûØ8“½ÒמþËþü… ŽY}ÙË7oœãùôÍ«st~NÛöÖï~ç{ªS$þ:t³Ùõ™ÛôßOÚnŸíN™ú!òœÕGÂ+‹»Õøsÿ§|þ´ÿæíìuuþøö?ü3sÊcnûÎïV¸«çîÜ“ÖúÉFë¾­Ïï½Î¼k¯»÷xæO‡ü@ò•æaf‡ïÏ9Ìç÷ïåUò}ý{ø·}øñ¯ì{p÷ðùé·—ïÐ èƒ×OÊîá!ù<¿ÄÉóòì…óž`¸Gò|SþdÖ~¿ôýä+kÌò{Á õÿîë7|ÂMÇíò÷îKöa°w±[Á+³ïëôõÿÃ3öÿÏúäòÞtÇ…Í›äýgÙ)ç=ø¨ÿ®/ OÙvTœgýý½{*~¿h£[¯øÕMÃ\>|Vþžžæ€¯¦÷¾ÿÿÓ÷îwÃÌÙ ób¦ñü/„_€óÞþð½S~r–}rŽœ«ewÿî·ßzlù¼öõÓkË½Ž¿pnü>»/nrùÉsƒ{ñÖx¼)=WxÙºŠ#Ì«ÆWÅ/ãgñ`ÎýàϦ¼Ïp®¦sàúÿðfêÔ¼½`á¶~èûz¯ùwëS=àiœ>O?9êK’ŸŸõó9Gýÿ‹v_ù°{>ðÂYø¿HüÓŸ‡£#ó`äuœkv¿x4|¤x+÷|Öóá½õ÷ëâ|:þË~‰Ý3¯VþN¼5ì#½²Ä=p‘:ñ¼|œ$?„WU7+.ó$Çíú¤§ovÛÇÊ3°£üpùÇÜKq±y½­_ŸÆ«c<7œ»Ü/¼0ü(ïMÇÝÓ‡íÿå¡á ü„ççOÜ;<µój_ìÛ9'ûs÷ÿxy$vÿ>a–t~=NÁDßkÖ} .ìrxFvÎ÷Óϳ‘Ÿßú“`gÅâîäYg=;ÿǿ՞YW÷Kœa½œ—qe¾™ç ~î÷û²W½ýÈçvrúïö¾¡å~‹ãÇ~ÓóïýË8 n…kÔÕe³¿—Ï‚“Å·â‹æo“×Å_w^{âxùtx@‚|~ç_Ó±1w"vÑ=woÜKy'uòëp¦¸×ºáÅU­£Q—\佪{·¨ Æëó[xíà1^ô¤òs¾Ï¹'áiÆñ`çÑ• ¡þZ] {ÀÞÊÛÊ#²_æ0ȯ²ßt+;—;þÓ¹hj>Gݵz |Vë{èŽò¤Ö_Ü ÇŽëö;¯.}ÒÜûß¼{ø=qdóå9gêT¬;¿Ñ¹€£¾|dçᙋƒ—WÿÐùæÁçâ-??šÛÛ{€ÇuŽMp“¸®óÜ×Ê?È[šÏd?Ôs9ÇÖ©úgé¿Á£µÞR]–s¦^„=m}@êCœ_u úƒÅ™Õ±Ï9¶~òDÞ~`Gà!8ÌÏãaà@øªó¹ÌÿˆÏT×úuõU©hÝBÞ¿ûžùr ¾½Ò>«Ü±JëzÔO‹#ä ÔºwêÛ:w+ñ`õmé§eØU|EÏ =ãäÇ[esÞœ'÷ Ÿô’ò¹YÏêD5¿{_ŒçÜÁ!ê:è9öÞç^ÚOø]Œ{ÈδnçÞzaCýEî |Îîñã­ƒN{SÝÁðÙøñûÌOù}y÷ÖÊÛŽæã:_î<¡N‹:çγ .RßÐx?Ÿ§ѹâÉÛòô#ù{¸YþÂ=¨>Ÿ:q:žú[Â;T1¼Uç&Áæ6dÙ?ö\ýNyù¹Øg¼»ó­¥s£rOù›â…ÔEðcê'Ù õ&ø)üiõ5SÿÓyKæ”Ð;ç'ð ž§ó–r¯Øü}ëãìçsoÆsªÙv¢súr^ø;uBp üCÞ{´Ÿ5öR=û×¶oGß]ì ûåþ°¿¾©¾kxùéÎ}ÿã¿ÛW5š×Ñ~€¬¿çjkΩx©:-ÑÁ).éèÃ3ÖÛ9v~­ž¾ýž£:pü³ç¶®íß žðžÖE^Õ9Ï›PŸä½;§:ç>q>ùyø‘¿mùôÜ´Ô½äÏí#~ˆ.¯NÜ\לC÷îËÄÓìwëÚÍ¥ÍϰOò×xêÖš?¼ãž«g…ħíKÊùuÎá@¸NNç+æ|³Ç­;cg×°âõö¿Äo·!8Ë=tþÚÿ~Þýf—ß·9Ÿð|!OèÜùyñ0</Î1û$TÝäØöM¹Çù¾ÎaP'i½s>œçU¿ãœ–—L¼¡þ@½ þj¼ÿêI_x‘_¶Žö .mÝxüaç:äúž®Ÿ|JÞƒ\éá»ÅÛx¸ñ<ë~¸ù¸öÏêÏ9±þ_}ÅòŸ<ðê“îªó<³–øÉþó¿ê5«cŸû‹ðÞüOuçG¶>¸·úÒهΠˆ—ˆÔÇâ#Û¿MŸ›þ·~)|ƒuÌý…oÜÛþžu Þ°õã±çퟨߠÛn®!=¬ðú{ÔSŒù]÷±ó0ò=μ\|_š_ožRüž«yÙ©?ŸÌßêÝ—=q§t}Ùõ“â¸ÆûY÷öyvžgöƒŸÆûTW#ÏÃŽxÎÆ‹ô«èög]åÑŠ_âØÏÁ?wîØ¯ÏâÙCýµðMç§æ^x^ö„}w¬SçaÊ[³{±Ëøœ1Ÿ £s§snàÁÎQ Þã'à[8 s—ó}ž_¼Õ¹ÝÑóKø†Î̾°çŸ|÷Ï~õ¦Ã†çÐ?š8¯ª>£s©²Nø[¸ÉÿãíÝßâŸøc¸²sfÕ{›«Ÿ3|\➊§«Ç O‘Ïå—Ä×­ÛÌsà):?C·&v¹÷,çžiûcc_«Ç¢¯Ð¿'~ñ§Þ[”õk—>ýø«Ú¥ÜuOµ—ì½ïËþáWÄÅâ ïÛþòœKy‰öCÇÁ§pqUü{+.ÄK:Ïü~³|zžÇ=´ÏÕOH?Pqïhžœ¿wÄ­ÅKY<ÜL_`\çLo_Ã;‰?ì›÷—÷³ïðoý‘9èðOâ\8Í=ë“”? ¯ªN…ýißMΙ¼‡~ß'ÆOÁ-pZuS—Á=­oŠsNôKˆcá;ö›.Ï<ÂCünêj‡þ|»‚?à'Ä[/šý¹l—®°î3/,^Æ[»pFù½Ü#~Ó=¨_ÆužXÞ£}Îynøƒ}àà¥ê~è#†‹ƒã$¯ÄÏŽûÇðæöQ=Æ8ì :·ÑW?µï6çV^Äy°ïÕñÐïžÄ>Š7Ü vV¼[žÐ÷zŽò“Á¹p<®Nw¬¿-¾¦¿h}è:GÎkìÖdîöŸÚñúÔ +"}»ï:­;¢_Jºz°¾'}LÕVÿž†ÞÛdÎ{?ùñ‹NÞ£xÂ:Ew¹:–ð¯õ¨ÎíÿwNBõ £w$ŽœÌ½ù¨ådžs}ÂGác—&so;móÖ<¢º×p*;\ýài|3è†ÆO±·ê¨áúOã~>Ï]ý0|}â¹î#<0ÅÕçŸëç­ÏÜ×üüÑËVﯸ?ñ€>a:ˆíw„óéŒæ_éûå'Ú7<Õ-’þÀáÜDßÿ²¾ÕQn==Èêüæûå÷«Ë…o-þ ßG/„^Zûw£ Ö9'±îéx¾Mûéc¿ªCü€g®.]‡Ä¿ø}ùZy ~DÞA^\\Õ9¼SÛüý¬œ—ê(²›î­÷ÃCÐÉôÜâ†ê:…ãoä½ðÃx²ô]ôýZ™óBß#};åMÕ=ñ‹üfò9c Ÿ:~¹ºÉžÃù„à v¯ÞCð-»Ûºáà#öþ²¾ì¾¡ó\sþå-ê÷óó‹n.Uð\‹Çí«Šü4>,y¯!^Æÿg[G¼hqpÎ׬>íÜ#vÊ=cOøz6î??ØxßßÄ+p»U]B:]ê"ñb>7çk<Þ=§SÑ7¾ÊóÈ#Ó ¢siŽÕœg=a¯Ë>öÚW}mt¨äïªWB_†NzôyàxÛŸ^·}ý'šøÌ½ëºÄÿà¼wç‡OóðÖ©zðìÞE|!®iþM¾ŸÝ͹ëé ši][_+¿–ø¶ºaÙgú(ÖÝêü7ºYù翟ŸxÏ+“{÷LÎÞùyz_}-q8}ˆÆ‰9_ö“=—74Ï‚¾ƒ¾¿Ö‘e_áãô1×NÀ…üró3êŽÕó„àØ{ç.çf2÷£§î·ê tøÍMN_:^A\áùëÇsÿª›ûRýš<ïXoÐçôþFŸCÝ^úÉ˱3åÁèÞ[÷©ºàÕç/ýy}Âîþ§zêækÈG$¾Ægt®‚ù!ÑÑcOñ6ôA«w€GëœÐàaø óm¢sa~ÂÜ®ÛþÅs—týbç†9Ó¹;> ïÌÛ®¿Þq×a]“žÓøi~±zm‰7;gËœ’¬§ü}õÕèÏI½ú¸Î‰Íþw.Wxñ¸<…¼¢u¬¿4_8Ïí>ÑÍåÏb÷:G­ó#_õæÍ×Ú·}ëÆ' zãÁ‘±›õø‰ÎÉÌ=/–çggáȱ. ½Lþšî>MÞw<_¯º[ù{ùEq{)Ž?°+òkê!ÌOÐßTꑎ”¸ëpçžMæî¶Â%«tNõ,ÕÛá:‡.ç°óÊsäuÙ9ÏUØð›Î8ßóT*8ÜÎsŠ?ìܤÜëÎCÌýžû°®_窆yfüMxpëV? ÏA‡7ß#m½Ht¤ª7”zB÷îk~Û\ÌØ y…ÎY¡s5½_“y Ï;íÕ‹¶h\ZÝñðt’ù'­çËù’á·ÍSÀÏ„_êç5^3WË\Žøu÷—=,›óÅ>âõº~±SÎ|˜ÎžÀSWÏ)öF½£ºõKâxöAž¹zÛ9/x`ë\;ÀßÄ^©ÿÂÇWŸJ~>ùnõ죟ë\;öejºOô‘£“X»$‚ÿì|"ùþä¯ôE¨£ƒGØ=ßùdámáTñ^ußØË©ÝïÜ–ê3†ß4Gþí>Ç_Y÷Î Ë¿Ô/éx!ñüY}åÄî5;ÑûC>8ÿ#a[Ÿ`ž–¹ÎüqâÇð“yû}tç>yÃ07Îü‹à¦àÃò¥êë䛫ã<Ä~¨?¨þxÖÓ>™-/ 6ž Ÿã÷àÔÆÍôòF߯>¨ï»U}ýäÿª«˜ólž¢8 _ìùZ×N÷pº_Ã|˜Üï|ÏdÎå;_ôÃ<»ù©öÇ„¿ ‰‘÷jið=;Ú¼^â|yçhÇ®ñ7Ö ÿWÝxñ ¿Bo=ó'ç~pf·§ö²!4Ò…ã×Õ Yû ާÇ_šCw‡]í¼Ðð5Î]õ¢á”Øwùv‹ÿ¢Ãêýõ%4Þʽçñƒâhñ›9Jsa>\»ÄÏÊ?óOÍgLó^µGp&\¥øýñ¯ê¼VŸ—N0}Ëð x%¼žÆ>vßéþ¹êøñ¼·{ᇊkØSs²Âox±¾¼¹üýhncç;‰Ç;Ï88´ñ¶¹Añ·ôù~É~µ®8ùõÀòüåÕ¦ö ~ËúòóÍO$þs‚—«œ\>ÊûàÏ[w™ÏUgXŒàýáÖ]ŸƒºÈöÿåóàóê7Ç~ª#iŸÍ4OTû¤¾°_ü,¯ þÆ‹WäïõéYçòFú—¦¼QçÊ·ŽR+öÕzðŸâø«x6ë8îó’?ißUòúý{>õ{„ÿï<ïœGymñ¸xÌû·ßP>,q‹{%¯Ñ¾É¼Ÿ{€­Î¹ùWcÝÇð÷ì?\ýá{û¥ê»¨GgÔÏà}Ô×¶þ)vÃó¶ß<öU=lùõÊÓu/_©ž‘Ÿ—oaÿábö©¸"߯¾F_‘ø‹î ^A½+<ܺìœSxÑý‡ÛœoïáüÉë±K‡¼Ÿµï"û4îOu_äsàñ²ó¦¼<µºßà•ø‡7§!v¶|4; ®Æ+ˆËÅgúJ=OëÌ÷ŠwÅQðµóìçô…:ßâ ñ/\Ü:×ÊïÀxdü0œ OáyØíêvÅþø=ë)^o_kø)<ÍÒK_ö±n®}d—ë×ãw[ïš}”¬NyÎaóÃS|P^~m^œÞðhÎ?Ê^5DÙÜóaâ7ª “Ïå—ÅêDðhæ€Û~†½‘çÀûàÕÕQÃ9ì™<›sÝ:ð¼/¿`]Ëk˜ÿ˜÷d'ØÁ1?oü=»çÈOãaìGû2âgàîÖ›'.Qÿßã äMÇuî~©v/õnì{ûbGZ¿ÿØzŽcþüÙ3~Ç¥Åéò”>GÞ‹=×ÚÇê*Äù‡ÖÓéÎvÞð ö³ýÐ9ì½õñ¹ÎÏÅËZvî…óé9­›u,n÷;ú©šŸ19÷É}‡—ʣ듦sž{ ¯µž\¸:ͼ/ w©¿SÇC¥sɲ­ƒL}Ü!ÔzýYG|“êAŸ²‡æ£Ðõ®}¾¿úóyñiy}ó³Ô×É7?Áež§ø:xÉó·þ8|Ñ™~þ±gsÐ«í¹¥ »«Ï_(_Œ§è|³ô4‚ôíˆzæêýE¯Ès‹'å}ܼ­¼–{Áž–gŠŸÕ¿á¾ˆg­¯|1¾N_X¼è~—?ˆ_ׇ/ÊG¸7ìh猗ŠcË¿è÷ ^óÞ"¸²ó9óª'r/Ä[ãySì‰|<¿hÿÚç?W{o°<æ/‹Û䩽gûbÄAã~²öwÐCˆ¿…Gñî—¼róE9¿ì€ûãö\dØ1øÿË.uŽqð/;ÁoxOëÇòãêfÙ!ºEøA|µ{·™o-¾÷žÕˆ¯NAâãòÁùwç[Gyz}áƒ<É9?ú¢Ü;çÙºáËÛïûV>.Q컾ìöÅèÃÊ:Ô~Ñ×ɹÍçìHüSëUs~îYë»?:ñK¿Îaêd<¯sÙücê!àpøŽ—úç ñUîƒóé÷ÕŒûÍä©àMñcùˆÄ7xaïaýñ*üVõ‚#àDxe¬Óà^Áeå]ĩߧú“^®uá·ä]ØÎŸO®n“äw:×(ü§xªzDùùΡŠ_£c̳å%àòØç_MWŠäßäãÅ+ð±¾£ö'³Sææ{ÛÇ{äýÊ‹¥®¢ó‚Ô…çùÙç[_]Ï~عø?çÑ~³gü >YÞ´|DøöAþ_4ªWýçU¸ïœ9}\ãûæ‹àëøSõ¦üθ>-÷¦õ8ÍS%OXûhÓ°ÇÍÓ!ÍÏaOØ!y(¿Ï¥‡l´ß®[/´/8ywõ†Îcùjù‡Øë ×y.ëè\´.ö·u¹£ú5qLë¤óÿ}N<}þ¯áY;'*ÏWûƒ§ïG”o“”Ï /²à-ËÖÜn¿Ë†9Tñ+¾·<Œ>¿‘®ç†ëðF­›`dzÞðO÷×|#ëœøß¿'/?™·ÍoÀÏ®=uþü<;Ñ>áœñâH­ükç7¨Ÿ/ïËðSÕÓʹƒC·ÖÑŒÎ?|áïÙÑÎs ïÐ|Zü.\ÚúÁð~Þßó­'‰ÝoþÞ¼Øð…âtëÈïºßò‚­;4Ï0q¥<©øžÝ÷µ¾‚Î`¾·z)¹—íÇ’¯vñtòºêS71®Û°/âxOÞç¿Y|êWozLó±øbö yÔð®Í“Ò1qÿáf|?Ï^5ÿ<ŸÚw‰7€/ð¬øÉö“„?€Sð©îUîmû5Ä—Î…ubwì>ùèüß7¸´zHáÓb—&ó}î‹¶™û«~¼Ë»ïøDõÒ‹«>!v…]cwZ¿MojН'óO|Êž{ùÍ}_çGþKÝŒ|ûAÚfýeÛys~Øû˧´ezþ'ónÿëvÛl¿Jq õ–וWæw[@g-ñŸxžbgÕkôÄGà-㯭«ýlÝBú5ÇsæËŸ$®ésÑ« €›·q~â«/»Òþ¦àö s§Ÿ7ô ¦^ˆýaÿ/ÚÏð3í_É÷ôþ$ÿS~4÷¨ýÇîmî)üæÿ‹‡²®ü‚>Áêטãœçô\åAðãÁYö=¼ìdÞ^?¼èQÏê W÷Ûmû×yàáñà…öñªUÏ¿W}Dö>üBç%éãÆç5/ ÿlŠGÚ7->¯^Vx.çèsÉ£fÚ{è>Ú‡ö{êë ?¿áC|oõBcoÃcLæ¼òøCóÆ÷3ù¥â¾|níA쟾…1o¤îª:0ùÿòRt(rðí§‰ò½ø!õÎs~~2ï¦Í_úà7?ÔùÇV'žŽ€_{ÿ㟫‹¥ßP½¾>蜃¬ÃdÎÙ_YñKþuÀ¿t¶ÏÃúÈ+z/ûØúWsàÃÔeVÜœmùŒÄõ‡â·ð«­4‡˜ÿ4<çĽfÄOž¯zôFéÅæ\û¹úÏøÖùäž{ŸÆ…É3à»x¸Ü÷òΓ¸ ¿ßyÊñC콆ַæs¬Sõ…Ågñ3ð‹úFuð”}‚w=7Þ„ýVÿ1÷Ï9bÍÅ+6‹W‡±?ìsçˆÇî¶?Î\ë¬sýqü‚¼TçÎ3\ª þ$qàWâ“{_c7¬#¼ÛþøØ]þ U?œ×¹ïp!½ñNÎwóÙ9Oí§t?¦v¼÷~ ƒ7áØQvn¬s¿µþ;çI\$l¿rð=|P¿;`Ý}õVÒGfàH:â³ò™‰Sk·Ü»Ø³öLJ_L\U?ƒ†›Æç‚½/ŽQ7žõjÝFì3á=Ü?¼$\„×*øÀù.¿›}¦à9ª·‘ó!uÛ?û¥¾R|îþ6¤g„Óš'_ÛçÄGc¾¢ù}¼½zcyÓÄiî«øM%œÒx3ñì¢Í'ÛxÝ݃NëÔoLæüa¯ûl•‡|›çJü*ns?Ù%ö¼zbtƒƒ·zóì`ù†Øµô{Mæ/ºõƒŸúâ*ƒ~¾ ëQ݆ð}Îø ýtÎQðEëãôQ” ïšý­>$=ÈØ-¼XíÝH¸?¸mÜ_±ü ÿÿø=ö©|—¾­Ñùh\/J\;àÜã—ÄaîËúÆþZ·Î­6ß}¤#â=Z§¨¯múÞ“ûló°}^tò_jÇÄÁåõôeǾ°SÎ[÷!Ï^c2gË37zö: ‡ºl|vì²÷àkÕC%÷[OýÑpÿ:ÖÀ°Gö§<]yÁø±ÚµðÁåÿÂè{r¿øç¼sÌÝŽèzf¼‡ýP7UÄçÄ”çÈûÎZøƒîßôLÆuíÎEu†ƒ?}ÿÅŸ«ó‚ÙÑöA©Ûc‡é\¤¾­õ%ú¡Ü÷ÜïÖÕßߟ=‰?+~ò½Î{ã:y€ø9ë´ß0~K>ÀùÖOÒ~ ùþø yÁöMÆ~ªK£«Sœû1ŽÙ+v·x&~MžûÈÏÉ?Yw~Y¢uñ¯Í;™ë~hÎ?¾ýÅøvã1öµ}=£~¡ò5¾‡>QÖ©<_Â{eý'ó®þÉŸ¾÷.=ßâžâ­à˜ê$«KÆN°·ê­øÅö?ãÙãùg¸¢ý;îYì xª¼Ìwûû›/xJ×›].¿”óæ«?‰_j<…WO<]·®;]$}4£ûÊ®Ðßõ½ÖÁ>øùò,ñ+ì*ÿT/÷¢zOy/q'~¬÷&ïßþ×ôÉV‡Q>N~Ê?åž”G‘— ® ƒXÞ1÷§ùíœsëXÿÜÏÞãä+ñüyý.>0¸¯u¨y®â=ù„ØÝðC“÷{ðQ“5W*Þë{ëãÊ:µ>„ãèô˯´î q|yúÁòÞÉs5Ÿeî{¨>Æ÷©Gèܼêcô#µ.*|>¼ë™óÄOøýêi‰ó~õ—#{í^·9ëmÞ=^MþBÜn}ýÙ8HœJi¤¿Vž(ïÓ>¤‘Ž {ë´‚ÎPp¹sQ\ïéǧ«¾¹ºSôO³ïôÄÛç|Ä߈ïÜ#ÏŸõn¿¿º ¸ ~•—‡çÊß?Áúe«+…—‡·ÕõæóêÍ{£ƒ>ºþ:ëX^Þ¥3Q¾5ç^¯n³¹%ê{Rgg}#8^eŸñÇõ;á{·©{?+?Ëne]ìOïwö¯šç›ÌÝdŸg\yÒN­Û`o¬ ;í¨ó糿íË~ê|íYØ ¼Š}á÷ést¾¥àPÏÝ>Ox[?vx÷˜¿)NþÈ},ß™þóžþ;q(»IÏ£<^Î3¾I½£zû’¸¡¼†ó—å#›G燪£<Ø:Ç‘½ qÿG?`îy·îûý£ëýokâCç½÷X<'®žÖ¹ýAòyôêG:úvÚŸ6µs̓óÕYįóøééûö÷äàçJ¼Ú:ŽàµòN9—êdô‹µï7xÑùñûÅ£ø(:3xMu"¹gðPuÔ]©ù¿Ú¿ìkë˜Òæ×_¸y>¼žóß8$y¦òIúþ’—àÎòöË7x‚¬ï¸îVýùøÉâ„ð¥x#sÃÝ~P¿kû•bgðÞøÅö•Œì?ÐþƒðÎìFãÿàdñtõÔ×ÊÇ«G‰¿õýìŠçl¼7õÇîÓP·G ÷‹¯ŽfÞÓ½f÷åÝç¾úG;}lë«kG<¿sݾ'ü*\Ÿ{ÚužÞÃê$7¯ä\ЧðžÖ­y>÷J$Ï 7ë÷oT—$ŸÇ_µ¯-ø»|¥¼¯z²ÄŸÍÄîÀ_êá~z†svÞøQÏXiçáÅ?Ò o_Ľõt&ó.ø÷ð–Eõ+òcÅ]¹§ò¹íãŽáÄ3ퟌ½·~=—ù¹Æâuxp{ÖÍ9¨Þ‚8Y^$ûG_?o}kîkãúmô[FúÂÍ?Êçϱ>Në?¦ç¢~T^±q·:ªð)ì;èùá~ö³úÒâÇô™xØÚ_ûÀNè»+¿0µSƒCÎó,ΧùSÿ?™»ÿ_ñø'Þþ½ò̉—ª;œkÙe÷QÞŒ=hFüzëëϛùì¶+n¼uß3¸¡ö!¸µú,Îoõ¼‚ù=ÏÉ©/ãŸÛW@ÿ”ýn+Ï–}§£?žc=ûÆWêÚƒ«ó‰·Éóâm[Ï!~Ów«uXtúcàÆäE'óvÝé×?øŠA)ŸOß²uÓóP&Î?Ôºv¹º<Ñ{rÞØù:ûÎnµôÞuEƒ}¦ï(Ÿœø,ï]<êÜU—,úýüqû„GýáÍŸæó¾õîüà c‡}ý·Ï¿ìÓC_{¥oÞ:ª+ã—Æ<“¿wÆõ´î+ÿ¢*v¡|VõêŻꀿ«kÿúüôíLæOöyÄ'¿ºùÒ®Kô‰Šgé;ç|8Çð–óV½ÓÄIüÌ=“o²Ö—wêÉÕNq[ñ˜¸S}…u†ÆújÎ럧~p2oå_œxé§^2èÀ'9Õ!Ë9ëüK:dñ#p\ë%òþãz¢q\͹f‹µ—-}R틾wýS"îGÏ>8¯êM;RÝeð6Ø÷Ë}LJ«¿³Žü ¿&!á‡jO§ç ~q\ïP{–x5v«øÏz‰‡;/aj†ú:æ©#—šgÆ3âs¯ª££?<çËûZqeù6uâMz¥òó‰ßšÿÕ·•¿ ®Ïú ó5Ø=8-ù¿öd¿é!Ë ´nkĻқè}§òòhy®Üóú÷µú™pSâ4zFÎIâÒɧzý][Îêîð¼êõYe?ÛD­ùÑØ+þ›½2¿dî|õä 7_®¨,ï»§NÀçÙç/àgðCö‡Ž¦:nv¥Ê/‰Oïí÷ïŠ+Ä-ö!ó &óWÛêÜͶý@ï3{äÜñüMógù^ñRu!ôsàÏGú(þ^¿ˆÏoý}öÇ÷—ÏIÞ^Vߨ|jÎKëÍÒûÒúíæ“åÙèå«TïfþfþìZó8ÕƒÁ3ÁìKuÀÔ±Å^ë ZÿØz]寧;}<ååå5ð0Ámp€xW~Á=µÎÕ-IÜ!?Ûyàx/óÝÌ›ŒÛŸVwNï¯{Þ¾QùeyÍ|Nú˃ñÃìSâÄê•7咽yš÷¨Ž\õó=úsǶ_ÉÏÏ5Ž Ï ¬uà9/ö¥|@ÎWïƒzLõEøGüÍÎ%ž¯ÿm^O=ÅÙtS[gмªú yzkò¤£~ù9ýÆåÌšÆOÕi­n¾ùùùÖ§â­â?Gs;«¿Ü:ÐØsûÔ¾ª)~ª.¤ó7êGžÌ9ä’mŸ¿Ë³†û¦_<üó‚¯|ã°Ï>a~×ÃóWG1ç”=d[&=gùóÖUÈ»äsä5÷>ló?~âäºí¹ÿÕ¯Ï=*>Èó;—}ÎØ |ã˜/ÄÁÕçÅŸOíRñ|cës‚Süé\ã ùCç¬ý²±'½ç©3Xð˜¯}qÃ]ï©ßjÜ%®Êýk?gÎy˜ð]Þ/¸q2ÿÒó÷Yã›?ôúÕñçðÅñæˆCôá9³Žò`ü»sWž18Û¾Ö¿Ós_¢¯¼|†¾úØmx¥õáGàz¸¼|§¹HâËÄwååsð@òqæ„o‡?kS÷Ü:…Ø)xÛ>[·Î¿Í-(n›þÙ8Õ÷´¿.ç·ù } Y_|zó«é{oª3áWÊ뫳O¿Â‚µöØñYgÝ0ðfñí7ñðòåxYçyþ=[ÜtÓwŸX;Q½ÕøþÊ=é<¯ÜÃò>pŸú>u¶áWÂ;wbër^rNkGù‡ê äó©Ç+±3©7Î÷ñ!ÞØ¹W?”çì<˜àÏ×ùFòÇ©sÂïáµçýôßþ°Â[ ¼|êÜÃÎåÊçÖnÐOŸž›ú…òÊá¡ð¤â©Æ»úÍrZuï:ö>‡õäÄñí'•ÏÔÇ-Î1ß&öDÞˆ¿¥¯¢ŸeÖ|Z¼#\ wÃæÙ¤.¤úع—íOT_Ÿïéý§ƒ¿Ù¾pù»Q¾sRuõJìØhþkóÀÁ+Õ…N|ŸT?(xQ\u'+ýòè#8ø¦u_ñÇìRëks¯áè⎑ÝkzåÃf¾5Եʯ:á›ðdå7²Þìâ»ÿ¯mûçÇ4Ž_w—9xzè9õc9ßú1šGËþ‹cù[~³:Ûô…ÌÓ‚¿ðÓá!ª£ý­Ž‚çÌsÏêoG±‹yþöï¨Ä—ú<ù,õwp53:ÓÅAù¾æWè ÈÓëÿN¾ yòéyk,^´u$±ê0ŵ>¯u3êqR÷Ü~¾éþ7.iŸmðzù<ùËì}›òâØwø®ú#êr³îÌßµ>)¸‹_7w®Í½ëS˶^oTÐyȉ£Ë£ûÊÕE⟜ýêï3Ï­qÒÔt®dóc‰+«›”8»ö9÷°õ±çÅót¸S×%š¿Öw¾´ìŸq?ÒÏ—w6ç ç¢uɳv®cøËÞ~6þ‚_sÞwÐoU¿§^2ç±ó‚GZ/œsÑ~§Øgq ?Ã×/¦îI¸u„úsy®æáä×Õ=Ý;Îò’ÉÿŒçc•çÃàëâÿÙå¬Sãaçɹ6×F?"?¡?¢}(êËÔ٫׎½TÇ×þDù”ä­:§)û[}õFôPä]œ÷ØõGã>N¸³ºBúr^fá߬oçSèk…GÕ[ŒuðLôérò‡ááŠßô~/ñFíã˜Ïܾ?gεùÛ9Oλx€.¶þg~¿y¤Ôýác锵@f>oøôyÇlòëŸð×A‡Ã3óÓGz4ÍC;w©?êÜíœW~¾·µÎ^ÿœüQì%ý¾Ö9ɯљ͹ªÝˆ½í9€£ò{Å=êNr?£ÎeWÇ!^¡‡?Q~ƒÝÒ:ÊÚ/ëV^)x¢ç,ù!öI¼[ݶ).,ÿT{Øþàܛ꾉Ù3ý6úð~x‘i~c2÷g{½ýñ“ÆøRý¾ ä—SÙzq‚|VûÑFóDZûÊŸ³ßË¿³ý¦«ÝysíQ÷'õPå2‡Ã<°1îÅÁí˃_:—ž‹ÝsžçôÊ•_ÿÝ¥C}FüaîCùX¸9õ.³êOٛι3Œ?ŸÚÉúüŒçª=IßRÎ);^ÿî²k­/’ÏÍ<ܱ^ª¸Ä9¯]0oI}—þhõ·Éã«7œ÷ñ5ÞwÙ__0Yøçÿ¾ê™Gl[üÎN:üfý£¸.øÅœ)ïï>³í“TWIÿBÿ»¾Lóh§ç¦õÂõ7Ö'¸Qý1üR]t|cxøys.~ò1ïùdëoð©ümûXãÿ:ÿÒœßð,=§êXÝWöl4w)÷¥u ÍÛšû¥ï&÷ª¼yþ>þ¬üœseŽUuÖ§ñdûañFûô{ª×åô9äç}®ø’â?«|è^V'ajG‹;šoË=¯ÅhN%<[½½‘Þ´8©õÞù¾Ö5Ä´Þ.uRðJç²Ð9L¼Ô:~<÷ôþ´~§ç5çZüѼaê Ô/ŽëŸsnºc]ÍÎO7ß?êSf­OëLbZ‡²qEê‡à]þV½èxNSâßæ›ù—Å[}ã1?ºéúƒ“…ûmöŒ+÷Ûg²à7÷9îŽ'ÿi²`ñqÛ,{àèGMæOíÅdÁÞ;ñ°•Ö¯Ý[xé3|嘻&ówûðëîøß•é£Éƒ³Ã“çýèñ+<û!“…÷¼ï·—Þô×ÉÂ¥‹¯Úꃟ,¸c ž±Þ'Í}œ,¹{ÎÁ÷Ù®ÊdÁd§¿8hÎdþm—Þ²Æy ðù}Þù/üÔ‚÷¬°ÑdÁV›ûéûþïdþæm~ÓÑ“áïó>}¿ÞïÜ5ŸóÉ‚]´þ7~ñ»ÉŸ·ý†wýóß·~ïy;¿îUtÁ&‹®~Ðé§_øÌÉÂwîxå·>üJ÷ÿ1è8MÏßdéýžpÌãßwˆ¾øÉ¯ìò¥ëîwÜdþÕŸyáßûlqš}ÅçN]úá«^rÇ' ?þª_ýzã[Ô)Næþaû[®¸ó“G>íCk^´“|¾y²Ý¿Ì‡†'‹ö?p³U?¶ƒ<ÑdÑÇøÈ‰—8?óÏ[é²—}"®÷œ?p¼ï‚õ¿¼è£÷ÿé°þ#{kŸÂçN\uçÓç.zj×oñ! öZó?š,Úé«~å}_\»[?÷¢½h߯>±º.ÁÓ“Å;žøÄ+_uMýBüMëPƒ3jß~ëûÏÚj½É¢­Þøº'ýþ¹Ã9º}ëÿRõ‰»NüjýQü¢û·`³Ã.Úýô_ô½íGÏù´~²hfïÞø»…µ+îõ_xú«_{éÊß¿ŸÇ7Õ²Óê"Â'Ìßï¿_wÀö÷ÞÁóÞ½åÊ÷ùÐý'KžôÍ»^ºÝ¤ö.ëSýSç'ufêì¼³ò¿;ý-_·öžó‡Þ›]H½`í¿só§óo~ü—<`ÀSö¥8Æ}Ûgí·¼aË]¬q'ÿìüxn÷ }æÅ]‹WÙs‡E_:®Ïí9§ö…]/¾Küºè·OÛàK¿¹­~½užç½èÌ žñ…£º¾©©½²_ü‡ýdg—§X°î·ï:ó´ç øc¿÷¹ÙG~®°}.8'Ï_¿”uª_ÉùŽïÕ.¾ß&O~ÂE“ù_¾åÕ§Î=l²x·¥oØnÉí=Á%]?÷(õ|zôiïØd‹ï×-zôÁ/9hæå/bOÌ,<ÿ{[ºìµÅ¥ß^iŸUîXe879Çò[É ô~¸·ðjqsö×ó²ßplòH“¥Û¬pðQ¯ú8{,ލ]÷yü\蜤¹~ˆ_IüT<{Uå®ë§µÿ5uõp©s¸d­M¾~ÎKŽ©Žnò̵Cž=õÿžsñžO{äV§îÞ{l}à4ï 7Áãì=»ÀÏf~ðdá ÷xäŠOÙ®öiÑ»68ó¯óÿŒÇp.<]\œßïþ±3ñk©Wî¿çs7Y¼öz·½¨øzÉoW|Çû÷¹»ûè¾x~v3¼ZÏ{Ö}篳¾]‡iž.îk>né}…¿¦þ°õpSñü;½ŸøÔÚ³ðÛ=Îsì Þ¡ë¼è~‡¾þœ¯^}18À¾ˆ÷ØEþaÑWNû¯ùQ»È_âû“_UçÛsæžõ<Æ®øÓýŽ}¨.@×/~µø!çOÜÅo.:áìÇëîõ†¸+8Þûð=ç±_‹—¼éß›·UíJxãÚ©âªà3þ£ñæ”(þuoØ!Ïï<´ܺù\8Ñ~ØOõ™K<à…øþß=wÎùKûá¾°Ó‰Ëzþê7¤ÞiÀ±³ñ·êëÿs¾;?Üûà9–®yìA/}ó³O‰–LóƒµÓY7ùÖÚ‹ù¿yüåûnòÈž?¸;ùE¼Vq¹xŽdÍw„Êg³îK3ç/Ã7À[옸Kœ\¿òÃõÎ^õ´=¬°¸¶ñjì= ×–g§‡‡×ž,:x×Oœñ /6é÷Ný6³ýâÅsâÌà±Ú!8/ü?kÛ§”óí½ÙùòP‰Ïœ¯Æép‚xÏ÷ŮԎÿùyq²s»5ܳÜãÅsÖzØw2)ï0÷sO>÷ùýCý¼\|ž{,Ç ‹÷yÍI?ùðKÛ§H/ß!OíÞŠ«ÝôùS^õ¥/À·ðþeÁ߸ôÖËvŸ,úÐyâEëÆäw[‡dߣOÑyo‰»õ“´^#öb¬ÃÝó›<`ó¿ú&õêÉ~©ko[}kúeäQûýúES§ÒzeºKò·yNŸo½:'zzŽ[Ç‘<êPW;š_鼸×Ö[^_r\÷މ^^ûìõ/ŒôG««×úÔôÿvΡßÓG©Á>&þPgSéQkëzÕo¥^Q»úOó/“nÜÄž¦n£ºyí£®ר?ÐwÕþ’Ô¥®¨~®û8ê¨ÎÜô¼ ë•>Ìö«§Ûz9Ÿ½ê b?:g0õ„­7é[t.Qp†{£ÎQ]ŒºÁÖƒ&Á—«ãiižO½<ÿ¯>±u«¾7õ·ê;g@{ìkñCΑ{í~üùŸÛã´|»õ.úóÙmº­/ËþŽæ´¶.´ºF©ãj=Uêj»ô>R¯^}!u‚©¯¨¾nöµŸ§>`žOÝ^û é;é“1/mêZ·ÚúäÜCþ¥:ô©3ÔÄ>U×U¿)‚{ëSÖï¶ž+ýfõ±Õ K¿­:ËÖG¥^‚_ wT½˜ÔEt~=—ÔÑWB}XüGû‹è9ª§“­Ž&õËê5à¶Ö½Æ_ªw–¿ÇÿŸǦ~¦z[Y¯öã¨o7/„ÞOìœuW§?é§w nhÿýpó‡è•d¾Fï©ù p]úé[n]*ˆœËÚyóbgÛ?¬¿18»uçÁí«N½xuóž£ùiƒ.”ºÇÄ!úb«›º¨Ö¹ñÛt÷ÍÍÕ'Æ.¹—êã÷ª»œÑú*}Öô»Óïå=äI†¸"}̳pdâM÷´Ÿ›þ¬êÓEN¼ªÞ"sÓ»ÏüHûdóﵟ©¿ƒÓøƒÖCÓW4ïÀü§èG©_T¯ÏþµÎž+ÝuUüüJê›;Ÿ^v?«¼X¢Ñ¼#ëÄNíƒ>çƒDÏŽß,nõ²ÿïßé_¾Rç©þu<_ɺ:·ÕoƒÓ­Ó¸.V·9fô=²ÕŸƒ?ô¹Ï»ÕWÍg®^™yÁÝ×ÏùÙæ;ýt»ÆãÒWíüv.©y5tÕMÓåU—»¥¾²øÝ!uþY~¡ûÁ^Ðw˾¨/ì|,ý@ñ¿ôå:§:ÿŽwhß—{œÕ:\ý±ÓýôkÔß»Þwö<,óÿè\¤>VݨþbuóY‡þ;\Àß´W<›úDëV<¥Ox4Ç žm_Žzp8…žx'ç×þµ%çöêå=íQ3gqUpy×m4ÇÍïé‡ôóÕgÔA9}e³ú’ƒw¯›³Û÷|×=³ú«¦ÿ€J}yë˜á˜ôo×Þ™Ó*ÎÎó«cõ~åâïõqÀ‹ìTë†Gv¾ý‰'å/øgsÅ}îCç]G/‘}i«þ¹èú™cíœëaÇ/Ð;Š]èÜTz5ôQÌñ2·‚SÎOíä¨/¹z¹Ñé½j]*ûÕù›ÓºÜ¡;ç»s&ÏVE?dÎGûŸî݇3k^hçƶ/5÷×ûõ;—0x»}Wúdéq›;LÙù6o:}¹cý!x©ú©ñKíS¡kN7ßÜŠØo¸ÞówÎ8xö>ÄOÄŽ·ÿ>vÂçâ›Fx·xM±xY¿†çñóxºúÇôË5~PçOלLñVÎóX«úÙÇÚ¿ðRçô1Ñ× .dªc7êOí¼ˆà”ô½—×קί6îw±ãÓ¾¡òŒÅÑ/ÀoÖ¯ê™>OãjñŽu§Ð“L~˜;DÏiŒ§ëgG<5{W»çùós_óŽŸý’AÞÓïÞÅsø}—åýøË¼Ÿz }9Õߌ^fuˆïÍ“W÷-ß™8¸}]™ßÜyºæñ3ú ðrôö÷ñ$¹Oüvë¼âת;ïüú³y÷éºú‘Óø¶yv?ñEõõ‡ÎÍLüaÄh®ÑЇ›ø½:R©·Ž>bùºâ´ü¼¼‰øÔ}ÏéÞèþ—7I]¾ça¿ÄÕûE÷Ê÷·>®¿ûë}š¿¢ß™ûc®tç‰ÄoF×iØ¿ôõunž2?Ïß±SÖ“>TçtÄå9š—‰=ò©òÇYW燽î\²).ð{åƒðw}Α^cûƒÓOΟ⪟¿×¾Éà,ñOçˆÂóæ;OucÚ×GOE^±ú³øRëû\|E';öŠ}¨niøëòtKcý{ß?x4ë<ˆûÅãúÍ;Îü>¸Lž£÷ŒNEx1z÷êÞ:׎ž-¿žs=žƒÝ>róÜèÇ%¾È¹îsU¯38Èùmü¨Ô}õ÷üòÿô>äu§þ_ÝS×­z؉øë«úênžùå,÷ê*àóÝïÜWþ²üaì{×¹GôÛ¦öw¨k oG‡®}Ëù|õâÍöIçüâ·/´N[>‘_©YêMF:ÅÅÍ¿Å~T'&ñˆ{Òº„ø;þ í|:÷ž“ý‘Wª~¬ûÙx^>€n|ò˜ÍÃÁ)âyùè_×.E‡/Y?"Ý”‘^È cš8 þP9º;½êG«¶Î/õøïaÿÄÞ׸ÅçÉïºÅ¹÷âç´ûš}Æg6 ¯fýŠ{óyúœkï=Ÿ£öVþ—h2yêÎÑ›òÒ]Gõˆì'ž)öZÝzñuuã_ qŒþèlò‰ôyZáe¿ø y}õ©ã­?ƒkZÿ?‹·(ʆ‡kýGê¶û¼‰‡õU4þIýuóåtGsnäýÅ]ê¶Zg•xµ:Èô)Íá ßÑy\âèØCæ}êÿ+ñ@í»¹Š‰z¯Ô½âñö9©‹2×;ø¢uêòÍß[—dÐGˆ>ó^]²Ø¯æc'bwk‡z.£oN§²vyúÕ¡Â'ÁsÖ£qËó-µgsO§/°q„úüRëÛðÁ'ö·uy#ýqø¤:‡ù¼ÖÕæ·ë¦Z߇†qÅ Þ¿ú²ÙWq„sP½·ÔÛÀ©ãæ%_cÆzx­…?r?àœæ]ã_­SóW±Oîcý2<žx¤yÛ‘þ6ÿâ{믳õ#ÉËu~Ip^úTjçÊÓ¨oÆÇ¨ŸJ¾.©ž5]qyxÔúư­‡ W;ÔzÀø­ÖÅåÜtÞmž§¼Lâõ\=·îAüaçѤßR¾þÆö$~îœbqfμ¸ó GøàaÞ~s2ñêâns2sùƒ±î­ó×ú=þ(õäö]}PãmxÚ| õ¹G3ü¼BW‹“ol4eN1{Ýç>öï;¦.R;ÛÿÏwýjñ‡V·žÀ‡x®~®9©©ž?Æø;:[ÍŸ«‹pÞc¿¯ýÐjïùÉÝ{V‡”þÛ5»|⽿YmˆoZoCï<ûT¯¯¼b¾«õ2¯Ïºt^NòIWì~ê÷ßè’a.ž<"=ãøñ«ßpø.»ºåPOû 7úÞÌotåÔË¿ë3©S1ª÷èœqyùØ3|µ9I­ÉþÚW¸²yÜèJ¶>Ö§ü=5žãX=]syŸ_û°<ໞۺËöàÏu.@>—ŸRÖ:¢ðêDü½ûßyÓ9g­oÏ{Ìšdþµ¹,yŸëÖþÌA{/ýrí@û¬ÔâõØýØGñ?*®W?Õy—y_ç¡s0rÕCšocžHçÐÍçÈ¿ã…/ÇŽ´î4Ê3ôüªçšÖ7öœ·ÞÓüæüþ8?Õ¾¢àz÷Õ±6×-x²õ>Y'uEÕíÌýqÿ/ýû¥ÿèj¿âŒØ5sÊáqûÙú¨è¶G¿©þÔ{±_ôg£#QûÌÿ8/ìÿ—wõ}ì£yåc=m÷™Þ±÷îÜN:¬æð%^rn{^óþ#¼fÎØ0ï#u êVù‹Ö[¨›RÏ•ûEoX\).SOW¼^¿shÌi}l=ÛH÷¶~—z¾·u!æeÝ:¯„?±æDd¯ßz÷Ç<úyës¸¯=7£9”æ²É Ùægý^îeç0À¿xƒÄiÕ{4Ï6ñ ÿÃâ¹ñyíÇ‘Ìú9×Îyû{Ì]Ô’ø¨ö4ûÚ9fɲgî¾ËŸÖ‹NmçÁÄŽ¶ÒÜúìŸ÷ªÎµºÐØeq¯sÞù]É—²ópþn_@âë{Ýeœ¸ç»ÞÒúŠÎý¾wÏ·®ž/ûÝ8T,qrózá÷Ù5ëÙúŽÜWõÏp"?e~]çñ¹çô““ÂWÀî7;Þ>Pú®±§Åæ{¦®õæU^|ß+þ±áàwGõvõCÙ‡ö…w¿È»Í¨ë“SŸkŽ]žN':?7î>³í¾Ÿ_£÷Z½iûQð‰cjGs^Šø“ÜöÌzv~°y³±CÖ¾ß 8¢ýУçjý|ó*®®}¢ûŸsT]jú³ÉÕnègL¿£|ûÐú´ÄcÞ—_qÏk×ñ‰9/Ÿb×ísß;ó|ÅÁ/XýÆöÛt–~7ÿ&žì¼¯Q½ü[ÿ•}pÏ<—ûàñ‰ÿ÷óp•}¸vf•µ¿pÍYC¿{0ŠoZ¡îuó~p}y…œ;öBl. »ÛùA9çʼnWÇõ¤Î)¼4ž£ gWÁãyu±üAç e?;Î\ØÄw›—{ĴΓ>yÞÃüWö®u¼úÇÕâŸs^:ŸBœ»VœûÐ9Ótóó=Ó©î |ŒûϵJhÖ¡xÒ\LþBžV}J~ïꇾvýUwzö0§3ûî{Û·aKpZuùƒÇŠÿ¿É¿¶qäëwÇýZtØéü‹gëi¿ª«žïs;—Æ|ó)².#Ÿó‡ŸeøóÖçïÙÿñ<¢â6~+Rw»‹O°oø„êÛ›+œç¯õ\ÆþŽý/?ÈßuZx è™ÖŸu†yWÁϵìAì\çôŠûùéÑœ*~Õ½,ŸýSWÐû<½p—‹¾ºl¿A\__Îiuãᥬ«÷9þíûïù–•nê=µ/òüž—}uêOô ä|šë6ë<š‹;"®Ä“z¿êòÇàÅOûî^ÝøÍožqø/7ø™àÇúáÑ\­ò6λº•ÔUçÚ»{a®möó†ýNÙäMÏyDߟê|q^þ„Ÿÿré#n8éþ; s“Ù“9Îã}¿³O£9¶ž«ý#ü¯9÷ÁÅW¬µéþ{_xî0OPcîMò¤½ßö‘?ùÓ›Þ~ñ/YÜúÉÚ™Ñ<ûòœ‰';OV½0{£žËóšï–}§ì}Ê¿ßtÁ6'>ñß7ï¾È·±øßãÞÔÎãEƒ Õñðqy±àCÏoÂý7Îýα׬þÝâ‡q¿xçÍ{?ñZîïX'dÌõ6ç scé'À xJú"x+ó±ÌK€GÍGuÎé|à?ôAÂ_É7”gUož~ ø®s]rnàMïÉn7îÍútKΉßwßëo‚7ðòwiÞPüjãÂ|®ÏSßqÝ7Ÿu亟Þiè— î¹i¤G€ÿnߦz0qþ÷à½úÁìgó-ú‡ê“.î5‘]ŽÝr/ÿô­¿]µï//ê¡Í Ç¥ŽÞû[gúQîÛ•ÿ¾æWw¹úûüóäÁ¯¿t­_}n³÷w®Dûƒérä\”‘߯ ¦?¨s7ÄËñÇÖA>®<‡{>¶}ÄòS¾ßœºð>ÍǪÓQŸÏ­nQü6þ”Ÿ-^Õ×§ß1y¹ÆÓæ©ä9ðµâÿžûÂW}n]zží3¿Æîˆ—Ü«ö©—H¼¸)ö¤þÈù¿Wá¡éÄ´~'uÖÛCWÇÜÂÔ/‰gÚ“>Æè% óIRŸaÝý9ÊÛW7–î·ü³~}8ò–tª³—‡kÂ7 z­™Gìž”¸wŒz¢Ö¨“tîéÏ©»kÝaΜ­[>7úç_jŸåƒÂ˪óÔ7cÿ›ŸÊ=Îý-Á7é£_´Âü™è¸¶Ÿ7ÏóÓy§Œ×0#:|‡f ¼sôªË&oïþûêË7Ë3»÷ÕÓIýLuK—Ûùj|˜{¨^D?y8ô?Õ½”ç4¯ŽÆ[ÄOä¼´n©óeƒã[Ç*©(qNóOôŸò¼í«£½¬þýq]îyãõgòž‰ÍÕbwŠÕi™ –s¤Þ3zŠÍÏ·¯^.P×ÊÎÁ1=ÿtF<_ûøÍ¡R—¤Þ/œ©®Œ—à¯ËOÀ9gê/«+3µ«­¯÷^ã9Ýcý–ömg=àtø€ßãäο£÷Aÿ-~J|®µ>ÀœÔسÆåø}qG~Îi¦:@z•â¬ueÒgÒ¾3ö,ÿßúŸi}È o?Yý¯i½gÿò׿ÿÌõ›;œÓ¬«ü¤Ï©ÎDtÁØÕÎÝËû²{p˜s"Ž·çµµï(v¬¼|ú½£=Ì_§+©ŸmÔwÐ: z(±ß;ÃˉÛ/Á1©+ þ©és†¯Ç/Ê_Ñ¥nŸÎ½qPçÁ¶Ÿ,ë 'V_nÇó§Ï±:%úÓôÙÓqžôyGà·¼7_<§ÿºõêxÒé¦ûg~­ùsÓúðÖá^þ‘§n½ÕòwuÌúÚôçûÔ7ɺ;Ý×Q)œ¤ÿHÝmõù~ýòEÎAùQý©øusCéò¨§ .¨¢úëèK8oõOÁÏÎCõrŽÄ5Å©±­ÛÔ|\=(uöêE²¾òÌŸç;?í‰=mß~ê2éýªK¿ê¹o<éÆã~?äyøGúTúlÔéåâË®?æÎï.8lNõ á‚ö)äOzÇ~¯ºéwlž$ë®O¡}»é·ÆOTç~r^Òç=ïW‹nœœ9ô$«×#‘§Êý]þ†×<õü}}¨‡Í:ð?ì<‰wô÷£yŽƒ^@|?^€ŠšôýÔ«ÏïíO÷4~u¸ÿð œNŒû~ïþóâR8P{ä¹Ã}ŽêèéÙ¿|_õ ùAý3ô^鿦^ÿÜ:'ŸOÁ­âzʱÕQTOœ>õèâyÆÄ5Á¯ƒÎ¹ºhóa彨+ð üVuŒb¿<'¿ÞºËøïê?ÇX'x Nl?þé~ ým9êUÛï•s-¿Ý|!ÝÎÄÝ—½þ¬í?ïŠ!¾Mþ§º¥™Ç”¹lƒŽ^ìNuÞƒcÕ¹¶Ÿ7þ+üfÏwçÂ4¯N-÷—}î~LïMu)Úo'Ó;ÄßÐÿé#ÑùåÏÚç­†^GüPuòñÛÕ9 ß×~¢è!†Wðµ¼*|¯%ñ|û"è7$ïHÿ0ó¾Ð<sôÉU?É{ÁÅü}椳£íµxÀ¼Vv’ÿˆ¿¯}¿ù¯øÌ?{[ígÎqíMõÏRŸïþ;ÿÕˆÿÃgÀ‰ã~~Îú5ÿ­ÞY~9öè¼oº€ü`ðNû–ÃÏ4¤.‰ŸÊ÷·3vy¬÷W^-çI¿?> NjÿVö¼Ì¿µŽ¤óäñž+çG>·}.±ãü°þËêmèÓŸÆõí‹©Ì}äçð|tþü\uæ2¿­x0:ï™{Õý¬~@pˆ{É¿4?žx‚¾‹¾ù‘}t†cßÔ½ŽëÔÚ¯>ÛyÔ¯J¢qˆ¾¹è.àU3'uà+̧ÿœø½¨ÞPìÕˆ¿lÅŠÛŠËõ—Òo­þßHš}é9ÿnߥ8….CÖ©º™Vûœ{Ç–wRW~š¬¿HÞ‚îYùº¸p#ݵœÇöÿÇÎW'%öA);Û>øèè;n}³ðÒxÌžïð*õçÁ¡tð‡îauÙå¥RêüÁoùûö‹ÚO™{LïÁãê“ÐsžFóQnú·ÿ# 4Ô]˜+!> N+¯§ïkz^÷–ïR¯ž>wúCð¿Ñ8&|wyÑè éw7gÏ”ùCFΫú~¼ö)ûßúGºê}äýbï“oâ‡ÜçŸ?èü}±³ÖA=SçYä¼ô…7l¥_ÜØþZqqâTö óh¦|\ðJù¶{¯ûÀkÒãoé¤ç¹Ø'8´u¼êÖÕ»¥ž£õáOñ(ÞoÜ7äûá<ü?\"µìîßýöâ[ê'ó}×ïúÞïxܺC}Kü/üÒú•Ô=±_êÚ7”8¡zÿáÕZÇ{?·N•¾†y8ÉWÁÃÃvþ@øæÖ5‡·áwÔ¡õûRйSɧ¤.}2ïžWþüo¶oMëÇåés¿›Ö'£¾?~L}žóç=›ÿJœ£¥ýê1ôg^ þ`ñ-^†Æ%¯Þó¢>=~⦶Xó¸•þÖúœö}§ÿÖ9j?`î“z_8I_˜{éïÕ'µï-ç¨ý#©ï§c=Ñê¢8—Õ?Œ}VïQ]»<÷µ—?ê k|yÁÐ'¾Q;óOÕ!Læýðœ]O~ìÃy ^ Q{ñ—]Wþê“—úwã>Uëÿ—ý6{þó·9©u{­—Îó8'êšÔ…÷œd?«¿§OßA÷Á9¾•/m=aî‹|Y¿7upŸóáÏÖͰ³tÄÔG©“Õ÷5å;‹¬wóá媋>îÓI½dï¡y.#ûc}ª‡ü(æóõ•xûÁ°ðnó>ÁsæÖÈÿ]÷¼—Î9õˆw sZR?1¾?ø)ëâÜVg%:LÍ?7°—ì2þ¸úx‰ëª»L×#<¶:û ź±÷ž£Õøqé¥Ç/ûØ7—O¯Þoö»v<ßç^ˆØ3qCó“Óõé¼è何}g'ÔWUŸ˺ˆÿš÷ä·ØõðàÅ©V¯#N²tâä-Úw{˶ï$vÐy°oüõ·ò—µw8xè‹i?R¾.‚ÛÊç<[?¿Ÿyäƒ^¶ûåž'¯¦.¶ýú‘ÕOê³N¾ÌÿWß-y0:·âq\­ÞÃù¬ß˜ÖÁ•gð\ì›u•ßí>Êûz®ü‚ŽPòÿó§ŽI>Ês_}ìE'¿mÉÅõSÎqí ©þ<õòì|Ð|XâÞêÂyîÖG²×ù|ûàþ±cÅÁ Þ£uÀê±ÃK·;õ¨úŒ›ÖÍŒî_ñiüeyRzåúìbÿõùóßì—óƒÿ‘¯:lƒõ—=óÑ×ç_:Å/Ùî|?ž¦º‰›ON7ž·Åÿ—×W4Ò“ñ½øžæ#îÍw_zïâÏÚ Ÿ{=^Ïöèß;ª?fø3Š;[¿?Õ9úb?®yÃÜï|è=§‡kþTxŠÆ/±¿}ùJ¾W<&U¿ØzÝøQ<_ý}>ŸnQ÷7vþp¼wëÂsoÛ/*搜ƒI^°}sÉ Û_ë^|¤/.ñvç“Å~þ¼ýy¼eÛö¯µ¬y-T*¢ Í%‘JœgI¹RÑ„JhÖ@i0VJºB%ª+I“R!%4*•!³Ì³Ì2/|ïëúlïí|:ÖÏ«û~žûõë/Yëó9ÏãØ‡mŸ¶Ýu.ù1üýk›ë]ÜxÈÀ޶së'ì=å’¦Õ~ ò<ìåb®„ùüs3²ä×ðKÞC­ú³óÕª`÷ÝwI—¾òà>Å)Ô?¼ÇZvÔ}eŠŸ8oäÇüjê‹ÀÏ„¼õœöÑûÝχýû¡Ý2î@àkÞŸ8~ ø_x.äŽø;@\e¡~äÅsMz~ð®ù¤äÿ½ÿ½¯O:/Êœ }ûìÇ’w¿‹xÝ'ð¤`»pŽ%ä™BO9ß—™s1ŽMÅo~çidŸ°'è/þ;Ž>ò<æàž¤çÎ[è¼Á{øü ùEâJÛ;ÉY°ï*Ú´¤Ì-÷Žèìý5Ö/æ¡åÿŒû…׸¨Z¯ÃN¶ÝòžLõwclŸèÿ_Rñ$ùOÛ½j©´´ãN37¿¹dDznôíÇ™s?:#¿î±ÌÝÆ%–ÌPaàä8»áMÕÿy Îiõæ©mù!Îj¾`ìé×fÄYÕç¶zí•Ã<'’UëçE-ÒãÌqµºTZØÑŸ“™ÂÉqVÿNý6öMœ9±ð›Ýg¯21û“3s¾i³øÈâìi­{vësNœÓ¦Ü?úÝO&ÎYÚxáÉïvõ÷ä·ÎÜõcö3ÞìçÒ÷¨Ÿ!Î~ëûC»|çUúzØ•·ÿ×ß›Çm†n8g¥½3ý‘Fãã¬Í&_ûÝEqf¹¦WŽ9}`r¥|;ýÎ~q{pžù8gPãæ‡5ªgN9òî•ç}ÊscãÌ!‡Í©TïÍ8ëà#“–lÙgÝuà±÷‡}çEÒ†bþ$Î-;²Þû¿¬ðsç*ÿÏóêÿ»Î™}ب–³//ç¬ù`tÛa}â¬5w¬®3ö¾8swÕÔ|>Î<ìè q¥’Ô'©gÆykså—ngW>zöÌJÓ“ßÓyûyõ¾ÙåÚ¾Õê¾ùqvÿiÿ(1llœUiô]â÷ð÷u¼°æöÇßr½0§ö=lÙ8·v‰#j½ñiœ=®g¯KWõˆ³5»`å –ƒœ¹{¯õ`ß8¯úèé³[·‡).XzÂ…d<àsËRsV¹iÝãœøŒW+žqCœÕúá¹OÞ|}œ_iêÄÚg¯‰³Ÿýðé)K†ûÿ‹O4Î*Ûc× ÇŒ÷󔨹d{…¹™Ì ÅY»ºoÓ¯NœÙÿÍÑ/V+ç4îôΑ;Šssv—í4ïË8{ÉS«¯Ø}¤Ï+g󼓦G5è3²|ðw>_unöÃÇ9¦œ¹òúuqvÔ§Ñ­ßfÅyÍ–~7 bÎÇï—ûÖæßÚçí:0õ@äØr?îÃ×¥çûÊŒ;f~>,-ÎɽíÞw3ZÅÙ»¦ìyɇqæðìÜmï÷ðý¢?YÏ^ÿÅ—·³? .ñþ;–¿©ù‰Dß»<~Ò”…Éûf]Öý¤‚sÚÆY]KW¯0yƒõ3냛>8ªüˆ8éé7=uuœ¸'siƒä 7ع¼IÇœ^³÷ä8·ôâÃOËÛ—˜rÎs=®Ùç6^Û¤ñû;ï¬éMo\Rº±íŸÝÈy®ÖI­~îF~ß¿Ÿ3"³w¥>òsf-©“Ùr‘íç’ýì3Þ:PÓv€sS½4.Ô{dÞ¹¸RÛAËl³_ÜîÒ¢UÖÃÜVþPÿ³ÎÖ7Ÿ¿ž;/·á÷Û­ŽÖ,.³àºUÖgô-7å}¿ØÏœ>WϾýò%‰ÜK¹§œJýJUh™m¹Ã®ª¯6ñ:¯Pîl§ÚäŸpý³Öž‡ÏµýNñÓY>ÙSƒ^¨o,ÎI«\qð±±ýíÐÒ‡rßxió)‰üé^2›äT©¹³aœÙåå;¿\¿–÷qŸ=uú¬‰¦×{°´ï5³ýì›Æ ;5ί=rÌùÛlg5'—ØzÆM‹ÊtJì§üGvïï¦Ü¾÷‘8ï°j“Ïxd„õÞö¹‘½“ÿŒóvÍØúLÞ Éó6½°ÛôÏí×KÌ-¹ìªYS,7%fœ¸íǽãýïÈ›ä‚{uˆå}•¼hÞÓr[¹É¿f_19Îk˜Ý¤õš«ÿÚ§ùÈ'¶ìŽsšW¾×õôÑqƒž¹âÏÜSÓ.¸æ–[m‘ô{È}åçÌ*·yI\PiÝíM/½×x5ëþ+ßzêºäsÎï?ÚêIëwNÙçÊî÷ílˆï‰§lï忳kŒÙöúÅg&¸uJæªU3¾JìŠô ¿‹ýGþó›œ^±Û›¿$¸;$ü‚â½Ð3~žºõMöÝú,ýE¬Â#yiW*ûæŸÆèïG|Á¹`wøýìS†_1,º•¸Ú~ÙöQø \W Wãõžà0p%zÞÀŸc§ôsÑÌÞ¯ô^ó/p–3é!ú®>«$.H͵8^2ƒÝDlwdŸí׉tOù¶ |öñð$øZv†x1oH•Ñëö­JâXÅÆòƒ9c¿wã†ã¿#\Æ}ãWïÕ>bÿ£g¹ÿÝï!œˆÝwpð_p¶gŠ×ésó{ËNæœÒûÌÂNHð+ç¯ûp¼¤û6¾ßÊ_åLëóòúSú[o9Oþ4>Á~è~ñ؃œËýóÊ_Kð¾ì úÂ÷JŽÃ½UqFÙ .xyB÷Ê^`ð‹œøû¥þ´wUîÞáÂß6Ùn©ÏÉ÷ ^#.CÑOäÅvy✱K»ķà8~Ÿ³]”Ýâü°ïøü’ÏWÏ‹Bxò,ÜSîýóv—/y­óÈ ¸]v‰ùtË ¸(»Õ­7Wÿþ¢Ä¯ÈÛ_Ë9.ÒÿwŠgb÷ÉÈ®8þJå¼ç{¦þÑä½úœ5æë3ø¹À›²óœ·óIø™ÕûÎOÏ>/.QªåöîûoLü qˆì úC¾ÐúÄ¿K®¬'øQÉ~þ3”}ÉÕ¾ ç1ô<¼/~>§}絓«eÚþh®Á¸{‡P|C}(Îí0ä°‹ÏÿÐxÃò«÷v<‰^+·]ç¾äìÚñèo­j:àŸÓûû}¤·ÆçäïÈO /²£¹—Mh7ôÓ󓼚ì’õIv\^ÁÞÚî ü¼1÷º÷ÏcG­_ò›Ø3ò¾Ž¯$Îs€K“ýÁÐfåz<”àgÙxŽˆóÀùØü¸óœ|Žî/¯u£;¾?{µåý1n•=FìÏÉ;KO8Ç’µüŸÖSî•?™ r\®Õ¾pçydßìûõ}û‰£’xAq›ã.Ý›ómòSà‘ÿ©ü+λÜü[ËØ~8~!nK}.óýIÞ ¥/Þ»gܯ|÷Å>MÇÛÒƒìö fn+±Æú‹ÿE_ÐsçkÈãH¾Ñ÷i¿óQœí¾žSó–cç7ÁQØ ì@jojòÜ:p§óâȇ挫$G¼'rƒ ñþÔywŃ®¯àOåü|ò«Š/ÌË þƒbvœø¿D¾Ú~Fçêü“ä?KžÿŒŸ?’å÷òŸÝuÃ?Ï*oa<ž–B>‘{Ù9Ï©9Þ“?å=ÈŸûˆ—Âzï¡|†ç¾¨€;?¢¿ªÏ€Û°Ãœ“ëѪ'¾¾r²ñyTuÙ!?¿ìøÃ~÷¹²«_y£ã!ãɯÏYqVî´{_3.¶Ÿ&.B?°Î¦žÆ9K/±ãøWËp8ŸÇ÷àõžÄø'òºœ{΀~üä©+ŸwýQùÇs¿à^>yÙx×À¥ØQzŒæû÷·|ï‡ýr|Ïó뜹OãØ®y·´ÍÝ•à4ä[rLÝŒ¸ýÁÎà·+ˆ_ÑCêÔ/d?É‹¸þ—²{æ‘1Þ¥ŽDýøMrŽÜPï°~“Ç£Þ¥÷qÝËy ÷ŠÇŠé3~*¹'Š=Ç“—߃óþè+rš3©Íˆñ—ö÷ðsð$ñ9È›åƒûÔ¿s?ÖêFª Ëþ˜÷Êò©xHrJÿ«ó‰¹kŠzÿþSÛ8?Îzýö{Òüüèç.¢þ_.ÿ–Sôt>.Ì'SGp]]øK÷n^òøùkÖžq×ör‰]Bn¨sÇé9œ÷‘ä9°ïÎÛ¢¯Ä…uü(=r‘¼)ö}áüð’WË¿ü¯åŒz„ìªï[öÎñt—r¯ä¹ zïøà×wbÞÄq0öÿ†]0Ž#ï#yÌÛR«~­Á “óßP¿àþì7õïÔ-ú\x]—CïÀ)~_Õ[ì/ðgú=ñ$zªs³•=°½$/O½½ç~¸GäJ?GÜI~ÈòKžGñ¸­°ÃþË»o/k=,ø`Y‡÷¾¹3Î;õèg>¾ Žûˆ«ÀÇècþôW/[ò¾ýzÝ*¨5kúôOo²½õýÈn“À.ÛîÈ.9ªs˯Q*¯Eýy~⺂5{ZŸ?þ‡ÄÈ¿”]ñ3_ýÃy5ô‰ºøy¯òù|.öƒ|3÷ Þ*xvÛ¨[Vðsj.#‰äw]§&ÿ"y$n²?WÀu,ýéóÑ÷çînX³ãº‘ÉùsO:7òŽØ#ì.ïO}ÝþMzLÜÉσ;ùœ¼ƒ¿×~ö×öWö{’Ï‚Ö,ØþàÛ pCÁ¯^9.©›ð^È¿ð9uYž‡º¦ûŠô¼àä…ºJanþ÷_Ž9Öv”÷á÷óÛç½wó÷»¹Ó9à'y׉ŸB&=o‚ÝO¡{wŸß—ª#Ðÿé:%¸dœ…Ÿ.ÏS݆çó9ÈNæw=gÈø •|.;ïû›^æ_œðp\²CÑ žŸôÕB^È}=ògÆz.¾¿°ëaUÆ—d>)×á裠îF} Ü+üý”ž÷bzçWáÜŸB¿ýnøyõ‡9Î`Ÿ±³È…óïôÉ(sÞEø ýÌ>ççôîïù=œ§Þæ~°Ãàiç¨Ï)þ ÎñïѦ|Ïçú<ùü¸Hþž÷u¾Jö |”ûìì?›œ›Î|D^½"þs_Aº›ÚnösÒ?‚ÿÑÿE~U~×yCåÓýùä‰È×ÉOºßHÏoü†’ý1NM}žy \·^*h]±qßJŸ&q®ìçâüœ~>ÿ²Õg}5õpãgãrò ä/©S×%?!ÞÀúùåϋ奷Èó)¹6þ-˜¶ãä5^Lê:Â)®+ ·¡ØoòãÒÛ¤Uχý"î*$_Œ˜R¥g÷~—ôsÒG…¼ƒ_‰÷ÉÊHÿ]‡¡ÎL=“ü%õ.â?âvò½ôOÑo&}-È-sláÌ’8’üu{ìöUçâ+ûGü¦ò]ùÂwäÅ©’o-tÜ)?_¼<Áõ|oP§¢Æù9ù!ò(àcô5¯qQí^Í/Mì?8<ˆ}Jé)üƒ‰âwÈËW‘§Ûþ¨ÎQ0è¨j·\œôéÿc/‘CžÛ}à:òq²cÜ¿Ï[òNý@öȼ+Ø ôÃýMĽz/ì”ã‡Þ0¿?u˜ü¹;w=XêXã^ã)ùyãâ@É??OßbžxÅÜo-éŸë’ôÓÈÎà ”=ö²³ÛúžÜ·D]^ñ?÷ËÏYŽÈS¢_ƒúùWòHôÓrÏ:ï‚6§Ý\±Î'¶WùÓjÐsô¯Ö+ÿ>8G8ÑöŸ8Zznü½$N•* ®~¤¯Yõiãü1ùòóÔèó /„çR=,@•;oiÑÉùxìúÖ]‡¡Î&ùu>;ô%£WŽ$/ô»º?Ž<#q¦â_á&x’9 ì—ô‰çåûðÏÜ[žú$ñûàlûð8OçÌ}qÎÆôɨ^®¡Þáú¯òä¹Â<vÖ}Âò®É~¸O è› åÎq'ul¾"\m{¤?IþÌòEÞ–ûÎ&Îáï>G}}®£Rg”žº?Š>½¿ãjÝ—êâær~êNºÛaò£ÔÕRõÏÝHÁC®cKÀaÎ;`_èÓ ú‰_üXÉÞE‹F_sxñùú(éïQœF?†ëï þ9ð¹îºöÖs"ÂáýW_±%ëFû-êÄäÀ5ì)0Î=¬Ö wqŽq-úJ~Âöû¬:§ëÔ%°óA>Õùqú½õ½äkˆ7JÝàþæû¾µÝɨØüמ?=k¼!{Vò°cöœºìOççÀu–_áä”<í*ý˜:7ðŠó‡ôç_g /#NÏ\Ò/]§Î¤çr\G¾“z¿ì ÷…ð9äéq½Ÿ¿ËŽ„ñ8{cÜ+ùO—¼“ŸÆ/pôùëwSŸ³íóoÒâY÷#ÒÇA_¸Eýk®Së9ɯ¿›ã"~@¿™Ã"ná܃þë5y|æ,è{VöÜAüá>2æUħ©¹yë©ë²ÎèÉç œ—xñ,oγÑ÷¦8Æ~Š<~Pã\<Ÿô× wó>î÷£—8Sñ{^ŸÃT>¢µÏÉ}_ä¯Õàú¬ìñ6~]r‚Þ:„]įrîŠëÝEßù*ÉuPúû-÷Ê¡Wa¿\8w溱öyFÛòoûã{ŸƒóNÔÈë´9¬çïýÃx‰9Hì¯ã\æ£À›®{?èù‰_ݯHÜÅüùO=ú“ßlõkå6/6?Šr¤äÑ}ga?5õIá~Ç?­Æ#è#q˜îÓ}GòÿÔ1Ý×Nß&}ä‰úOÁ‹ÊãÑ÷kŒ{‚¹ ÷«}0à2牘¡ƒ¼&uOò›øwò:Š«À+ž’Ý_Òwjû†Ý§O¼†ýgþx”¼±pùJ櫸ì!{èàÛã¹­×ÌÁ*¾¥oÛyfÝ;öÎý‡ÌµQï}!ÿBÜB~Çs ø¾{(;ä~3ý!Ø=ôÜ}£ïÏAž9oäµy[Ý/up»ûר§€ë˜¯dŽ =>ÀnÛ.H¾Á_àxÏWÒÎ{—b§éï¦-ûî<–ð€ûJTq|.'nT¼ê>楩Oz^W?ö‰òóž'U¿£û˜;Ñù…sXŠSÌOÏ9¹]ûKæˆçÉûHß …g¨ÿzþGöØþ@Çï‚·]ßcžœúšp«û È PÅË€_Wÿx‰¹JìœçK©ƒ#‰?ð[Ò#÷ûÒ§‹þPçV½S¼iîuœ-œï¹uÅ#%*î·xË™É:ubðòŠaÿ;òê9 òŒ’×u¿ø#Ï›‡…çA÷áþ!ú”‰cÈgg2¯À\1sÇØgp§ä”øA¿ï9!Ç1ôËÞ!GØ÷IÀÛ:x½|>¶ôO~|iý_‚çdç©ç!7|.¿ïycõxîKx}týš9=úB™»b^|€Ý D~ynúƒ™/’2ÏóÚôýµß8©Ãè÷]W žA=Eòá¾jù}Ïá’¯ËNÙNªÊõwêCzì˜ë]ÂUÎ;ËG ?zþ–ú1ùh枱Ē'ûUðW8çÆ\-õjú¿ÈËÐA¾ž|ªä,_8Þ÷¦?=ÿ ¸Âüä}±ß·äkŒ¥GäÍ[¡{p¿2shAßyYú`œo'þ‡×@qºãx8¸/Åõ¶›’ã==WhÜ¿ŽSø‹÷E¿ùÓsïØêÝî'^p]Wq¦ûÑÀK|ö‡ùxèÁocoˆ_èWÜ…üósÔŸÁ»á|®í:ùsä€<ªÞy=ß·ô›¾ÏÂ#D^ ÜÍœ8r£ß÷|7ó Ä—ò3ô?pNô­#·ö›ðIЧ/{íŸCÎõ½ÆMÊÛ’Oõ÷Kßé!¿M¿?Ï\"öyr]|„}F¿„ÏÍÿ ç¶¼’çGƒçeN-|Ä÷™§I~bļ~†9PíÉfïƒëÝÔÉ‚ùkã6žCñ’ù§tŽ®ÑÃ\ñ9õ>æ¾Ð'áç‹ô<®ïçÈ®ò§ó,ä?U·Âÿx~1Ì{¢WA\Àsã/­/Ô¹”§ hûHþXïa¿MŸ)ý”7¤ÿý+×?g¢~L~Zrc< \…^Û2Ÿ¾.òœsTà’Ôsy?Sè߯B_õ9®ëò=Ø#p<|àx©˜#¯ŒœÃ·£xÛý›ô¨o¿ .Ä.xþÞê{̹¨oÌsÃÔCt~ø-ç}d¯¨³™‹ø’ŸgFvÂ~,àÁâÿ;_§{ò¿'KþðW®[2GOÞ‚|0ý‚©øÄ<îÃ%þÑ97sÿŠcéÇrŸý<ØeúŒtØí´½v¼§:Ÿ>â8Wð'uGç¿™ `>ˆ:NP_0·Éçxž9Cx•À#Ô'ù;ógòÔ Á…øsÛ5øš˜Ÿåó˜gT}Ð}Ùò“Ú¿žÌ+Sg¡/Ž~%æ©û3_§ï·×ç¹^Jü!¹Â.1Çô¹/þ$Ù;ÇÂßž«xOÜO^'ÿK>\ùL÷gÉŽƒ°;ü‰Ü8Ÿ¡<Ÿûš™G€Oy'?E_«ðx.œƒrÿ<^øø°˜3Rœâºy΀G ;—Ѧû=e6×MòÉÂUÔ ü9:Oô…÷ û_,ï²æ«¢oKþÀ|rÚ¿vé°Z'G³Ìǹ¤ç­‹×¾1ܼíðbÃoº¹Õº ~ùé’è÷±¯i]òïgG|Í­}»O{ìíhë·{Æ69ù±hUÅÜWΘ1Ú<èð/:÷˜¥3çíôžöÇl¨òÏa}ò^¶ü‡ÿº9û\¢±ëŸø©ûU7›ßVž—ϧ—}›»E÷½þRó ¯ª›÷y…í]£ -«ü\¾Ùqæ[…Ç–½9ìàûØ7ñG¥&#»ìžg~Ô¹ î=óé§kDFį”y»“y€á{‡OŸý俞4uz«û‡F?wÛSuSÚg ²xáçÞ4hj“Ûêm˜ðû³Ü­zkÏê×Ç/ðžtøqÙ7­ß÷~~žÏá{ØGO5|ý .l~BŸk†GË—.*êÒöWïóX;pBÍqû»š—¾oxšá§Ý0ðÂq5^èè½Y“Ëþòb¹)ß™g}Å÷ËœÐy›­îÖâ—ºßèôœ?×Þ2¦S§Q-¼¿‚="È{—uz><ñ˜Lóa#Çá ô“se¿…÷GH.à!–ZÎáÆ'є٧|÷]OóšÃ/¾°[éÑ»,ZñƆ•™å>NöEèOäý6ÿ¸ö†›_^÷„ž¬XúÉ‘k,²~Ã˼¾Ë1~rà9ìûÍ“=]<îþüGß¿Úzò2óÞýÑúîÏšÖ©ï}SZü”þt£ã-Øaž ¾uøÂá‡f|ÔìÅXSiFµÜ»çzÏß„ßßû8d‘ø©W|Õ¡ËÜgöEk»±v¹Žu­Ïú\ßß’½Kž}æ˜ñÞS~,‹}zêülë7þÄ{‡´‡þjïÿ‘ܰGþþo?½þتM£™—¾tÚ¬5½O‚ûE9wöðÞ|Þüz#ëÇ%ûúžW.9{ìÖö£M“ޏðÉGÚn²·yû±LÝÛk¾Ù*ÚÐùºÚm;Öñž$¾ß~Súo^qÙ)ïsã>ôýè|êkÞì?`Ӣϣ•uË–¹èõŽÞ¯ÃþôÉvPçËç°¯tc¥GÏ­uîôhɘƒÝ-«Råø{nO~^uü |ê«ÿ³!#±çÚ+d{­}2œ'v‚ýGnÁ+;ÏÜXý‘*ø ËŸGû(8_ì%{ìïu~øsøñWüÇìKöËHnðì ØXwç ×Î-¾èÝKjöêóeŽý½¾½ö^9ñ¤ƒ·'΋=¬Eqµ¡ïFƒ|>Øõ_ºÜðÑM¾´ ÷|°çÅ~I8 œÆy²÷ƒ÷CïØ†ù½Ö‚Ï ßoù˜“ÿÌÊŠÑ[¶“øI}Ÿï…=›ì×-oÜ‘öd=Ëçºå·¿Ùäü ýùz?ÿÎçx–öèó̳½Çÿ~í‚ï~^­¡³Z êk?ÏçÁ“þ¯N»ðËûsfE+ߪûÉEíºáwÁUÆ£²Kì§`ç¹'ô<ÃÞp~½âßl; íÔ¨üÊÞÇ€Ç×±÷œú >Âï¿vìCÚ÷°Ü‚ÛøïÖÞ;ì{VN¼¹óMšD+LR¦ÛI–ä?Å^ä¼²ê¶{~ÿðŠ¿/ø{ÝfÄÜœ^wôÝ:Ÿç_7ªÖôús£u“Ë6šRz˜ñ1~¿†?ÿ ÷Þ‡Ðõ¦f »Üfü NÆ¿²offQïÝë|êÏgû-¿é\ýüf;{€ß’ó ®’ÿŸ;ñå{ë·(šÕéÒù5)Jö¯h4xðGÚ¢£›\fÞä=X>¨~ó'÷¶MöÈ?-¯pßòGW´¼qNì‰Nôsb§¼‰=Nznö°ð¹à äý]ÞòÑ™µG§[?±CØô9ÀÏ£—àä5On8¢UÎo‰œXéµNkßóûá§À9è'{®ÖLØ•ÕøÈ"û%ðÔ²ô¥G¬W-Ù›&½Ãß±‡ {ˆý—òLû î "{ÞMßöýÃW]»½óyÏù±ò'jÜm½À?a'ˆ§¸¯i#›wü´­ýäÂϾU±ßÐdÿ‘öˆ°¯–û\~ÑŠK:žó+ç™Ü·p2z~^º¼yù#/ÿ2ÙÏ—×½¤vWïåGpÿÄܳó:ì¸jÑž»ŽœÙu»÷¸°ç½—Ä=àqü r3õÔƒ¿Í/Š–¸òõíC§F«÷ïŠ÷LiéÏõ~qíÉô¾8Åר;ö­€ãØ„ÿfŸû)W×tÓÖh¼ß—½)Üqݲ¥[¦þ²þFï·DÎçÿ<¾ÄÈ}ãŒsŒg„KW¶¬°èö;¿ðçòyàò:ÄqËÞèØiÌSï;ž`_ÛŽÉËçÿøÀS¶Ãà<ö}qžì gŸ,ç¨| ø×rýóûäuf޾fÚñ'îõ÷­š°ä¥Î%/|÷àÏl}×û¡¼Xò·ì›ëÛ-÷šq*ölWzö[×—ì›bÏöépžøwîüŸ÷Ó‘_Ü6ÚçÊžŸyîúWÙõYN¹oòàð ñ ö¸{Œ^Qùêú,˜SÌãW‰çØk‰}/ Gø!ÞãÀæ>7O:Ã{wÀÃàQžCþ'~&õ>^ÙUôœs‡ç8ÎÖÏë{¼¿¹XþJñ,Ÿ‹ŸCÁè'ùãÙyü2r¿Høß~Iv•¸ÜH¼Ç¨f#:×icü†_àßÉËr/Λ`g„oy®×Öý°xN¥ÎC äC9oåM’zêæ ­:«óýðüÐçCLªÌ2÷÷h.ÒóæôÂÿ/·ÎÇ}]Ô[ÕGÇç¹.Å÷©?Þ¼PÌ㛢:˜ûcÔ7ÂÜ–ç ¨÷QgR]ù6ïýñôÑÀ› }ðÛÓ©º$ï ?ëdº?óWHÙsD?ŒùháÁP'rC?.ÏéyGøÃÕÿAŸ¯y¹àcî¾9êyú\ó«èÙü©ù‰èçöƘ\r‡þ‡üæËýl®««ïÁsPšÛ¾´½gîÈ<ôѰGò„\zIóΞ¯ÅÿÁo O{è‡Uý+Ü¿ø¨‹{î\à9vú¹Ô‡D_—ç…˜_c^•¾0æí黯N`§éç}ƒ=î3aNƒþwæÈ˜ïgùeøMƒýöê?ôÜ}¯œ#ó.ôÑÒßL_ú62Zõ=8ý²‡? ßòÆó1ç&ûÂyÑgÄžïO“½Äž™Y}µè§yé{g΂yEú’à;?1_¦}Rž?Fè+¥Ož9ø˜ï`?fjÏm2g€^Hÿ[ÝûQÝŸæþGžCöÒûUR}XæÑ6¿}wôÅЗ­~:éqZ¢?ÌË› žÝ£û™Ë¡?›9=§ý8¼ËØUÙAΡ9~–ùø÷áa¥‡þAx+á¹àçù;ó ì=Ò¼8ÛsŽÌI†ýÊÁ|¶û§˜óaoüVè™ì5ø—xÒýhôE²·„>Qæ°°»È±>Ïr/ü‹¼cá(Æ/Ã/iËv,àŸÀo[^åwÍ' ¹Çž»Ž9údõüô5yþ€ø†>(ú6郆„ùJú›Õïèy>á-÷ÁÁãË\ñ}°àdö$2W…]ø´­Oâ%%^Ð\—çQÁÓàóÕs>7ˆ9Cú-™‡…Ç\ýÀìC.­oðÔ³_FÏi~ùbüÙôisoôÃsC:ýÓÒ_âæì=—ì ñ¾UöliŽÕý™:ö$šÇ…}âÁ0ž’<¸ý´ì¹ƒ§½WÄÃz.>Ï{n胧¯™yøFdÍ3ÌþúÙ ÃÜ玿„Wæ µOõòdŸt°—ÇûÙWÍ÷°‘ùÙMϽ3×N¢]þÕýòïžS$o®çûôȽô„¼^1>çpîÜ}¸ô13÷ŠÞ³G~ÏspÌK‰ë‘7ì“ç!ˆ›Äkɽ'zÞú­i£Ù0'‰[‰ãèÓd^–¹?âeö˜Ð×ìÎè=dáÉõÏKöp¯’Oî9$nó>4ÍÍøþ™S.ÄÎúž… xNü‚ý Ñ”}ð~Ùbû`‰séû†”¸^<ù'Ïû¼ºÆ'Šï½/œ9â0ó#ì/bîCÿNÜa^-ì*ühðQ€Oƒ=MæcošìŽùáÈ_ÑŸÎ^ùó^ÂóÏ{eØßF^¼Ê¼½ì‡÷B0Ç&=7O s;ì«.1ïp0bþXæ”á Âî3ÿEœ¢÷go»ç+ðÇ̃b?Èç!çäUµŸrékóúNl™ª _E>Ï<0Ì'Hÿákq<ÌÜ'ólÁ½bœO"£ù1Çã²§äe\üq´w냽6\d´§ä˜ê<Ô“¾ê¸pía_uñ¨èषÆ\ù4ïq°ßÕ9‰$:иb‹r—6 ey,Yv˱_¿8íìßzOøøû1ø©Ø7IØñ |Ûâ)à|˜ô~Ö”?‰.ÑhPçÖ–/ôœ^§þ¯]O IöÛ–LK_qõÆáðÁ»ŸZuò8mⵋ¯;¢s\ªMÆ-·?vå^Mõ{˜ü¬ëÔôkh¹éÊõÏ÷ˆö¥UlYë©yÑÞÞ™—Ýf÷èúÌÞ.­gåMzž¼Jt`à¾KO[¿Æ{Ùï†Ï æùÙAá’hßæ¬…mOï`~1ìxÉœ¢ÎŸÔýÁñPÚïצAUì}±÷͈7ùâ^…?£¢­5¯rl¿ÄOœ¸rkï'óÏ;ŽfoÖ ?ûªâ›QQã–¯µèüí¡øïè£Lì¨Þ »Î}¢ŸæGKÍF[çU¬wÙõæÝIûOße»$oŽý‚·%5G½Uç©v'Üé}oÌÿPÏ„ÓþFqŸú‡Oöm*ÿ,œl¿ï¶ù”™·T]üA_BúY¯ýtióÒŽ‡Òz½—óÀw¹@ËGQ…õ¾š?2áóÕ÷òùi—<ôñ3¿Nô}«Ï”y×#ÍÅ|"<Ê¿°¿Gv…½H‰ÜŠR}ÞI}AòÆs—ªÕsÒ´&Ž[øwñãÒ/l»ªŸss‘²[qúò²vî7^ƒ—çM±è¾ú.Lìžò#–'í1&U0vùÓ+&fF{[ ›xö©•Àø[âãhÿeŽþçÔÿÙyËy~ï9—"¾ÀŸD <N¦ƒ]Îx EéÂ.GðüÑþç,zÜÛI}AøØ¼¯utx"”§d#NŸÐ¦öâvQ´wÒºa»Ç˜ä Rq7uó ¸¿@ñ¹ìƒõ ÿ€Ÿò󩮎ÝÅß?´˜Ù¨nÕ,Û?âO¿x&åG¢½Ÿ~Öîº÷K0—á¼0zàü+ùò$ÒÍC$<´êB¨w:þPÓ}B§àxð—äÛ~ƒ:%¸‰ºšïIvlOçcžÝr×TãJü!ö\î=Üòï’ŸD.uªÒ_ë¼ ~ÜvQrÈž úAÜW¥Ïw§äÒu0×¥á-×{`_è»Ðžð^œþï~ß Ä3ÎS—lX¶oƒO¶ç¶©8 áO‡6ÌZ±ý_U蓌ÓÄWà¼g DE]*¿úÝsùÞŸ±«Ï݇¾·Üùdä=Ëò#Æœ“÷²¦äÁþÙ¼©~ú í×Ã<vP|·Æù|v¼!œíø;ƒ\J}ÞØÇ´u7UYœW=áÅP~ ?ßàÎÞXÅ£ôƒÇ骓«¾Äð^eÕ,§È§ìùìŽãÒÔ}XŽ\wIþ…|–ì v%‘KÅËöŸð¥òô_ósI=Šú£êdsÛgÜþ¸óãàäý-÷—\õ´÷')ÏîõW 7î#…Þ{Ý+ùTÍczO1¸{伟ôØyPâ.ú$7îÛV_xƒ9Ÿ„?Oq2øÙú(»ôW;ŽTŠóq|eÞ7Å'àjçõs¥ûoo—s´÷5°o ¹Lüû¹xõ]9_E> Ð{õ/z[Zîüww÷žÔ°?Aÿò_tKÛUç<Ý"*ZÚ뽕9¿·§(>'ßeùOá7ãZå‹,?®_§òÌ©Ðbÿ ~á=‹üÙ¨ï˜ÖŽ»‘/ìjÁÜÍöλ9áM ö{»ožKúŠôwäÄ}®ô)ÁÏÍ^XúfàsÞö~êJ©:”ãó«_Ùýð^J/ šœÍ>â9ïKó>xŽÕG†>˜¾)ú†˜¡?¾ø®á'îãù°O!1r ®2.ýTðR©NÈ õêŠî+¥ïC8ÆuEø©ß*?ÅÏÓÇò“'ð~qá5.sBÔ¿éÏ n®~ ü8¸›~ ï'¦/ˆú(þM}ÞóG†pû/èß ö¯šNñ‰ëíô'Ðg ¿-}ôÑï%ýôw±?^?çýâð‚ªoƒ÷ _á|s5êCðûTÙ/Ë^úœÙsG­þN~Âýêÿ’¾EE¥>9¶ðÂ3¨/{¯†y“þ^äÑ{ tnÈóêª [~èû~û„ [—ùò–…s™/õ\Šû;Sùø|’}ðTÒ·C?ú‰ ÞOß!ù ýé÷e^ƒ~òÅÒ÷‘ÁKM¼æâ›§ÏÕ}3º>ßöxßk>MöX1o€éœÉӹΦþò¾à/ÎÅ{—¨çÒ¿{°OÖ¼ì·Sÿ£÷#°'–½Æì“/:vÔóm²ŸÞE?ó%:ð}Û{~Ùù`Fá}ö¿ä;8'÷‡„ü×ÔñÈÛ‘'¤Žø›ùùçp®Ïýêøúîé+ÃÈÞšSßc\Ÿ1}vô‡³W »£> æÀUôï`WÁ'îßb>Nýä=°—Þ+Ý‘Þz¿$ýøØYêúçW…ËÂ}~þ`.Ïû'èw’>¸¯–ócÿ®æBÌL¿=¸@Ÿo¿&ù ûüû䅻̗Ig°‡‡xÎû¿e¾rþþ]úìØ3„^0ÏÄÞ2ð®p›y‡5Çç~3Õ¨Óa½ ö6Úîj>ÊöXçî÷<'{o$Æ»ìóH=<É0ú|Ñ'ú·ø;ýùìÖÿwŸ›ü­çÔOåy'ú~ÑgöãÂÓ þÞ0þÂþÒ·Ç”òö‡ô¡ôÉÑoŸ®ÞËýfÌýÐ×Ä9Ò/ÆÞ3ú²ôóÌgÑÿ"¾ë-~ß{aƒ9–b}âìq’ݧnažxöV±W ~Zö³ÿš~>ü78ÜÍœ{<”g°œÉ®y3¸DöÓ{€T Ö{ŽÙË ÍýP'¿á¹Tý¼ëÞŠ¼oXsäÆÏä¥è'Ó¼7÷Çßí?à{–ß ¿l¹eþM}¹æÿ. ßf_ö~¡ÊkÒogoæ „Sü\Ü#øTöËs!âÝ6ÞeÎ=Ò/ç³_¸þÇ{³/R~Æ8ÜË~p*}–ÌC¨¿Àûñ˜g/xƒþ¹`¥yìÙ¿¨ût_?û'¤Ž“èof~ƒ~sÕ1ü<È7rA sÆÂËø?ó_3=`¿ŒîÝ{ŸØŽ~²7‚ù%Î?î-Õù¹|ìSòþbú7™Û`~8e'áÑMúëØ¯Eÿ¾ìçäøY{‹ÄošÌy0ÿó×¹0÷áGé;ð\!xÞ~öb‡t^î‹ÿ+ÿ}²=ö4ÑG·»ë–¼‡ZTKüöWyÛEâ9æ8ƒ½¬ö7Ì Ø nÂÿ²GŠ>uö&0÷ɾ ùKóHÈÎØ>£ÿ̲}!®Ä¿¡‡ô[ÐÇ ÞaŸ søGúèÙ· Þ@ÀoŠÿéëpÞE÷E}ÂñœôÔç.ûÀ¾0ï9wÃó¯xÅ{EÙÅžcΗçGŽ™G•½¥ÏŒ<—óœûáÀKÂÉœ«qø–~ö¨¨NoȽ0gŠ?!_!y±Ý¢þg~ ø*ØËÊžø%$GÄ;ÞÏM<Ëœq§á=°_î’ßò<—òTƵªO˜¯‚ùìq!ó%²ƒžG ïŠ8SþŸ9|¾Ïöžx“¸Š9Aì*ýâøüs䙨{Äýázð°÷Ʊ‘½‹øWávò–ÎüußG²—|û‘ð[̓Ⱦ‚ãüÁ±Ÿ—98æïÁ“â¼s’ðhÞŸsq|ƒÞ°‡üÇy#Ϛ礮éü‰ì¤÷©³—VŸã¾wä1Ðϱ}rž ŸÊÙß1ߌ¼ÃÔw½cÆSß®¼×øÓq§îÁçÈ| vûÍïqü;vš9¿`î ;N%_ROöÜ{X„×yoêèÆýòka«ãÞ`Ÿù‹„Séµ?P\¹þG^»Ä¾AòUàyÙiú¢½o ;#ýõœ ó´z_ö* ïôKê\܇ôK$û†É;àÑ?Àœ÷º°§„ü‚ì/uÜ€ ‘{æÀuzoêŽ3× ^è|Sø'8<;öPüDà€’Ï•>åÌ Ÿ&}ïðÝH¯‚ï7O ö›>aöeR‡€o…y1ö§Ð?>Åî“O„¿ü8|)uŽTœï>Bã4Å{Æ}äÁù±ÄCžc=ùUä9%ò“ø{öG¡Ê:^‚Œ=ãÒ/Ï{’œ×—=+ì°ÿòîÛ“ý%…§¾£L£Ò‰Ë>‘?*h]±qßJŸºžìüç¨ó.$Ÿ>¥¾ÃaÍ yŒî‡Ï/Uió÷/i–ìí%Ÿ*?ì9[õ¥’×ôÜñ>sÒð§±·» ûóÞlÙ‰Ò­óÏmž3 ÙÛKüŠßfO'õ^Õ ½ßQqŽó Ôµä4?R 'yõGö Pw’Á±‡sôžwåÐ#ì‘yÄôÞ|¾y/_!sjÈø™ÌÓæ_•ß'þ—{¯1~„}:ú^ú1°ê“Hêìî°þwï \ï|7ù'åu˜¯fO¢ôÕõê¾ÄÝò³ÆYè³ì&ñøÁ{Ó°ø;øKˆ?Rrîyï½æ%½:¡p ÷ãüõ ž›|-Ü ÎÒûدƒ»êjð éù‡à8›<úÇÏ‚+™Sç¹ÿzn–ω§Q·ò®¯RÏaï8x= /]Ôyº€ºy#p$þ’x9%oÏ\sXWJîm78_êõä%Ù“¬ïcžžÏ“ÉÞáý{ŠÏOÂ2—èzxПÁ}{>Ÿú!û¿ô¼ö‡ð"’‡Óy˜×JöÖúŒþNþ> ×õéaïùöU2Oß.8+à ó¡æ¡a˜â.ž«°v©ßöª›ìmS=Ôy=ý>õQñ<º¯ËøýçÈN"Ÿþ^xóžÇ›ôç`Wé·p^: ?ϾuÅᎰëÄ}ú}ïM x\¨¿ºï€s!?Î^o=ŸýyRò¨ð —ÔoÀûà¯ëø%áסÙ{Ïœß_ëÎÞ'm>HúeGc³äÁz¤÷ÅžÓ_ÌçáǬ¯²çô‘º‡ý ü4ó a ôøiæ,Ý_ß@°¿ Å9ä_½gžìq8ùIÉŸå?ÈϸîLÞ˜ü ñ¾Îýæ|±“æQÑy?c_>_Í©X~¬G웕þ˜ï•ú0Џ4”3ÉEXW ?ì½òìGç¼”ÿs?u°‡ûk}„Ï>É‘û$ßäLJÁ“ù×>Ûkä ÿàïÇ]÷ÚiÆ©äÀMä÷™·Á΃7°óäù ¶ä4éQó¥âýRø}êûìYg­ì.Ïcðs›g“º/ü.ä+Ñoxüà)c¿8ùIxV°ÿš?±}G‚GÀÒsæDÁYäwè×¶ßæ~Á;ð“_!>âçÝÈ_±_UyBÏ þÖ}7’K×›ÁÃðxÒ7Ÿšÿ±þpð˜?Sù×ûžÊרñ(ùÎøÞ9ì vW¸„~Vï·%îÕ÷/”¬‘ß3ãòúI{ÅÁÅäËàwÒϹÿ&¿ÍyÐÿêz} ðÝý|ù!÷ûQߎ5Ÿ¸ ;ø$eg-§ôoPAÞÀÛä5„çÉ#¹Ï‡óe¿®ú#mïÀòã΃sÞ¼'ýA—Þ ¦îÝq«ô°°Ùβ•Ïþ?øàg‡Oþ$Ùcê5–öT ¿zŸ¾×‡Þ<æ«é»¢ûÞ/÷Ân÷±§[Ïi¾5ðü©)yò|³ûôèáÎNueüúÎù'4_èþ Åû䑯`wù»üªûýe¯ŒàÁ£Ÿžü!ùá1ìçe¼ÍûÉaw Uíö‹“¼{è#Bñc’þ¸Âü¨ê»±]£¾'ûæ=ð£ê=è‡ósïâãLꚪëÚRÏ‚˜º3}âØW?ý¡<¿ý7ü_ð!‡ø-öÀc,œD>;œç€ŸÈ<øÄ‹:'úZ‰[̧ Þ%n¯’o•>Z?°ãAÙrL^žø€7ÞøL÷E_rèßl‰ÇÁÂ9æSÜä|”êÄuä}à_q¾™ýÊG9n+Ž¥ÎSŒÇŸýå²ç®+Ó‡Ô±ÿô¯Öù„õhŸ7öŠ|yMüù°@N܇Ϝþ›s úï‡d¾@÷ãzu úlÕ@ÿs È­yŽéï’Þ›'ƒüR`üù²›îÓŽ-(=ïÅ:õÎIú\‚þQò3®‹ ï2§ä<yaüŽê<è%rê¼€äƒs5ß<ªä)é¿"nÐ=šÇŠz6yPæSdðÛÆ÷º/÷ þÖxž|8¿ôq™Ÿº-û*°‹Ü~ž^='ùüõüŒó´ú<ââOãaž[zb½Nsù'òõôÙÃG_³òG…¹ùß9æØdî~LêÃÂOôé™÷@~‹yQíÇLæÉÄ߈?vŸ2}"ì3€žyöÈЯ¦¾$û17÷nÿMüMÝ%èW²$ŸÏ< ¼ïàWøK©{à ¯0<Žð$ÃWÎ9ó¾ÎEú oŠæ…<‡k»ÎÜ uVÞ'à_÷} _ð” zo×ÿ•Ï2ý$Ô¡‚¾lÿ>rw2÷'¹"Nðþƒ€7Ì| øaxäɇÑOÊ~úóõÞîgåyÐê²ôÃ[äÇíßÑ#òÀÔÐwÎY~{q]›ý"â¥ñ^-xÁyêìÌgH¿íGÐGììòN†OÁþ¹-á÷Å0·+}r]Ÿóâ¾åoÃú¢çØèW•\X®U¯vüÿ:~HÏe¿ÎýŸTžçpç •ð9ü~Øqñ{ú¼<Çþ½¸%Üä~wòô•Ë>ÿŸøÎ{ÊØ[§¹+çMÈS¡ð‚cÇà%ƒï“y~òÞàcݳõ{àsé«RŸŠyÎù>ò§²‡~Nü§°ž±g"àïÁnº'¨“¿åïÔ¼¯O¸Øû$°GÈ'þŒú}êÌÒ¿Ìùa¤÷æ§Â‹÷“ùc?u!òÂÊ«ÛaW‰3ÜϘíÏÃ<vÜJÜG~!ÈG{Ïs_Üx¹ Ê>ìßÏß±'ð#‚#è×êãö_òãæ‰“ðüØü–çà·R?(÷ฒ<zH¾VŸG|ì9:p‰ò îC âS÷1‘¯`ïc0ñl…G–m»$ñoºOì©qxûÏ^0ö62_žàܘkA®É³€‘k½¸Ï“<‘ý!ü²è©>¿˜QWd¾;Ê÷²'Dq‡âþ„¯> â æ€èg%ÿ#^´¢öÍ*¼\i•õ/ìûö~ øÐÄûÌs8?B=˜¾RåȮaN*èÓð¾·`?ú`|Ïé¯ãnú áoxÈÓóyø!óú¨Æ9€ Âïñ}2ÿÌ™z~MòJ=Ê8½ ßˆ¾Uä ÀŸÜúNœÌØOQ¯ N&®°ÇV~‘úúO|ë9(ö ÊoâlŸ‰O‰ áiAïÀì3‘~ó=ä›ÂøÒs*ÂÛîÓ—\¸?‰ü9ú‹ÝÇ>3¿K\Ëœ%qñúK݆{"n¢_ ¯"û ¸/úUŸ%oåyògî÷ý²/ü#;ä~<Þ—|ÎÕvš8 ÿ¡÷.¶ß¿L>£€§;l¼ÃûÓŠÜÁOÊ~ŸºvIy?xð»–'ò©ÂÁ¶ã!ødçÅÓ˜äȧ¯U÷A?F(ç~_É«í¤üû¢¤Gäƒ\¯£> N–|_0/«{"Ž£~l¾ ôŒø‡ß×y}¹I=ƒïÃÏ/±¯@xÊv¿É¼/ñ‰ôÔvJs Ž‹°»ØEömó‘üé¼ï!;Áï‰^`gÿô>Æ{èä½¶Gÿ‰Ë™Wùìý@ôÛÃ_ ÷uÜO¾Bu ãAxæ°Cà9ø°ð/“?#ïÂù1§¨¼'þ$¬ [Ÿ¨Ë¯cÁùÈ7ý²ú^Ë óàXætoôõùý¸ìûIþºÕ|ØÆÙü¾ô›º$ç‹ãÉ‹ùU°[:/ô…~'ïÿk?TZZZ©´´ãN¶ÿÇ^ôˆ–.o^þÈË¿Œ¶¬;ªôØ~™Ñ¶ék~Ê{'ZuÛ=¿xEŽÿ¾-Å­[~û›Mο¾ÎhÛÛ5ùñ¥­ÑŸÖû¦zc™¿‰þ,>ðãÂÏüïâñˆöø£ÛÄe+¢=ÿæeþrG´ýñé|ù{—hç±Ödím»ÿ»5§XÁ>ÒhÛ…[4ûåEx Øoê?·¿çÓoŽ9>ÚÒô§þ§v:5Ú1²aÕk~.mݸxÓ96E»ª­þd@‰»£?ßÙwý©§5g^;Ú¹´þÆhñMÑž–…‡¯º²~ÍhÇàçŸWíÏhÛ'×m-œ<=šŸuä°]ÝnŒö4©òq½NuàÓV½µgõëãDÛ¾k¹sóÉ3£ÕÝúãæo¾¶ýÙ%í¡6oD+'ÞÜùÎ&MØëçsÙqQþîþG-ж¾°õ©çnïýÙåØyGœmªü{¿.5+úÜ9Ïíß~þxÁƽюJW¹¢‡y娓­¯ø~™:ωÖü¤Å­Ç,‰v”:ïoV>­y³ÿ€M‹>÷¹Šß6ÚÙûèÜ•Göó{.>ðí¤ßw|íçªÝdsïh~‡ù-'æE[Ë^^jÅþK£ÿZzÞàïûG[tÛï¨8«y·6¾§??9rÔ”žM¢Ÿ»í©º)í³hÝþµýO¸o,{ý9|noÖ°ÃÀhËö¤4çÜ|Ï »•}ð±Ë¢¹û–>Ùoß8ÿÎsCË*?—ov\´¡óuµÛv¬Íÿy|‰‘ûÆE›[­»à—Ÿ.‰~öí¬Šý†²(Z4eö)ß}×3ú3eÏ}>˾¹¾Ý‚q¯E[N8sÎÕoG[¯=zÒÛÏ/ж×Ç=®}ÝïÉ9ÿ™>î®î«ŽŒ¶=yÑ»…sÇDÛŸú~óVƒ|¯ÈÓïc_Óºä;ÑÊ+½Öií{¾Ï9ùϬ¬½m4µÉmõNð½²ßdËçï¾úxÓöD«oÞÙlDýŒD$oköÏ-Ñå›iÑ΋T°ô¦hSÚIÏŒ>áëèÎ¥_;{ióhÅWºÌ}f_4}êÁ~n0*ZÖé²üuø=fôúåæ*‹;$z;üî±%Þ~ Z>¨~ó'÷¶–W¸où£«Z¿ÄÓm}£âI…Õûúßµ7Æ?·³ñÇ}¦—x4Ú:sLý/híèþöc9½WD+*_ýAŸs¢ß3ËoþaÐÕð¤û|ö68gÐØK¢í}¢“:MÊcßv´õ–ñózìí€=± W<ÿÎ’ëw”=µZ4ûÒ¡;¯þÇ x$¢ÿ9¿‚hÛ?~\QqW¥Äî¤5þÜü´h]½Ù¿_:2Ú²{à—ß-«Råø{nÿÚç<ïÁ]ÿ*»þ£hqÏS^m<{‡Ïí´EG7=¸Ìz¼zÒ¹ãË®¾>Ú´¤Ì-÷Žèl»¹qÐ-'7Ûú³ïuê©;›_ýYóàºí‡?í¾(sÓcüýTùõ§÷M;­Z¾ªì¼êDK.¹çü‡×´¼mžØº\49šU{áðÒ}÷Em}sAµï¬wÜËŸ÷Ýv^ÇK{Ùî-ÿ²Ü ?½^9ú¦sõó›íìá÷ÝÞ>­üÕ?ÞâçØ>-¯]½RGG;j\üó×ãöÂc-ýúÙíêVµ^ýÙ÷Ýç9å‰híÀ 5Çíï­›\¶Ñ”Òâ5On8¢UÎo¶£<Ÿ?Wr¾zùû¼›SÂþ»¢ýØÑöj£J~~×rËz¶å®*=Ñükì¡å{†=á{wv«qéØW>¶nöjú2û ìò†Þã7VzôÜZçN·?Ôܲ?Ï×9bO7×»¸ñ£Ý~>¾]£EÑoÛ¿ïÐfl ËvG¼Ùö¯ø?ñ(G›.ºìú¾U;Ù¾Í,ê} {O£]éÙ_l]{\´µó_9±Èö`Ö䂳óWVâ|}®ÈËò¥‹Šº´ýÕö·¹r™þý/K·=ÀŽ£’_òªút´yÉì…W>ùšå›¿OIûdÆ&m}¾ÈÙÆ´‘Í;~Ú6ú£R“‘]vÏ‹¶Ývö+/Œ8Î~žçEþçN|ùÞúí²ÁO¢÷È÷ÆyZÞd?<ÔuA¯òÝý}à~´¼å£3kN_ôî%5û¶¿¾hÍ»7ŽYskßîÓ{;±ïÂs+–~räÚ‹¢•uË–¹èõŽÆ;kŒYpݪh÷Á“ylö´h^­¡³Z êËÞ´hçÆÎÍy¯“Ï »­} ¶s>¯³å§½è~ä†ûäùø“÷ßqë ¯ùk®ÿÿÒJ%ßéxÍëÝŽ»+Ôù÷è÷§èœÞè ëåænÑ}¯¿T!zï¬ûòË}²Àçµu_£…ãN©o»a¹–Ü£Ôí~rvün4·û×mFU<"Ú]ãã7î»þBßß·¦ÒŒj¹wϵÞ#;õ”‹÷D;^RqÂ¥‡ÛþWïðžè¿åEòÊ¿ã¿&—ýåÅrS¾Ã~'~sù¸ŠåœÍù±ò'jÜíªrÖ’®×l±}5®•ÝÅm™ßfÊ™'67ÎÚµqâêZÃrýsàî ¹å>‘ λƒZvá—÷ç̲]^U1÷•3fŒ6\ûôÔùÙѶWv¾Yÿ™ëˆ |OøÇEç³tæ¼ÑÚ‹yâúSïIîQñˤa߯Tzƒ÷ûl¬»ó…kg²ý1®•Ü£w'ï{'stšýÓö‚×â=[[Ñ#ì‰ÏQß˽qŸ[Îyå×Kž¸Ö?Ïû!¿|.Ïg/û NâyV´2âÔ?ïò¾Gí‰1î_‰õ„xÏã{±Ä3»JîÖåã\Ç!øð38Ž&Ñþ$ã­0^Ø]¹Úã]ë•OÎë¨y¿¿’qX´}ãÀ[¢vöø[äLóׯ è÷$žCãHü+zeyïöÛÍ[‰}Ÿ¿ýG~÷E_-Ú´â²Î‹}ÿøömÎì½ñºAïÕ±@ßñ£Ä™k&ìÊj|d‘ÏÙúÔàÛIgòK4òÎ…;_عÀ~ý_ÒóÖÅkßî{Ä> üÜ®+/íxΘ‰Ò烻9ÇM·Üuò˜’Wyo‡q‘âí]Ë›òßóº[Òµ;ú£õÝŸ5­Sßq5ò¶«ó ß3èrãCì#v ýÅîò½àñy?ùÅm£“û=Ænà7¾Wû¢QÍ Ft®ÓÆö¼rÅûoJï;äòë«—Û5î"û­ßîÛääÇŒ{¹ôaɘƒÝëxn]•ûr¿ªµÄzÆû#/œ“ã]Ù žßq§Þ“çäÿcG8Ÿ=“V^ë¤MÑüz#ëÇ%ûú>Ö~½ð§»s÷sñ½ö'ºG俱à»xfë»Ñ´ûv<Ûm߃Ñïì.ñÆ%ŸEk»±v¹Žugðë[ÏmÿEΊQÆõäyÀcØéµ.ªÖë°“-Ä­Øü¢ñ‹ì‰ñkç‡ý¦†ý×”?¥?ÝèxËíê7Ûýëº{ÆD³:]:¿æ1E>_â,p躷»ïˆ,t¼^ñÿ—þb‰¿8Oü&z¸7ºûÑþãŸu<‹=þyÎæzѸ ~S~ o#;¾&ŽÄn­ízS³†]nsÜm¼.ûÂ9ñü¼÷†*ÿÖ'ïÕDί®uê û÷ƒ—á)ö=ŸòsœöeÃÀ ÇÕx¡#<ç~þߦï+ürR Ÿ ~sùÓçµnµô~ÇS¿=¿´ãm»$ñ:ñi w$ññ ò%½—òy|8Äy é=ñz¸9}ð×ëÊ¿ãsø^åW9ö2“?àýÁ?Î+(nGc7:ŸÀs€c/äüÇΙû;n*ªcüˆ} Ÿaù”¿±B_ ðõÊ·ê~rQ»®¶3ØaÇ_ÂGœ7û¾±Û{*o|aùöÆ{ë'ì=å’¦Õüàä<”óYúwpÞm´uò{ã§À‰à1Þùä\ñçßÝóÁsw–Üâ8?BÞÄ÷¥<¨ðg‚‡å/ñØ%òœàQüÛªºyŸWØÞÕòLœ¿ìŽÆ<õ~‚OeÁ'ä‘CΓsä{+ä…÷‘ü'ñ°ìÊÚ¥ÃjÍòçb÷ô9õ·)mouüC¾ÀçÙ§OßskÞìe?CÞBû2}Ïäù|â·bú¹´Ù¢Ïßœçû%ŸÎûÛ¯ËÞ /ĵÚ#­_~rµ ¯fFSç<õÏÕ+î´~ ÿƒ±ŸÔ'Ðâ­ÕÝZüñR÷»“¸]8šß`ÀØspò.ã÷ÈW‡ó½ØkòKë»óà'žs^’üìª K^ê\òRçeÑ7òaÎSÊž"¶Ÿ jV¿~›“øFv<ëêý»â=SZÚnû\ôÞûJ íÐñ­ÕI¾Uú»¼èìÒK§=a{ƒßFïCì9ñ ñ—qmàŸøwçuÄIìyâüÈŸ‘ žF‰÷G®ÐOü¥ã)寱ãäÉû€ð¿Ø7üç }µ®“WÃ/€OÿøºQµ¦×ŸkûGžÉøY÷¼!­ëãϵ?=ÿïužÃîó¿S4'¾V~y!Ÿîæ~y>Þ“øŒÏçüwoéxÇê‘ωÇ’¯Ø0á÷7f¹5©#è¹wðú¸¾UÝKÿÍvÍú¤8ÿ‹~sþØ%êEœø {ˆÞaç´Ÿ,Ég+ƒ|;>•þòsœ£ö·Ù?ò|Ø7~9@Ÿå‡ðÇœ¸œÏCNt½áŒ ›tœÀ¹ oä3‰‡\”ùàœ—¦]>ñO×E‘WŸ/8[ñ>÷äúú¤÷"®/nêV·õEÕŽ-öïäÉñû*zû®eIû¦žƒà‡ðÿàMä“s¢îï¸]ùìÃÞôË­ïÿˆãî\ÀσÇ|òKâ“r~•x{ÆûpÏÜ+v…ø‡ú,¸;BݽÁþ¹ß@q;çÊ÷/Üîêcömu}û°>*[ååu¿G §à4Ççzô‚¼ò‚üŒ©ðÉs÷¿¿Íç…ÿðìòSŸ,±˜½Ô¶è{±ú~XözÍE7ÜûdÝ+üœÔ÷©Ç9ž.å¼yò×È1qΞá×5?òñÚ–_êu义ßÁØCî=µœê½©‹»ž¥úœž÷“= ó$<'8\I½ 9%Åó"·Úãe;Å9mštÄ…O¾8Ò÷‡¡×Èò¾Á‘—!߉>ó®ßÊ¿Š·Ûq*q ùªÐò|àíW°œ!Çü>ùç¥õ§öáF³3«.oѬ±õ9ß ¯øpù.þ¿æ$œoFOŒßeð#|~A}Î3ã·Âü¬í¬þŽü’çwº¨Ï'rÎÚãíYRgâßdD»•ºøŽ }m¿xŸ0…q.ÄO.¾2íç±÷Zní¥ßü;ñ™ý~_yäÆçŽ?ÞlXöá”çÚßÍ(z¨õÿìïÁ>W»^¬üvz³ãê¢ú;~‘{#îçsÀåàpì*v?17§×]'}·Îõð1xÆy Õg‰ûð_üÉyR'â÷Ü&y÷ù*EþécÁþPGÀ;äKÈŸ¡ßØ3÷mȾSïtŸ™âü>ßÃþoð2~Ù}&²k|¾ûÆRzêø»h¹’¿±<ꜰ{Æ‹Âcü;÷Ïy‘Ï7žHÉûÇ·áóTõsÇ[Õ·“þ,ÅäɉW^[÷Ãâ95–gíV´ýÊ›Ÿ²ž’²½S|C}¼k{Å{bï¤ÆÒ׋ƒ~ ¥Ýó~ßÞx˜ý,öùçù¬?²SÎg"GÊÿ㯌K¨Ó*þ€c8'üˆë‚²ôZÎeðCøaòÿä%èt}*e|OöϪOðwžxÖ}7ØCáf΃8û@Þœ>Ç%ú;ùçAõýÔuðçØ;×ÿõ}øï]Æ.[vi .y,ê›®êó±óØ%äÊubáΗßý!öËøUöûãß—ž®ëÔóá‰Çdz¯6ñ uì.òM=œçþ}ö`_ﵯ>}Î Ÿv÷@Oœ_R> \AÜNþˆ{^™Ñû¢ÙÕK&ý²sÔiÈÏPÏ&NqþB~‹ïÃþ‘—!?G~=GŸñëÚïd{E|ï~_âÄ  ~@‰û¹?òóûZ—_T°½®ï¹ã|°£ô«º®B\ ¼.ÏË÷àwÝ«>ç»$Çøðö€ø›w¾MvŽï ó5øâJì~ µãêö¿rM/ã3â(p/ýpœƒÞÃu£bß«û!&y÷ç;¯,=A9ï0Ÿ.Ç_s®®+©‚¾ž“ó¢„sâùÂ|u7î“|öÜÍçp>Èóþ“Ë”¨Ü†¸Úv•ߣOy%¾$>wÿ}1ʇÿ;¿©xˆ¸‹ów~ ¯x½$¾¿ã·ÀS»†UøúÍûøˆ‰ã‘_öih/ýªó%²ï¶ë’‹9ÏŸÚ«õØí–CÏ7ò9à Ïqo—Ö³ò&=ïÏgºŸ]8Þ÷ªóç8Ÿ¤sÆp¿|ÿgÿÉÿæsÅÿãßy?ê²ÚSﺘüˆŸ›û@>ÉcâO?!(¹*ÑuF³ùE‰<#—òO}¨QøÇCú}°ÛÈ·û$ôùØ[ôheË ‹n¿ó ÷ƒ“Â;¿­ó$® Nà<ð7u>ŸßsýN}eàkê¸|ò@_qþƒü*ò‚½¿ßãÇÁC®‡Óß$|†ÜãWÝo®÷ß5ø«^Þñp´ô–Λ÷Ñ¿¢™“Ë/¾¦y‚—„è›á~7÷×P¯—œb—¨» àOÞÃþ\ý<§ý„ž“>Û1é/v;KÜÅÿ'¿ƒD_Ð?ÛÉ#ö›ß'#^gà·Büã>Ùpçù‰Ûy>ì$¸Æù*ð ç¬þ.Îß~†?‘[ð“ä´¨qË×Ztþ.É[ÈnƒCˆ×ÈÛ»~!;J^z°ãEêàúü.÷y ÷åßx}«ï}F?Á—ûGœ³`èqoû<À7î#U¿ƒq }®ò;Æc:pqyYå½Â|ò€½¤^@^û—ðyþ»ìùêßà]îÁù"«ó$äaÔ?íyâ á>_çm}^æÇŸjµÜý2ÄŸØú¼¨køy%_ØÅ3þ\ê¸è…í2qRsÏß,/YùÎ ;<DÞ…sçó°?㦕«Ý£a¡ëëè=ö=sýYx†{!ýöƒÑë­ÚÔö ¼Ìïc'ˆÉ+¡OêCLò©ŸOütÅ^=ýrºß“~Sì2õMòÜ|®ìFÒ‡!y¦’¹ûCòÁô½ÿµ#ùêü)ûŸÜ›ê˜ü;up yç×ÕïþK—>ºi×þü.÷á|ƒäÖq ì v\ßCï©ó‚Ë‘;p#ø{ÂýsOà}÷‰ÈŽ’Ç§žáùè÷£O>ü¨?—:ì ~ˆ~úd]GfŽBu$ê9̵ð¹Ä¹ÎsIÀø ÷O wÐë8MyAäš¿Ë%rÁÜžäÇ}¡ÊCQsâ俜Pô¼’âEç鯧+ô³àcÏ­·"Ÿäœ/Q¼„\-[ºeê/ëo å=ÑO͉rä]Æo€çew©ÒO¾´ŸÓóS‡á÷èûÁq¯Ò#Þ£Øsÿ)?ä¥Wøoä‡úŠûb˜ßUþÚvNòîþ*ýéù7 ßÏÏ{n€¹ù?ý|Ò‡¥ûçñ®Û˾£îûÑçâ7]W¤†> å¥C}wýœù2á]Ï_ÈoúO='rÄ}’W$Î OÆ!až…ï÷¼sô¡(oâú•ú*¦vM›ùâå“}þÄóØü’ë~²¯z¯dÎN÷Ž~ùœõ^ÈŸûÞ¤7Ø/çaÈ#éÁƒ<}ÿΣb7èïeÎ y’».˜_Âx^Lù4ê¬È»õ•þòëÂwÈ;ñ½ßW¿ŽÃr?ø{êÌ 7ÄuÄkœçšÈ×ÉÞ¯>®é¦­ÑxË=÷ËóYÿÐÙ[÷³*¿éx[¸»ƒÝ%îrÞY÷Cü‹<ÒÏŽ}à>‰Ép/®/ê=‘oÏe+CÞŒ“ƒù#ü‹ùÏî­^rÓȳ¶?6nen ¾Ùð)òa}–ÜR7·c7~=iêôV÷µÞqßž’ÝGŸè«ô{Èß’o¡O‡úxŒóWÓ/纾\ˆ\0—å:€~\ˆ\qÜy?Ï—Jž±'ÔqñKœÏAœ þsžLþyjú/ÉOa/ùúSyNç!e¯—ó›ä-øì>} ôszžFý)ä™S#oN} ¿€œ¹Ï»$¹Àþñï䣱Wè»ýªîÙç¢þFôgæ¥/6k`ͤoJÏï¹oúÐõyÈ ñòù]ÞSîè_Á¿ô7$v>%—I}Qþ =óÚàô {l\¬{¤ß»ä8Sï‰þX®Ñgá)ô’yZ¿ðõ~ æu¯è¿âÚ„ßDòìùx呸|ð(ù[ž‡|z‰_÷ç0?¢÷öÜNêü’óÕ¹ñ^Ø ä€çàýÝG¨¼8þ‡:¯ùaÐ}¾í´ô¹q¿·êGæ anG¿‡½ÅYõ'ò÷ý黯>V«R‚3àS¡Ï|'\Æ÷‘_6/ò[à êLämø}ëäçy=é×À£ØòM§½öç>gÙü÷„æ~é‹ó炇•·Ã8Ÿ-ÁûŸ¥_ƒûäœ<çüé9='(;K?>ÏaÞÉ^ö†¹4ÎQ÷ŸÌñÿuÿÌI{ÞBχü£—È!uKó ȹ~¤s4_€äŽüŒùq$çê[óóq~žËf^ŠùZ}?òÞí]¼ùÇ({ˆÜÃùRÏæ÷dGˆÈ{—É/àgñ+ž‘üàߨ«ÇZ%¿è/ò¤þO?‡åSúF^wï¤uÃvÿÐçîsнN?ó«ÇGœŸàæoä§ø>õ•›w ý }Bä1<‡.ÿíóTƒ}7Ï’îßýèñåš&~Ìs(nÀNéym_ÉKèûl÷$GÌÝ`Í×À9/©Ÿà÷Z >?0|ÒwGÿŽì™ý%óøÌ©3Ǥx œæü¿ôûæùeÙGìñ.uÏÑëyÑ+÷ép_ò»Ä­Æ½º÷ÇêóO%øWò@Ο€cCôPvÍzϼ²p!üâáöý‚<ß+y õÌqµì ý Æuøy½çg?œ vÛv&¼q¿>ú/½v>”¸DbÂ9Qóo‘—Ó½9îÔ9Ê'x\.üâ¸Br‡]€ç€{‘õçŒ]ÿÄOݯºÙy<úÓ¸Ÿƒ]gÜòð?/aÿ†÷©ówxòd·à7Ž Üwéië×À{íyîG}‘qz¹´í«2g˜O=½É€ VþØ1Ú÷Õ£yÕŸÚe~^íkŒ4®Ø¢Ü¥ ⌆3\ðò„8=Å}õíøV/t3¤ã#*¿ú$üëѾ´Š-k=5s€‡”¸þõèÀˆø•2owâÜã´Kúø™_'ÚÏɯ±ÿ6Ú_}àK97·³}åü$çqZùæ}gÌ?ñ¨ïÌŽöG/|Þôà5ððFû{¹!*º ^SpûÚ‘Sóѧþ¯]O ™a<ƒŸ*ê3&³U…ýðåZ¹õ9™¿ÞpïMHñ³{ŽCþ3ùÞTŸ¼³øÎ?ÎhÕ÷àôËö>øˆ½Oˆ{irdzÞÊÄžÁ;lû€Ÿ?¸yýÆ÷¿º >äèàð?ß¼sÕñ~¾¢6ê;¦µyòÓRû+ð—ð‹G{[ ›xö©•¿NœòqΚF·Ö'Î8뱡ïÖ™æß÷ž…€g7mⵋ¯;¢sRoJõ#Çk?¹czŸNĹqÚñË[3guœ®ý™’#ߟâ ß³p7ü¼è8Žç‹3²æNkš}S‚Sñ|üÆ¡â™ao‰íȾÅûºðüSÔã´‡ŸváOÝ=O¨~ô’½%ÑÁ%# êÜy‹Ó~é}D²S˜ã³=Ù_úÚ¼¾[²§Àz§ÿïþ¤à¾Ùk;Aœ…ýѾQpHœöòyKFß5Þdã òŠû~nÃ̯è«6/Ú…Õz/ë±ß|çâqvß³ÎÇüÙšHöoj<Äâ´Ütåúç{X¿Å×o»{ðþž#>›Wßû_Óµ×>kɯõÌûuSûe¢}âs–ÒŸöýÖùçàï½;íûŽ“¿­ÙÐy³ƒ•ßùhJ¿‰ö#éÚÔ^Ü.Jöœ²'ú?}í¼^sí=/${³R÷ëÏ?8é­1Wþ#-:×½¤v×8ýÖáOtxùî8½^å™Ù÷.ôêþÊýÏ©ôíÆÒCë“ð(¼çÖùá8mÝMUçU3RûL£ƒiG|½àðM–ç}÷ zråqø]äýsœ%ÿã¼™pqœVõŽF¯Ô{½ôdáGöžÚ.£â#·=ÊèÜñ×G¯ðþV=·û•™Oây‘CÞG~Þ{ã%ì‘ü‹å`ÿôªo¿=úQïm±¾J¯¹ñ °WÊy"ô(ãÇëJ·|'/ù¹óÎzãÂx. ;HÝáÀÄ ®¾~YoïÁ“žbÏð«QQ•;'|ôʹqz»^.XÕËúOƒùÈ5ŸŠ?Á¾j.#ÙÿœÚ?ï>>Ý~^º8ýÄ•[{?ñ˜õRrc{Œ}žâç±ßäsÀûÂãqú¸´’§®ü4:8­q›…7Wòü¥xÁ-Ïô7‚ÓèÏþcîŒý!Ô)mïBþ~ehý=ÒSϕóók[NµþC‘wâÅQì HpŒôyß ?ûªâ›Þë‚~ñ|žyŠ„ÿ‘gÛYÙð úœ#è©õZø‰ø8ÿ+^lߦñUj·=m ÎU^J~Ïy2å…=$}ðïa´çÿa R¿¨q>ø;}y‹ Y;÷ÇiËŸ\8¤L]Ë-q}ýE5ÖûjþHË<óÒ3Ûw⃇µ»|âk–ô”>wöàÏècݳ¥éóßqdœþÁ+מQ}ºõ#mVÿ‚~C·Åé#{ßsF<ÚïA¿=r.aO†öÚŽh…õ¼{ :ýØó¾,D¯­È;zƒ¿@OèûP~Âû˜ˆwdß¼_,í¾Ñ·—=â úÍmÙ…=V¼‘ä”ÁNóÕìÙ‰Š¶Ö¼jȱýØoA¾§ÿL(p¾ <¥û5.VÜ`<£¼ûgœg¡/]÷iœ­ûrÞRqFrŸšBÏ$wqÚ¸ÊU§¦mñ½*_j¿.Üç4îôΑ;²¼°ß#}ÍÓc+å$zL^Ü-ä8¿ ®e)8‰ówÃ+ŠÁþš‡Có‡Ä3Ü{úY¯ýtióÒØÝ8íõq7?µuãmö‘a¿ñÿð©0ÿG>šþoù/ü„ïYþ¿ëüÊþÍ}wÝÞóûÅŒ¦Ïß°ò’! ®–¼‡¢ÿÌù WÚjü¬ý.¶3è•ê*qúãQ×óG_å<ñû õ¹ŽGÁÊøó‹–özoeί _ƒì ç…Æ_V~Áö=É‘Ù»Ò 9_L\'{’àCáùmö&x<ʧ ìÇŠö·Ü_fpÕÓl'‘Åþ>Ù!ð®ï{+?Iü âóÿ%Ü¡ý?¶#ºÿžq»îYs=Þg#yLü¾ô|OÖš;V×{Ÿ÷ù‘gɞĥ?Ÿ²¤×ÆKà/ç ´¿ »@}‚8ü }­Þ?€?&O„ÝÃ>ãgäßâôÓšw¬”|~ƒý~Ú+j{§}²¶oØ_ð ÷CÞÜ|穼*{³’{”En°+Ø{ÞWò ¾p¾„¼€ò@ì5µq~J{Œ÷ä¿éÛ Ÿ9ÁÏIŸˆkÙß•àén0~Ç_€Óx>|eÜ »I¼I¾ÖöQyç3Tq—ºGïc•Ýv\†½Ä>)_dÿLþN8#No3ø¹1|<yrÉ[’Ç”|齨s–øßþltqù\%|ßÑîbúíxü¡¸–=ò¶óÄäkxoôŒ|!}óÄIʃ¸¿‹ùÖpîÚü%ôS_W¾Üæ>Håíù9ï¥Q]ÇsÎÏõ úR]ïP}—Ï…—ŽÏg>Ù¼øðS‡V]’¼2ýUØócªÎêþMõ†ýqî'W=œ¾ó' ·3?JŸõ7×ÕU§`n”çg®ŒºŸëð§ó0ô™Ïž(ÕÃB~ó0Ò‡D?°æšÌç©û¡cú¾B¾}÷ÍsþêÇÿ~íØ‡†5ïaWêIðPOfž†ytꃮƒ)Olþ:æsäßá¥pÝÞ^â(å¯Ý_ y`ÞŸ9r×Ñ%ßæóÔsÃ#í>2Õ#y^ô€¾i˳>=u=”=hzô0ìs¢nI%ùÿ•gn¬þHÏQyŽF}'ôY‡3÷ë9ÕÑü<Ò{¿Î‰zì¯=°åþƒž?£.LŸ…ëßA¾Zò\Ü38=w½“:)|êgFN¨šoEuqêÉôóP¿³ýQ>€ùs˹æ yúUØ;À=ÓÀã}$êsÀ~?‰:é[EŽ¥wæEÕòè>æ+•'oÐ× }IØp?s~ÔÍ9?òv¼O·»É©Ç%ýñªëc™+¢O‰}5ð÷Roà‘ ~?ìãïô£Ò?BÞ{Ç4Wé~!ö:IÎ<¥z´û`ôžÌ™`·oü;yæéfÃ}QìYHÕ}ŸØ×­±C’KÎûfΖ¹[ó*Ò¨{ ùTñ–{ö¨ß{ÉÞ%Ï>sÌxë!v™þ_ûeøé“S~?ÿ–÷7Ðïô37OÝßsŠÒ#æºÐox|˜£p¼ï)yKúÑsøx忊ÍÑü¶ìÛñ^ùGâtøÈðØ[ïí’œÿqoÌ“€óÍ›‹_¥ïYçÀп‹ßæž=/*üzîþÙcóH׿ƒp vÇó¶z>úN8ñØ.šçš9=õÁòþ¾ù-ôÕû>ÙÂ\@ Ç8ï…_Å^y ý¢à8ÎQý)î÷Ò¹âßÉ+±÷ > óåÀß ~3Ε>ÎÉû¨„6Ú±â‹-}=Oc¾Kíñ“°œR/0~`®KøÃûAtNÌsㇹî?ú/ïu¤¿Eþ=ä9Ì{¬{ ®ƒ>£‡ž xˆ©/ Oüžùøe7سà½zòïá\‡ç àç]ExNì®ç0¨ Èî¢/Ø7ò&îÏ“ÿåçÀAà>—{aîzÑž»ŽœÙu»åžMp Ÿƒ= ç #æÛ8Gü}÷àì$þ¿ÿ vÀ}ÈÁžTüó€ð ⿼wCñþÒŸGÿ¾ÎûˆÁn{ÎArk\Âü²ú§Èû`97ϹÐG¥9U÷ÓwÉ~TåU±¯!d~;Š|yNCïC?8œ‡=5^ úÔñÛæ'aÞ—x~å¿màûðžÙiú¹yNîÏvU÷J_1ññ"ü?A,Ù{$»î+‚GÂýôú“¸¼á}ª›1Wá¾?xÇ4W@{ˆþ¹^Ï %¸Âs…ìÒû·€ó‰³¸oóÙj>½aìyr¼ì˜÷r0÷©ï'~AB~p>ÿO^ýD~Ùg>ùeÞ‡8z4q2ßëùÑ€Oüœ÷tÐg,{ò–Ù^±wD~’:|¿ÌAÑÏÆ\.öÿÄs"GÈ1çêynx1àÓ‡?Iù ǯ:?ðû?èÛu?³p8ÖxL<0ØIâ2æ Á}øó0¯´àÂæ'ô¹f¸õÎq¦ìŸçØ›¨9päŽøÞ:p <ôÿ‚ãÉw¹_<vF8‹ø†ÏGïðkÂ3Iÿ5yùWæñ½·›þdæŒèÛ% ïVçÄû`?­—ºã x²OšG2uO~>ïEÓ\€ãvÅ-æ`žZ|-îf€ô »í½MðJÀûN…OVrž'O`¾mð¨Î<‹ã+öÅ0§(¿ä½„È=}ïø#åKˆKñ Þ+ÃÜ·¾ÇüÕ:Wü|fžcIõ3û|±ÇØIü‡ã8}®ç&¥OèAhç¸Õ+‹õùÏz¯·ü!øÁÞp6vzÁ¾ÞyÜ0Êñ”÷TJß-·ÌHþ©kã·À]ä!yúœü¹àd=?øÚsõy=ôÜûP$—¶¿ê³Æ:­óD‰‹œç æ,§äC$OÌ…Ÿ°ÿ ¹bßøÝ<ôÒÇ“Á|œùbôó|?xþ\ó>Š—ÆóNÂÞw"}#ož„WÝþûCÞŠ9,æ˜ôùÄü—çQt¾è;ø¹Ã®"Ü7x?ßöû ¯‘ãâ ýžŸÿ&ždô›÷E¯‰á%åOì$ûPÙó^·Ã¹ù{ÿ]¼] Ÿ(üO)¿[Œ7Gç—àSö™*N‚Ísˆð)¥ä"Éó×q®O1þ3â Íw$|CÊ7¢oΛßÇ^%ü-ó{Äåèñ9}Ÿ>D꞊ü²Åyû9¯z²ø˜Óg¾ú›ÎÕÏo¶³‡Ÿ‹:­xiÒñŸëàûïå÷Ð÷iÿqGíÆĹ!v‡ç#©÷úIoðkìõÔ™1¤IÛhüKËü¬S27§÷Hx>Fì'rÅy’ÿ2/¦ì“ž/±cA}Åudù)êràüçŒÓܵ?ç“ãßÞ¹ííÍÅþ¿xò’ïÓya¹_ò«ðó>º¿ðóÀÅþÿàìòD|ðö±Tyhøï?%?€~ë^ýyÜ3~„÷ŸPõö:“OJø-Ám쯂¿ghµc²¾ý7ï˜âYìx…ºYÈsÊ~ç}ôÿgÿ8çØ9$û7Éò\Øaì‹ö‡R#_ î$Ã꙳Ÿ{±Íµµ+Söó¡?Ìm gøßeWýw»ÿ¾hÊìS¾û®§õ~Zžÿ²¼Â}Ë]}Ð<á²sIýJö’ç&Jœ@ž »®ý^Äòãþ^ü¥ì‡óLèx »Á¾LòFÂë¡?/¦oÔë•8}c£GŠŸ³yS¸9±;âõUøÐoòþ¼òsÉsÈ?‹ÿÍÿ_úžÌ‰« <¾…ßIõ—bïÁ=aÏÄ¿Rìçè§!Î!>â^•JæÍSzZìsä÷ŠýÿPoô\I|¡z òþÿðb«žØ£~ößÑoêføâê—ð7ãç½ø)øðy}N1< ÿïÿ/»šä%SuËb<¿Ê[“ƒÐƒÓ¤7Éç*^”ý,vß²Ÿ žQÜ"Qü~ÔˆþÉÏøßÁ׊¿üÿÉ¿aÏÐGü8xéP÷…]è7ò½Ÿ*]ö«ýúÎ÷â§C{†ƒ—ûo~»åýA v˜8 ÜÆÝÊ›$öJñüÒøÆiOÖƒw¹X yÞ#´ê{=¤Â^‚ŸGúßñ—¡ä/'~-e÷ÜÇùSÿ%?¾àÜ‚çtþPýÅþ?ycì u ÐßpþÔ™ÉGà×Á àð òB)xŒú+ûvø;ñ7uî <@<ÞÁn¯"Ì-†yÅ5I¼øòNKüKÊîøïGOø¢ûC¥‹å'8Wì†~îø»îUß`1UÌ.«>‚}•Õiák‹yß4ñq8ÿ,üîÏ ìxbç„„[B|å¿ ç†vÍGâyî½~¹¹ÊâÑÌÞ¯ô^ÇÏðÏÏO…zž(~ ý‘?»E>óóO—7ùzϪbøƒç¥ïšó%ÿD|Åù†ñ¸â–by â[ømÈßÀ#¾ââþ[ñ¦ì@òþ)¼™àÃT\U&åñ‹Õë¤?ŽËdwCäs¡N@œ@}„óRœWl$qv| îo`G¨s®Âs‰¿ ü/¿‡¿.÷¿KÀ5ÅòÔ˰Ûè‘ä¤XŸ‡ãVÅñäqÐOäŠzÌ;§õYvõ[ñ÷þ<ü6~»ßSïG|í>;ñiqØI>z#uZâúИó&nò.å³ÜÇ¢y#êÉ<ugì¦y˜á‡RŸ ý[‚<$õ_÷ã OšÇT}îW‚¯’ú9}+²ßäsé7Á¯ÑJ]ÇùXÅ!uSú)yoòÒÈ‹÷‚ÀL^‚}ÂUè{¶¶<Øä+À‘Þ¯ìÁò å‰WÁËôÐW‹^ù~ð¬y‚ƒù"÷/ê=ð‡ä;ɯ2Wáù-ÉùFó J¯ùyò×äíè«æüØ/G^Ž÷G/‰?ñGÞWKÞoõÝñûÔƒÌ-=bÿö‹¸ž{#Àù¸¿~rx¥GÞ£ç0ÿ´úú‰·±¯<7çbÞ=éu(ë©òMì‡ò<sôÛë½mUÇàyÐï±Ô÷˜/^OxýÔWãù$õk¹šú¼ìðNÃk¯>êYÔ!èÿðœì<øþêðÞ«û¤ÎÎñœ[ê<’8ƒù ½ñÏ9}Û÷_uíVßy5÷±_A~ƒº›÷ÿP‡V¿}côy×Ñ‚|‘¿·½ߊë™Ì—é÷¨ëÒOá<¸ü"vóDÍ[Êþý<üÔoý|ìg–ÿ£¾bþ[õ7Ñ¿E¿uoúmð»Ô]ñcè¹ç@èóPóŒøsï—¤ßyñS˜·V}ñàZì‹yr%Çä)Ýïõ×ýUIüÄ'ì<ûa‚½Øî㓤¯Ôûصÿ üëù/úñ™¤I÷„Ýt_ûDdOà«"ŸGçÌèÓ“|²Gü ¾ ÷£Gô×Ïóü!s%ð´Ò—ª÷ðü@Ð?Ρ¿È8‡¹eý>¸ÞuoÍ7:ß§ü>{s°àyä‘}IÈv—z—çÐàç ø±WÌ1`ÏÐCÎÙ¼›ú}äš¾ð®ùvñ—A?‡÷°wAçg¾qønéCPÿí½Î| ¸!œ›GÐL_ òŽ^ƒ ÁEøì çQlß§ú°¯ð  ?ä ÌO-û„œ9^€Ïù`ÿ~…9-=ùD÷¯ ÇP?í¾õY¿nÀÿÐ×Hžˆü˜ýŸž‡x<âùî“ýr앨_Îü×Áþpóæêÿ£7Ä÷äß¹Vì/yóøòÞÒò æç‡g—~]ÙϵÃW¬?Éçxï¦ò9ŽoôÜæ–]a2<ïûf¢ì†÷^ÁoÍýë=ˆ+ýÏÞOË<óy²c®‡«¿<ô[Þw?1}÷ì c¿Œ~Žùqï©Ò½xÞ„yá ü?¸†ºñÉ¡ö68Nb_þ?øŒ÷¤ŸÜs’?ïS„ÿZ§Äq4~Nöœ…ÿ ÷¨É»*>8d¿#ø—ïµý^2߃âCúÂá‹ó{Éþ!OÌ]x¨òTôW·¹ì3çÿ ~ÍqŸÞ;A?=ùDòèì±eÿ•úÿwI_…?Šå¥C¼ ωø”~.ú‰‹ù;vÞsãŠ÷À«ô롇ØWçOä,O̳°ßŒýš:?úïw!ÃKé)÷Î~Eï«dÿýrìq‡ïR~<?!ïé8JúŠžx.½r²_øyÎ ¿l^ö8Hß±Ê šGŒ÷!_C½†¸Ãþç¯<- .`ÞCýœ+ùHç[‚z8ù\úµ½;Hºâ7ïGaï–âXp£ßWö<¸žñ¾%øBrOþ‰¼d¸¯Æû¶TOãžèg$Ž£^ÁïKn’úú+‹ÉûØu~ŽçåO¨âw½W\ùÆð^œ¯ã~$Çø;äï#ÿeþö*®!.ö¾çH܇ÿ°ÜJù,ï ×ïÑ;ö?*ÿKÿõ çY?n¼Á¥ôûâó!¾aþ€¼‘ðr~xž›=xÊà ØQú];’ôy(/ä<†ôŠ>¼pßœ÷Á0o„þ¥ž#9¯¿ÆÛ®Ï0ÇBý ½¤Yû>&æ•ÿ"NÀžÊ¾'ó@š7"> ÷"ä)Ä÷X ¢Gè=þØ~Jù%ò%œò©úpØOëú ß/œôc ·bg¼Ç”9,æ ´ÞyÅØìõ Ο:õ*úEñ ä©yú•áõ>æÁà%?ÁîxnDòÈ<#~i^*æÚ¥WüóçÈ'~ûà¾Cáiò“ĵøEþ®çOæÅ4Ÿí9mp€â×ÓtÄžï.ÀžZÿä¿L¯ñrÕÝ‹ŠÅËàúˆáËà\Ù C.÷è8Rv?Æ‘å¾ù/ê÷®¯0צ{6”žúeXŸå¾B»€¾“ÇÇoó\®ÓPg‚'~+ö;×ÄÞ+ýù-ç‘u¯¶[ä7…Ÿ‰/½·Hò‰?!ŸþDn¼o™ú4{‘Áò+ÄèyQ×Ù“®91ò³Ä§äŸÈßq_è‰ç—™WV|‡¾9/£|.ûzWÈÇù|ñOùDü²ñ¬ê.a =Æn{ïyK=?ÿ?ÆsÓÏ@ßõdøuÞÆÂGŽ»¨Sêÿ#ÇÄAaÞɽšORÏÖðÏÈ üºœ3z?-<ðÞ§©ïŸ1OÂÏÁ—J½Ä<Ê3‘ÿ6¯“ò¹àçQuœ—ù¢à÷TJÆüoµ~à,ª—¸ýÞÅßb·ÐGó°ˆ¯Ž¼3}3ðÚ˜¿ü…ä»gžOâHý»÷Î+ÿßâÜðWØ_âðþ¹Wî‘ùÃpÞ  o-çmüI¿y@éòˆ]öþíÑÀ¿m ö¶/0×ožÌ _^£§Æ‰àNɵó5ì¥'¯ªó4ªô›ýcàbìö„¼~×ùZçáytÅ Øuüò+>ëD„³<÷.®EîÂü³yO$Oæã„'QýÎG›AÎ÷³Q\½ÁÞ›¿HrŽžPCî‘;pö ^š°ŽBŠzS¸Ÿù‡zß#|"Â¯à†‡ÇsÌôqéï®+J±sØòºØ/îÓûEù=}¿ÿÔ=›gJzâ¾hñïðüöß²+à,ð-<÷¼·÷BÈÚë{ðûøGðý'Ö#xY¤?ÈøyÀ#_ð~;Î_ê~ÈŸc?ÃwJ}ƒüù^ÕÃàép<€’Gøÿ½/Eïo~fÙYúnxNò5ô[{ÿ¥~>vúî°äUÐ ðçDß.ö•¸|£¼v±=æÈ‰óÑÒC×!Uçƒ'Üu7å±èÃó%ø7Ï·ÃgFÜÏܼöGy/ ûÁ©K)Dž˜ôýÈî˜'}Ó½‘÷rÝNxÒü¥²£èx;ëø}í+ùù'ä¿n}–±œèùÈóðÞà-Ç-²{|xÅýªì/nõ>Qö[Û§>xL¸'ó¹oP{Ï÷pðÐ7I½˜çÆ>ÑG‡ß'/|yjçù}p%ûxòòÔ‘àqa΄|˜ãáú¤åâ͇5ßòUœÄ㪛—Fö~Nú®±Gä{ÁEèöÎú sØôo#ŸôZ¾d/ܯ§sGo‰ûÝ—¥óÅÞG²¯‰>Y>¿ÈÛÉv›sà~ð³ôÿP7‚÷ß¼–’êáìÒUÏÏ„ü‘ôqr_ðµ 'Ž÷eçÉû[èG!ÿ€2¯{ˆÕÏ„]å½È0wÄûðÿÝ竾5Î~Xì?y%æÃÀøUêýÈ3òâ½Fâ &oåü˜ì?ö<^¤Ï ¹u½@þœç<¤â{â÷ï*nå~¶|àwx\Ï"¯Ø[ôÿ‡t¿cgø<%‡¼r@ÝIñ÷[:/¡¼Ï>ð{Ìý0·ÈypÎðK:¯­{¡îÖ]øÿîO%ϦŸÃO“_÷ÑG…ó¾àc÷K“'"ŽG¸/úñ/ŽƒGòžæmþ§yWroèu+ô‡º¥û~¨ƒ¥È?zˆÿq^ÆA?™ç9¨ÏK^ÈkPŸ4ÿ´ö~ós޳á_–¿µ ì}xä%‘'ë™ä˜Ÿ³×}ÂoJüîýÝAŸŽûוÏ 7¼7ù;Î~_úàÁe®§©¾B<‚]¥~ïz‡?#®ÃÏñžøgúTKo¨Gqü=lÞ·A ûÅp®Äôg"ïÔ7§R ê^¼ö€ûw¾]Ïòæc÷‘{ôßòô}!OÄ·ð{ºO€=òËð¹?]ç†]à9õgœ9®V—J ;úý̧ n•~ÙN€c…Ûù|ü›ûÜdGÍ_ Ï"û(ðWÂø3ä—93p>zöñ1_ÇsÙî×g3¿í¸Œ¾eø8á –¼“Çu_uåÝÖLØ•ÕøÈ"Ëq¾Î£¿˜çÆÀ;Š{x!‘_ä¾6û»ãÙ öBùs‰ÓáµU yR~Ï{ÎeÏì'ˆ#¨‡È?M=uçàoó‹Ì×ý¡÷ä9”GNûþòhòçþŸ¿ýyõ ùïᜫð\ÚÿÒÇ¿Ωòß9gæˆôgR×LÝסαØ<³æþ×Þþ ñ…sÔ®“ªn}ÈÏQÜtÈ®8Ôœöÿø¹ƒùÔb| øgâræE™SUÔ!??äo ù8Þ¬÷#™ƒüëµëðÜç ?P±Ï 縕ÿ_“æ«™#g.Œ:?v-ßC~üÿæ!>è+;Ô}¸¯_ûQþÛïð.ü?Ÿ}‹\üÿû?÷ƒö/ä+ý_ÿ^æÊ¹gx6ÄCRìçý*ð?…übšïöï‰'ñoŸ<,|ûý^ÞS–âQI>?à/Án}%a}ʇǖ~í>4¯˜ö}x.ý¯¼PûÊ üß_øã¿ýóŠSÿÇ߃â¿ýyñ$ü·>àøÛŸÿ{òŒòçTOHäM}WÁ¹…|ÿ]ùƒoèÐÏ)9Q*äÅ<äï©îXŒw> 峊ó­¦ú É;C}%àí(.÷Ê׫®Yìßá#ÿ£þ´¿÷Gê+¤˜¹ØOJÍïD¾æKþÕ·ò¿æw47ò¥çIRžBrò‡üí9â—8Gó‹(ÞËû¹ÿ/ñšó}š›ýÛŸWžçÿ5ÞJxgÔwJ=Xy×ÿ6> û)'÷ y,‹ñ“Ó¿ô_&畊«‹}¾x­þ·â¾Cþ>|’äÅ©§…ý¸âç:äçü7Ÿ÷oŸ^”À/þ_žúóÿÇ¿'Þ;Ï=’ù;{©>¸Cþ;ó'Á^‚âxH÷!{ÿÿ|?ÏÙ\/·³ØsÀÇFÝQõƒ$_ ~é°9àß;´|Š þXÍ þýðߙӃNJþúŽá?.à•:´ßV¿)õŠ€úïx@™»Hô]ö†çüoO§êZû|!ÿrÈ~ ý%ó½ÿÛÿš?;Tüp(þTåáÉ£Lÿ…òï!?óÿ4_w(ÿZìçàc×<àõûïÛÏ¿ò}òç¼wIõOå}CGaw”ßð¿‹¿øÐñ®æí´7 ¸¦ò§ûÜôý<®ŸgLÙЮû9Õ‡þöó´÷âÿø_¥ÒÒŽ;ÝùpêUÔËdÍ)…û¨éû¢@¿|<äãy~޾EúIt½áŒ ›Lúxé'gO¨>ϼiú¾ ú:ynúLè_¤ÎKŸ$}´Ì'xÎö?õ‹v~Ï-éý™Ã2oŒêPôOû}ÕÏN¿}T!÷MŽûúÙ—ª~ꛜ?óü;ï§|H²7“~]á§ý-÷—\õ4×…yúUÂ9Pò–ÌËpÞÔã¼÷½œê³ ÷8yž^õQúw<רz õPäÖý½Òä˼{Ô5%§øu¾—yvïa•üH‹ë^R»kÒG¡z&çI‰~n꥞#U?}Bðò¹/ˆû“~qîî#’Üù¼To6ï”êûÌq!ÏìÙaÎ~Qäšx—9ÕUã´ï;Nþ¶fÄF}ר!ΛûFOé?AÏéc¡ÞJ?rCÿ¢ír¨ypË•~Þq¼ú=‘ìçZUäÿóœ¶OìÙT)ú.3ï{ÚáçaŽƒ}fЇB½á¼±{ØÏ›Ëú^ÕŸ‚~0‡#{§W츱êê’>ÍW¸¯Bv†ç¢ßÏçûù\×u©ójÎÉÏ+»hžö¢Áë&{ì=ÙÂ?œukxJégó¼¢îZÞ»í9$ø?$ïÌŸ OèyX/ñÞsùIú¹gë/ï!}áý9¿p?<ý5¶›ðoÁ!œ] žŒ&Ïf=–?ÆîhopRWÖü‘ùŒ·|­Eçï’¾Féõhp€ý•öƒ™'ŠýÌÁlü Ÿ»ïÌ}UçUIxUÐwæ4˜/Á.c¿ÐSäÛþ4ùEüAÑ-mWót‹„/QöØë?~ß|z>ÏåH/°›|>vÌó…º'ú„±È…õWò‚~`Oá½ÄoÃ÷dû*;‰üÑWH®üœ~ø“ó–½Ð×rý¯qô‰ñÜîwWŸ!÷Š}Åo‡¨…þ9žÓvKz‡¾ïq΂¡Ç½mù4ïû$eg‘ ¾¹Aÿ=Ç®>Dþ?s?î_–=@®àOÁ¾¡?¼ö hi¯÷Væüšì_GÿtßÌ#XÞé3ƒ÷Q爠‡üqßôï›ÿû/¿m9ÑýÑŸÇ{`Ðsóٱ绦ó0N×Ë.ƒè ZnÁïÜ/{„ÙS‡Þë9‘ô–sâ>=' þ,÷'é\¬²ÃôϹŸˆ¸FçÃûì:ã–‡ÿy‰çÉÀuàbÏ+Iþx~Û]öÌ'°ß–ù æét¿–§`ïýAÈŸûä˜7•Ý@/èóxì48óÀæ>7O:#á½dQ÷½—pô#è!sÄ|ýHæ}•ý°ÝÒsÊïÆi-f6ª[5Ëþœcü¦ÿòZ…~+ܧÏÝñú{_}í ÌÑÿœšÄØîÿнF¿°¶ƒúùUNîzçMŸ%~EøÞr¤s:ÐrÓ•ëŸïás÷fcϘ3µ~K^ÁûæíR²y…™Ã’œ`×ñSÄ[ûïëþÁóO9žà9‰ÛÁCƧú=úÁð×<Ÿñ°þä|øË­ì råýÑ+p }åèýºØM~Þ¸X~ß8Xz Þ÷©ÏrNÎï— NÄî€ïW™SVÿ¡ÏOÏëùlÉ—å >IÝ‹ç „ç­ÇìÙÖsÙþHbÿ²“^zú«öóäUˆÏÌ7¨x ý _|£ÿžƒ½yp?æhù|ÿÿ€š÷&~; ÏÇãB†eÎçż!ýኇC¤_È~×ø\v‡xÏvYxÎü*ô»†s¡ÿÔï¯~räŠ|q>ñ®ú†âôÇ£®ç¾*Á¯úÇÑ’ð©å[vçw¼%žÑ'‹§OÏz)ܪ¸!NËÿîîÞ³ܧ÷ âÑľê~ÁÄ¡Åì£Î<qŒýƒöŸc·°gØSâÏáI~9OÇw’žÛñöOïŽÏ¼‚äÐOòž£S\¹ ‡ÎÏès‘ú‰-÷äsá·Q^‚û<¸dD£A['xWñ s]ØAôÜyÁ n0¿»ôÂ|ªºò5ô‘ÛÎéy°³Ü÷ÁxàˆÊ¯>™ì¯×ÿ§¿û‡⹜oÕû‚w,Ý?£ûy¾ç”O3Þ ü†å’ŸƒÿZx“<÷ç=ÇŠcömÎZØöôɾyÙü?~ð’äŸûÁ^ïð{È!øÜvUz½€s¸7ÇË:ï n…÷VöÉ{!°ëÄù²›Wßòɹ{®}Õý;ï&Âç‘·ðyÊ~XîÈ“Hî6¹cÈYoe&¼ÇÌËîÙ.éܸϯ霰‹ÄŸÌ!ë¼ÈãGxNÛpï)\Á|¯í=ñ•ôÊûQà—e¾ÕùJ=?yž°®…^÷ó<æ`îDïgþ-='zo=R>€÷¯Jò§]X­÷²ûÄrNįà#ãlò&ŠÏ].¡®C|@^Á{¤—ʃÄi¿ô>¢GÙ)–?ì½ç¾ä']O xXˆƒ¨k9Ÿ=®à9-úwúã‹©·¥ìzœvÝw#N½õcÛ£íg­¼¤vuŸ7{£[ðüÁÊï|4¥ßÄdäƒïÇŸÉOÅég½öÓ¥ÍK;E<î|“ä¾PøRÌ£/gùgß/ç¦çv\*?DÜŞ畜í½'Á|¿ç¸„7Šíu’>˜×YçAÞÖq¯ö+ðùø-ôAö%Î8¦ËŸ{žûÜç"{§ý[ï ßb<í¼±ì­ìkœ~âÊ­½Ÿx,ÑcÙ]û!ö°H½·Hw}ЏNöÎq;z™ÂàË8-ØGÄùL;âë‡oò=˜·^ ñ´ÀÞ/q¸¿Äý¢_Ä{®«ûŸÀߨÉsœvßèÛËq†ý†í¾ð“yF{µ?WÜD^Éõhù5çå¯í§¨Ÿù<ïÿP>ƒû>p==qœ¨çËõ"úNæ{œê_ħÆ9äO© s/Ô7xnãué öû£Nú7ûIž‡¼‰p4ù‚’OÚ¯á_Ñcó]ÈobŸá« óŽÎ—°¿‡z¸î™çuƒüùRžûÂb$o7ð-þ ùvÞ>ewâô‘½ï9#ðüè¼Áiæ}ƒEqq!úê8Cù;ò¿ÞG…Þ Ï7П`ÞsÙ/ÞËuøñÙŸ†ÜàŸSr§«\ujÚÛäŸß#®ß8ÏôËpÏá÷‡þÏa?°Ëû»¶ëUµËÛ;ô¸{ÇØ?Êï7Œ©7Ò_)û‡ô¡_'?ç¸HŸO¼g'9qÝ[ÏÏù™‘ysx€eÌÿì1sþFòÅïsÎð 0oN^?ãþðˆðŽâóm˜ßú1}Cò<‡ã>=óÛÈïO縼ÏÞ.áEëpëRú>ú†Œ%OÄ ®Ëéè_3¾~±=‘=¥~}à°ïç6Ìü hœA}żkÒc×å©;ë{]Ñ}û÷„ð_æ÷Q‡]0ßžô?€_1ßRêÿÇiW¼_ÿ™U±óq‰W·7ý9}´ñS'Ã{„]ôþ‡‡·ÁÞ˯z?~Hú§m©ºé÷_7$|rzOòñÔŸèÿã¾\$®#~'¯E]–}XÊ?a·ñûšG3Út¿§ÌæºÎ#y¯õü€O•þEøåŒW‘ú¤® g ßE[k^5äØ~ ¡ô¹÷˜ü(} ?ÈóX.•7F?\‡Ñ÷¹?N8ȼÝäçe¯É³¼•º‘ì–çªàW ö —ø­—¢wØO×Ãô=ÊÓÅéåÒ¶¯Êœá|‰ãÅ‹èC˜Ç²žKéwç`ל7‚÷¾NxU•G£ÎïýìãT½Œ÷VÝ-Î<õW.í|0é§ ¤õz/çï¸^ãúIß—ž_#_®S’§â~éàsÑ'çÛÒŽBŸm_å'±¯®7#÷ÄCÊ+ùüegÀ»ÎþõߟˆGwR¾ýñ9IžÂ|;síîëSß™yƒÕ€?á¼ÜÇE ÅóÊ¿’o’Ä_º?Mçˆþ“÷p]ƒ}äõáQV\ã|D7ð^:òú;Ïmü:pߥ§­_“ôg*긚|»ì~‡÷Q|§·ëÕá‚U½¯b¯‘{ÎÕ|ßäè¡_‚½"²gæVþ”ßçOïù ðƒó‚ô1Êžcÿm¯Á“úy×ýƒ½@ȇý{¬àK£>›òOqFÅæ¿öüéYë1y9ß›î›çs&ýÄú“<¤ûoè3a® œL}þ(áWó¤ „÷¾àÜǤï'ÞW§¾ñûo…xŸçr>N~&ä%óžú©éÛ"NS>†zr{pøŸoÞ¹êxç#±Ž_È¿ûéÐë°ÎÏ{2oèü*ùgé!r¥yÆ8í’‡>~æ×‰®[úy°§ô«ê=Á;ΓŸGÏSzgœw֞Р‘ Å;²#žç°Óý»¿‘:=ñ|àÿàoƒ›\—¤>N°ðré:“ðé½]âûsÊ„á ø7ù\óoâ¯ÉÃáÿ˜ÛÓç{ïö…y_ñ=ÃËä¹ágãQå1¨€ÿÌ(žKúÄç”äùï OÞÓ¤w‡äjño'ý¾#ámåþW-_UvÞGuB~„„Yù ï½W^Çñ±på? üDØÿ‡|‡ñ3ýìýó¼„ü{‡m·°Cä½å°»Žg$·ð ’GásÝ×D?‚âVóÎËXÙ¿¡ygÞü¥šoãœÅKæó²åÿæ~rá!úhéKqMüM_÷ ß*ópƲƒðg{’ðò Ï+ý€ðà·°‡àvðó+î‹Wݹó~Oúäÿàôߦ(=่O«¤Çî—>S÷#ÿйîEžê@>WæK'{Î^{cˆ£WøÎìÏÉWHÞ÷`—ž`ó1ƒÀeÌÒ7 ßYÿ˜o’œz?1óœðüy0âäÃùxÙ1äÙ}Â]ü;ߟ.öœäøGz_%q1ù='ùoç$ŸÞw(¿JýÛýÖØkæäçˆ'<·‡=cì{ØÏ`>mÝ«óªºϽë9ÝwOÿ1ùnúï¨ãч¯Ÿ7ï·êOè <¥Ø?üªëO²«žÛ×¹8Tþœó…ï{âøWzæý`ê¿ó\êðIpÞî¯÷°ÇËuvúî„g=Å\'öYÏÁß©KóþÞ‡ÿžæ8oòÏÞßË^:ö¯Ò/Âü ù9ùMâòóÞkÁ>ö ?ÂhybN[öG|˜ Oq¤~ùÀßzo ä‰xü‹¾º¾²qzÓ:öh½Öõc÷ñJ>°³ð»¯F矔=OöÍ0'̹ºßVù;ò*ÞÇM1}BÌÏ“Ï!® o“s‘ßÐî—ËÞ' Ÿð»yNOzOÆ~TÏk{ƒ} .©sâ÷Â=î£d>QùBø…x~~Ÿ<<òè¾WꬒoǧA(úBÄKc}s~•9e}ø„=ªôEø^À±º?ìœûrôýè)|UaþVyœ„ϾnøÌuÞôX ú*½ŸŠþ'ê÷„ó«úyÇÛìNAÍï¡<‰ïƒþ9õ7p®è¯û*ôÈ|MÈçðð«à`Î þåYÑgû7öèп§8Ø}s<—òäÄ7ô¯†sŸØ+÷ý1÷¦¼ùAï›bþþ¯v%©“x‰÷ã=¸'ómèOÇiºoïƒGﱋ²Wø7Ï© Ÿú=.ó‘Ô5%_œ·å…þÕSÁóèñLxož¿îc^ÖŸô͇õl÷û?²ç—¼ }çàì”ùEàÇ‘ÝF~°¯<Ÿói’ë/|àòüÊÛ¹Ÿ]zf?¤ï·Âëù<ùâÒpþ™xÃü1ªS…çÈû#ßì'ñ\÷¾£€Ï¹ãßÑOæ™Wô|sJð ðÞØæôuØKôŸøÄòJ?“ä÷Æ™ßBzc$ý¾çï˜?§î™ªÇz×} ºwÛƒ`îÖMç¤ÇÄ‹¼·íÎÕxXöÖ{øô|Bs ø ûqx¯4/Îçº?›>úÅ_:¯¨8}á{èoÃ>¹o™z|.àCêúÓyæÄ™¦Ÿ•9dÕoŒà«úT­gŸy@Tu_²ì¸íqvOŸ}%˜/¼,ÿÃóŸaé' —ÄàuÞß}þÂ9æ;QÏx“¾üšì´ñ†üqb8Ïd¼…þð}ôÓ“'Qœo;®¾4ÿý¿©{Mâ2ôŸùjý ŽæžèCõ\s¶Š‡=Ê<°ò}aÿs¤ØîœÈ½û=/A~ À è›ëÓ̳wXý@ÎoÃóð÷Çèû´÷Åv ¼À~qò¥Æoàøè¯îBoŒ×ॠ/ ¯~Jq”òïæÿsùfxÑôüÆ›äèdž‡"àEpý6˜/ ûÆ<¯žÃÓ&{?!ßê|'¸–ü%ýCÌÁw@~}Ùäñèkg_(y/æñžxe‘#ü}1þEÙ»Õ“Î_võõI~Šü¶êàdä™90ù™8kP³ V—êX0ü˜öó⬮¥«W˜¼!.5.kŲ}çÄYiïL¤ÑxêÎq^t mxá 8kDÉvÏìçŸósz÷÷âŒÎÝxôŠ8cÈìÎ?Ö Îˆ^¼¯ që8{ÉS«¯Ø}dœÙñšÛ+Ω}σÇ[6.±öŸ—ùpÝ8oK­úµ/Œs/›Ðnè§çÇYwxìýa_ǹ¥~ZÞÆ8gDfïJ'|—¨<¸ßâ-gÆy¹ ¿ŸØnuœµ«ûÆ1ýêÄù‡Õzáî#ΉK¼iË–wÎŒÓ_ßã÷Q[ãìIµô›¸Ó¿W²ì–c7¾~yœ•—³ºÕãgÐß’<_Æ _í¿~¿ïÙsêŸöK\¸ö°/ŽºxŸK_Oœ™óM›ÅG~g´ê{púeÇÙ•ž=³Òô875Og•nðíô;ûÅ…í˦çThgN9òî•ç}({ìeg·KL9ç¹×lKê=UWsw7¬ÙqÝÈ8»vÕþØ{»Ï/³r÷þ¶)Îl’S¥æÎ†q~³Õ¯•Û4ÞsbYÍŒ=ýÚŒ8ç¹Z'µú¹[œÛÿó1ï5).¨´îö¦—Þçõ9|@å#ZÇyÏ•íXýÊã¬q~¸.ý»8ý—vÛWìëç ©2zݾUqö¼òm¯qFœg½~û=iq‰Sæ4l“þEœ³yÞIÓ£qî#>{tÔÅqÉþltqù⼆ÙMZ¯¹:ÎþÛŠÁun‰ó«6ùŒGFø<Ô—ÊÙU¥Î­‹âŒUî¼¥E§8³Ùè…ݦgw|í”ëJ]ç·ÎÜõcö3qÖÄNÓë=X:Îzöú/¾l¼=ÎìÓqFÅ’µãœImFŒ¿tpœsØËñÙÕÆ%Z=°ì̪çÄ…C›S©Þ›q‰Ëze>˜ß(N›Õ¿ ßÐmq ü^ª¿9.Ù$g]Ëi¯Å¹?¬ü¡þgãÇ´šÓì¾Çâ‚Ö,Øþà’8¿Ã–Ͼ3>λÜü[ËÄÙßœ<öðQøË8c×¶¶mÚ•óªž>»uû8½Öòíýº<gÿ0댷Ô´Üê÷âì»ß”ùR÷¸ÄÜ’Ë®š5%.9 û´N¦ß9.Õ¤ðç-yÄY™´dË6ßsnó´ªwîçÆ×9æümqÚº›ª,Ϋ§·üܘ‚NqaìÛÿU%Îè=dáÉõÏ‹K<:îõ§f~L:ªÂŠsÛ3'gÖx»hæ´‹ñ qöÚ£¦O_P'κ¿ÃÊ·žºÎr”Ó¾óÚÉÕ2ãRý·ÞÛù˜sãì†7eTÿç¸Äûï\Xþ¦rqN×¼[Úæîâ¼É/Ç™o—PvwÙ¸`îæ?{çÝì÷äÿs?º‡8sîGgä×=6.ø`Y‡÷¾¹3Î8eç]ùÇí‹Ó—·˜µsœÝêÖ›«Q\mË¿íïãÌ;Wj;hYœsJï3 O8Áz…~–˜xÆò×›œgî®Úà‚šÏÇ%–ÌPaà丠cnûŒÛ·þ ¿y“Ž9½fïÉÅž3¿\þ-§,èé{+È-sláÌâ‚¥'\øHÆqaï7ï¾ý²8o\ZÉSW~j»È9æÏݹëÁRÇZîЫìrmßjuß|Ÿo¾äùÍîòøISÖˆ ‡o{¼ï5Ÿú{ÕgçVXteÛ8ÎÜüæ’˺Ù.`73Ë5½rÌéã‚6§Ý\±Î'qÖ’:™ý'Å9mÊý£_ÑýqnÙ‘õÞÿeEœ³æƒÑm‡õ‰³·¼4õú~lŸ5/a½Ìnß`æ¶kâô^¹öŒêÓãüœY¥ó6/±Ü ¯¼¿æŽãŒÒŸOYÒëŠÄþé9K|^þÝÝãÆXò§Õ çè_ãüÍ;_|þ›Wlr†ÔœUnZwßkAëŠûVú”~8wÄñŸíú|Q\Xî°:½ÇôŒ³ÊöØuÃ1ã-OÙ‡j9ûòòqNîm÷¾›Ñ*.œ¶6·Ô â‚Ý_½rœ?7Kö*»ÿ´”6ÿ—Ôûp>Ø;ü¡ú>âœ>WϾýò%‰|¤žÓ¿Ç9å­Ím”_ºyœÛaÈaŸÿ!xÈv;Éó`·³>¸éƒ£ÊHîmZŸ—ןÒßþ;ÈûgëÙëÒU=â‚öUv¾µ¹ø,ÎoŸ÷ÞÍßïö{ãŸrÊ>÷Pv¿oâÜ^޳O~ŰèÖ8kÞ»­G-¾7Ξ»íýö[é]ó•æ¿~ÍÊõxˆ<­å½Æ>ᇱùMN¯ØíÍ_è·ŠsŸ½"ãágã]Ÿºy÷Ÿ¥ý9¥ÓÒ¿>vƺ¸Ä ;nþ°Ýð8÷®Ý§o_Z=.uÿû›ïûÖþ;³ÿ›£_¬V"‘+}OÆY }·Î´D/§7½qIéÆqî‘~WíG·žd7Û ÝpÀzœ3wïU£ìkyÌT¾÷‡ß–³ÖܱºÎØûâ̸cæçÃÒŒGJô°yÒiã[ϸiQ™N–SìöŠ{2JõÉúܹ÷œ)™«VÍø*ÎêÓ|ä[vÛÏp؃œ´ÊÛße¶ºúëJýé¿ï”j¹½ûþã;—l¯073.Ù»hÑèk·½Éº¬ûIç´eNÚÏŸUiô]’à3Ù‰Üûçí._òZ>þ®ÄŒ·ý¸÷¿pa“¬ü±c\ئ ?yNÔ¸Gý€ö'Ö·óûǶzÒç\P£°î¦¶›mÿu?ô¥Æ™ÌÓi¿ð°£'Ä•JÆk?¹czŸN¶wy¯ýì¯5â¼ÖîøþìÕqÉ·öç~ò`ãʼ´ïpWWËUV4âžÌ¥ ü|¹Ó>î}͸Øz¡z¢çFs—|>þÉëâŒ-ͯ<ú¶ï|àϼԜOœ3¨qóÃÕ‹sâ3^­xÆ q‰”¾Æ g6¸àå ÌYn3ô£ÿÄ'ïèä>8g'q>÷ZriáîåÏý—\N,üf÷Ù«ðËô[î°Càxü‹ýcÿNý6öï½-9vo…q'_ØÞ_ö"#Õ§ãûú½…CòÕîÕüRÇ5’çä|eolïgÈŸû=rÜðã'O]i\¤ùà8wÞQŸ_¶°ùŸ¸pâŸû/:æ¬ä\vMÙ7ò’}ž¥jgõœ4­I±x ;“UëçE-ÒcÕ÷œø=Ý7rˆ|"ø!â[žû þÅ>«N—ÔÿÏ­Üä_³¯˜ìïÉ]SÔû÷ŸÚÆ´(]ØåÇ÷Ä©àpö܇ÉS|O¼TX»Ô‚o{Õ³Ÿýðé)K†[ì·u.¹}Îóõ™ƒ|/ĵø3â¾'«úÜV¯½rXœS©_© -³ãÜÖYÍ~zú1ãXì^á®?zåèãÂAÇòóÅËãwwþ²Cçã,×È+r6bÑ}õ;]˜ÄË«žIÍWÇy»fl}&ïûqäû7XÞe‘?îÍþ_ù˜\ášügwÝðϳÊ'~_q÷KÅs:ΔÎ:eÚ½MngOkݳ[Ÿs¿Þ•ÿç||¯ØYùìù>}Å?8ÃÉçà/ðŸ<ÆÕû?zåÈmoðÛà Ûž_÷îä=°ïØ7ì„ãá7ßsjÌ÷F> À÷Ôš5}ú§7ùþÈÃÈß'qfûÙ7vj\ò¹Ò§œYá¿â„Æ·»´h•ó)<·õN¸ª ÷Ž~}ç!ãzìOa*ÏŸýöDøÂsr%®j_áêÛ®@¾]tŸ«ê'Ô½ès3O}ÌÓÑ—L]õ’°Ù{!àG†·RuóäÁw™ª$u¶pîÝý^ðÓè½¼GAÏϾï)Q¿‡ypT/b¾Éý–ôÝó‹î—` ü¢ª›¹þI= ^nÕáõòÏ©>FŸ6óô˸ߑ>X‡÷#Á÷J£æþ¹·§È|”âI6o›>—:Žy4U—¥ÎÄšy|5¶üÉ…CÊÔM~žz›êoôU˜OQçË|žëÕê#sõYêñÚ£áx‡º·ä“9`÷ëñ^ð©ÞÄœ1¼]û£>ozðÎ'N{øùgþÔ=y~ꌪCRG6_Ûaí.ŸøZ†ûiÝÿ¨ú(õkä¹±b<\ºæîy?æYÍãÈ•ùm™;WŸõ!އϣïÂó—ÌŲ_>õÑúüà›ƒW^Qu`úzÃ~C÷ƒé<évÝT} Ü#?çþøaeG°£ô?2·ê¾FÕ+©+zÎ+à™`Δ|'ór̹r?è—÷ÒiN‡ûuÿtªÁõbøx¨³z/‹ôÉ}zð°·Töˆ¨ŒyOûJÔ7„½Dߨ ›wCö“÷FÎéŸð|™úy¼'Fz‚}ð6ù1æ_è‹EéÛ¥OÇï!ÿÁ{ØÏ¤Î;ÙCI?™üïiÞ&ú¦á¿UÝÚ|VðÀŠ'“ùxóöÑ׌>Âÿ@Ÿ{¯à_Ð9¸o(èÇpŸ <ز÷î+}`_nÈ7Aÿ¾ù¾Ø÷¤sEþÈOÈŸ 總ïCò¶hÏ]GÎìº=™KxcÐkü0ý=ô§R÷wŸ›ü/ý-Ìår^ȑ燧ÂGмmJ;é™Ñ'$ü™ž£?ŠýVêB˜?2ß´ôßýmø+úÜègÑ|‡÷2 Y¿e§éBn±OÖöêÏ…>¸ïƒ98ön0ßÃ\'}ëø=Ɇø¼ä=Ìaÿ8`ÎMKËúsèÃ…ï 9âßÍ[ÈÜ‹úá<÷N¢ßUçëyú˜ä_˜Ûò9{Ô°cý´þ™@xÅ<’êD¯Á]àNæ{—¥/=bõ¸¤ÿÕû_Ð_ä@òˆwÿý¿Á¼òŽ ¯“>-ž~_<~æYñü øIòÜ#oðǘ‡Hÿß¼êðöÂS*€Ý„ÇÇó:Γ¾mÞƒùGü.{vgú¢ÝOìaqÿVÐφ?2O <ôó2ÂsÊŸ¸¯”>4ø«¤/ÞO*¼ükî¥Ïž} :Ï=*þ ç=°Ãà:þ?€þÓðk<¿í¼þnÿ&{ž`NÏýfÌIȾ›¿G}œ‹÷€H¾ÍÏÇ>2á2úÇÀ_Žké?dof`,Gòî«£-Øë©sKúòÙwÈþù?úCÊ¿{ß öy-ì‘ä”ÏSœ§U½£Ñ+õ^±\»ŸóßÑGOß>8\ ?æ½ìÇÑŸœ;óšîf÷N¼¨xÏ|œA¿ ìý‰gÿü£ð§ãÉs(ŽõÞkÉ vÔý¼ìkÆ®ßd·Ìó#yäy±£œ sà‚Í郿^WþÞ—þ©¤ß–>câlù·pÎÈòȼ1û›™ b΋}BÌÙÉÿ¸_W8|Â=zî>föÇèœÃ}ÔœvÉó&ô›êÜÌÏξ"ù!óIKÿ¼¯U¸Þ|4ºOôÜûàqR|¥=IÎטý ÁžpøùÂ9aüüqðqb_5§áx äwfOxœÄýù\to¼vz~Ö‘Ãvu»1éw ú{9/ïÁÀþ²¯WòâýÊç€ËÃ=˜ž?‚'¼™ä›ûr8¼q’3ïI“þ9®Â¾}Ëð—8õ\„ü›ãI䚟gŸnÀ#ÍyyOûô4_á|s4ºoÎÃø‚|&<ðSHo<ò¾ðÜÁ<ˆã9ð9{´d7ܯ-ù2>d¯78PsÄEÞ¨:7¼ÀÞ7?1÷ªçõ~Köä±o“½UÂaÄAÒoú‰âUøÕ„_0×'ÿn¾gøGeÍß/ûìç‘#÷Ò}ÿ>_~þSæûÃxZq1x »]ðœ¤äcc¥GÏ­uîôDRçês÷~aö’²§ü:ö“sc>ü!=1/+xƒ½”Š<'/ƒü4¼+Ì=†vÍóXß%/€¼;¿<ǘ#Ÿ/œô”ïõ¾ ½ßo¼ªü‡ñ ükäÉ$מO^F¹gòÅà$òàæƒ”CÎ'$?æ§“ü¿š×þdÉ{¸/ÈsäAà‰”ž9Âq~=iðb0¿${æGKž?Ì 'æo¤ÞOõ’”]tÞ]þ±Ø|i1ü!ûM=Š9 x'¼O‚<šæØÙ_e>wxg÷;¿Àþ4òàlæ¶™ßcÿ³Î‰øž¹D掌SÐ?üî¾ìªyt¾ð²¹>¤û"^b¾|à÷Ö\çÈ9á¿Éšÿ޽x)¹KâfÙCï};|xØÏéâõü®—Àc_,<Êš7”ÿt> ½rýHçex`þ?ì)|&®GJ_=ß žCߨ'¦Ÿ'naú÷Çת5½þÜäž°§òËȽù©7éy±;ÞL‚=9øýÝö}q xÙùNùoü+ç…Ý2n xò™‹ n>qž;";hÿ¯¶ìçå:ƒò–ž;D¯÷‘Ï7¿Q°—Âù7òðÑK¾6Uþ½_—š“½Š²ûÞ-ÿEÆ|>Ìñ3¯Ç^få…°“>_êÙÌWÂÛ¯ùiïù ö¦áï¨gçñ÷ä ±Ïæ{‚ßžd=7z㺈ì©åœNÝ”9OøU‚y:üåºÉeM)=,™K#ß ¾Ö癿“¹ÚÀ^ñ=ÔÿÌÛ.¾×ÆúFÜÏ>Å­!³çë…ãÍ÷ ß·\Óƒ¾°*Ø“Œ^¯Ñ;ó%<æ1…ŸKçí<¾ð’ù¨…ߨ+Øo+ÏNž<Œ»ñËð’8ï¤÷wñï<'~Ð<Ôª™·ŽýÒw÷Ù`ïô^Ô½O˜}6Ò[ÇýA߆ù}áõ¡~ƒýÓób?à³ñ¼¸øë°cŽK‚z˜÷yÉ:žQ<â>*êmâKÇ_‚óyÇCÁ¾SòÜ·ãø©¯Š· ûíº±ž“üYˆ÷Ñ/äÿB¾Óüzò³®ëKnÍs+>0ì‡ûF‚<¦ëŸªï„{ -‡Ú` øùá™@žØ‡'9ÙrÂù›s®~»ø~Mò<ì= ö#{]øžxØ‚p—ëì‡ÈyÞÓü.ÄËäd—ÌÅÞiö±dßÑ ç§È Ï:'Þƒú¢ã=ÙgäÂulɧ÷ ³ÇLylò%ô gà8ó2Àƒ¯|¤ëKø/p 8’1öÜù/O¯`GØaÏüÔìi¡o~Cò†²Ó¶#䉑öbI~ݯ*\†ŸOʸþèx¥:xœxØõ;üx’ûÞ3¿8JuäÁ{ÖØG'ÜC_P˜?æßÝªÏ ù°¼×™?©ÇSŸë|ÍÅ^GÝãdòYô¹7зÁ¾2ù_×/$¿îk”ý2¯*¼fðPIïуpß©óØ9p*øMïË÷›ß™=粋˾¹¾Ý‚q¯%}tì+‘_°ß¤…¼=uVýé|¸ò¶—ô I^]oBŸþ˜pEÈßÄ=‘?qÝ>Sêß’CîÀ¾ ü”û|%§Þ§àS÷Kî]Ÿ'_¯Çþ›Ÿ ¾-ìŒäÔ|\ÎGO\¯ÔçYžÁ3àYâxòÑìu¢ND½Šþ=½7<êæñ†o]ñ÷ã¾Eöé{±sœÃ¦‹.»¾oÕNI¾D8^ù•8mðißoNÂK¯ülÈûöÃ9ï.d¿”î{À¾jçC¤ðß;ß®x ÿ…þâÀæ5¥oˆ=ˆÊ³’72ϼnì—Õ{‘§ò~FõzŸ:ózO÷?Ó!ûC}Ù}HÄCº?ÛIâNü#}ŽìŸ„ž9é™÷Y«ÎÃ9»L=Ž>\òóô_H.¼¿†>=§õ>’`o³ëÒä™éη!ßÌ~Jæ2ȼ¶Ž£ˆÏƒ=ÕÔ%ðC΋  çá÷o¦üsKîç2>”Ýåó8gê‹è©÷ ›7üÆ^ü¯ðùÙO?JþÛ<”ô—)ŸÂ{pÖ é1þÿï½Çìû#ï¢|çöw¹ž[âSöMK„’}¾ô1WÀwLÝ€=ÂWîÓ}¹oZ8 åúª~ÎüøÅÇè‹ëYäU3n'.à}ØÓ€‚ÿ‘÷pþ7سâ-ïw!N¦Þ!{Ãß±ƲôÅ‘Gw^_rJ<ìqݼ~—ç‘Þ‘wAñ›!¿*ö»èù*p ñG0b^æ_ૃ×PsøWû=zí¾ òvðZƒçé³¢‡½|ôEsXà$Ççô™°÷SϾñÜý/ä!胤¯8=å½ô}îK…_ûðqÚ²·œÉÞ½vË8—ßn£þêµûƒéÔÏ›¯“8{)=×’/s‡pµû‰… À—Ømä¿N>¼½÷€ÿدÌþxp©7·H\-¹‡wÐu@½y;䕹º°¾Žó<qóôQËÎr®>—€§ÕuÉ y+ã#öÈ®9þbn-è¿3ß'¼ A¥q#çI˜û£_HòI0þ4ŒÃ<碾UÏ PÔ¹`_Ý_¦8s7_.{˜™ßS½Ì},A>ì>øeéf”~Hòòêðï1?A_†ì2ú°¢òÕôY0§Ø\¬ç‘R¼kÎç;ïOÝHúàónu¿ûh%×ä¡Ožƒùó„+Oö-›š<çF?{ŠèŸB¯ùœŽuþÀ}Fºï×eÞ‘¹PÝ;ÿnÜ*c{F~†99ù óIÓïJ?¦êßøuì¾÷cxýbÃx ˜Ãö¼©êsäI­wôÃÙÛB¿¾¾‡¼¦ó!Òƒ-/°ïyáê=®ŸÑOKL]‹çbnYŸãz¬î î>úº©ëKNÌ«N^}¦þM¼Àü…Îsq}GÏç= ø_}OÈŽ?s¿õVð8y\øŸõ½Þ›E!vTñ }ËÄ{ŽÓ97Α~HÞ‡>]ü"õSúàT׿~ÀYžÑy›Ÿ—ó”½çžÍ÷«ûðœ"¼¿ô]#dÏÀ—®×ÓÏ EüïýÃøâSåå9Ïe)o|cÁ#øKï}ÒÏ{Ÿ7{ç;âø[øÆý¯œ}}²›&qá“/Žô^F~ŸýŽÉG³ÇWr†p){¸uîÌ»¹NìÙ5.eïÝÉm'¶™Ö=ÉÿJÙÿL<ëyxïuäÌ«.y#þuI¿ï¾ áJúÁÝ®—ɯ#÷Ô³Àö˲óìòßSû›^›åK:¤øù/ò)ú<øõ’z+qyÉ ymöµçáÈkr§íoãïeÞNê.’£p_rÊóÃãs¿iÀnÿËóŠŸ&ŽžðE÷‡J[¾9/ó©Kž´OÒsâôóa?Œ£”—£n…]ás킾WÎÅyö€Ï÷ܸÿ&èwqÿpЗîú.|²/|¾ñ:û•$¿îs ö© W̱“ñ<ŒôÆùòýððžÔɇ²–ýG“ÈûtSýhð%ýíÂ…Ô—À)žw3·¯} ¶“A¾`ɘƒÝëþWü.~ \èü4ûP·¹ïƒý*ô|Þ3(ûM>aÝþµýO¸o¬óÝ~Oá(xû9—µ'Ô·¿kÂçN½€ç êgÄ)a}³ßÈ÷~ªtÙ¯É<Œ>Çü!Ì÷ês7 ¼p\:&ûZéwd§ÎüÎÁ§\§"¯(¼Œ]ô~BÅùø-âÎ…?É_!È‘ó<’ð-ß¿Hû~©„ù"ô¹ØþæËØ¿ôÃ,Ø×;ïF‹óçN|ùÞúí*æg\wű‡¹–ßçüì×ïx^°ˆ>î ûˆ<¹Ž ýÿÒ²?ëÔ.©±—:~Š=ÌK2o­ù5ס‚>Eöþ¡®3Èà\‡ýk?wR”?s¼N“\Ó'ï=`Âüžçô|Î ÊÞ‡{”É÷z/Ï'y ÷֛ˢ?~ÙaäÆóŸà;á÷©¤žÈ^ZÙ‹5Ýpï“u¯Hø­ˆå¸g>‡¼Ÿûgèÿ€‹¼”ä yYõÖžÕ¯_ÌËÙ_R¯òîe‘ù6Ý+ûG=ÿžxIwÓwçz¨ô~qÏS^m<{G’ç•¿5~&o¥÷q*u¿æ7á|±Óîk–œƒßüsÇÝX»\ǺI¼®8ùà[UN™ÕøLã\¾×çA^‹¼°ìú§ÚÍšŸðÀ(èý®òóÝrr³­?;Ž–<${ä}q}犛ٳi>!æÐcÙ—9ùϬ¬½eù=8üÏ7ï\u¼Ï \_"Oº´{ÞïÛ³>º9àíÁ>¸?CøyF¾‰cy~êMô»*îˆ3²æNkš}sÉ^,áxüÁÊ–Ý~çƹìã&ë}Yºü8u ÞwýÀOZÜzÌ’dšòÍæÿ`ÎTþŽø»ëyáÏ3Ò§ö·á©³ÒO${òGçÒ¯½´y1¾üÎªŠ¹¯œ1ctÂ?Aƒì~•üU¨ŸÈ‰çNè»Öç9ßLÿ½ì-<;æíÎp?³ä-܇ã9¾ oi;¤s$>ã=À«ä…°›ÔÏŒ£eØsæÝÜ·›Â“žrÜÌܦüúç9™”ÞÀÓê{vÿ¹òƒö'); ¯w2ßAŸû@õ=à@Ë}èäOà‘S¿ò >Æïz/–òdŽcàµKé¥ã:Û7öªÉ›!è'ŸîÉò^2þ$¯H¾A÷à¾LúyÈÇ2‡*¿éxnⵋ¯;¢³õ˼„ô›¿¿ÆOá/…Ë\ŸPÁ¸ƒý®Š±ûžK¤žðfÐ' ®¤þì¸Vø ÿï¼ùGé zãùÎMràýíò/á\ƒëõìÁ’>€{Ñç°Œ: zg^9ø@èÇ úz\WgnAöÜý­Â§áPü Oç€]DoÈ!à:× á€cîŽ×ßûêÛ—MÝê¶¾¨Ú±ðx®\Çyz>1…›¬§Äøwß›ø†Åû}ŠÓî}{Ù#ÎHp*¼ð.ÒçÀž.æå•÷4ŒâaÎ~/â>pç㽕Ï•çöéC…_„z"<“êWåà7àóc^_vÈyTæE” ÷nò¾Ä;øKÉû¸9/ï¥_>e¿loá0ßÖ_ûíáNöRK^WȾ?ºÿGõÙ=æM}>Ž d÷Àëàe÷_+náýï¡ßQòîýÌ#S—ö[šö¯ü0æKq_2ýŽØ ý>y>ïù…ï†9-ú‚<œûÅŸ“>¥ÒK_-ÍJâöd“¯ êÁä…œ‡—·? öúšÇDþÍsœìë„ÏBø‹¾ƒpo¤yàƒ ø!ç§NK‚Îß¼¥Ì¤ö¾%ñ#y=çúŠï—9¡óœ¤¯ {Σß¾=É-~Ðuòà>‡º|ˆÂÿ¼yêÆÂ{qZjߌïÓ|½àÙ?üy×ÓàU®ßØùáÁC¿©QŒÂüoºwé±ỹìo徜N¿ó\aÄ{ž§ ïäW¨ Ü£øº{.?cÍ ›¿? .¥½éäE䯱kè‘ñtJÎãôv½:\°ªWœ~ùW½ýõGÅö™ºGuçstÞÌÃR·•ÞÙïØîó[áþKôò´EG7=¸ÌùTó6©ï•çá=è›6Î æxÉï 7§5n³ðæJIßµê¾È/vˆç ÷}»Ôùˆ ÅÞð÷Ñ¿Ï|…ìýSðÆ„yаîB_†÷Æ¢×ÜuAìõ5}?îyw|†äÊû·éßV^Ç8›9 öh뼄CÝïà¹9áWîxÄ{°™–æ~Ò/¢¸ ¹FžÜB½6è‡s›p†åIrC}Ö<$:Gêàk÷KÊNñœèƒûÏðûð´h¯í óŠ’S÷M“‡r¿4óEz^ð˜ì˜÷(šO–þBâJÝzeÿÎÜ yPÙ5x®CDþÉõ#É5<È/q´å™9qøÅU×·=Tœj^[xÙÉéyÈ×`÷Ô¿§¿¼õ1sVç8Jÿ”ä5ì3oVêyž0棘[‡ŸBø4½bÇUWÿàú¦ç(„±ãÊ:žG¿¬¿ôõ`¯ô{î»ô´õkÇ›‡MùBì\ÈçàýɺWúŸŠÅñôÒ—L}…ß—ýðœ£ìÿŽqøêˆ›éû†çVs'Ü?vûp=”¾:ÕÌïžúJÏa~Lò n ÷¯¸?+èÓ çÔÀ-È£çôèÓ§ÏQx–>‡?5«_¿Í ßð;öÛ¸IŸÖyÏ—é½ÉCï€Ç¨§Ò‡K¾˜9ú¼$'žo“5Þ„×BöœŒ|\2¢Ñ Î­“~’p>ýNÅì3õó®ºížß?¼"§ßòɼ;vɼ ȧü²ë-²{ô ¹BöÌüôŸÐÁªpŠë Ì#HÌcNŸñŸžÃ¼Cð“àW!ßE ïÐ_óö‡ÄOÄäsŒ_„§è+uŸs¬è%ýÒ);§ß:ü‰/'}uÔmsðö•¼€~ÎøÕñ'<•œ翈³ä—ÝÇðLò{èúPÙ;èï3ÏO*¿Í>¬hIÏ[¯}c8y^êqqúš§ÇVÊ)`¿ss®×M=uçàoó‹’¾.í“Ô>Xÿܲ–¿µË¹xEôÀ¿é²>›ÌŸþ÷5ve5>²ÈççˆÌë&;?­Ââ?îh¸5.Qyp¿Å[Î,ö{áçƒã|÷àÏl}7ÁµÊ|µhÓŠË:/ƾX~è§¡osÝ[ÝwÄ?†ŸÏ>Âbõ]ÅUŽkƒóõÏ‹ŸÌGΧO=øÁÏ F9ÎYÖé²üu$ó'Ê[g¥½3ý‘Fã£Ý~>¾]£EÑ”?¥?ÝèxòåþÜï׎}hXó>§ðß™#™ßa~ËÉ…yþÿ3¢Qµ›lîè½ü"s©ô»°¿—ý€Ú/}³¼då;'ìåŠú¶¿çÓú,»úŠ­Ñ²øØ§§ÎÏ.vN+–~räÚ‹¼7½ ìÕKÛ¹¹Cù:»èó^hñi“÷i¦peœVþò»Ž¯û¡íøªn¿Ý¼õ‘8š\ö—ËMùÎóÅ¿MßWøå$÷8ªøÖxÿMÿ³³îË/÷ÉoÅúË4ëçãóuqƧ‡ÿ’W&yëbçî-öžô‘ ?ôk©®çEÒ†JüŸìÅÈ;î|aç‚hFÑC­o|üçDﻦÍ|ñòÉ–Côi~½‘õã’}ž ñe²Ÿ.ãà“¥_šØÎŸ³¾Ë1~rà¹hÍâ‚1 ®[åÿO^»òý黯>V«’ßgõò÷?x7§D´ð³ogUì74éHùcËý¢ÄŸäùÎ=S¿{þ}NÙûPý9+LR¦ÛIö³:]:¿æ1EÄÓqî#>{tÔÅþ}É“÷g¸Ï)…üÞo«ýùmëùÃ{ÿˆ¾9æ_ïÞÑõîºN=žxLf´®Ê}¹_ÕZ’œƒøJõ\è…þö•gn¬þH÷ßêýâÚ;Ì^Iäiå[u?¹¨]×hÁC]ô*ßÝûºÅÛŸœŸê>㦕«Ý£a!ûýùìÿžvߎg»í{0±ÛêW}ÂÿŸ¾Å·þÿß~0zý±U›²Ù¸vBÕÛëL>)Ó÷%ëß#¡~bv|KÚÿÏÿâü¹;w=XêX÷«Î~îÅ6×Ö®œÜÛÛ%”Ý]¶˜>>ÿo33,Ù7Ÿ7¤ÊèuûV²×¿SLß9·ŒÏ/øæõY¶«ÑÏÝöTÝ”ö™¿G}š‰ˆwSówÅ>wÙ;yê}ÎÑ¿W¢ÕËάzŽí¤ö¡Gk»ÞÔ¬a—ÛÒñûÏ“óH탵œLÛqòš/FËŸ>¯u«¥÷ÓßáçÑ|¢ÿ.{”øÕqè'[µ|UÙyÕa»o ߟÚ[ê8 {°ü¢—t<çW÷É.QÇdÏl´rÉÙc·¶¯>ùXòhöÇàòÿîËMáû8ýð'ç-{¡o±{ÐÏ'~™½škÿyÙ™×užΕ?iTãîhàÑ?lù¦ÓÞäÞSø¿Øç²/äƒs^švùÄ?}޹»Öì¸n$¸ÊýýŸº¼É×{Vá7¼Ï¶ÄÜ’Ë®š5Åy‹ßǾ>¦uÉwŒ·± <Ï÷ÏŸÚ«õØí‰ÞVë…»8'.Õð°f/•ü/;ü<¾/š¼æÅ™_Ý»$Sá“çî[Ò÷§:˜ëçš_VŸ”.ä=[º¼yù#/ÿÒø=kP³ V-«Råø{nÿÚq¿ëÑ)?^ìÜdg©×$ò=¹É—Oý°­˜ÜçõßÓ7qΚF·ÖÇçÀùÀ#CßܼŸŒüâ¶Ñц*ÿÖ'ïUç™9•½/š]½¤ŸgT³‚ë´IÎsúQ zŽþÕ{«Ío­>æ Àkô¿ /+?Xì½ø÷ÞÙ]âK>s~õד¦NouÿPÛù‘böJyß´¿ù/ΚØiz½K£ÑÐjÇd}ûü¢èÞ”·ŒKôØ×,š“éx<´ãà8âc=oôõUËíw~"±w’oâÊ¥_?»ý¿Ô8PqO19Y4eö)ß}ד<<û “¹tåßV¼±aef¹‰ãÜÒ‹?-o£ó²þ\æèc\5aÉKK^Št߀ì_h/Ùoïz ò·¨Äé=ruœ_iêÄÚg¯ÁnÄóO<êÃ;³åwàÙKä"•wÅîzN@{5û¯¸ž¾Tò»à®ìS†_1,ºÕ}øì/×÷D>´·¹ÎPþyËízú¾/ߎÍÆóËŽ„öµØû†uEæ¦oûþá«®ý¯øóÑq¯?5ó+ç­WO:w|ÙÕדï íD´zÿ®xÏ”–‰½Jù-ÿ}æèk¦â^úã¢ÅãîÏôý«ýç¤a߯TzyÂä9õý¼ùªP¯‰ÿ±×?=Ö æ×ûÓ˜+p¼D­Û¿ÕyêqÑkë~X<§ÆRÛAÅsè¥õiú™_=>âì|ö;ƒÏÃç婘?'~.·_ÍoŸ÷ÞÍßï¶¿[rÉ=ç?4¸&?ϾiçQÑWx@ÉÓ·ËŸÓHõÜ}KŸì·oœíò¤8¦˜~r?|®ûƒå¯Ôw–ô©Â|Ê-¾èÝKjöêsPwr>©x:‰û”ÿYvàÊ×·Ê@1»«½à¶›ÿÚó§gÿÎ'ñx ÇÄ%¶žqÓ¢2’:^jŸbœqÊλòÛ‡ŸMpµòÞÔñJ”j¹½ûþ㌦Ïß°ò’!èq‚£Rsþ;ûaµ÷ž¸3Nß9­yÇJcÍ÷©x6‰ÏRy8'>ãÕŠgÜà嵟Ü1½ó/ä™ýw×õ•ß ûÓ…œ–Š“=2»óO§5p==Ô?ü:øCøÉÿŽ?¢¯>äTspöwì%P>/Ñ{ÕuÇ»¿Ü½¾UÝKÿ-‰»Rql1»O}}cŸ}‰öUv¾µ¹šóÿÔs|AßZ\"pÂM?5Å_ú{˜§Wk謃ú²—ÜÿNÞWsÅqÃæN“¯ýî"òwð[ ŸþìhpÉ÷¤âÿ}Aæäò‹¯iî~+Ïé¥ò7qVõ¹­^{å0æ¹â‚Ôy¯‡rÀy€£ÖTšQ-÷î¹Äƒ ŸI*\ì=ñçàIž¼ùѼJ_»òöÿóœþ+†>ît×á¨S˜GYu£½¿(ÿÆë[=wçýäåÿÚOνÒGKñD‚§;W?¿ÙÎÉœ¼PäñU§®ª›÷y…í]“yfÕ%þ¨Ôdd—ÝóÑ''û’ðÑߌ?‡?ƒxŒºß+ÿ£ú»ëëæi…Ï3õöïš_÷ÞBê œ·û‘µ_j]½Ù¿_:’8ßyQöJ¸o,Ø#@9ð÷q§ð^Ôk‰w™ç¤ŽÈÿÇ.¹¯AùIò#²Ž¿Ü£øŒºü>Ü/vÊû½T7òœ¯ú6ÖÝùµ³G9¯H O‘çà'¡!•ïr?¢ÿyCñVÀ/À¹±y`»çñÕo@>îƒûaÑûp4DŸõÆp+÷Eý¾M×·Ô?Í¿s^ì›ðÞGÕ©÷8D¿žçÙèR=ÌúDþ>õÑ7à=â­Æ2/¿#úÆ{Ò¯Bÿ‘÷ÌÉ^pôcaĮ̈÷ ü©õŸÏ§~®5ÿ²ôÙüÑzOÍ·¸ßßóNìUÿ ýjÌia_ÀýžOV]nù—åNøéõÊð¿'}Nªƒ0¿C¿yiô¾.î—þüªÏIõ,ú}”ÏIö=)o Ïý&Ô¡©¯“0Ÿ¬ê´æ³”¾™w"ÕÏÁ{¹OŸz¶û1Øßˆü$vy¦/š~N×õU!Ï»òÄJ¯uZûží5üÔɳ߯WÈÑ Ï ré9nxT÷ÿ±LÝÛk¾ÙÊÿ.<æ~9òþÜ?Ÿ‹ÝÄNÓ¯?ãœ97ì%óÊw»®D~“:9ùwäÁ{Çy_áböG§ÁNó9æ9fžB{~K4Ö|ËW1vÓõ,÷é~Ïœ˜ý§ü7þ?J=»BýÝæwðWøcxlø\Ï#2§+ý^^á¾å®>è90òmàlê/ôO7"Oàwæ%èá~Áø ûY=ó@ÌC'š·D}«ªsÚž/oùèÌÚ£ÓíoÈgù@ŸwÈŸÎ|s@ÞS—ÒWæ ¨ßºß¿dÿ!¹¥ïè׎ØrÿAÛsä7£M÷{Êl®ë8•÷Ç¿¹o+à÷v¾\çîcâ9ŒãÔçÆ3’ÏÇÎᯄû©«:þQÏw8?¬~ ïÅ`/8ó]ð„É^€]ÏA4O‡Ý£ïÄrˆ¼éù™Ã yfñ‹ØGí *V×*Æ#Àžù ù‘8íáçŸ]øS÷„ß9É÷rË`ÇéË/`¯Ô_ìEÐ=Ñ×H^Ô}êóõ¾xú¨àÅS^‡¼øi…궇àKöÉ>¡Þ{˜Š»÷#gðÚáÌ+¯Ï1’ì."¿ØæüÀ5Üúk?­9NãÑÔýºÞŠ}p\ ú¬yTØ{ "z.ÿã½zpŽù8…7ÈG—ø¼ü»»ÇIø?åwù<ú´ŒËá×’ý—¼2¿i;@œæ~%ù{üžûöõ}èAØGìyaõ›I^ãôg~Tî’î§çܱëÈ uzóÞ+þ@n•Ç4î¢ßÿ·:íÂ/ïÏ™å<­ûØË'û´lé–©¿¬¿Ñ8;Cý‚<ùš[ûvŸöØÛÉü´~{Gÿzɽ¡—<7}röËøuöY¤p±Ï ÿÉ}ð=ôcò^øsâ1úÝŸÄÙäC±·æo^ÇÿØ~¯ð>ʃ&ü²›ØUóñI>+Øc¢ó3¿ðuæ˜?¥¯‹ø†øùæ=½GCñ)yºõËO®VáÕLžßó÷ØÅa¶¯Æ ðDØï(~2ne/¡ì6u$ð™ôËýKž{Ó¹ØJ>½'R¸»ÄÜ,~?…œp¯àlxÉ?çJïøï‘W}ÐsÍ©>#Ï8ÞÓù€[©«€×‘ú»©s2Ça’Êk9OÅç€ï7§þz]ùw¬?žo‚÷^zËù˜ÿKù2pþþ îIùØ8ã¼³Þ¸ð„–gxÓ¨oªÕ~ÛülÂMØïT|ŠÎw*q¦ùáè?Wß(ù ÷OKì§e—ÁkØSæsC¾iãlx e?ø9ï%`îWx‡¹ïí&½x_Aã$ÿ„>R§A.yòløEó•Ⱦ2_*½ŠKdïx¼×+e=wH‹ë´šÃËlذáë¯i;`œD~YýeØÕŒÇ+ÝÒ@©d~Xøyfï× z¯N¢ç²§ž¿n0›ü<ý ìv_<ûŽÈ“€sô9œ7rŒÝ‚É@O°ÛøaÎÎ÷ÛNñùȳâòvæ#Õû׿çÓÙ™U—·hÖ8á†?@u?ó5À»ÊüüÖÈ;û¬T·Hÿ¥ÝöûzÇ2g…ÝEŸÁgØî» .$ÿ©¾û pzâýàÊï“Gf/.sôáÜQȆþ)þqÿè=ðꟳ…½\ðÃôz/çïX_½¯ ~Ý”ÞǪÜyK‹NÎû’ïòœ,ÿ_ù$øN½GDyÖpß÷ó‰'…¾âïKÉ#øÐ~+ÜÏF}„¹)xoøþÑ{òà‚ðœ=&ýÀÛ?k¾ƒzšêÆÎ?1ï$\êþþoUö×õFïσ×Cx9!¿–ѹã¯^áù>ôÂ÷H¿a —»”z¨yZ„Ìó©ïgn½_^tvé¥ÓžHæO˜ÿÇþ_ôó¯}i O±äÓû:™_‚߉=HòOä=¨×‘SÊýÔ¥¸7ÙéØugõm“Ÿe>xÒübª_{¾BûÁuØIó[±§Gïež凉[ˆG=OO€ò«Ò+ó…} Æè§ê?ðñ™ÏkÝ~‘8Èû.àÇÖ¾_çËT7ô—ž“º¬ç,e]WÔï©ß#é_è=dáÉõÏsž±|颢.muP8Ç}‡¶+ì÷\Ð7BÞ†|¥ù{á¹ÿÈ›ï&Øëfžø5tÏðæ©/<áuÓ9šoJ÷ðö±TyhøÄ¿Âïo*õ }çè™3—½¦>@|MÞ»ÊÏ-T¿ù“{Ûzþ’:iÈë¹fæ’Ù/$;@~¿lþFÎ)…/ìÝ@ð:„A¨e01* Œ½5"DTÀ9N€2É$ *Ô(à„Q¢¢ˆ"‚"2ÈŒ2É,M#Š "( ºŸß³¯«ëÖMå[·*»«V>ûì½×·¾ï‡ç¥ÙS?þ›ÕñìÚ·ÏÁNè\¨ôY…OÚR<-8è”>ÎùÀ +NUøÅ}ðoñçè•Cý–›îzné'û9š·õ‘^ºéÞœŸÄkø·“—%vwäyõûï­ù*þ:ïâ¤g}ìßÎEàŠ×=õåKsâÆçÙzc}¦æØðÃÉwòCN=Dû÷óýü“âÔÃIOZ¾ÎWçfå<Äg†þ[ñ@Çë+N“¸MñªýçäKûþõ`µ›ò†èœð䱊Ûc.ƒyãð8¢w‹zVg[|bxæ’Áˆ=U|.8Jy}•ÎÃgÅK¼ÙºÄËØkô¹8Iý.¸ ‘cóÏ ÿä9=WqBÅ'Ê9¢Û>Ç'¤øïüìÔ-{þRqªrÿ¡_g¿×RïùÞ|kèµó?ÍŒüŸtéßœàÅ^ë¼’øëâ3ꙋ§š}ªÜ†_lPì¬öƒÇ_çàÕ/óMå»~f‡eÛíØ›&ó¿Ã¯ìvkçÄg,xæ–ÀÛ”G_‘¸[çkÐñƒÕQ©chœL^Úàgí“ÈGÏÕ¹K‘7ômì¿úEø§qáЯ8\çdÅNï8„‘oäª8¥øó“o(Žž9PñÙeô<ìÐGãJ­×ïWqÐ?Íç;~¤ù¶‘óòÅí?ÁþÆåÓÄoõË£ŸúU¡Cù-u2­#Oßzi>.q¯ä믉C¡Oþ§8–ýí\4Ï‘ç•W¦wWO½`ñøgÉwä9ºïÅ ‡Ÿ9Û¹­ã|Wù«ø2y.óžù­ÅÅQ¹[¼ìè³y¼tÕ×}¦¸hå¿â9ßÈõ_î‹^Šš¼që–ÈK}êÁKê¼û?°k‹‹•|Lí9vcê'è1ú¶s(áý˜ƒ¸ xý#~Ô~)¸3ð·"¯Ðmú;Fóæüp½3÷|oívuýÒì‡ú¹ÊÃ䃼^üóÉà·ŒýÖâuÊ·ÃË¥øqê·é“è‹Îgìœ`øÛÑÎS>M\Ò>]ñÞåû¾á¾ë&s\s¿ðù$ß$ò·yàk„ÞÉ/î5ûÛÜkñ„Äç:3ó™Š/7À{‡tŽöGü¾™ïqN•< ¿wܨè¸è]R:»©ö=;IÜÌçÕsv &|œäÃV·xP÷Ðümä´y\³æ]ÑzÍóVÞtîJòø:~kãès/?‘ø¹<Œsúüzk^´ßüe}ëAcoÊëÖÞ=­oGž¼õSú ÇþXõtç/D>7.yÏŸiüÃ\Èñ> û¨à‰ÔÞg¢’Wïúøaä{"y« >9œos{c'„oábtôsáGq‰æ[áBÃ[ØïìZòáßo\ë[G¾â­ÍÑ÷αóù¯üOr—^vÞêË·ð2ãÏ×Îb§ÄÞ,^§ð©|Añ÷ÂW‰3מQoô4ž}Ð> s¾øéc½Ð8rqÑ“G’¯ÑÏ(NÖ:šøäÞ¿ýh»c¶Üè™åSqUññÖ&ïÝy0êeò¼×¿sÕ“|Û¦ûÞdöuXOWœÚÐã9©³+nÎħɳâ|©óнDŸ‹\MÜT<©ó|Å?ÌÇòþØÅ—T—=­ÿ©ó‰²â<õ“ÇPç%Ï®^“}Ùùëü'øxêÓ¢—õ§âsþ½V»)vRë-²ίu«‘3ÎY^y0Ÿ~4Ó÷Íì¹dóI~:r“=6‰ª3Wz0ÏO|ß~‹?tîDâ“#±¯äEȑΩ3×Ð|—±ý8©ß‰>mœÛœXskÍ‚ÛÌÏ·µnñ¥è©ê}ñ;Ôãò*­‡½‹êk¦Ž@Ý‚~çÄ~ÖëÇVoJî gy‡Î‹\—¾jŒ{QûBÜÐz:=ùvþ“|ƒ¸*ÿ½ðŸÈCõPê§ø/äŠzA8pÀnù}\yÞÒ+Ÿ÷Å{¶ú»Ë&}ž±WÕ‹D_·ÿYßCè¬õ[ÖÑýÑ?—¸[û¤b§ˆ ðoÒoÝúœaú·ïäµz™îgì(qÐe|÷Œþê¬æƒƒ7§¿t2¿ÏÕÔ‡ˆ§šÈm>*ññqÁÞúGÕ©)Þzq|ã¹Î?¸=_ú—Üg7YçòOï¾Õ÷ÿ¢Ÿ÷>~(ý…?Ž|ó:+ß¾×çáûToÜúœï½ãeOÞyRG{Œ9ˆô­yíð¦®ßüW7ëÎ#‡ÿ‡¯Hî·_,q/õGê\ôCº¿¾ñ¸±ýP»íÚ‹¿9ÿ«÷ŸÒúÜÖ{臌?Û~ø0è%ë¸p­z×ý—<Ø>Bõ4;‹äç¥ûÿy¿}Õqí¿Â§­7Î}БsÐû¤ó ЉgØGç«ÎF=5ÿ]ÏÖœÌÔ‹ˆ'чž_=‡zHúTýCëÂWì+ó+ÕEÛ‡ÖU†_~¸Áu§>pÂè›Ô-E_©WhÝmä§ûZú/ÄÏÁݪ=ÉOµz¢u¥¡õ«•?™»vÝ3_ùÄ#^|¤îdöK¼fé:ô þ ?S•ê™ãDZŸëŸD?­j\¿ÂO‰\!GÑ™ú†ØUìçBî ù•\Ó×Âΰ.v=½|Û¿ÿ«k¾ð‰êþ»ý è{ýÈΡù³ð=º&ߨ#öÝ´ï%8†ò˜ê-<ÿËýؾ§u¬ñn}àÙO}ßÃþ´y]8 ü9t¹5Áÿ‹üTg|Ÿòyľvïǯì£Ó¶8ú-óv|Qå¥<‰çc÷ª#´Nü§oŸƒ­CÝ—ºòêsrA]høÜ¹õ¬ë/|ãì»äbé5r˜]‹ËÿcùÑ}ƒ¯ÎÞˆþÈ©È'ôHO¢{y‚Ò_ìIv‘=GÝý¥¿‚@ž’óžþy‰¿ø)í‹ü$ŸÑ¹Ÿúõzo=+3rØ÷αן¤o/úšË^¡ßܯú8òŸ0Ì?Ó_öU}¾&GÈÇöc¤Þ•ümßIêAм;õÎÓùµn>ñr>ËO9êcwÜpê¤YÝzì9t.^Wþ‹¾òé°_Ϲ£sv>i,ò‘^"ŸN_°ÿõ_vlßﹿvØÃîO¯Ì:'¸1ÑÏòLpÙµçÑ-==â<É ¸Ãø=ÑÓô©uùžËÞ÷½×>~Ù>ähã^¥‡è¥âëdì]õÕkáò]½˜õºoûKCÏâÅñˆ~+`üµöóå\ôµØ7r«ý•ú¶â¯ž´É†Ë6^û¶ž;;])~dÿôKʳÉó³Ú¯˜:#ö¤u’ øÞ¹Ó+ÎuùèU¿š³ß³j¿Šóá;ñ~ò ¿ñ§åy}®r#ûÈ%òÕýÙ)ö ÿ[]€÷w£ývÙG~Tû2óÓçèUvƒ|Ì-Çìþ‰—î|rýà;vÝè½ýÀæ†Ç³èò»k/³Ë}Oö¡|ÿ&ß?ÁŸO¼–¾Ã'ìú¿“sµçCÎÅûôyˆÇô~±Wû=ìÓèù6r¯|¯¯6ûÔ~ɬ[¼»s ÔÿÇ­G=q×o—Û¾ˆ¨3¦—É-牮é›â,¨ мïCGêáØ5øŒÝ‰nè=÷á_ø>瀟ì{âÊ ®zÌUÇÚø€z…Úíy¿~ËìãG ß/n׸UöWÞ£8Lá'¸ ønPë¢"—Ð+9É¡ï|{²~Uø¸ô¹I> ð„«ÿÈmyöxåYì%ñÏ¡ßN~ËÓX/»Y¼I<äg®´Þ’?®~ŠuÛ¯Òi䆸›}ÇïìWñ*úÄ÷¡;ú}ú½}Õá/ÏÑz™¬Ý°Ãø½ìñnö®ûÚwûVáèöJÏI|+¿ãCû÷ß‹/8'|ßyíñÓ=§¸=½Ž.<Dž_YÜ¥üÔ§GïÃÕ·?¬O!ÇÙUÃ8”}霃äÙ»zÑûv|Ò9ÿÖ¼2¹ Ç‹ŸÀn¬ü Ÿòwö—¸ >¿z“]žö®w­3±oÆrH=ühɸÏOŸØh•xÛq_>k4sßS6ùëuß«.v´hÎZòéÇŒFsŸññ Ÿ÷ÊUG‹>ö÷|éàŽÞxð-/¸ï‘ýiÄÌ gï:îÝð*àsæ»ýk?¿û £…çýà/>õÀº£™-=~Ý{6ƒG9Zô¹u°ú%fŽ:æ¤çcK'ô5ž;2Z¸Ç&—ß5ÿ§òœ£E.Þv·Ù{G3Gì{ÙŸ¬²ádÝÙGÏZi•ÿæŽÝ~>Z´|‹ëÿô³ª/-Úô†÷¿ð{oSï7šÏw?úêóF3§lð»~ß®}ͼûú 9õ»£y÷ÞµÛN»¯çºöKðþFKÎxô‹O_P\­—¾üU7®º|îžß¢ wÞó Y ~ë¥õëïFwÉÇï-8â•_}Ç÷MæËŒëúzž•Cø{ŒÏϼâó4&òÿfÞÖ‚ÕÞ}ï߯ñÍÑìè%5©ç½hö »|vÞÖ#C>Í_cë«^±ëÛ&ë1_/÷'×WZí¶çrúßµnÓz+'¿ó’e/}øÅ#Èü‘ê7|NާNs¢×¢z>ÑïæU⃾?ß7ÿüõ{÷‹Q>ÏœÊÎí³ÿpà Ð׳‡^yó¼½èÝ£.ù»ù_þ{h´ð•£¾ø³Ìkë˜Ò3ýûŒÞÕß9{Ä3N>ëiÇŽ~ÎùÛýæ-í—èynîG7½ñ¸êÿE«¶×œ]ú\¼ÍæÛŸ»Þ-£Egìô•o>ïÓ}ÎàóW¿²?]rćn[û¨ê‹ù¾úÎ;?ó´ÑìQ§žüÙGÑïg×fž™y‹ðw&öBätÏC¿å¸ß¡çN>ÓßôRæ:ô>3ÿð¡N»íÖÑÂ{Ï¿ÿ«Ï-nEùÙ 8Mö;ó"ÊÇø.ëRgÑû²_g7œÿð Ž>±s'Rw1šÙ÷™ëÞýöOUO°÷f¯yÔ©›^?¿sÜÒŸT¹§nÃó[oôÕÄ^Îóð#àç/\}·Om½ëµ=§™=®|õÉ_~²úÕÑì>Ÿ{Øs6ú¼9äp×ËŽ¢O;(vqq¬ÆõÐÕ«ý|Î'veñbw7_¹Bæ]•Øç<Ûø#ù¹i®ÏÌ-÷o4wá_ÁM©]ü‰Îû\pü«Ôš_ÍÇ­*Ïk§{È~›¿÷Žú5æ¨ás>ìk¯»òùk§ÒûØáÃê­ÔmÕÞv_û”~Ñ‚ßrÆwÞU;ºëÏ!¡g'}cœ8v`í~‡s'ñ¿>¶Ö÷©=Ê.Ï’òýìy?>ïo¿~À„¿2÷W_ ;xñ­³›/Yõ•÷[œœœ>䯰çÐMí‰Ø‡ô^íÅধž»û¹lå#~_êW¤ëð_p*&Ï›9•ìKûM.Ù7û¨t@_òOéEßÇsŸ•—Þµä ·Ÿ[;š}û|bœ±Ò.oýØ£EçÏüä'—Þ¿×îÏÕ©þÅç9OùöÊMçlî ý`<»’}ßÏEÎëK¤ßé)~¹9—ð Fóo¼æcþä™Ý·Ú{Ù7ü¿`éWvžY¾Iý ò¶öõ8¾?±cÌнRÿûÖG]zéuOü/÷‹>¨œÊºÈÑE‡mð¤­/~gq ìKïùÒßcWÐ;äþ'—ê?Œíñò™¸ˆ¹ºì Òcä<ýû£zAÜdÁ½ýûÉÙ¸~.½Rÿ=r3ŸØñÈvÿ$x£%«/ÙvíëÞSùÅî*ÞxÎ=û7š}òœ¿~ñ¶¯ïßÑ/¹Ãî—‰ÕûÕÎçÑiåzì'þZü”ÚŸ‰{Nü˜œíq®å{ÍýÁ{G‹ã±¿ÉíʼnwÕßÙfæÞ Òþ«âíãÑÌÖ[õôËÚk·mø”÷_pøÝ£‡¾ì[§mqwçK.zåZÏ_|ééÝv±¹_ÑCC;¼r™^Áÿü½âð§ÿŸ½xv³s¿³ûCûþŒ·}ñ³_2‰×E®»âIèÏœ½ôoW.âïEkþ´•ŸøÄžCæ®õÇW^þ¸K{^Žç®Mä|ô4¼¸2ä9N®ó«׌=Ë¿X|Øjû>ý…¯ªßÍåoàëÅO?éÒ+·Ùc4»ã}~÷ò§—ÄÝjgeÝâŒä#zF—ö>bçŠ{¡WûÍŽ^ûÃs°?ø1µ+rþ‹7[¸å6?ݪûìs‹¶>æÉ_¸ó¼Îõ¬\Œ°p雿þ» &ú‹Ÿ3öÓZÇ%?X\žôª{‘ogÖ? ¿ªNS^[<^\ñrS/"Ÿ/Ϥ?WÞ®}LɈ·ËŸÊ/´o5øê'Ôtî<¥ø›¾žBó¯ê®“‡T¿Úº„ä3à{'5y$uòcò”í{Îó§.f2O,}zðÝõ+ª£+®ÜQué©gO=@秘K¨.Ã9Ë˧´Î!ù ýò™ßÜúãöã¦ß»ø'æSä<åááLëk•G2§#ûÐø¿úï‡ïdÛaLö®°üŒzyÀân¤ß¡ø9ÿΫJˆ<íïVú±?Å‘^\ñƳŽÎ#J?uëèþ°>¿x_ö^@瞤ŽZݲßÙè[žM~­ûœù ×ìyï'V»í “ú)õ6©ïµ/ð{äuáDȇ믄aßœºÐg«Ï ¨º«â½§.Á|E}¦êOÛ'$¿¦Ž!Ï™8jï«.K½89áÜìñ6Ìá‚ë>ž;ÑzÉÖ†¯ô]åVóÝpaÓï/ß­oÓ95¯h[ð[¯ ÷.uŃÍùÓÓú…Ô7 [8€YýØ<˜sÓ×£oEß«ºrX½|õàÞ×ù©oWŸáÔ¥^¾ýÂpßä¹õëZgñõøWêtô7qå;¯®Tž[ ÀâcEîµ®ShêÔÓÀ›UG/¶¸ðÁ÷*UúúÈ_ô ï΂þXõIs’:“Î{IÝ¡¾GûK>Ó+öaX/ÒºÖÔ½èÛ‡KØúƬ8×â8„¿Ô+©*žiús݇}`ž ¾½ñ77zÈßl_¾º1zQ=…º{¸\ÅÝ"8¿ó×O¹cÎ×—Þ¼üK¼õ‚ßVß¡÷'÷ØѯýúÜç‡õuèÁÜvõ8èŒüiÿÖXoO汎ùt\×â;ðWèAý¿ì-ò’œU?§>Ú|¿Î¯¡§Ë{øm|bë3Šã9rBÝGçhæ9Õóy?ûNKç¬%OÙ¾ëÔ—÷÷Ôy·#üþ‰^Êó°CÙµÕ3ÙÎÑ ýt^ZìIϯW:S÷¢n‰]T·|/»±óžáæ™>ôzq)BÇìïÔ³ÀWÅ-\T癩¹¸jÁ3…à¼;ÓÜökìLuSê±:’|Lýgí›Ø—úá‹“6îû/n =InúÞⶪ' ½F.ˇ•Ïè]ï/Î2ÈÐ ¿†Üí~ÀɈ¾¢ÏÚg¹×y3áw~ ¼ÄÚA‘ƒì£Ú›¡ßö¹ÇnQŸ§^Ža·³SÐ3ü„ÎÍ4§5vCçš…à¨u޵9j¡›â5eÝ뛸»Ö¾Ö>/ß„¯Ì+,ŽIì|— óE"¿êgDOÔ~„‡ —i¬÷:w—êü¿ÈvDqͲ?îW|š*>0ü2~9Än¿9®æ&N ¾P|ÕÔ‘ûG¼_œ€îuþUûJãïÀ§§j¯‘KÙ8Ÿî§¢x+±'Ø·<ûõüüìs'ýŸâDæ$>Án²/üëö÷&~/ÞXOý4±É¿ÈáââOÊÕΙˆ½%ÞªßÌG¯â‘ûa.uìUö+yGÀg¡OõÛˆW‘“pÜôÐãüú}’âêà“®o8¿Â× ïÈ!ñÅâÜÆÞa÷5ÿ¾3‘œÂoì„â}󝓸÷¸~°ï'=Oû¡ÇúOýhq«Ù¿¿¼sÐá÷ŽýÝž9­OµsðÌÕŽ½À¾e_ákr‘Þö9sÚо‡GƒÄKà&îÚúJ~{qÖÃg›ˆóÇ>‡C@o˜ÏØMÅ¥H^´~¬~sw·l_–9D‘›æ)Ãk£7àûyñ=Á®äÏe_Z§KNϘ¿ÿ­ý³±‡Å1o=æ]]»°r]N¿³Š÷$ù„žèuþlú»'óÖâÿ’ËîWœ“ô9vÞí;_sûzcçGÓìc|(ÂùÑì*ôS=»°q§œ<t §|¢‡Ù·ö…}Nð5ýg?Sñ‰bwàëf×4¯zÆïâSø‘žc·ñï<;›œÂ_ärq¢OØ­õ?Çü=‰×g_«ÏÒ/Zè¼î\ÅkÏ…>ÅÁ.Øíc»]´tÿâ£ñ é9|(n‚îäuõqãNôuû³á.Æ?`÷‹'±ëì“üCq–ÌSLþÖs¨ÿ…Ë->Í.KÜ®xøÃ;ŽBí¾ÄƒØ'èÆ¾”ÿƒGËß«ŸÿL^tho·O9üxÃ_®±üòkîi_†üsq2¯Ö×¹±º¾Ø«íCN]>aóMÉ;q8r‘oÿª/ò=úˆÙ{øžÜwà¯âvݰ>DüÄ\Y¸üôOÞÀk¹âîs÷Ùé¯Yzí‚G~ùÞw¾ª~úö½>゙Ó9X¿xŽ|ZøbÏå'z…ÇA]zуÇ_¼É×ꉋèó…ÛÆÏ6 Ü-vÀ‡Sÿ/ýRÏäÕè%ürú wܼé˺ä_ý[þçàŠã¿ÿÀ¡·ä7Ñ;~•7e÷¦.­z^ýi]„|cü)öùÙóÌ~¢wò‰ùÒþùž»þùçÅA‰þh=NNóËå›Õ°{r¥ƒù=NÏu“y…ñ«ñ‹ý'Âg­ƒO=#n/.î<è_òœþ•'"·nÚÓ%ël|]q¼Ñƒý(.jâôÅm@oð"¯àÿÑ×ð™ùSõßàÓÀ‡Œ½óñ;oÙUë,ï<)ñ–γH¼¾x±ƒá]gfÎà_é†~¦ÿÙÍæ•“Å¿…=Ë®Âgô¸õÂ]g*Îlίøáwçïù|þ˜ø»?ËOóð)9Žþɇâ×%¿A_’ÓöÇzØYôµ¸¿¼Í ç_¹ö9ç¼gNü‡ÝWÜÔn.|0߇ÞÐãÐþ¡ÿnzü㟰óvœ ò®õ‡®&ó1ÄacÁwž~ïüO8Á‘ä Ü;úIì¬m±ú½§<»qkxÌž¿¸Nñ§[™u‰Có“ɸcò ìmò NnãYìø¿äwåü88L<¿Ó£øÄ¾ÕNO¹õ5ã¸^çÿ1ssùy¡£öoó ìšâÂÅß®^W–ý«ŸºôÜÉ­ê£Ð5¹D.ò_£÷g·tNzü#u쯋»¨_0§Â9°ÃÄ#ŠSû–?á¾äDÖ­/¬¸ôžøØ'o‚«›ç§wÉmôÇNu¿øO<ÈíÚß±+øÏô{ ½ÄNè÷°›É#qKña|mì¦ê/ò)Ï_üõè/ûÿÙ5~Þ±[uîRíµø…è > ümñŒÎÛMü‰=í~ì1ëÖe«ç©<<ûe»_wÊÇ'û§Ï/¼Èó’£ô6¾U?0Äg_ú¾æ¥ÇvÕÄͺŠW˜Ï»/šÖGžÀ ÃoôŒõá“ê5yØÈ•ÎSÏ}É=òÔû“Ïn=CõqÖgßäË›§ÉÜ4rÊœMûÆŸçv.Cì+ò±ñÝØÙçÎïCçÃ8{Àº>òÕ¹ðq›~¿þ=¹e®†¸9_WœݱóåãØ­žGœÃ~V¿‘ÛÑßìvZqÜ"¿¾¿ïæo¾óMN≰oùcâðõÒÇ0ˆ_Ö®Wg þÄ~k}bä‘ûx~þzc' q‹»?ÉØ»ûÃwwÀÜÍn<·y£ÜOý§<y̯mýü`¿P¼³õýæÑ%îÍÎ$Ô!—¿ÆÏ;‰ÏD/ª»ó¹æoRïÛ9J©?hߊøŽºÿÄñqû\ò9r‹jÞvL¯ÉNT¯‹?[Ÿ“ú&õd­ý×O·ÛYÍÓu^RâMìzüiÝìëGlÝNäž92üÊÖ¹d¾+«õL©¯£W‹×z£/³ÿ­gO½LãCò(âøÉÜ(õkê@Åq:G:~zó“‰{¯=öhët’ç!Ô ñ—Õ ©èóš·ž~Šöm˜/ê>ê¬ò<­G ¿_:ñù…!Ž|ñ£ïá^Á‘èÜ´ìOó9‰ª7ê9&ŸbêúäÅùåÔ£ÈÛu^¼èØOyßœÎí÷iw.œ:ôƒž;,çyõýË÷ûÈý§èoý(»–<ô~výfW±/䇯l_ZçRç{ð±þò]½Gë-ƒ/2çÜ}ÏüMú(¢;ï*tÒyÉ¡úEý{ë"Í%1'Ö9G^T®â ê—Ì9•í$wÚÿµó4r?qÒÎ)cçDþ¶/™Ï±“;ß&òE}¤ûª‹ãOÊ׋˜W–>kö_ñ™éùºâçG‘ûOœx¡ýésG_¢Wß[zß±'[Ç‘:„ÖAÄÎFÏüµÔ½ÕžW'?ªÿ¿*Î}ä§<(;­sG§Óy%ÑÓ]_è^¿Žœ·¿êlz‘œºe¯7þ–:Q÷±?êÑÚ·9_»H_Rž»óí§ôüüºÎ÷1‡&ò€Ø¸¨>u~;Öóákq uEâ˜ì:zXÞ¶r)ôDØÿöǪ?Éëì”Æ ²_âÂâÚ­ƒ×u×eÇòÛÄyÉ…ÚK飅{ª’œä÷˧¶¿H?ø8.U\•¹o_zàF'½h‚WOÇ®çmß·¸dâ ©›ÌWN^¼~KίýÌæÉ¢ÃÈWzžüg£ôØø$»$|{Î⃿ü‚£]þnÜ#ë­¿mþ‘y\éGï‘%Gøçô˜õˆcˆ t޼NâkÃú(tÇoþ)ùDþµ|Cë‘BçðŒùíÓËzÅIÄS70™«©'q¦ä)ŠOgƒÝqÕó}û¯VyéS}8ÂùÈïÂUèÜ›èyòŽ6ù(ŽW}¾’/ì¼õWÉSËcÐì%qFþ˜8lv”}?pîCº è½Î+3.ò¬óêàdÄ žvqcé ç!%Ò:»Èó¯½b¥¯°ñN•[ö[ü]…ü—|•x?BœÚ>5_™óQ?š8ô0oÐü¾s~êÓÈ%ñCùQñÆm²?òàëú•—j¾Lýtê…Ècv¶x­óã7±7æ]ðÒU_÷™Å“yæÉËÈ‹î7Þ~W¨ßÔíású„<&/È/þÏ_>÷ÇÇ®ú³Ê!v©så__ò$O»»óàrNñë/‰Ó©_–ŸGOû’ûú½õ\ùÞk6øâ^sì‘»òãÕ¿~óƒ7íùõýw¯Nÿaãj‹F®ñÉOöœüxóÁ‘æ2³Ïø;çÏùÒeŸÛr·ž'{ˆœa·ó“Ú‡dn©¾°ØYƒy+]?ùFÞvžLôùHŸ¡'ò‡>bñ‡jﲃ¢ÏÔ¥|/r ñOØÝô¶ºØîù¬ÃþˆÜWœQÞ´¸.ÉC±cø§Ö©Þ§óáiä¹Ð'}(¤/É9{Ÿx::nÞ9vùßy1Y79'¿D_“æìŠ èÃè\àØ%~wƒSzK|?rtR79¦^ŸwÿÇþDûPí#9IÞ׌<“Coö‘¾%—ÄaÕ+ôã²÷¬ýÑ-®üUëÉœ»çá/YoÖ?‰ƒç{:#v`é&ùôÎ1ŠR)Þ8”­Û}ª?kyÖGŽÐ Ãzuä±{.ìQôÜ9æÏE¯’]uðûo¹y‡úUò"ö•¹éè}÷?ùàãúÜìAs|†s?äÍè9ç®^®üÍ:;ÿ™ßmŽpäp쎉\Š=i^Uq "Ø»ùÙ>ú²õ¢òЉ›‘k¡ÃÞŸuÕk}ióuÞX½Ñ¹¸ÉïÈ÷®.ëç'5ÞÆ_Ye÷C~ýÉ¥—ø×Þ´æ^õ‹ØU>ùó>øg?øäºµC[gþãï³Sàžˆ×’Ïâ^í‡M^E\H¼ËûÅ!Šo‘¸Zâ{ðG'ž.ø¥­3×êïá9ÏÄO¤_ám«C_Â?퉜.qâtî{ÿ‰›¹ãiWÖN€7¼Ñɼòä%èiõÆðWñžâ&ø~8‰Ÿ´N&ë³ïêËäÕ=ú­ü½rÔ¾šg“¾ÀÆùõù>ñ~ûȯö>AüœâfÃÙ`Ç«ÐÿØ|@ÎÑþó—Äéiu‚ò¯Åð=úÏÿþÃ~“∗—6W%x™­Ò‡gôãÑ+üx¾âÖ›:ŠöÕÃcpîê ¼Nïú»x•x½ø¼qê¡‹'?þañåbÇáS}‰øÌ|Ïÿ=Gñ>·óÜ¥ÇØáà›üìó¿qž¹þ>ž¯Ð>õâÈq6›ÿž3y×N3¹¼¥ >Tè Ÿ¸/üEô ¿Ö¾Ê7úTGªou *úüÉïâGùÃÚ[©S¶Ö…?Í‹ÑçƒîÔåÏ+~<“àjTþ·ì¢ÆÃäºþPç/?ޮ䬳|ùg¿¾qãïÜ~ö¼Æëìê1‹³ÈÞCOpí†øöÓ÷–¯CòDôPð>Fs_Â;öùÐËÿôžý&W}¯¾fv•}àO”?óyû/n¹Þ9 ðÅ9ƒß:Ñ¡ }}ðô¡ˆS¢ò\møµ~lêoÇ÷lÿZê¿ÉUö¹óL=RóJž‹üq_r€}оf¸“‘7äX÷9õAúÔÅE²®ÎÙ¾—âØ$OÓ¼fp´È u:ößË3’¿ÁS™ÌÅã&7n_£ð;ÿ&¸çÍ[9ŸâHù>q÷[Ý ¹Ú¼›|9¼ûwZ|¬üº‰ä¿&ý˜É—ß³Ïäoõ y9%¾©.‘ÜÀÿòâ;áëöOÓïüiñ5ÏÏßA‡äç—o‘wGÄŸ¡C8í{-rXþÜsú~q'uVö>?>óœìVù]v~×wïþê ŠÿH_'$ŽmMë>búžÚyãüLq&#¿Š£]œÃñþ–?*G‚SA>Z—xz­É}«ŸCÅQÍþ‹ûx¾ò]ìŒÒWämü.¸Îè­ùh8\è¿¥u-ž«¸&‘kÅáI±ú0vuíÕô§;×Ò?½¹Êðü•Î ¿¨kñ¼á3rý¥Ÿ‚îÈ[ç„Ïb÷ÔbŸ:ïê¿ØGÕ³á“ÐoqÚ:Ž|œÌÓ{òÑ~Þöy|OqßB—ò_üqrÈ|´âÒÅŸµä">*^Tô„< ¿Þñ‘—x÷ÄŽ‹×ÉOÉ/OúûñCè§ô=–·pÿ{Þ껽T;9?‹æ|èѧWý^»8u„èÍçò\þäq37¬ùcû"þÅŽ¬<‚ó{#rib¿æÜÈkv=JŽUnEÎËs³KÔƒ°kù¯òÙ'sì&ö\p¥ùýò¤•ûÑ䡸ƒù2ünö¿ý‹_a^BýXt@>º¯ø;;y¼òxRñ°"‡å›êÏDÞWß±O3¯viö—\,ŸD=t\¾ˆ\“?à_°Ÿ9È~,Ý…Å×'ËŸáœÄêWzßÕß ?›ƒ-ö¾y3]gã#±KŠ«8þþÎyrq¶ÖIëkÿ£WuJè¹vÄX^´n€ÀŸƒ‰ÎÉüÀ®¬=ùís#ï<~z­^I¢ß¹â<ØÁìÃò½}›zŠ®§öBè‡Ý"ž†Îèst ïü`Yþ6vž×É;v;¬ù†èGùìÆ!c/±J<騙œŽØ#Þßz“Ð_ëÚò|~ªÿ¨“ûó—«Ï¸ž‘çò¼â¬ü?ö8~LæÐ$Ž·KÜÃ}ø÷9çÉ\Åè¥ú“ÎMü"Ï#®èwú–×yá£êK87⯙Ëÿ‘?SÿLÜ!þPûÐCßôiç.§>­rÅNóýΛ½8<'v:³ÞºOñOÉ>6ýEN[7¹ßÅWŽÜ-¾LøÀýú÷ÈQu[Å)àÕÓ[+‘úÚ5ö5v‘¼">/~ðx?'ó¸â§4~’çUáyÐ_åVâ’æ©»p^äÅ þ~ò»øLöAhóäù»ªtŸ:Yô­N«ñØïþðw¯v~õ´ç¦×wʾ Sü_:GÈùÑŸöU>}ЧÕã‘Çí·‰ýÉYç\û'}èм¼>w¾W¿mûA¢gø=ÞÇ.$/è_q­ú¹‘OÖ¡>œ=&Þàóì¶~n 7ézþnžD|›^ÊþÉ•þÂêíznòyNþýíÜ~½*~ÎQg…ÎäÿÙ¿ðBÝ·qbrÎ|ÁÄQ[Oýùc#~«ß„Žíƒúeüž×ͳ+Ý”žc¿èËh~ž/y“‰ÿ->˜õ6õ³ðçNÚdÃe¯}ÛÒϯ·æEûÍ_Vœyxø(Ÿù³#nÚê¿XúÛÞqáA/zmŸëŠKï_ù´3^£þ¸¯Ëç~ý÷8W4O«=uh­÷ðº|½¾yùìö÷'ÞøÞßÁQ}y×¾ÿÜÔ륡ë€Ë•:†ÉëÁ±±>õ=g¸ê³¶|Á¿¶îAÝÅù¯¹pî»6Ü—ð$àᜳóñ‡í°Êð'ú÷àòô÷Ë–~mÃ-~x?òÍë¬|û^Ÿ_zê‰?Úò¬_ÿdéÙk|â³Ûx{ëíä™Õ祎ªŸ—ÿIýSÿ~Á#þf»uÙºW§×I=•¿ÛOuYïÒ÷>öŽ¥?¸v…ç?}Áþ×|ٱйñ=¯_vëÑ'´Iý>?á|àà­´ô;'}û[íµjë…ÐþSuí~Ïþö¾¡‹þ®_YýºcG§«ûøí§l·ñ™émçnŸ®ÛëÀëÞ·æAÝý¡ê0†ûëuüãüàŸè“q¿ø/ýüi[ý–y;¾¨u§øÂ¾Ú'ø~¢ ûyí³¾ú·£UŽ\zÊ%«oøîÍV^úÉ?>ïγ÷ÿs]áÜð?úCçǯÿÁKžÿ_vž û]ýÛ°Ý\ýíò·{ìÕ×Õ#Á»)~^Ö™~¥¾?uaý]ßÙ<}£WÜóîÖc¨WŒ\ïû/|Û&ëžõs†ëšà¦Þ}_²ë¯}çý{êû_aì¯8>Wç  ]E^õóêÃá |ÿI]ºõ›¾Ø¿»¿Ÿäœï…3õÝãOºí1Oyy?÷Ϲýñ{ð¹I?´þúÔ;‡^Wx8-äºþ°à¶MøhüzW‡†O³ý{è}…çrÎä \†Ðwß×#ô1Ù¿ÈSu©èš~ WÐzÒ!>t~èÈçñzc×¥^²ß£þÊ:òùø@½û?çWþ"'‡x2䃟êT‹{7ö«W»èÄ~ÙõX9·~î‹O]cÁwòéçýÞú=ô¹O_Nö5ÏÉ~}w‘[}õvøÃñ ÝOðzg/ÐË=Ô}…?¨OAž|''ÉçÔÛMpbÒïûõuzØçÕÁâ zǾæýû ëWßG/ž÷™ûæýܯ—_Ô²ÏÔ žùÓ\~ú.7V?‘ößü£áó Ö±ÂùíüA>Ò{ñû¾“ý¥ÃÞtÜ]Ýë§7†s¨œ\.òP¼ÝØGõù‰³®°~üë¼#ÿV°ïÜ×¹ Îa…ïâEáK|—½_òèe·o¿Ù/ºOîK¾íNt¨¿AœžRìw÷}Ðï!¯ôé°cúÀ¿p×Ôß§^}²®Ð—¿Ówìçzí>×¾îÌ•OìÎЉ}ÅÏÖMïÃ?qì’ȹ‰<‰}ð²W<'ûŒ~¶>÷õ“œÎϾÏýØÃèI}=ï<éþ‘s$ߣ—†t?‘×ùæœÐ³ýAGÖïÕ—[/ùÁþ·~uŽä¢÷u‡ëïùÇ{®[aŠs4Žw®ðwþŸºúàÞôïCyì9رè‚;­ûIÀ1£o<ŸsŠ^/]©ÿ×W/Ùê¢Ù 蜼!ï|ï€NjGj…}±çGnz.߯Û:àácõÜäcõdä!ýƒÎéK÷ðÑ ë$Ä…¢/Và}Þ7Ô÷äHpXû:{ßÅî]aÖëyìï7f¼m›Ç¾¥ÏMNz‚ÿêüìÜHzÉ>äg÷]ÙG8aÖUÕÔ§‰3÷âsêâñyÌþð[í|Œ¯ØáâC:%ì‹õ‹[à§¡A.¡+ϧ>ŸÞÒ?=â£áÏ]ô~ò´ôBù.ë†K…Îô#ð³­î¶øçwö¼ï'¿Ò?¸‚ÿ€ô5 #}˜ìmïϹu_Ý??Wàÿðq_wŽâô?{è7êãª?;—üò;9½×ûѯøŸò Øùö½²ƒ/ûí^Û¼êíw}èÏOë"ÇùsþŽõéà+} ìñ¼â¦Åù#ôù€Ÿ|¯8‹¾gû{Óë®Ø}Ñsn®xçïÒn=¶rB>Oµt¿ô1ú:Ò8íÃm4V ©ÿþ€ã… ŒöŸrh<„ñUØ¿y×oæúEô‚!ÖÀõÓÑóÂ]¸nl?@ûé `­Û?hL‰A¿û4ú1|Öc{nØŠãkÂß*Œý3ƒÓi¢¡l'ú#Áؿ׹’&æbûÛˆñè? íjKË àÎWµ—ÆåXç*æ|T"ï•‘ˆ8¾rÖ=žËÏÆk4VЀõ±ç7ßÝçiÜuÆblß…~>h+íË‘—r!—ÿ]4îļJorõRŠ:*Å<·#¿M4nÅ|¶!OÛ‡4äSŠqÊ:iT¢­Çõ•¢îJQ¥qu½y\_Âå æ­B¿-X‡-³}iLBÝà¸\ÇfÔyqòëXˆýɈ…Aˆ¸o–—p÷iŽÓaI4æ£ãÂÑŽAÜ€ëÝ€º^‚ýëQ7ëQOëcåŒzY‹|P\W¶/ĸz¬ßj\ßjâ|²¢8çd#+_} w_iÑÖá<é7-†«Çœ7ýc>‰L‹êöKŸ¬‹7±&¾©'÷9“™ONð)#t &xÓñT„îˆq^D½ƒà•™Oäbè_Wd^d\åyjiˆçjÁ«Áó„ÈWÒ¿þÙsÜ¢§íXèì[Òž“+ïEÎúl'ÙÚ-¿4|ü,³êï£Á%cF±ÅŒdpdê²ÈTt~³#ŒtdêMÆ‚ð£á&[¢X½™ÍŠ|ûÆ{a0®»½qÁ•"˜|êsR2T“¥ë»à¸fdâчCÁ*!a‘åŒ'05¦Ø_Ö`Þqt’TAÃ_ Éu>=Ƈy‚?ÊžÃΧtµBXBqå\iÞjP=µäufvƒ‡½q%t$³úUÅß72>TQáëV?¹ªði¥;Ë~•ù˜8 ­ ËÄ,{gSƒ”å¥SÓoƒØ£]ÐêàÊUúÈ6_¥µ¦Puî(*fy9B@V±_ES"(N¥YoÒ–gšqÆ£ÞLù¹[»îÂ?M?ÅàŠ1|“–±ün >Y}s?ʉuö²+—íž›³z‘ÕŽ8zþØÏ +:?é«+ÿ÷š«ÅÓ·ƒü`x°óq%ÈÂÿ²àÀö^Þ76µ” @¾ñ» ¾yÂââ+Ç®ïe¼iRc#ÈCç(·ê`ü÷j‹e͹)|oy¼÷Áð½9Ò‘*òeÏ]ñ'ÊEªgac/SnYùõ|']\ê?ºÄò¤•~›ºAl{öTÙ—wÙóÎe¬ßfþ¡…àù‡ìw+N€wµcF°q xã>bΧ!wô»wtÖ2çx¹Èþ±- <›-×¥rψ–N´±ûʵ,ÞæÁç©àñ¤1{ÏAxØä×~hõ!/ÊI®ieõ(H8õðAM5¸Y‡ÜÖ{»;òÃG¹®©‰ŽˆÀ-¹±6Ꜧ\–ŸüÛ‘Oar{h/œ¿,,?Nm¢æØ|){.N¤÷«ôYÕÞÄ\É_îõœwç¦Ë´K2zŒê{yŽ/ÔuÉKð÷Ð V—™–±v1Û‘˜ÙçÆg–žª01Í_¾´§·;UON—¢Í`&fyñZV˜®}—ú÷ËïÌ“pvÿgss/data/bacteriuria.rda0000644000175100001440000000170512545250042014761 0ustar hornikusers‹íœ[S1†—Ý‚PDQPQQ±Òlv ž@EåÚ+nk)3á0SªÞú“ýà¶“}: ÝäK¶Ò™‡|Ð%O6ç´ÓþØÚaù¼ã8®ã¹CŽëEaÎ~ 99g,JÇ–+j½ö«^+;Ž7Õ|>J'"xë29Ü6<¹ +2BàZFÏ0F ã)¸ž‚‰n(p³I·Ü&0E`Z‚;ŠÜMÁ=3îKò€ÀÃÌJð(Çž¤d®O™WàÙ%,$ð¼‹^(²¤ÈKË^X‘à5ÂÞ¤`•@‘KÀ'ÀÛ$ ”¬X'ð–À»Þ§äƒS°A`“À§>ø¢È–"_ |#ð=ÛÉœ;úŒìWW÷Åîs[üu¨,ü8àqÄA¥8X‹ƒu¸ÅUDED ‘ˆ# …ˆJˆÖÁÁà`p08 ƒƒÁÁà`pøpøpøpøpøpøpøpøpøpøpp88‡ƒÃÁáàpp88!!!!!!!!!!%8Jp”X['®ì—ã>Žž¿úêQtB8ë[,‹e0q-‹Åbé?šÇ ÷Tœ|Ü„Ó}ë ïô²³Qó=.7_¬i>6GE:)Òi‘ΈtV¤s"é‚HEº$Òe‘vÊß´E¤‘®jòf]îA«§~¹]åÌ:Ÿ¬êwPÇ·õv×Û¯ó«mÿl÷½~_݃Ò/ì~Mmý½È“Uÿ¹*ó¡=Xo/ïo:ÝÝÿ˜õöjù®Jÿ¶^;Þº¹ÿ4=Nl?ìóÝ^É×â÷iœ¶ÇÆ?¹ße¯£æ«ZNÙü©÷•¶<²©îògoÚütýŸj¿’m?ÝãE6j;êjOÕëTïC÷<£ÚΦú©éñ «_ɶ»®zî4O¦}Þt{©Ö»©õ)«ùQ×únjþ4ÕT˯ºoнÎ꪿¬æ!êz¢:ÞTLJ©yÖT?–­ŸAM©ýAÖ“Õý¨®ß²ãSW½«–‹ZnÝû¬ÛÛt{õÛ< »^é:©Ö£lýšj_êùÄT9TëZÞn­ƒÝzè¾oj;êj7ÝýØT}™Þd•o·úê<ßkó îuFwͪ¿«ž³³Ú/¨ç{þ« ËÕø« rñ7ÔvEä5ê æµƒjüùœÚá^µÒ¸àÓ;ùÝr£\Ø«G9·ÙÆêG ±±ùuwîßV‘Zo5?êsòh÷…¨-Qgss/data/gastric.rda0000644000175100001440000000073412545250042014124 0ustar hornikusers‹Õ•=OÂP†/-~@¢!qqppp&ÂA“C…P*¤½€FÅbb$ Q‘ÕŸàèààOppppptdpF[Î[’’ã¢á&å¹÷ž÷Þû‘6¼ z£^ƘÀDÁÅÑìºóÇÅÜÌcr,%é\Ë$§Ì¡Ÿ4ŸØB›u[hÍ ÆBÄø,Qy"îB—C<'jÏN0_D~ú"æK¨W‚¾Ôvrúý;â|!¯Ü žÌ Ô5ªà±ÝÙ4?çq'«ë ôÕbõê¯ÄKøºÊ¯9ø~›/Äü·‰ì߸ ®€«`Œ`ݬ{ÜD| ñmŒ“ïD>ŒSXwÚ&Ö†¿ä«ÈSÏáÿtì³~óðq~ÇÈ/#߀/çYÁyœŽƒðQž^ ^Ãþ×à»1ÎoÒ ö»%ÞÂW‹ÙÍq¯ÿšv¶z?ÍjÿµÏÃÂß¶Áyâ„u¯»¯ôá{„á{ŸÏѬ\”³ºÙóu£4ë Ø`Ÿ~$‘•t[Þ+¢H žÓÌ^§_¾'©²-{òϨ²=Ò¹Ä :F"×x_ –+ùí:Ö]èMlÝK(~õÙñ&%.ùÍL!K¬ó ô¥T€Hgss/data/wesdr.rda0000644000175100001440000000751712545250042013622 0ustar hornikusers‹ÍœÛnœWǧIÚ&¡mÒ¤Mí\Ûs>zŽžñy’”D®¸êm  BjAJŠ*îü¼@‘¸åò<@x€¾€¯‘@ªpâõÛÒþQ+±g°Tv¾ïÛ‡µ×á¿{?ýèÓþÅO/ …3…³g^+œ9{øÏsgÿçµÂ¹Â…Ãöõ¯?ôÙÃBáìÕ§_ÿ{ç°ï¦¥ožþý~Z|òôïÏÓµÁ³¿éfáÙß´ß÷ÚsÑïn´·¢ÿrôë?xö7}7ž×¢ÝØ?šïJÌû~ŒëEÿ‹ÑVcÞZ<ã.Ǹn¼_‹çøÝÆzDÛ¶ý·b|w_ãÞï}ßwbÜ­hA×ÍhÇ1_/¾Ÿ‰q›Ñž‹ïí k)Æ]ˆþìw!ÚBô?ýxÿžø³írô¯Eÿ×bÞV<ß8Z7íçõø~9žW¢m"ç ùV¢…7ÐúG; þ Ä7ä4ŠïÕBÞ^‹ïƒè¿ï$Ÿ®èøAÐ9Žïð»ã—´ÎJô¿ =÷ŽæƒOËñþ–ô9­ÆxôµãKYëýÑbÝX÷Ãx\gäx'žß‰yïü)ø°˜ó{F¿ öãá?ëŒ‚Ž²ö±‡ÝÆüŒoÇø!|`Ýh™>• ¹}ÃOì¥ï7cÜ ø±r\Ž~ÍXùÜyêZ÷r|‡žzŒë‰O›±óOàG¼¿.»*j~øñVŒÛˆq‹AvÛ•]…Kèi?ú-Çû²[äržýF‹½ßŒ{‡ÎõXo"|DÈo!Ú7à×Ñ~öþQÈqö½˜÷taÿèWðy1ž™o•õã=ûϯÆs¬›üKEmMö7/býÀ-ì¨Žß ºÁáÞã£ïÈþØë0æí ·òÉ®‘ z‰}Çz´ð½…ݰó£A×uá.~3p|ZŒþ—´_ðÿËzïE Þ`¥x¾.½ÂÃOü%þ¾µ£Å´âùšpº-9W¢?ë£gèùp}çQŒc+ôÇ^å?° pþ•âyQ~pAýVŽÖÝûW<£oÊ?–ÄßîAØS´èO_þ<ÄÏ3þ-Åà]I8‡]‚ÎÇ÷Uñ»ÀìÜ›~üŸëÑâ§Ñ·cžÑã\)>ÀÅ÷h5Ë÷ŠüUøá½¿ÆóH~6üx’ x4÷ÿÄ=Éña)÷ï{ƒŸÐïcÞ´>óŸ•Ý€ 祯cöën€ ñ¾¯uŸâEâŸè?^Ìש(î¼$¾ Æ%<ÿ$ôñ¼py‰ƒˆGÇ¿Ïè{U8ƒÞWòõ§ Ì+{DŸ™çÝžV£_ò¿Ä•1/8Ž‚›Ä/àò‚ö±ãËÊ7°—ÛùzøAèDÑ#â®æ…ßÄq í³‡½ W8uíè9Åñ}àí y‰â.ö¿ ŽD;‘œÄ_1?ú…Ÿ9§xà¦ðoUöL\³ï;Âå’â’ù»„!ÏíhòOëÒç õÛTHÜÖï[äèMÐÁøAŒ»{並·—ëYYñqþÜÂï¬Î|'<]Ü’}A§üPCqKIøG´d?}í#ñGrÆ>S>%¼gýžâ)æaŸÅù×ÿ¤÷à!õ¾Žâ‘Å%Eå‘UáPó:êOòzRYu’¦ì½¯}1¿‡&Ü$NÄ4¯ñ·#:éG{]öRU=»Où8"9Óu[ÊÁóŠüñçbðq©î/µ$=*ÉO® ¯‰x†«Â¹²ð¿%;èKï{¶ä¢óµV^ÏNãk¢«-¾¤õ¥kòËð¼2þ×dgmÕ…Ö¨>Z”|ׄ{eñø°¬¼¹¤8–ù[ªTä/Я¾ã“XwI|¨+þYSÜRQ~ÜP¼ÕÒy"ò÷š²즩:z\ßÊòg Å=Ž·Ve¿í¼î˜è"Oî›^Å?ÊÞªÓô䟈WŠ²Ï´?Õß’?×¹8ê:®ã>òŒeñ'Å‹ÂÞ×…5ÅCMÅ'eW'¼~ÕtN?Zš§®ó-⋪pù»\‘ÛÒˢ◊⅚ð¹'|k‹%ÑÝQ}¹¨¸ .?^—Ý5ÄïÚ18Ö>ÔUßjsÞV>fýšp£":::w¯ O+_–¾ÚÏ,+ìªÞ _ñãèAK~¾ìºù~Ž{Œï8nC?i…ŸØoGñQMçëeÕo°³Šô yÔTOx¤}¬)îk)ï‚ï#ÉÅq!úZ”ÜŽóCEéqò_ÒGÎד9þP^ ßkòKÝ7©ë¶"±¦úDI÷Jò+EÕÏŠò/àã²ômUuç—ìç–⃖üfSú°"‡ýAW[ç\)?‘}@OI÷{˜·«8¯ªsÛ¤ï²ß¦ô´­ü¸¡¼¢¥|½&».ªÞÝ–ßâ>ǪêPeá!òëèþÈ-Õ¡“¼¤WK²ƒ¦ÚžòÔšî9°ÿ¶ê2%åÓé\<òHü7v°¦¼wM8[•>_×…ß×;d7Uí¯¨úUEû©)¿­éÞJÍø%>W•wU¤ÿì“{R«ªoV„û®ïX.¬Û]Æ×ªòíªô§#=vþ¼(\+ ÇÒù¨äÕþЯ(û¨¨nC=¬mœ†?ªwr¾Ë}¹ øôLÔRŸÞåŽ{f±î(ì€:ï.纇FýŽóãyóo2/ucònÞÇ:Ì¿¡óË ü[Ì?a~εƒŸëÚ?çñœ«s޵żñ<Ö=1æÜËëN¬Ï}/èh>ô¥ãá3y!õ±âîQ`ÐÍúØçzøŽœÄø6äÜŠûÈ…qì—üUrÙŒù¶r{ἈsøˆžCïc<òY?Èï…rŸ‚÷èô£·ë–ÐÁ:iô}ªnÈ:]ç`GÉ~TdØ1yã‘;ëbè=÷¶±#èd<ö¤õàÃHuÏm­‡ž2îŽô7É›uáã~þÌ=9ì=X½œ#!Mì‘u¸Ç ½ñ}}ˆñÛè-ë gäÏ<Èg1¿ŸÄ<ëº˹XÒ?Õi’=Å<ð}Œv€ýä÷eÓzÐOö)Üo¸¯߇Òç-èŒyЋ Ý¿¡N…àÇÖE8Ô×} ƽ°„gœro‚}²oìIü‚î¾î3EǺô8é˃œï¶wî¯$?€~‚ƒ|]脯è[ò+…ü^9z—øÎ{Ýç¥Ýä~rb<+ä8•ìŸ|T8:V>•Îňoà/8…Þ*OoøÃX÷œ W&²› Ýû§?ò„ð™¼E}7ÙóƒÜO£_¬¿»˜×]¡#áSÐ=ѽDìwCçìg(=·á;ûHïáƒå#=€þÕ É×ñèúº+\éÉßsožøe(»Á¾F¢{(ÿ;”ý¥þ…gû’'|Û^öä'‘çÇñÌ}ºMÅð¹léÌÄ8Ì8žcÜÞã7ˆ“‘þê¿â´ýg“] ‰7ÒÛmé'v¸!<‡Äëði°˜ûÁ¡âNã*ûCßÑ'ø:PžÀ{ôpKz Þ/°Oô ?‰Í´ÛÑH¸;”_Kòzœû¥Û¼òýú=RüÀïµÀééÃnÀeÙížò~ÿ1~&<ÿ ‡úŠ'˜[u5ìúøÝ\ŠCösÜØ"ïXTþÿÀý^æ®ýˆpýÙU|Œÿ§óÿÛÓØÇAþûµð>Ot/\×ÇŠ_ÇŠÛàÇÐqýr=çþ!üäwˆÓiŽGàæºòøÝ}œÇ;ò×ð—ø†{¢Ð…ŸÝ‘?ǯ oðçú ?Ì/â]ätÛûê¼w¤ß9íj]ÅáØ;ùîD~|¤8q¬|(å¿ôS~¹%ÿ<‘AŸÑß-çñÒSÖÁ‚çää1›ú=àHþ¾€??~ã‰óø±âÖuá%|Ûþa'à=ÏèMOñ!÷œ·”Ÿ&À¿€§à xrç‘#ýnÿÀwø˜ü¹~w±¡|×qãºêààšüÊPy7u¡~/ÿìê÷™i^pGúÄwðn(?›òÛ{ùïvǺç‘ú¿¡çÈ™¸=W ¼›Êž&ú½cÂø¿öúʃGÊO¨ÿÞþVþû¾—ߓƎ¶Ñý<ß$K~Q|½­:v„ÜУžüöBÿðj‹x½á:u}~ˆŽy¨wŽùÛûË÷·Ïûþ¼öEÿNÚÿE÷1ëzÇõ;éûÓÒZ¾'¿]çEõbV}š·><ÎYõóÿ]N»¿çŸ—žTOOúþUÉwÞú5+ŸgÕ¯Yé˜N«/kÿ'ÅÑÓâñIqò´¸:«?ŸÕ¿þ¯âyëüô~^þó¤úyRýš§fÅÓ—ÍËžV¿f«gõŸ§å÷¬ršU¿^µÌê7æå__–ÿ}Õqý˲«Yño^ñÇií|Ö|cÞqË«ŠcæGÌŠSóÆÍyŸgÕ¿YóÂYõúeçmóŽçÍ¿—§½lý˜7Î<Ÿùÿ¹ç¯îùù£Ã\~ú%^žýì7ùç/¾ø-ÿüÙ—¿äŸ?ÿJ]xøë¯;LööágöŸ­ö´²š¯øó/î?bE^^üìþW÷;Ž?|úîéÿþÎÓÀ™Tgss/data/datalist0000644000175100001440000000015412355360641013532 0ustar hornikusersColoCan LakeAcidity NO2 Sachs aids bacteriuria buffalo clim esc eyetrack gastric nox ozone penny stan wesdr gss/data/aids.rda0000644000175100001440000000260612545250042013410 0ustar hornikusers‹…™kkG†Çv ‰¡ÅPÈÇR‚J1¾È¶"YÖ¬î«ËÞ$»þ*§’â–~ÝŸ¦ŸÔ_P*Çón™Ç»ØÍîÌœsÞóÎ9g¤¬s¼{³kŒÙ6;Û[f{góñÙöæ¿-ó̼¸¬>¾¿3fçÇÍçû—?l^½¶æÛŸýÕÉWçNþâä'»ùƒ|éÆ{˜WsòÔÉŸœ´¹?OÏëØWãcÌk99póŽð^zà‡ì³ðËbžÖ —RúÚãž“QîãÕƒ¾‘“—Ø|Î`¿ð‰0¿=±“ ¬ëç>®¯0ï­öÉýñ>ü<oì›:9vòãQîëO€±ÓÜ÷ûñÚCœ/Á;í×ÒÛ„ð:uú“µÃ1÷ykÇ<·àå~&Öׯ÷]ØQƒ²sœû<ýóÀIçDr‰}§9pž‚¿âxæ>O„“žÁ£6Öi~cäCÖ‘ü­ã\öÀé©!î-àƒ×Âm¹öýoãüêù~È®‰“3œËìî@oq>q®ÚOè±È‡cä?«û)7°øqžRÔã ê ûêSÏÝy*ú§%ðŽSÄsûÒµ¿»Y·:ˆc€zÖ…òÅø>ÁúCàz†xÔ*øË~N8dk?/¬WÕ{á•‚O7k¯ ó–Ö×£ý®¬_ˆ‡xt…ó#=‰“׈[¡Ç‡à­Öq^Ǩ!â »¦àÛÕÚ·—öËÎ ÌϬ¿?ëKBÝë ê#ÈÓ!úLÅáþ§l]n‡ø6G_¡Tܧè£çðcŒºª¸yÀúþÏ€ßãøÉù_Gþ§Å§À”÷³<Ÿ!Ÿˆc„ø÷1Oü˜ï#œƒØß1åù}†|´_"èﲟ‡]âï«Gð·úÒ…ÿÄ=ÎËïûŒë u®‡¼4À¼òMùLþ´ðü7ä1ÅYó‡¨kmä‰~&yùý™}F†ze‘§Z¨‘)¿¿ÏÏqðüýZÀüˆ8h]ž5ïòTˆóséó½èŸtOu;ÿøRÏÉŠuÆÏËÇUë¸ï£y{OèÊŸçå²x?C\ë8#œëóxÊuMS΃ù„ù® »Ny€œã}ðÄ÷oC¬ !eOó†à}€ï%›ÈG!òù9E¾áýi„ýšxVÌ@ßç™ß'ÎÑw„Èw¶‚}k}¥æÍã)îSÜ'BÈ.ø0GÖ%ÿ_.ÀÓ à1‡žš)ÏSSð´¼صO|Q§gèSl~=SÞÏ©ïˆÑ/©Šp‰Q?RöY苨3ÊÏÔ“¢àþ úÖz {á—î­ êXŠïKµO†q„{ya¯ú·Ü¯ãÄ)…=IÕ¼5ì2þ8¾‹¼Üž~.žg°'ªÀ—óyHh¯ñqÔþWØ÷©øÅ¦ü}þÅèÜ7R~Oüøž™ë„ß–ǡ¸Ÿ[_ã©y ØÇýbàFeGRKÜÄK®KMù}$ªâ%ylËŸïTß?y¿í}÷eõùönóaïÛ{î¿_Þýõÿç·îóÎê÷[¬ñõ¿´Ç÷÷?">¨ÙzMEï>­î¤Hw߯þ\|øºY¿ý{ÿï?wSzggss/R/0000755000175100001440000000000012341416625011271 5ustar hornikusersgss/R/sscox.R0000644000175100001440000004434212355360640012562 0ustar hornikusers## Fit hazard model sscox <- function(formula,type=NULL,data=list(),weights=NULL,subset, na.action=na.omit,partial=NULL,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { if (!is.numeric(time)|!is.vector(time)) stop("gss error in sscox: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sscox: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sscox: time and start mismatch in size") if (any(start>time)) stop("gss error in sscox: start after follow-up time") if (min(start)<0) warning("gss warning in sscox: start before time 0") time <- cbind(start,time) list(start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sscox: response should be Surv(...)") yy <- with(data,eval(resp)) ## model frame term.labels <- attr(term.wk,"term.labels") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+"),"-1"))) mf <- eval(mf,parent.frame()) ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sscox: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) random$qd.z <- random$z random$z <- random$z[yy$status,] } ## Generate s and r s <- qd.s <- r <- qd.r <- NULL nq <- 0 for (label in term$labels) { x.basis <- mf[id.basis,term[[label]]$vlist] qd.x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s.wk <- phi$fun(qd.x,nu=i,env=phi$env) s <- cbind(s,s.wk[yy$status]) qd.s <- cbind(qd.s,s.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(qd.x,x.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk[yy$status,]),c(nT,nbasis,nq)) qd.r <- array(c(qd.r,r.wk),c(nobs,nbasis,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in sscox: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p[yy$status,]) qd.s <- cbind(qd.s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rank=")&outer(yy$start,tt,"<="))/1 bias0 <- list(nt=nT,wt=b.wt,qd.wt=t.wt) ## Fit the model if (nq==1) { r <- r[,,1] qd.r <- qd.r[,,1] z <- sspcox(s,r,r[id.wk,],cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0) } else z <- mspcox(s,r,id.wk,cntt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias0,skip.iter) ## Brief description of model terms desc <- NULL for (label in term$labels) desc <- rbind(desc,as.numeric(c(term[[label]][c("nphi","nrk")]))) if (!is.null(partial)) { desc <- rbind(desc,matrix(c(1,0),length(lab.p),2,byrow=TRUE)) } desc <- rbind(desc,apply(desc,2,sum)) if (is.null(partial)) rownames(desc) <- c(term$labels,"total") else rownames(desc) <- c(term$labels,lab.p,"total") colnames(desc) <- c("Unpenalized","Penalized") ## Return the results obj <- c(list(call=match.call(),mf=mf,cnt=cnt,terms=term,desc=desc, alpha=alpha,id.basis=id.basis,partial=part,lab.p=lab.p, random=random,bias=bias0,skip.iter=skip.iter),z) Nobs <- ifelse(is.null(cnt),nT,sum(cntt)) obj$se.aux$v <- sqrt(Nobs)*obj$se.aux$v class(obj) <- c("sscox") obj } ## Fit single smoothing parameter density sspcox <- function(s,r,q,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias) { nobs <- dim(r)[1] nxi <- dim(r)[2] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(lambda) { if (is.null(random)) q.wk0 <- 10^(lambda+theta)*q else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda[1]+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(lambda[-1],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscox: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscox: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,log.la0-lambda-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization if (!nnull) { vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.r <- vv.r + bias$wt[i]*v.r } theta <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:bias$nt) { wt.wk <- qd.wt*bias$qd.wt[,i] mu.s <- apply(wt.wk*qd.s,2,sum)/sum(wt.wk) v.s <- apply(wt.wk*qd.s^2,2,sum)/sum(wt.wk) v.s <- v.s - mu.s^2 mu.r <- apply(wt.wk*qd.r,2,sum)/sum(wt.wk) v.r <- apply(wt.wk*qd.r^2,2,sum)/sum(wt.wk) v.r <- v.r - mu.r^2 vv.s <- vv.s + bias$wt[i]*v.s vv.r <- vv.r + bias$wt[i]*v.r } theta <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } log.la0 <- log10(sum(vv.r)/sum(diag(q))) + theta if (!is.null(random)) { mu.z <- apply(qd.wt*random$qd.z,2,sum) v.z <- apply(qd.wt*random$qd.z^2,2,sum) ran.scal <- theta - log10(sum(v.z-mu.z^2)/nz/sum(v.r-mu.r^2)*nxi) / 2 r.wk <- cbind(10^theta*r,10^ran.scal*random$z) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } else { ran.scal <- NULL r.wk <- 10^theta*r qd.r.wk <- 10^theta*qd.r } ## lambda search cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } ## return if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) { q.wk0 <- 10^(lambda+theta)*q qd.r.wk <- 10^theta*qd.r } else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda+theta)*q q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(10^theta*qd.r,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## Fit multiple smoothing parameter density mspcox <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,random,bias,skip.iter) { nobs <- dim(r)[1] nxi <- dim(r)[2] nq <- dim(r)[3] nqd <- length(qd.wt) if (!is.null(s)) nnull <- dim(s)[2] else nnull <- 0 if (!is.null(random)) nz <- ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) qd.r.wk0 <- cbind(qd.r.wk0,10^ran.scal*random$qd.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(cbind(qd.r.wk0,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*((nqd+1)*bias$nt+nobs)+nn*(2*nn+4)+max(nn,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*qd.r.wk,2,sum)/sum(qd.wt) v <- apply(qd.wt*qd.r.wk^2,2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspcox(s,r.wk,r.wk[id.basis,],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,random,bias) ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta ran.scal <- z$ran.scal cd <- c(z$c,z$b,z$d) counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscox: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- qd.r.wk <- 0 for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) qd.r.wk <- cbind(qd.r.wk,10^ran.scal*random$qd.z) } se.aux <- .Fortran("coxaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(qd.r.wk,qd.s)), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(.Machine$double.eps), as.double(qd.wt*bias$qd.wt), double(nqd*bias$nt), double(bias$nt), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } gss/R/project.ssllrm.R0000644000175100001440000002322712355360640014403 0ustar hornikusers## Calculate Kullback-Leibler projection from ssllrm objects project.ssllrm <- function(object,include,...) { mf <- object$mf term <- object$term id.basis <- object$id.basis qd.pt <- object$qd.pt xx.wt <- object$xx.wt ## evaluate full model x <- object$mf[!object$x.dup.ind,object$xnames,drop=FALSE] fit0 <- object$fit ## extract terms in subspace include <- union(object$ynames,include) nmesh <- dim(qd.pt)[1] nbasis <- length(id.basis) nx <- length(xx.wt) qd.s <- NULL qd.r <- as.list(NULL) theta <- d <- q <- NULL nu.wk <- nu <- nq.wk <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu.wk <- nu.wk+1 if (is.null(xx)) { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nx) qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } else { if (!any(label==include)) next nu <- nu+1 d <- c(d,object$d[nu.wk]) wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } qd.s <- array(c(qd.s,wk),c(nmesh,nx,nu)) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk+1 if (is.null(xx)) { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } else { if (!any(label==include)) next nq <- nq+1 theta <- c(theta,object$theta[nq.wk]) qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) } } } } nnull <- length(d) nxis <- nbasis+nnull ## random effect offset if (!is.null(object$b)) { offset <- apply(object$Random$qd.z,c(1,2),function(x,y)sum(x*y),object$b) } else offset <- matrix(0,nmesh,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.rs <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.rs <- qd.rs + 10^theta[i]*qd.r[[i]] else qd.rs <- qd.rs + as.vector(10^theta[i]*qd.r[[i]]) } qd.rs <- aperm(qd.rs,c(1,3,2)) qd.rs <- array(c(qd.rs,qd.s),c(nmesh,nx,nxis)) qd.rs <- aperm(qd.rs,c(1,3,2)) z <- .Fortran("llrmrkl", cd=as.double(cd), as.integer(nxis), as.double(qd.rs), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nxis), double(nxis), double(nxis*nxis), double(nxis*nxis), integer(nxis), double(nxis), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) z$wt[1] } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift if (nq) { ## initialization if (!nnull) theta.wk <- 0 else { qd.r.wk <- array(0,c(nmesh,nbasis,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { mu.s <- apply(fit0[i,]*qd.s[,i,,drop=FALSE],2,sum) v.s.wk <- apply(fit0[i,]*qd.s[,i,,drop=FALSE]^2,2,sum)-mu.s^2 mu.r <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE],2,sum) v.r.wk <- apply(fit0[i,]*qd.r.wk[,,i,drop=FALSE]^2,2,sum)-mu.r^2 v.s <- v.s + xx.wt[i]*v.s.wk v.r <- v.r + xx.wt[i]*v.r.wk } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nbasis) / 2 } theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("llrmrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(t(fit0)), as.double(offset), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssllrm: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssllrm: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nx,nmesh) if (!is.null(object$b)) { qd.z <- object$Random$qd.z nz <- object$Random$sigma$env$nz id.wk <- 0 } for (ylab in object$ynames) { lvl <- levels(object$mf[,ylab]) if (is.null(object$cnt)) wk <- table(object$mf[,ylab]) else wk <- table(rep(object$mf[,ylab],object$cnt)) wk <- wk/sum(wk) nlvl <- length(wk) if (is.null(object$b)) { for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*wk[j] } } else { id <- NULL for (j in 1:nlvl) { id <- c(id,(1:nmesh)[qd.pt[,ylab]==lvl[j]][1]) } offset <- apply(qd.z[id,,id.wk+(1:nz*(nlvl-1)),drop=FALSE],c(1,2), function(x,y)sum(x*y),object$b[id.wk+(1:nz*(nlvl-1))]) id.wk <- id.wk + nz*(nlvl-1) eta <- log(wk[-nlvl]/wk[nlvl]) repeat { p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) u <- (apply(p*xx.wt,2,sum)-wk)[-nlvl] w <- 0 for (i in 1:nx) { w <- w + xx.wt[i]*(diag(p[i,])-outer(p[i,],p[i,]))[-nlvl,-nlvl] } eta.new <- eta-solve(w,u) if (max(abs(eta-eta.new)/(1+abs(eta)))<1e-7) break eta <- eta.new } p <- exp(c(eta,0)+offset) p <- t(p)/apply(p,2,sum) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[,id] <- cfit[,id]*p[,j] } } } ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/family.proj.R0000644000175100001440000002473012440620716013652 0ustar hornikusers##%%%%%%%%%% Binomial Family %%%%%%%%%% y0.binomial <- function(y,eta0,wt) { if (is.matrix(y)) wt <- wt * (y[,1]+y[,2]) odds <- exp(eta0) p <- odds/(1+odds) q <- 1/(1+odds) list(p=p,q=q,eta=eta0,wt=wt) } proj0.binomial <- function(y0,eta,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) odds <- exp(eta) p <- odds/(1+odds) u <- p - y0$p w <- p/(1+odds) ywk <- eta-u/w-offset wt <- w*y0$wt kl <- sum(y0$wt*(y0$p*(y0$eta-eta)+log(y0$q*(1+odds))))/sum(y0$wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.binomial <- function(eta0,eta1,wt) { odds0 <- exp(eta0) odds1 <- exp(eta1) p0 <- odds0/(1+odds0) sum(wt*(p0*(eta0-eta1)+log((1+odds1)/(1+odds0))))/sum(wt) } cfit.binomial <- function(y,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% Poisson Family %%%%%%%%%% y0.poisson <- function(eta0) { lambda <- exp(eta0) list(lambda=lambda,eta=eta0) } proj0.poisson <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) lambda <- exp(eta) u <- lambda - y0$lambda w <- lambda ywk <- eta-u/w-offset kl <- sum(wt*(y0$lambda*(y0$eta-eta)-y0$lambda+lambda))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.poisson <- function(eta0,eta1,wt) { lambda0 <- exp(eta0) lambda1 <- exp(eta1) sum(wt*(lambda0*(eta0-eta1)-lambda0+lambda1))/sum(wt) } cfit.poisson <- function(y,wt,offset) { lambda <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(lambda),length(y)) else { eta0 <- log(sum(wt*y)/sum(wt*exp(offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Gamma Family %%%%%%%%%% y0.Gamma <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.Gamma <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- 1-y0$mu/mu ywk <- eta-u-offset kl <- sum(wt*(y0$mu*(-1/y0$mu+1/mu)+log(mu/y0$mu)))/sum(wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.Gamma <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*(mu0*(-1/mu0+1/mu1)+log(mu1/mu0)))/sum(wt) } cfit.Gamma <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-offset))/sum(wt)) eta <- eta0 + offset } eta } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% y0.inverse.gaussian <- function(eta0) { mu <- exp(eta0) list(mu=mu) } proj0.inverse.gaussian <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) mu <- exp(eta) u <- (1-y0$mu/mu)/mu w <- 1/mu ywk <- eta-u/w-offset kl <- sum(wt*y0$mu/2*(1/mu-1/y0$mu)^2)/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.inverse.gaussian <- function(eta0,eta1,wt) { mu0 <- exp(eta0) mu1 <- exp(eta1) sum(wt*mu0/2*(-1/mu0+1/mu1)^2)/sum(wt) } cfit.inverse.gaussian <- function(y,wt,offset) { mu <- sum(wt*y)/sum(wt) if (is.null(offset)) eta <- rep(log(mu),length(y)) else { eta0 <- log(sum(wt*y*exp(-2*offset))/sum(wt*exp(-offset))) eta <- eta0 + offset } eta } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% y0.nbinomial <- function(y,eta0,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } mu <- nu*exp(-eta0) list(y=y,nu=nu,mu=mu,eta=eta0) } proj0.nbinomial <- function(y0,eta,wt,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y0$mu*p-y0$nu*q w <- (y0$mu+y0$nu)*p*q ywk <- eta-u/w-offset kl <- sum(wt*((y0$nu+y0$mu)*log((1+exp(eta))/(1+exp(y0$eta))) +y0$nu*(y0$eta-eta)))/sum(wt) wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.nbinomial <- function(eta0,eta1,wt,nu) { mu0 <- nu*exp(-eta0) sum(wt*((nu+mu0)*log((1+exp(eta1))/(1+exp(eta0)))+nu*(eta0-eta1)))/sum(wt) } cfit.nbinomial <- function(y,wt,offset,nu) { if (!is.vector(y)) { nu <- y[,2] y <- y[,1] } p <- sum(wt*nu)/sum(wt*(y+nu)) if (is.null(offset)) eta <- rep(qlogis(p),length(y)) else { eta <- qlogis(p)-mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y*p-nu*q w <- (y+nu)*p*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } eta <- eta + offset } eta } ##%%%%%%%%%% Weibull Family %%%%%%%%%% y0.weibull <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) lam <- exp(-nu*eta0) list(lam=lam,eta=eta0,int=(xx^nu-zz^nu)) } proj0.weibull <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- nu*(y0$lam-exp(-nu*eta)) w <- nu*nu*exp(-nu*eta) ywk <- eta-u/w-offset kl <- sum(wt*y0$int*(y0$lam*nu*(eta-y0$eta)+exp(-nu*eta)-y0$lam))/sum(wt) u <- y0$int*u w <- y0$int*w wt <- w*wt list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.weibull <- function(eta0,eta1,wt,nu,int) { lam0 <- exp(-nu*eta0) lam1 <- exp(-nu*eta1) sum(wt*int*(lam0*nu*(eta1-eta0)+lam1-lam0))/sum(wt) } cfit.weibull <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta + offset } ##%%%%%%%%%% Lognorm Family %%%%%%%%%% y0.lognorm <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.lognorm <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) u <- NULL kl <- 0 for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-y0$eta[i]) z1 <- nu*(log(q.pt)-eta[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) u <- c(u,nu*nu*sum(q.wt*(lam0-lam1)*(lam1-z1)/q.pt)) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } xx <- nu*(log(y0$xx)-eta) zz <- nu*(log(y0$zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.lognorm <- function(eta0,eta1,wt,nu,y0) { kl <- 0 for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) z0 <- nu*(log(q.pt)-eta0[i]) z1 <- nu*(log(q.pt)-eta1[i]) lam0 <- ifelse(z0<7,dnorm(z0)/(1-pnorm(z0)),z0+1/z0) lam1 <- ifelse(z1<7,dnorm(z1)/(1-pnorm(z1)),z1+1/z1) kl <- kl + nu*sum(q.wt*(lam0*log(lam0/lam1)+lam1-lam0)/q.pt) } kl/length(eta0) } cfit.lognorm <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } ##%%%%%%%%%% Loglogis Family %%%%%%%%%% y0.loglogis <- function(y,eta0,nu) { xx <- y[,1] if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) quad <- gauss.quad(50,c(0,1)) list(eta=eta0,xx=xx,zz=zz,q.pt=quad$pt,q.wt=quad$wt) } proj0.loglogis <- function(y0,eta,wt,offset,nu) { if (is.null(offset)) offset <- rep(0,length(eta)) e0 <- exp(-nu*y0$eta) e1 <- exp(-nu*eta) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta-y0$eta)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) xx <- 1/(1+y0$xx^nu*e1) zz <- 1/(1+y0$zz^nu*e1) u <- -nu*(zz-xx) w <- nu^2/2*(zz^2-xx^2) for (i in 1:length(eta)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) u[i] <- u[i]+nu^2*sum(q.wt*q.pt^(nu-1)*e0[i] /(1+q.pt^nu*e0[i])/(1+q.pt^nu*e1[i])) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,kl=kl/length(eta),u=wt*u) } kl.loglogis <- function(eta0,eta1,wt,nu,y0) { e0 <- exp(-nu*eta0) e1 <- exp(-nu*eta1) kl <- sum(log((1+y0$xx^nu*e1)*(1+y0$zz^nu*e0)/(1+y0$zz^nu*e1)/(1+y0$xx^nu*e0)) +nu*(eta1-eta0)*log((1+y0$xx^nu*e0)/(1+y0$zz^nu*e0))) for (i in 1:length(eta0)) { q.pt <- y0$q.pt*(y0$xx[i]-y0$zz[i])+y0$zz[i] q.wt <- y0$q.wt*(y0$xx[i]-y0$zz[i]) kl <- kl + nu*sum(q.wt*q.pt^(nu-1)*e0[i]/(1+q.pt^nu*e0[i]) *log((1+q.pt^nu*e1[i])/(1+q.pt^nu*e0[i]))) } kl/length(eta0) } cfit.loglogis <- function(y,wt,offset,nu) { xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset } gss/R/smolyak.R0000644000175100001440000000121412355360640013071 0ustar hornikuserssmolyak.quad <- ## Generate delayed Smolyak cubature function(d, k) { size <- .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size z <- .C("quad_smolyak", as.integer(d), as.integer(d+k), pt=double(d*size), wt=as.double(1:size), PACKAGE="gss") list(pt=t(matrix(z$pt,d,size)),wt=z$wt) } smolyak.size <- ## Get the size of delayed Smolyak cubature function(d, k) { .C("size_smolyak", as.integer(d), as.integer(d+k), size=integer(1), PACKAGE="gss")$size } gss/R/project.sscden1.R0000644000175100001440000001716512355360640014433 0ustar hornikusers## Calculate square error projection from sscden objects project.sscden1 <- function(object,include,...) { include <- unique(include) term <- object$terms mf <- object$mf nobs <- dim(mf)[1] xnames <- object$xnames ynames <- object$ynames xx.wt <- object$xx.wt nx <- length(xx.wt) xx <- mf[!object$x.dup.ind,xnames,drop=FALSE] qd.pt <- object$rho$env$qd.pt qd.wt <- object$rho$env$qd.wt rho.d <- t(object$rho$fun(xx,qd.pt,object$rho$env,outer=TRUE)) rho.wt <- rho.d*qd.wt rho.d <- t(t(log(rho.d))-apply(log(rho.d)*rho.wt,2,sum)) nmesh <- length(qd.wt) ns <- length(object$id.s) nr <- length(object$id.r) nbasis <- length(object$id.basis) s.rho <- ss <- 0 r.rho <- matrix(0,nbasis,nr) sr <- array(0,c(ns,nbasis,nr)) rr <- array(0,c(nbasis,nbasis,nr,nr)) rho2 <- sum(xx.wt*apply(rho.d^2*rho.wt,2,sum)) for (k in 1:nx) { id.x <- (1:nobs)[!object$x.dup.ind][k] qd.s <- NULL qd.r <- list(NULL) iq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy.basis <- mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- mf[rep(id.x,nmesh),x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.s <- cbind(qd.s,qd.s.wk) } else { if (length(y.list)>0) { qd.xy[,x.list] <- xx qd.s <- cbind(qd.s,phi$fun(qd.xy,i,phi$env)) } } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,TRUE) iq <- iq+1 qd.r[[iq]] <- qd.r.wk } else { if (length(y.list)>0) { qd.xy[,x.list] <- xx iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) } } } } } if (ns) { qd.s <- sweep(qd.s,2,apply(qd.s*rho.wt[,k],2,sum)) s.rho <- s.rho + xx.wt[k]*apply(qd.s*rho.d[,k]*rho.wt[,k],2,sum) ss <- ss + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.s } for (i in 1:iq) { qd.r[[i]] <- sweep(qd.r[[i]],2,apply(qd.r[[i]]*rho.wt[,k],2,sum)) r.rho[,i] <- r.rho[,i] + xx.wt[k]*apply(qd.r[[i]]*rho.d[,k]*rho.wt[,k],2,sum) if (ns) sr[,,i] <- sr[,,i] + xx.wt[k]*t(rho.wt[,k]*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- xx.wt[k]*t(rho.wt[,k]*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model if (ns) d <- object$d[object$id.s] c <- object$c theta <- object$theta[object$id.r] nq <- length(theta) if (ns) s.eta <- ss%*%d r.eta <- tmp <- NULL r.rho.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) if (ns) { s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d sr.wk <- sr.wk + 10^theta[i]*sr[,,i] } else r.eta.wk <- 0 r.rho.wk <- r.rho.wk + 10^theta[i]*r.rho[,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } rho.eta <- sum(r.rho.wk*c) if (ns) rho.eta <- rho.eta + sum(r.rho.wk*c) eta2 <- sum(c*(rr.wk%*%c)) if (ns) eta2 <- eta2 + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 + rho2 + 2*rho.eta ## extract terms in subspace id.s <- id.r <- NULL for (label in include) { id.s <- c(id.s,object$id.s.list[[label]]) id.r <- c(id.r,object$id.r.list[[label]]) } if (is.null(id.s)&is.null(id.r)) stop("gss error in project.sscden1: include some terms") if (!all(id.s%in%object$id.s)|!all(id.r%in%object$id.r)) stop("gss error in project.sscden1: included terms are not in the model") ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq0 theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[-fix] <- theta1 ## id.s0 <- (1:length(object$id.s))[object$id.s%in%id.s] id.r0 <- (1:length(object$id.r))[object$id.r%in%id.r] if (length(id.s0)) ss.wk <- ss[id.s0,id.s0,drop=FALSE] if (length(id.r0)) { r.eta.wk <- rr.wk <- 0 sr.wk <- matrix(0,length(id.s),nbasis) for (i in 1:length(id.r0)) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,id.r0[i]] if (length(id.s0)) sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s0,,id.r0[i]] for (j in 1:length(id.r0)) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,id.r0[i],id.r0[j]] } } if (length(id.s0)) { v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s0],r.eta.wk) } else { v <- rbind(sr.wk,rr.wk) mu <- r.eta.wk } } else { v <- ss.wk mu <- s.eta[id.s0] } nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization fix <- rev(order(tmp[id.r]))[1] theta <- object$theta[id.r] ## projection nq0 <- length(id.r) if (nq0>1) { if (object$skip.iter) se <- rkl(theta[-fix]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/gssanova.R0000644000175100001440000005134412355360640013244 0ustar hornikusers## Fit gssanova model gssanova <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, alpha=NULL,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","inverse.gaussian","nbinomial", "weibull","lognorm","loglogis"))) stop("gss error in gssanova: family not implemented") if (is.null(alpha)) { alpha <- 1.4 if (family%in%c("binomial","nbinomial","inverse.gaussian")) alpha <- 1 } ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[2]) zz$est <- zz$est[-2] } else nu.wk <- NULL if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,10^theta*sqrt(fit$w)*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=theta,ran.scal=ran.scal,c=c,d=d,b=b,nlambda=zz$est[1], zeta=zz$est[-1],nu=nu.wk),fit[-1],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter Non-Gaussian REGression mspngreg <- function(family,s,r,id.basis,y,wt,offset,alpha,nu,random,skip.iter) { nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { if (nu[[2]]) { the.wk <- theta[-(nq+1)] nu.wk <- list(exp(theta[nq+1]),FALSE) } else { the.wk <- theta nu.wk <- nu } ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(the.wk[-(1:nq)],random$sigma$env) } alpha.wk <- max(0,the.wk[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) z <- ngreg(dc,family,cbind(s,r.wk0),q.wk,y,wt,offset,nu.wk,alpha.wk) assign("dc",z$dc,inherits=TRUE) assign("fit",z[c(1:3,5:10)],inherits=TRUE) z$score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]) nu[[1]] <- z$nu theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspngreg(family,s,r.wk,r.wk[id.basis,],y,wt,offset,alpha,nu,random) if (nu[[2]]) nu[[1]] <- z$nu nlambda <- z$nlambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search dc <- rep(0,nn) fit <- NULL theta.old <- theta if (nu[[2]]) theta <- c(theta, log(nu[[1]])) if (!is.null(random)) theta <- c(theta,z$zeta) counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in gssanova: iteration for model selection fails to converge") break } } ## return jk <- cv(zz$est) if (nu[[2]]) { nu.wk <- exp(zz$est[nq+1]) zz$est <- zz$est[-(nq+1)] } else nu.wk <- NULL r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } se.aux <- regaux(sqrt(fit$w)*s,sqrt(fit$w)*r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda,zeta=zz$est[-(1:nq)],nu=nu.wk), fit[-1],list(se.aux=se.aux)) } ## Non-Gaussian regression with fixed smoothing parameters ngreg <- function(dc,family,sr,q,y,wt,offset,nu,alpha) { nobs <- nrow(sr) nn <- ncol(sr) nxi <- nrow(q) nnull <- nn - nxi ## initialization cc <- dc[nnull+(1:nxi)] eta <- sr%*%dc if (!is.null(offset)) eta <- eta + offset if ((family=="nbinomial")&is.vector(y)) y <- cbind(y,nu[[1]]) dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) + t(cc)%*%q%*%cc ## Newton iteration dc.new <- eta.new <- NULL dev.line <- function(x) { assign("dc.new",dc+x*dc.diff,inherits=TRUE) cc <- dc.new[nnull+(1:nxi)] eta.wk <- as.vector(sr%*%dc.new) if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) dev.wk <- switch(family, binomial=dev.resid.binomial(y,eta.new,wt), nbinomial=dev.resid.nbinomial(y,eta.new,wt), poisson=dev.resid.poisson(y,eta.new,wt), Gamma=dev.resid.Gamma(y,eta.new,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta.new,wt), weibull=dev.resid.weibull(y,eta.new,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta.new,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta.new,wt,nu[[1]])) sum(dev.wk) + t(cc)%*%q%*%cc } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) ## weighted least squares fit mumax <- 2*max(abs(t(sr)%*%dat$u+c(rep(0,nnull),q%*%dc[nnull+(1:nxi)]))) w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr if (!is.finite(sum(w,ywk,srwk))) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(c(rep(1,nnull),rep(0,nxi))), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { dev.new <- dev.line(1) if (!is.finite(dev.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (dev.new-dev<1e-7*(1+abs(dev))) break } zz <- nlm0(dev.line,c(0,1),1e-3) dev.new <- dev.line(zz$est) break } disc0 <- max((mumax/(1+eta))^2,abs(eta.new-eta)/(1+eta)) disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (!is.finite(disc)) { if (flag) stop("gss error in gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset dev <- switch(family, binomial=dev.resid.binomial(y,eta,wt), nbinomial=dev.resid.nbinomial(y,eta,wt), poisson=dev.resid.poisson(y,eta,wt), Gamma=dev.resid.Gamma(y,eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,eta,wt), weibull=dev.resid.weibull(y,eta,wt,nu[[1]]), lognorm=dev0.resid.lognorm(y,eta,wt,nu[[1]]), loglogis=dev0.resid.loglogis(y,eta,wt,nu[[1]])) dev <- sum(dev) iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new dev <- dev.new if (min(disc0,disc)<1e-7) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } ## calculate cv dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) ## weighted least squares fit w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk srwk <- w*sr z <- .Fortran("reg", as.double(srwk), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(ywk), as.integer(5), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), hat=double(max(nobs+1,nn)), rkv=integer(1), integer(1), PACKAGE="gss")[c("dc","chol","jpvt","hat","rkv")] cv <- switch(family, binomial=cv.binomial(y,eta,wt,z$hat[1:nobs],alpha), poisson=cv.poisson(y,eta,wt,z$hat[1:nobs],alpha,sr,q), Gamma=cv.Gamma(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), inverse.gaussian=cv.inverse.gaussian(y,eta,wt,z$hat[1:nobs],z$hat[nobs+1],alpha), nbinomial=cv.nbinomial(y,eta,wt,z$hat[1:nobs],alpha), weibull=cv.weibull(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), lognorm=cv.lognorm(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha), loglogis=cv.loglogis(y,eta,wt,z$hat[1:nobs],nu[[1]],alpha)) c(z,cv,list(eta=eta)) } gss/R/family.R0000644000175100001440000001731612440617773012714 0ustar hornikusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Make pseudo data for logistic regression mkdata.binomial <- function(y,eta,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for logistic regression dev.resid.binomial <- function(y,eta,wt) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } odds <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ## Calculate null deviance for logistic regression dev.null.binomial <- function(y,wt,offset) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]>1) { wt <- wt * (y[,1]+y[,2]) y <- y[,1]/(y[,1]+y[,2]) } p <- sum(wt*y)/sum(wt) odds <- p/(1-p) if (!is.null(offset)) { eta <- log(odds) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) u <- p - y w <- p/(1+odds) eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y*(1+odds)/odds)) +(1-y)*log(ifelse(y==1,1,(1-y)*(1+odds))))) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Make pseudo data for Poisson regression mkdata.poisson <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") lambda <- exp(eta) u <- lambda - y w <- lambda ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Poisson regression dev.resid.poisson <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- exp(eta) as.vector(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ## Calculate null deviance for Poisson regression dev.null.poisson <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) lambda <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(lambda) - mean(offset) repeat { lambda <- exp(eta+offset) u <- lambda - y w <- lambda eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y*log(ifelse(y==0,1,y/lambda))-(y-lambda))) } ##%%%%%%%%%% Gamma Family %%%%%%%%%% ## Make pseudo data for Gamma regression mkdata.Gamma <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: gamma responses should be positive") mu <- exp(eta) u <- 1-y/mu ywk <- eta-u-offset list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for Gamma regression dev.resid.Gamma <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(2*wt*(-log(y/mu)+(y-mu)/mu)) } ## Calculate null deviance for Gamma regression dev.null.Gamma <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- 1-y/mu eta.new <- eta-sum(wt*u)/sum(wt) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(-log(y/mu)+(y-mu)/mu)) } ##%%%%%%%%%% Inverse Gaussian Family %%%%%%%%%% ## Make pseudo data for IG regression mkdata.inverse.gaussian <- function(y,eta,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) if (is.null(offset)) offset <- rep(0,length(y)) if (min(y)<=0) stop("gss error: inverse gaussian responses should be positive") mu <- exp(eta) u <- (1-y/mu)/mu w <- 1/mu ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } ## Calculate deviance residuals for IG regression dev.resid.inverse.gaussian <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- exp(eta) as.vector(wt*((y-mu)^2/(y*mu^2))) } ## Calculate null deviance for IG regression dev.null.inverse.gaussian <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,length(y)) mu <- sum(wt*y)/sum(wt) if (!is.null(offset)) { eta <- log(mu)-mean(offset) repeat { mu <- exp(eta+offset) u <- (1-y/mu)/mu w <- 1/mu eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(wt*((y-mu)^2/(y*mu^2))) } ##%%%%%%%%%% Negative Binomial Family %%%%%%%%%% ## Make pseudo data for NB regression mkdata.nbinomial <- function(y,eta,wt,offset,nu) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) if (dim(y)[2]==2) { if (min(y[,1])<0) stop("gss error: negative binomial response should be nonnegative") if (min(y[,2])<=0) stop("gss error: negative binomial size should be positive") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,u=u*wt) } else { if (min(y)<0) stop("gss error: negative binomial response should be nonnegative") odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) if (is.null(nu)) log.nu <- log(mean(y*odds)) else log.nu <- log(nu) repeat { nu <- exp(log.nu) ua <- sum(digamma(y+nu)-digamma(nu)+log(p))*nu wa <- sum(trigamma(y+nu)-trigamma(nu))*nu*nu+ua log.nu.new <- log.nu - ua/wa if (abs(log.nu-log.nu.new)/(1+abs(log.nu))<1e-7) break log.nu <- log.nu.new } u <- y*p-nu*q w <- nu*q ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } } ## Calculate deviance residuals for NB regression dev.resid.nbinomial <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) odds <- exp(eta) p <- odds/(1+odds) q <- 1/(1+odds) as.vector(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } ## Calculate null deviance for NB regression dev.null.nbinomial <- function(y,wt,offset) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) p <- sum(wt*y[,2])/sum(wt*y) if (!is.null(offset)) { eta <- log(p/(1-p)) - mean(offset) repeat { odds <- exp(eta+offset) p <- odds/(1+odds) q <- 1/(1+odds) u <- y[,1]*p-y[,2]*q w <- y[,2]*q eta.new <- eta-sum(wt*u)/sum(wt*w) if (abs(eta-eta.new)/(1+abs(eta))<1e-7) break eta <- eta.new } } sum(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/q)) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } gss/R/mkfun.factor.R0000644000175100001440000000410412355360640014010 0ustar hornikusers## Make RK for nominal shrinkage mkrk.nominal <- function(levels) { k <- length(levels) if (k<2) stop("gss error: factor should have at least two levels") code <- 1:k names(code) <- as.character(levels) ## Create the environment env <- list(code=code,table=diag(k)-1/k) ## Create the rk function fun <- function(x, y, env, outer.prod = FALSE) { if (!(is.factor(x)&is.factor(y))) { stop("gss error in rk: inputs are of wrong types") } x <- as.numeric(env$code[as.character(x)]) y <- as.numeric(env$code[as.character(y)]) if (any(is.na(c(x,y)))) { stop("gss error in rk: unknown factor levels") } if (outer.prod) env$table[x, y] else env$table[cbind(x,y)] } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for ordinal shrinkage mkrk.ordinal <- function(levels) { k <- length(levels) if (k<2) stop("gss error: factor should have at least two levels") code <- 1:k names(code) <- as.character(levels) ## penalty matrix if (k==2) { B <- diag(.25,2) B[1,2] <- B[2,1] <- -.25 } else { B <- diag(2,k) B[1,1] <- B[k,k] <- 1 diag(B[-1,-k]) <- diag(B[-k,-1]) <- -1 ## Moore-Penrose inverse B <- eigen(B) B <- B$vec[,-k] %*% diag(1/B$val[-k]) %*% t(B$vec[,-k]) tol <- sqrt(.Machine$double.eps) B <- ifelse(abs(B)10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), double(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscox: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscox: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) obj } gss/R/predict.ssanova0.R0000644000175100001440000001027512355360640014604 0ustar hornikusers## Calculate prediction and Bayesian SE from ssanova0 objects predict.ssanova0 <- function(object,newdata,se.fit=FALSE, include=c(object$terms$labels,object$lab.p),...) { nnew <- dim(newdata)[1] nobs <- length(object$c) nnull <- length(object$d) labels.p <- object$lab.p ## Extract included terms term <- object$terms philist <- rklist <- NULL s <- q <- NULL nq <- 0 for (label in include) { if (label=="1") { philist <- c(philist,term[[label]]$iphi) s <- cbind(s,rep(1,len=nnew)) next } if (label%in%labels.p) next if (label=="offset") next xnew <- newdata[,term[[label]]$vlist] x <- object$mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { iphi <- term[[label]]$iphi phi <- term[[label]]$phi for (i in 1:nphi) { philist <- c(philist,iphi+(i-1)) s <- cbind(s,phi$fun(xnew,nu=i,env=phi$env)) } } if (nrk) { irk <- term[[label]]$irk rk <- term[[label]]$rk for (i in 1:nrk) { rklist <- c(rklist,irk+(i-1)) nq <- nq+1 q <- array(c(q,rk$fun(xnew,x,nu=i,env=rk$env,out=TRUE)),c(nnew,nobs,nq)) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) { philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } } qq <- matrix(0,nnew,nobs) nq <- 0 for (i in rklist) { nq <- nq + 1 qq <- qq + 10^object$theta[i]*q[,,nq] } if (!is.null(object$w)) w <- object$w else w <- model.weights(object$mf) if (!is.null(w)) qq <- t(sqrt(w)*t(qq)) ## Compute posterior mean nphi <- length(philist) pmean <- as.vector(qq%*%object$c) if (nphi) pmean <- pmean + as.vector(s%*%object$d[philist]) if (any(include=="offset")) { if (is.null(model.offset(object$mf))) stop("gss error: no offset in the fit") offset <- newdata$offset if (is.null(offset)) offset <- newdata$"(offset)" if (is.null(offset)) stop("gss error: missing offset") pmean <- pmean + offset } if (se.fit) { b <- object$varht/10^object$nlambda ## Get cr, dr, and sms crdr <- getcrdr(object,t(qq)) cr <- crdr$cr dr <- crdr$dr[philist,,drop=FALSE] sms <- getsms(object)[philist,philist] ## Compute posterior variance r <- 0 for (label in include) { if (label=="1") next if (label%in%labels.p) next xnew <- newdata[,term[[label]]$vlist] nrk <- term[[label]]$nrk if (nrk) { irk <- term[[label]]$irk rk <- term[[label]]$rk for (i in 1:nrk) { ind <- irk+(i-1) r <- r + 10^object$theta[ind]*rk$fun(xnew,xnew,nu=i,env=rk$env) } } } fn2 <- function(x,n) x[1:n]%*%x[n+(1:n)] pvar <- r - apply(rbind(t(qq),cr),2,fn2,nobs) if (nphi) { fn1 <- function(x,sms) t(x)%*%sms%*%x pvar <- pvar + apply(s,1,fn1,sms) pvar <- pvar - 2*apply(rbind(t(s),dr),2,fn2,nphi) } pse <- as.numeric(sqrt(b*pvar)) list(fit=pmean,se.fit=pse) } else pmean } gss/R/ssden.R0000644000175100001440000003500412355360640012532 0ustar hornikusers## Fit density model ssden <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit, id.basis=NULL,nbasis=NULL,seed=NULL, domain=as.list(NULL),quad=NULL, qdsz.depth=NULL,bias=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$domain <- mf$quad <- mf$qdsz.depth <- mf$bias <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and/or generate quadrature if (is.null(quad)) { ## Set domain and type fac.list <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { fac.list <- c(fac.list,xlab) domain[[xlab]] <- NULL } else { if (!is.vector(x)) stop("gss error in ssden: no default quadrature") if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } } } ## Generate numerical quadrature domain <- data.frame(domain) mn <- domain[1,] mx <- domain[2,] dm <- ncol(domain) if (dm==1) { ## Gauss-Legendre or uniform quadrature xlab <- names(domain) if (type[[xlab]][[1]]%in%c("per","cubic.per","linear.per")) { quad <- list(pt=mn+(1:200)/200*(mx-mn), wt=rep((mx-mn)/200,200)) } else quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } else { ## Smolyak cubature if (is.null(qdsz.depth)) qdsz.depth <- switch(min(dm,6)-1,18,14,12,11,10) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(domain)) { xlab <- colnames(domain)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=mf,domain=domain[i],alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } quad <- list(pt=quad$pt,wt=quad$wt) } else { for (xlab in names(mf)) { x <- mf[[xlab]] if (is.vector(x)&!is.factor(x)) { if (is.null(range <- domain[[xlab]])) { mn <- min(x) mx <- max(x) range <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 range[1] <- min(c(range[1],quad$pt[[xlab]])) range[2] <- max(c(range[2],quad$pt[[xlab]])) } if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",range) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],range) else { mn0 <- min(type[[xlab]][[2]]) mx0 <- max(type[[xlab]][[2]]) if ((mn0>mn)|(mx0alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } ## initialization mu.r <- apply(qd.wt*t(qd.r),2,sum)/sum(qd.wt) v.r <- apply(qd.wt*t(qd.r^2),2,sum)/sum(qd.wt) if (nnull) { mu.s <- apply(qd.wt*t(qd.s),2,sum)/sum(qd.wt) v.s <- apply(qd.wt*t(qd.s^2),2,sum)/sum(qd.wt) } if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) int <- sum(qd.wt*exp(t(rbind(10^theta*qd.r,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,int=int,cv=jk1) } ## Fit multiple smoothing parameter density mspdsty <- function(s,r,id.basis,cnt,qd.s,qd.r,qd.wt,prec,maxiter,alpha,bias,skip.iter) { nxi <- dim(r)[1] nobs <- dim(r)[2] nqd <- length(qd.wt) nq <- dim(r)[3] if (!is.null(s)) nnull <- dim(s)[1] else nnull <- 0 nxis <- nxi+nnull if (is.null(cnt)) cnt <- 0 ## cv function cv <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- qd.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[,,i] } } q.wk <- r.wk0[,id.basis] fit <- .Fortran("dnewton", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(rbind(r.wk0,s)), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(t(rbind(qd.r.wk0,qd.s))), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt*bias$qd.wt)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*((nqd+1)*bias$nt+nobs)+nxis*(2*nxis+4)+max(nxis,3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssden: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssden: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[,id.basis,],3,function(x)sum(diag(x)))) r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } ## theta adjustment z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) theta <- theta + z$theta r.wk <- qd.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[,id.basis,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } mu <- apply(qd.wt*t(qd.r.wk),2,sum)/sum(qd.wt) v <- apply(qd.wt*t(qd.r.wk^2),2,sum)/sum(qd.wt) log.la0 <- log10(sum(v-mu^2)/sum(diag(r.wk[,id.basis]))) log.th0 <- theta-log.la0 ## lambda search z <- sspdsty(s,r.wk,r.wk[,id.basis],cnt,qd.s,qd.r.wk,qd.wt,prec,maxiter,alpha,bias) lambda <- z$lambda log.th0 <- log.th0 + z$lambda theta <- theta + z$theta cd <- c(z$c,z$d) int <- z$int ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search counter <- 0 r.wk <- qd.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[,,i] } theta.old <- theta ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssden: CV iteration fails to converge") break } } ## return jk1 <- cv(zz$est) qd.r.wk <- 0 for (i in 1:nq) qd.r.wk <- qd.r.wk + 10^zz$est[i]*qd.r[,,i] int <- sum(qd.wt*exp(t(rbind(qd.r.wk,qd.s))%*%cd)) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=lambda,theta=zz$est,c=c,d=d,int=int,cv=jk1) } gss/R/predict.ssllrm.R0000644000175100001440000001327012355360640014364 0ustar hornikusers## Calculate prediction and Bayesian SE from ssllrm objects predict.ssllrm <- function (object,x,y=object$qd.pt,odds=NULL,se.odds=FALSE,...) { if (class(object)!="ssllrm") stop("gss error in predict.ssllrm: not a ssllrm object") if ("random"%in%colnames(x)) { zz <- x$random x$random <- NULL } else zz <- NULL if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in predict.ssllrm: mismatched x variable names") if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in predict.ssllrm: mismatched y variable names") mf <- object$mf term <- object$term qd.pt <- object$qd.pt nmesh <- dim(qd.pt)[1] y.id <- NULL for (i in 1:dim(y)[1]) { if (!sum(duplicated(rbind(qd.pt,y[i,object$ynames,drop=FALSE])))) stop("gss error in predict.ssllrm: y value is out of range") wk <- FALSE for (j in 1:nmesh) { if (sum(duplicated(rbind(qd.pt[j,],y[i,object$ynames])))) y.id <- c(y.id,j) } } if (!is.null(odds)) { if (length(y.id)-length(odds)) stop("gss error in predict.ssllrm: odds is of wrong length") if (!max(odds)|sum(odds)) stop("gss error in predict.ssllrm: odds is not a contrast") if (sum(duplicated(y.id))) stop("gss error in predict.ssllrm: duplicated y in contrast") qd.pt <- qd.pt[y.id,,drop=FALSE] } ## Generate s, and r nobs <- dim(x)[1] nmesh <- dim(qd.pt)[1] nbasis <- length(object$id.basis) nnull <- length(object$d) nZ <- length(object$b) s <- NULL r <- array(0,c(nmesh,nbasis,nobs)) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] y.list <- object$ynames[object$ynames%in%vlist] xy.basis <- mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 if (is.null(xx)) { s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) wk <- matrix(s.wk,nmesh,nobs) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- cbind(wk,phi$fun(qd.xy,i,phi$env)) } } s <- array(c(s,wk),c(nmesh,nobs,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 if (is.null(xx)) { r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) r <- r + as.vector(10^object$theta[nq]*r.wk) } else { wk <- NULL for (j in 1:nobs) { qd.xy[,x.list] <- xx[rep(j,nmesh),] wk <- array(c(wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } r <- r + 10^object$theta[nq]*wk } } } } ## random effects if (nZ) { nz <- object$Random$sigma$env$nz if (is.null(zz)) z.wk <- matrix(0,nobs,nz) else z.wk <- as.matrix(zz) if (dim(z.wk)[2]!=nz) stop("gss error in predict.ssllrm: x$random is of wrong dimension") z <- nlvl <- NULL for (ylab in object$ynames) { y.wk <- mf[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk pt.wk <- qd.pt[,ylab] for (i in 1:(nlvl.wk-1)) { for (j in 1:nmesh) { z <- cbind(z,z.aux[pt.wk[j],i]*z.wk) } } } z <- aperm(array(z,c(nobs,nz,nmesh,nZ/nz)),c(3,2,4,1)) z <- array(z,c(nmesh,nZ,nobs)) } ## return if (is.null(odds)) { pdf <- NULL for (j in 1:nobs) { wk <- matrix(r[,,j],nmesh,nbasis)%*%object$c if (nnull) wk <- wk + matrix(s[,j,],nmesh,nnull)%*%object$d if (nZ) wk <- wk + matrix(z[,,j],nmesh,nZ)%*%object$b wk <- exp(wk) pdf <- cbind(pdf,wk/sum(wk)) } return(t(pdf[y.id,])) } else { s.wk <- r.wk <- z.wk <- 0 for (i in 1:length(odds)) { r.wk <- r.wk + odds[i]*r[i,,] if (nnull) s.wk <- s.wk + odds[i]*s[i,,] if (nZ) z.wk <- z.wk + odds[i]*z[i,,] } s.wk <- matrix(s.wk,nobs,nnull) r.wk <- t(matrix(r.wk,nbasis,nobs)) z.wk <- t(matrix(z.wk,nZ,nobs)) rs <- cbind(r.wk,z.wk,s.wk) if (!se.odds) as.vector(rs%*%c(object$c,object$b,object$d)) else { fit <- as.vector(rs%*%c(object$c,object$b,object$d)) se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] return(list(fit=fit,se.fit=se.fit)) } } } gss/R/summary.ssanova0.R0000644000175100001440000000630512355360640014646 0ustar hornikusers## Summarize ssanova0 objects summary.ssanova0 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") w <- model.weights(object$mf) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(object$c)) ## Residuals res <- 10^object$nlambda*object$c if (!is.null(w)) res <- res/sqrt(w) ## Fitted values fitted <- as.numeric(y-res) fitted.off <- fitted-offset ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 if (!is.null(w)) { r.squared <- sum(w*(fitted-sum(w*fitted)/sum(w))^2) r.squared <- r.squared/sum(w*(y-sum(w*y)/sum(w))^2) } else r.squared <- var(fitted)/var(y) ## Residual sum of squares if (is.null(w)) rss <- sum(res^2) else rss <- sum(w*res^2) ## Penalty associated with the fit if (is.null(w)) penalty <- sum(object$c*fitted.off) else penalty <- sum(object$c*fitted.off*sqrt(w)) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics mf <- object$mf mf.part <- object$mf.part if (diagnostics) { ## Obtain retrospective linear model comp <- NULL for (label in c(object$terms$labels,object$lab.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) } comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,object$lab.p) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova0: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant if (!is.null(w)) comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) else comp <- sweep(comp,2,apply(comp,2,mean)) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rankenv$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 k2(x)*k2(y)-k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for cubic splines mkphi.cubic <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result (x-env$min)/(env$max-env$min)-.5 } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic cubic splines mkrk.cubic.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for trigonometric splines mkrk.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k4 <- function(x) ((x-.5)^4-(x-.5)^2/2+7/240)/24 -k4(abs(x-y))-2*cos(2*pi*(x-y))/(2*pi)^4 } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make phi function for trigonometric splines mkphi.trig <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the phi function fun <- function(x,nu,env) { ##% Check the input if (!is.vector(x)) { stop("gss error in phi: inputs are of wrong types") } if ((min(x)env$max)) { stop("gss error in phi: inputs are out of range") } ##% Return the result xx <- (x-env$min)/(env$max-env$min) switch(nu,cos(2*pi*xx),sin(2*pi*xx)) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for linear splines mkrk.linear <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k1 <- function(x) (x-.5) k2 <- function(x) ((x-.5)^2-1/12)/2 k1(x)*k1(y)+k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } ## Make RK for periodic linear splines mkrk.linear.per <- function(range) { ## Create the environment env <- list(min=min(range), max=max(range)) ## Create the rk function fun <- function(x,y,env,outer.prod=FALSE) { ##% Check the inputs if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } if ((min(x,y)env$max)) { stop("gss error in rk: inputs are out of range") } ##% Scale the inputs x <- (x-env$min)/(env$max-env$min) y <- (y-env$min)/(env$max-env$min) ##% Return the result rk <- function(x,y) { k2 <- function(x) ((x-.5)^2-1/12)/2 k2(abs(x-y)) } if (outer.prod) outer(x,y,rk) else rk(x,y) } ## Return the function and the environment list(fun=fun,env=env) } gss/R/nlm0.R0000644000175100001440000000505712355360640012271 0ustar hornikusers## minimization of univariate function on finite intervals ## using 3-point quadratic fit with golden-section safe-guard nlm0 <- function(fun,range,prec=1e-7) { ratio <- 2/(sqrt(5)+1) ll.x <- min(range) uu.x <- max(range) if (uu.x-ll.xuu.x)|(deltarange.l) nn.x <- uu.x - ratio*range.u else nn.x <- ll.x + ratio*range.l } ## Update middle points nn.fit <- fun(nn.x) neval <- neval + 1 if (nn.x1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() yhat.wk <- forwardsolve(t(ww),yhat) one.wk <- forwardsolve(t(ww),rep(1,nobs)) ymean <- sum(one.wk*yy.wk)/sum(one.wk^2) kl0 <- sum((yy.wk-ymean*one.wk)^2)/sum(one.wk^2) kl <- sum((yy.wk-yhat.wk)^2)/sum(one.wk^2) kl1 <- sum((yhat.wk-ymean*one.wk)^2)/sum(one.wk^2) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/fitted.R0000644000175100001440000000433412355360640012677 0ustar hornikusers## Obtain fitted values from ssanova objects fitted.ssanova <- function(object,...) { mf <- object$mf if (!is.null(object$random)) mf$random <- I(object$random$z) predict(object,mf) } ## Obtain residuals from ssanova objects residuals.ssanova <- function(object,...) { y <- model.response(object$mf,"numeric") as.numeric(y-fitted.ssanova(object)) } ## Obtain fitted values in working scale from gssanova objects fitted.gssanova <- function(object,...) { as.numeric(object$eta) } ## Obtain residuals from gssanova objects residuals.gssanova <- function(object,type="working",...) { y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- NULL if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dat <- switch(object$family, binomial=mkdata.binomial(y,object$eta,wt,offset), nbinomial=mkdata.nbinomial(y,object$eta,wt,offset,object$nu), poisson=mkdata.poisson(y,object$eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,object$eta,wt,offset), Gamma=mkdata.Gamma(y,object$eta,wt,offset), weibull=mkdata.weibull(y,object$eta,wt,offset,list(object$nu,FALSE)), lognorm=mkdata.lognorm(y,object$eta,wt,offset,list(object$nu,FALSE)), loglogis=mkdata.loglogis(y,object$eta,wt,offset,list(object$nu,FALSE))) res <- as.numeric(dat$ywk - object$eta) if (!is.na(charmatch(type,"deviance"))) { dev.resid <- switch(object$family, binomial=dev.resid.binomial(y,object$eta,wt), nbinomial=dev.resid.nbinomial(y,object$eta,wt), poisson=dev.resid.poisson(y,object$eta,wt), inverse.gaussian=dev.resid.inverse.gaussian(y,object$eta,wt), Gamma=dev.resid.Gamma(y,object$eta,wt), weibull=dev.resid.weibull(y,object$eta,wt,object$nu), lognorm=dev.resid.lognorm(y,object$eta,wt,object$nu), loglogis=dev.resid.loglogis(y,object$eta,wt,object$nu)) res <- sqrt(dev.resid)*sign(res) } res } gss/R/project.sshzd.R0000644000175100001440000001640012355360640014215 0ustar hornikusers## Calculate Kullback-Leibler projection from sshzd objects project.sshzd <- function(object,include,mesh=FALSE,...) { if (!(object$tname%in%include)) stop("gss error in project.sshzd: time main effect missing in included terms") quad.pt <- object$quad$pt qd.wt <- object$qd.wt nx <- dim(object$qd.wt)[2] nbasis <- length(object$id.basis) mesh0 <- object$mesh0 ## extract terms in subspace nqd <- length(quad.pt) nxi <- length(object$id.basis) d <- qd.s <- q <- theta <- NULL qd.r <- as.list(NULL) n0.wk <- nu <- nq.wk <- nq <- 0 for (label in object$terms$labels) { vlist <- object$terms[[label]]$vlist x.list <- object$xnames[object$xnames%in%vlist] xy.basis <- object$mf[object$id.basis,vlist] qd.xy <- data.frame(matrix(0,nqd,length(vlist))) names(qd.xy) <- vlist if (object$tname%in%vlist) qd.xy[,object$tname] <- quad.pt if (length(x.list)) xx <- object$x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { phi <- object$terms[[label]]$phi for (i in 1:nphi) { n0.wk <- n0.wk + 1 if (label=="1") { d <- object$d[n0.wk] nu <- nu + 1 qd.wk <- matrix(1,nqd,nx) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) next } if (!any(label==include)) next d <- c(d,object$d[n0.wk]) nu <- nu + 1 if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nqd,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,nu)) } } if (nrk) { rk <- object$terms[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) q <- cbind(q,rk$fun(xy.basis,xy.basis,i,rk$env,out=FALSE)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nqd),] for (k in x.list) if (is.factor(xx[,k])) qd.xy[,k] <- as.factor(qd.xy[,k]) qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nqd,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } if (!is.null(object$partial)) { for (label in object$lab.p) { n0.wk <- n0.wk + 1 if (!any(label==include)) next d <- c(d,object$d[n0.wk]) qd.wk <- t(matrix(object$partial$pt[,label],nx,nqd)) qd.s <- array(c(qd.s,qd.wk),c(nqd,nx,n0.wk)) } } if (!is.null(qd.s)) nnull <- dim(qd.s)[3] else nnull <- 0 nn <- nxi + nnull ## random effect offset if (!is.null(object$b)) offset <- as.vector(object$random$qd.z%*%object$b) else offset <- rep(0,nx) ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta.wk[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta.wk[i]*qd.r[[i]]) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) z <- .Fortran("hrkl", cd=as.double(cd), as.integer(nn), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(t(t(qd.wt)*exp(offset))), mesh=as.double(qd.wt*mesh0), as.double(.Machine$double.eps), double(nqd*nx), double(nn), double(nn), double(nn*nn), integer(nn), double(nn), double(nn), double(nqd*nx), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sshzd: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sshzd: Newton iteration fails to converge") assign("cd",z$cd,inherits=TRUE) assign("mesh1",t(t(matrix(z$mesh,nqd,nx))*exp(offset)),inherits=TRUE) sum(qd.wt*(log(mesh0/mesh1)*mesh0-mesh0+mesh1)) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization if (nnull) { qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } else theta.wk <- 0 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(q[,i])) fix <- rev(order(tmp))[1] ## projection cd <- c(10^(-theta.wk)*object$c,d) mesh1 <- NULL if (nq-1) { if (object$skip.iter) kl <- rkl(theta[-fix]) else { if (nq-2) { ## scale and shift cv tmp <- abs(rkl(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() ## cfit cfit <- t(matrix(object$dbar/sum(t(qd.wt)*exp(offset))*exp(offset),nx,nqd)) ## return kl0 <- sum(object$qd.wt*(log(mesh0/cfit)*mesh0-mesh0+cfit)) kl1 <- sum(object$qd.wt*(log(mesh1/cfit)*mesh1-mesh1+cfit)) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/predict.sscox.R0000644000175100001440000000552612355360640014214 0ustar hornikusers## Evaluate hazard estimate predict.sscox <- function (object,newdata,se.fit=FALSE, include=c(object$terms$labels,object$lab.p),...) { if (class(object)!="sscox") stop("gss error in predict.sscox: not a sscox object") nnew <- nrow(newdata) nbasis <- length(object$id.basis) nnull <- length(object$d) nz <- length(object$b) nn <- nbasis + nnull + nz labels.p <- object$lab.p ## Extract included terms if (!is.null(object$d)) s <- matrix(0,nnew,nnull) r <- matrix(0,nnew,nbasis) for (label in include) { if (label%in%labels.p) next xx <- object$mf[object$id.basis,object$terms[[label]]$vlist] xnew <- newdata[,object$terms[[label]]$vlist] nphi <- object$terms[[label]]$nphi nrk <- object$terms[[label]]$nrk if (nphi) { iphi <- object$terms[[label]]$iphi phi <- object$terms[[label]]$phi for (i in 1:nphi) { s[,iphi+(i-1)] <- phi$fun(xnew,nu=i,env=phi$env) } } if (nrk) { irk <- object$terms[[label]]$irk rk <- object$terms[[label]]$rk for (i in 1:nrk) { r <- r + 10^object$theta[irk+(i-1)]* rk$fun(xnew,xx,nu=i,env=rk$env,out=TRUE) } } } if (!is.null(object$partial)) { vars.p <- as.character(attr(object$partial$mt,"variables"))[-1] facs.p <- attr(object$partial$mt,"factors") vlist <- vars.p[as.logical(apply(facs.p,1,sum))] for (lab in labels.p) { if (lab%in%include) { vlist.wk <- vars.p[as.logical(facs.p[,lab])] vlist <- vlist[!(vlist%in%vlist.wk)] } } if (length(vlist)) { for (lab in vlist) newdata[[lab]] <- 0 } matx.p <- model.matrix(object$partial$mt,newdata)[,-1,drop=FALSE] matx.p <- sweep(matx.p,2,object$partial$center) matx.p <- sweep(matx.p,2,object$partial$scale,"/") nu <- nnull-dim(matx.p)[2] for (label in labels.p) { nu <- nu+1 if (label%in%include) s[,nu] <- matx.p[,label] } } ## random effects if (nz) { if (is.null(newdata$random)) z.wk <- matrix(0,nnew,nz) else z.wk <- newdata$random rs <- cbind(r,z.wk,s) } else rs <- cbind(r,s) if (!se.fit) as.vector(exp(rs%*%c(object$c,object$b,object$d))) else { fit <- as.vector(exp(rs%*%c(object$c,object$b,object$d))) se.fit <- .Fortran("hzdaux2", as.double(object$se.aux$v), as.integer(dim(rs)[2]), as.integer(object$se.aux$jpvt), as.double(t(rs)), as.integer(dim(rs)[1]), se=double(dim(rs)[1]), PACKAGE="gss")[["se"]] list(fit=fit,se.fit=se.fit) } } gss/R/gssanova0.R0000644000175100001440000003027412355360640013323 0ustar hornikusers## Fit gssanova0 model gssanova0 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,nu=NULL,prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate terms term <- mkterm(mf,type) ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", weibull="u", lognorm="u", loglogis="u") } ## Generate s, q, and y nobs <- dim(mf)[1] s <- q <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) nla0 <- log10(mean(abs(diag(q)))) limnla <- nla0+c(-.5,.5) iter <- 0 if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s qwk <- w*t(w*q) ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(-1), as.double(limnla), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) limnla <- pmax(z$nlambda+c(-.5,.5),nla0-5) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } eta <- eta.new } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=0,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression by Performance-Oriented Iteration mspregpoi <- function(family,s,q,y,wt,offset,method="u", varht=1,nu,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.character(method))) { stop("gss error in mspregpoi: inputs are of wrong types") } nobs <- dim(s)[1] nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0))) { stop("gss error in sspregpoi: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } eta <- rep(0,nobs) init <- 0 theta <- rep(0,nq) iter <- 0 if (family=="nbinomial") nu <- NULL else nu <- list(nu,is.null(nu)) qwk <- array(0,c(nobs,nobs,nq)) repeat { iter <- iter+1 dat <- switch(family, binomial=mkdata.binomial(y,eta,wt,offset), nbinomial=mkdata.nbinomial(y,eta,wt,offset,nu), poisson=mkdata.poisson(y,eta,wt,offset), inverse.gaussian=mkdata.inverse.gaussian(y,eta,wt,offset), Gamma=mkdata.Gamma(y,eta,wt,offset), weibull=mkdata.weibull(y,eta,wt,offset,nu), lognorm=mkdata.lognorm(y,eta,wt,offset,nu), loglogis=mkdata.loglogis(y,eta,wt,offset,nu)) nu <- dat$nu w <- as.vector(sqrt(dat$wt)) ywk <- w*dat$ywk swk <- w*s for (i in 1:nq) qwk[,,i] <- w*t(w*q[,,i]) ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(swk), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(qwk), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(ywk), # y as.double(0), as.integer(init), as.double(prec), as.integer(maxiter), theta=as.double(theta), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","nlambda","c","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } eta.new <- (ywk-10^z$nlambda*z$c)/w if (!is.null(offset)) eta.new <- eta.new + offset disc <- sum(dat$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(dat$wt) if (disc=maxiter) { warning("gss warning in gssanova0: performance-oriented iteration fails to converge") break } init <- 1 theta <- z$theta eta <- eta.new } qqwk <- 10^z$theta[1]*qwk[,,1] for (i in 2:nq) qqwk <- qqwk + 10^z$theta[i]*qwk[,,i] ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(ywk), qwk=as.double(qqwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspregpoi: matrix s is rank deficient") if (info==-2) stop("gss error in sspregpoi: matrix q is indefinite") if (info==-1) stop("gss error in sspregpoi: input data have wrong dimensions") if (info==-3) stop("gss error in sspregpoi: unknown method for smoothing parameter selection.") } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(list(method=method,theta=theta,w=as.vector(dat$wt), eta=as.vector(eta),iter=iter,nu=nu), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } gss/R/summary.ssanova9.R0000644000175100001440000000710412355360640014655 0ustar hornikusers## Summarize ssanova objects summary.ssanova9 <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") nobs <- length(y) cov <- object$cov if (length(object$zeta)) ww <- cov$fun(object$zeta,cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) offset <- model.offset(object$mf) if (is.null(offset)) offset <- rep(0,length(y)) ## Residuals mf <- object$mf res <- y - predict(object,mf) ## Fitted values fitted <- as.numeric(y-res) ## (estimated) sigma sigma <- sqrt(object$varht) ## R^2 y.wk <- forwardsolve(t(ww),y) fitted.wk <- forwardsolve(t(ww),fitted) one.wk <- forwardsolve(t(ww),rep(1,nobs)) mn.y <- sum(y.wk*one.wk)/sum(one.wk^2) mn.fitted <- sum(fitted.wk*one.wk)/sum(one.wk^2) r.squared <- sum((fitted.wk-mn.fitted*one.wk)^2) r.squared <- r.squared/sum((y.wk-mn.y*one.wk)^2) ## Residual sum of squares res.wk <- forwardsolve(t(ww),res) rss <- sum(res.wk^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) ## Calculate the diagnostics if (is.null(object$partial)) labels.p <- NULL else labels.p <- labels(object$partial$mt) if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in c(object$terms$labels,labels.p)) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] term.label <- c(term.label,labels.p) fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res,e=res) comp <- forwardsolve(t(ww),comp) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.ssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- comp - outer(one.wk,apply(t(comp)%*%one.wk,1,sum))/sum(one.wk^2) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rank1) { if (object$skip.iter) kl <- my.ls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.ls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) if (zz$code>3) warning("gss warning in project.ssanova: theta iteration fails to converge") kl <- my.ls(zz$est) } } else kl <- my.ls() if (!is.null(wt)) { yhat <- yhat/wt.wk ymean <- sum(wt*yy)/sum(wt) kl0 <- sum(wt*(yy-ymean)^2)/sum(wt) kl <- sum(wt*(yy-yhat)^2)/sum(wt) kl1 <- sum(wt*(ymean-yhat)^2)/sum(wt) } else { kl0 <- mean((yy-mean(yy))^2) kl <- mean((yy-yhat)^2) kl1 <- mean((mean(yy)-yhat)^2) } list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } gss/R/gauss.quad.R0000644000175100001440000000117712355360640013475 0ustar hornikusersgauss.quad <- ## Generate Gauss-Legendre quadrature function(size,interval) { if (interval[1]>=interval[2]) warning("gss warning in gauss.quad: interval limits swapped") z <- .Fortran("gaussq", as.integer(1), as.integer(size), as.double(0), as.double(0), as.integer(0), as.double(c(-1,1)), double(size), t=double(size), w=double(size), PACKAGE="gss") mn <- min(interval[1:2]) range <- abs(interval[1]-interval[2]) pt <- mn+range*(z$t+1)/2 wt <- range*z$w/2 list(pt=pt,wt=wt) } gss/R/sshzd1.R0000644000175100001440000005743212355360640012643 0ustar hornikusers## Fit hazard model sshzd1 <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit,rho="marginal", partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd1: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd1: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd1: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd1: start after follow-up time") if (min(start)<0) stop("gss error in sshzd1: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$rho <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd1: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd1: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) ## Use sshzd in lack of covariate if (all(tname==names(mf))) stop("use sshzd when covariate is absent") ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd1: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd1: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (is.vector(rho.qd)) wk <- wk*rho.qd else wk <- wk*rho.qd[,x.ind[i]] if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s, r, int.s, and int.r s <- r <- int.s <- int.r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nT)) int.s <- c(int.s,sum(qd.wt)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.wk*apply(qd.wt,1,sum))) } else { int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- phi$fun(qd.xy[,,drop=TRUE],i,phi$env) int.s.wk <- int.s.wk + sum(qd.wk*qd.wt[,j]) } int.s <- c(int.s,int.s.wk) } } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) { qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) int.r <- cbind(int.r,apply(apply(qd.wt,1,sum)*qd.wk,2,sum)) } else { int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(qd.wt[,j]*qd.wk,2,sum) } int.r <- cbind(int.r,int.r.wk) } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) int.s <- c(int.s,t(matx.p[!x.dup.ind,])%*%apply(qd.wt,2,sum)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## generate int.z if (!is.null(random)) random$int.z <- t(qd.z)%*%apply(qd.wt,2,sum) ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) int.r.wk0 <- c(int.r.wk0,10^ran.scal*random$int.z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } fit <- .Fortran("hzdnewton10", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk0,s)), as.integer(nT), as.integer(Nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(c(int.r.wk0,int.s)), as.double(rho), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*nT+nn*(nn+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) cv <- fit$wk[1]+alpha*fit$wk[2] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta adjustment for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) } r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } v.r <- sum(rho*r.wk^2) if (nnull) { v.s <- sum(rho*s^2) theta.wk <- log10(v.s/nnull/v.r*nxi) / 2 } else theta.wk <- 0 if (!is.null(random)) { v.z <- sum(rho*random$z^2) ran.scal <- theta.wk - log10(v.z/nz/v.r*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.wk,] if (!is.null(random)) { r.wk <- cbind(r.wk,10^ran.scal*random$z) int.r.wk <- c(int.r.wk,10^ran.scal*random$int.z) } log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (!is.null(cnt)) rho <- rho*cnt if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd1: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return if (!is.null(cnt)) rho <- rho*cnt r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk <- cbind(r.wk,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux101", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(cbind(r.wk,s)), as.integer(nT), as.double(rho/Nobs), as.double(.Machine$double.eps), v=double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,se.aux=se.aux) } gss/R/sshzd.R0000644000175100001440000006174312355360640012562 0ustar hornikusers## Fit hazard model sshzd <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,offset,na.action=na.omit, partial=NULL,id.basis=NULL,nbasis=NULL,seed=NULL, random=NULL,prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Local functions handling formula Surv <- function(time,status,start=0) { tname <- as.character(as.list(match.call())$time) if (!is.numeric(time)|!is.vector(time)) stop("gss error in sshzd: time should be a numerical vector") if ((nobs <- length(time))-length(status)) stop("gss error in sshzd: time and status mismatch in size") if ((length(start)-nobs)&(length(start)-1)) stop("gss error in sshzd: time and start mismatch in size") if (any(start>time)) stop("gss error in sshzd: start after follow-up time") if (min(start)<0) stop("gss error in sshzd: start before time 0") time <- cbind(start,time) list(tname=tname,start=time[,1],end=time[,2],status=as.logical(status)) } ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- mf$random <- mf$partial <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ## response resp <- attr(term.wk,"variable")[[2]] ind.wk <- length(strsplit(deparse(resp),'')[[1]]) if ((substr(deparse(resp),1,5)!='Surv(') |(substr(deparse(resp),ind.wk,ind.wk)!=')')) stop("gss error in sshzd: response should be Surv(...)") yy <- with(data,eval(resp)) tname <- yy$tname ## model frame term.labels <- attr(term.wk,"term.labels") if (!(tname%in%term.labels)) stop("gss error in sshzd: time main effect missing in model") mf[[1]] <- as.name("model.frame") mf[[2]] <- eval(parse(text=paste("~",paste(term.labels,collapse="+")))) mf <- eval(mf,parent.frame()) offset <- model.offset(mf) mf$"(offset)" <- NULL ## trim yy if subset is used nobs <- nrow(mf) if (nobssum(yy$status)) nbasis <- sum(yy$status) if (!is.null(seed)) set.seed(seed) id.basis <- sample((1:nobs)[yy$status],nbasis,prob=cnt[yy$status]) } else { if (!all(id.basis%in%(1:nobs)[yy$status])) stop("gss error in sshzd: id.basis not all at failure cases") nbasis <- length(id.basis) } id.wk <- NULL nT <- sum(yy$status) for (i in 1:nbasis) { id.wk <- c(id.wk,(1:nT)[(1:nobs)[yy$status]%in%id.basis[i]]) } ## set domain and type for time mn <- min(yy$start) mx <- max(yy$end) tdomain <- c(max(mn-.05*(mx-mn),0),mx) if (is.null(type[[tname]])) type[[tname]] <- list("cubic",tdomain) if (length(type[[tname]])==1) type[[tname]] <- c(type[[tname]],tdomain) if (!(type[[tname]][[1]]%in%c("cubic","linear"))) stop("gss error in sshzd: wrong type") if ((min(type[[tname]][[2]])>min(tdomain))| (max(type[[tname]][[2]])yy$start[i]) if (!is.null(offset)) wk <- wk*exp(offset[i]) if (is.null(cnt)) qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+wk else qd.wt[,x.ind[i]] <- qd.wt[,x.ind[i]]+cnt[i]*wk } if (is.null(cnt)) qd.wt <- quad$wt*qd.wt/nobs else qd.wt <- quad$wt*qd.wt/sum(cnt) ## Generate s and r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nq <- nu <- 0 for (label in term$labels) { if (label=="1") { nu <- nu+1 s <- cbind(s,rep(1,len=nT)) qd.wk <- matrix(1,nmesh,nx) qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy <- mf[yy$status,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt if (length(x.list)) xx <- x.pt[,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s <- cbind(s,phi$fun(xy,nu=i,env=phi$env)) if (is.null(xx)) qd.wk <- matrix(phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env),nmesh,nx) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy[,,drop=TRUE],i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE)),c(nT,nbasis,nq)) if (is.null(xx)) qd.r[[nq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Add the partial term if (!is.null(partial)) { s <- cbind(s,matx.p[yy$status,]) nu.p <- dim(matx.p)[2] qd.wk <- aperm(array(matx.p[!x.dup.ind,],c(nx,nu.p,nmesh)),c(3,1,2)) nu <- nu + nu.p qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) part$pt <- matx.p[!x.dup.ind,,drop=FALSE] } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.wk,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("hzdnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nT), as.integer(Nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(qd.r.wk0), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd*nx+nT)+nn*(2*nn+4)+max(nn,2)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sshzd: Newton iteration diverges") if (fit$info==2) warning("gss warning in sshzd: Newton iteration fails to converge") assign("cd",fit$cd,inherits=TRUE) assign("mesh0",matrix(fit$wk[max(nn,2)+(1:(nqd*nx))],nqd,nx),inherits=TRUE) cv <- alpha*fit$wk[2]-fit$wk[1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.wk,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration mesh0 <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.wk,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } v.s <- v.r <- 0 for (i in 1:nx) { if (nnull) v.s <- v.s + apply(qd.wt[,i]*qd.s[,i,,drop=FALSE]^2,2,sum) v.r <- v.r + apply(qd.wt[,i]*qd.r.wk[,,i,drop=FALSE]^2,2,sum) } if (nnull) theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 else theta.wk <- 0 if (!is.null(random)) { v.z <- apply(apply(qd.wt,2,sum)*random$qd.z^2,2,sum) ran.scal <- theta.wk - log10(sum(v.z)/nz/sum(v.r)*nxi) / 2 qd.z.wk <- aperm(array(10^ran.scal*random$qd.z,c(nx,nz,nqd)),c(3,1,2)) } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.wk,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sshzd: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.wk,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,qd.z.wk),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("hzdaux1", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.double(qd.wt), as.integer(nx), as.double(.Machine$double.eps), double(nqd*nx), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,mesh0=mesh0,se.aux=se.aux)) } gss/R/gssanova1.R0000644000175100001440000001557712355360640013335 0ustar hornikusers## Fit gssanova model gssanova1 <- function(formula,family,type=NULL,data=list(),weights, subset,offset,na.action=na.omit,partial=NULL, method=NULL,varht=1,alpha=1.4,nu=NULL, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { if (!(family%in%c("binomial","poisson","Gamma","nbinomial","inverse.gaussian", "weibull","lognorm","loglogis"))) stop("gss error in gssanova1: family not implemented") ## Obtain model frame and model terms mf <- match.call() mf$family <- mf$type <- mf$partial <- NULL mf$method <- mf$varht <- mf$nu <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in gssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Specify default method if (is.null(method)) { method <- switch(family, binomial="u", nbinomial="u", poisson="u", inverse.gaussian="v", Gamma="v", weibull="u", lognorm="u", loglogis="u") } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in gssanova1: use glm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rank=30) { warning("gss warning in gssanova1: performance-oriented iteration fails to converge") break } } ## Return the fit if (is.list(nu)) nu <- nu[[1]] c(z,list(nu=nu,eta=eta,w=dat$wt)) } gss/R/sscden1.R0000644000175100001440000005100012355360640012750 0ustar hornikusers## Fit conditional density model sscden1 <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL,rho=list("xy"), ydomain=as.list(NULL),yquad=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- mf$rho <- NULL mf$ydomain <- mf$yquad <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) nobs <- nrow(mf) cnt <- model.weights(mf) if (is.null(cnt)) data$cnt <- rep(1,nobs) else { data$cnt <- cnt mf$"(weights)" <- NULL } ## Generate sub-basis if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden1: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden1: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden1: missing covariate") ## Set type for given ydomain fac.list <- NULL for (ylab in ynames) { y <- mf[[ylab]] if (is.factor(y)) { fac.list <- c(fac.list,ylab) ydomain[[ylab]] <- NULL } else { if (!is.vector(y)&is.null(yquad)) stop("gss error in sscden1: no default quadrature") if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## calculate rho if (is.null(rho$fun)) { type <- rho[[1]] if (type=="y") { yfac <- TRUE for (ylab in ynames) yfac <- yfac&is.factor(mf[,ylab]) if (!yfac) { if (is.null(cnt)) cntt <- rep(1,dim(mf)[1]) rho <- ssden(response,data=data,weights=cnt,id.basis=id.basis, alpha=2,domain=ydomain,quad=yquad) qd.pt <- rho$quad$pt qd.wt <- rho$quad$wt env <- list(ydomain=ydomain,qd.pt=qd.pt,qd.wt=qd.wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) dssden(env$rho,y) else t(matrix(dssden(env$rho,y),dim(y)[1],dim(x)[1])) } } else { qd.pt <- data.frame(levels(mf[,ynames[1]])) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1]) } } colnames(qd.pt) <- ynames qd.wt <- as.vector(table(mf[,rev(ynames)])) qd.wt <- qd.wt/sum(qd.wt) env <- list(qd.pt=qd.pt,qd.wt=qd.wt) fun <- function(x,y,env,outer.prod=FALSE) { if (!outer.prod) rep(1,dim(x)[1]) else matrix(1,dim(x)[1],dim(y)[1]) } } rho <- list(fun=fun,env=env) } if (type=="xy") { ydomain <- data.frame(ydomain) mn <- ydomain[1,] mx <- ydomain[2,] dm <- ncol(ydomain) if (dm==1) { ## Gauss-Legendre quadrature quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } else { ## Smolyak cubature qdsz.depth <- switch(min(dm,6)-1,18,14,10,9,7) quad <- smolyak.quad(dm,qdsz.depth) for (i in 1:ncol(ydomain)) { ylab <- colnames(ydomain)[i] wk <- mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=ydomain[,i]),alpha=2, id.basis=id.basis,weights=cnt) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(ydomain) } ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } rho <- list(NULL) for (ylab in ynames) { if (is.numeric(mf[[ylab]])) { form <- as.formula(paste(ylab,"~",paste(xnames,collapse="+"))) rho[[ylab]] <- ssanova(form,data=mf,id.basis=id.basis) } if (is.factor(mf[[ylab]])) { form <- as.formula(paste("~(",paste(xnames,collapse="+"),")*",ylab)) resp <- as.formula(paste("~",ylab)) rho[[ylab]] <- ssllrm(form,resp,data=mf,id.basis=id.basis) } } env <- list(ynames=ynames,ydomain=ydomain,qd.pt=quad$pt,qd.wt=quad$wt,rho=rho) fun <- function(x,y,env,outer.prod=FALSE) { z <- 1 for (ylab in env$ynames) { yy <- y[[ylab]] if (is.numeric(yy)) { mu <- predict(env$rho[[ylab]],x) sigma <- sqrt(env$rho[[ylab]]$varht) ymn <- env$ydomain[1,ylab] ymx <- env$ydomain[2,ylab] if (!outer.prod) { wk <- dnorm((yy-mu)/sigma)/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } else { wk <- t(outer(yy,mu,dnorm,sigma))/ (pnorm((ymx-mu)/sigma)-pnorm((ymn-mu)/sigma)) z <- z*wk } } if (is.factor(yy)) { wk <- predict(env$rho[[ylab]],x) if (!outer.prod) { wk1 <- NULL for (i in 1:length(yy)) wk1 <- c(wk1,wk[i,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } else { wk1 <- NULL for (i in 1:length(yy)) wk1 <- cbind(wk1,wk[,yy[i]==env$rho[[ylab]]$qd.pt]) z <- z*wk1 } } } z } rho <- list(fun=fun,env=env) } } ## Generate s, r, int.s, and int.r rho.wk <- rho$fun(x[!x.dup.ind,,drop=FALSE],rho$env$qd.pt,rho$env,outer=TRUE) rho.wk <- t(t(rho.wk)*rho$env$qd.wt) rho.wk1 <- apply(rho.wk*xx.wt,2,sum) nmesh <- length(rho$env$qd.wt) s <- r <- int.s <- int.r <- NULL id.s <- id.r <- NULL id.s.list <- id.r.list <- list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- rho$env$qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi id.s.list[[label]] <- NULL for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) int.s <- c(int.s,sum(qd.s.wk*rho.wk1)) } else { if (length(y.list)==0) { names(xx) <- x.list int.s <- c(int.s,sum(phi$fun(xx[,,drop=TRUE],i,phi$env)*xx.wt)) } else { id.s <- c(id.s,nu) id.s.list[[label]] <- c(id.s.list[[label]],nu) int.s.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.s.wk <- phi$fun(qd.xy,i,phi$env) int.s.wk <- int.s.wk + sum(qd.s.wk*rho.wk[j,])*xx.wt[j] } int.s <- c(int.s,int.s.wk) } } } } if (nrk) { rk <- term[[label]]$rk id.r.list[[label]] <- NULL for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) int.r <- cbind(int.r,apply(rho.wk1*qd.r.wk,2,sum)) } else { if (length(y.list)==0) { names(xx) <- x.list qd.r.wk <- rk$fun(xx[,,drop=TRUE],xy.basis,i,rk$env,TRUE) int.r <- cbind(int.r,apply(xx.wt*qd.r.wk,2,sum)) } else { id.r <- c(id.r,nq) id.r.list[[label]] <- c(id.r.list[[label]],nq) int.r.wk <- 0 for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.r.wk <- rk$fun(qd.xy,xy.basis,i,rk$env,TRUE) int.r.wk <- int.r.wk + apply(rho.wk[j,]*qd.r.wk,2,sum)*xx.wt[j] } int.r <- cbind(int.r,int.r.wk) } } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.m <- function(theta) { ind.wk <- theta!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- int.r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] int.r.wk0 <- int.r.wk0 + 10^theta[i]*int.r[,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("int.r.wk",int.r.wk0+0,inherits=TRUE) assign("theta.old",theta+0,inherits=TRUE) } else { r.wk0 <- r.wk int.r.wk0 <- int.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] int.r.wk0 <- int.r.wk0 + theta.wk*int.r[,i] } } q.wk <- r.wk0[id.basis,] fit <- .Fortran("cdennewton10", cd=as.double(cd), as.integer(nxis), as.double(10^lambda*q.wk), as.integer(nxi), as.double(cbind(r.wk0,s)), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(c(int.r.wk0,int.s)), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nxis), wk=double(2*nobs+nxis*(nxis+3)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden1: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden1: Newton iteration fails to converge") aa <- fit$wk[1:nobs] assign("cd",fit$cd,inherits=TRUE) eta0 <- cbind(r.wk,s)%*%cd wwt <- wt*exp(-eta0) wwt <- wwt/sum(wwt) assign("scal",sum(wt*exp(-eta0)),inherits=TRUE) trc <- sum(wwt*exp(aa/(1-aa)))-1 cv <- sum(c(int.r.wk0,int.s)*cd) + log(scal) + alpha*trc alpha.wk <- max(0,theta-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*trc,0) cv+adj } cv.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration cd <- rep(0,nxi+nnull) scal <- NULL la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { lambda <- zz$est c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta adjustment r.wk <- int.r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } if (!nnull) { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 theta.wk <- 0 } else { mu.r <- apply(wt*r.wk,2,sum) v.r <- apply(wt*r.wk^2,2,sum) v.r <- v.r - mu.r^2 mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) v.s <- v.s - mu.s^2 theta.wk <- log10(sum(v.s)/nnull/sum(v.r)*nxi) / 2 } theta <- theta + theta.wk r.wk <- 10^theta.wk*r.wk int.r.wk <- 10^theta.wk*int.r.wk q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(v.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nxi+nnull) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL return(list(lambda=lambda,theta=theta,c=c,d=d,cv=zz$min,scal=scal)) } ## theta search counter <- 0 r.wk <- int.r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] int.r.wk <- int.r.wk + 10^theta[i]*int.r[,i] } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden1: CV iteration fails to converge") break } } ## return c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL cv <- (zz$min-cv.shift)/cv.scale list(lambda=lambda,theta=zz$est,c=c,d=d,cv=cv,scal=scal) } gss/R/summary.gssanova.R0000644000175100001440000001013212355360640014726 0ustar hornikusers## Summarize gssanova objects summary.gssanova <- function(object,diagnostics=FALSE,...) { y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) offset <- model.offset(object$mf) if ((object$family=="nbinomial")&(!is.null(object$nu))) y <- cbind(y,object$nu) dev.null <- switch(object$family, binomial=dev.null.binomial(y,wt,offset), nbinomial=dev.null.nbinomial(y,wt,offset), poisson=dev.null.poisson(y,wt,offset), Gamma=dev.null.Gamma(y,wt,offset), weibull=dev.null.weibull(y,wt,offset,object$nu), lognorm=dev.null.lognorm(y,wt,offset,object$nu), loglogis=dev.null.loglogis(y,wt,offset,object$nu)) w <- object$w if (is.null(offset)) offset <- rep(0,length(object$eta)) ## Residuals res <- residuals(object)*sqrt(w) dev.resid <- residuals(object,"deviance") ## Fitted values fitted <- fitted(object) ## dispersion sigma2 <- object$varht ## RSS, deviance rss <- sum(res^2) dev <- sum(dev.resid^2) ## Penalty associated with the fit obj.wk <- object obj.wk$d[] <- 0 if (!is.null(model.offset(obj.wk$mf))) obj.wk$mf[,"(offset)"] <- 0 penalty <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,])) penalty <- as.vector(10^object$nlambda*penalty) if (!is.null(object$random)) { p.ran <- t(object$b)%*%object$random$sigma$fun(object$zeta,object$random$sigma$env)%*%object$b penalty <- penalty + p.ran } ## Calculate the diagnostics if (diagnostics) { ## Obtain retrospective linear model comp <- NULL p.dec <- NULL for (label in object$terms$labels) { if (label=="1") next if (label=="offset") next comp <- cbind(comp,predict(object,object$mf,inc=label)) jk <- sum(obj.wk$c*predict(obj.wk,obj.wk$mf[object$id.basis,],inc=label)) p.dec <- c(p.dec,10^object$nlambda*jk) } term.label <- object$terms$labels[object$terms$labels!="1"] term.label <- term.label[term.label!="offset"] if (!is.null(object$random)) { mf <- object$mf mf$random <- object$random$z comp <- cbind(comp,predict(object,mf,inc=NULL)) p.dec <- c(p.dec,p.ran) term.label <- c(term.label,"random") } fitted.off <- fitted-offset comp <- cbind(comp,yhat=fitted.off,y=fitted.off+res/sqrt(w),e=res/sqrt(w)) if (any(outer(term.label,c("yhat","y","e"),"=="))) warning("gss warning in summary.gssanova: avoid using yhat, y, or e as variable names") colnames(comp) <- c(term.label,"yhat","y","e") ## Sweep out constant comp <- sqrt(w)*comp - outer(sqrt(w),apply(w*comp,2,sum))/sum(w) ## Obtain pi comp1 <- comp[,c(term.label,"yhat")] decom <- t(comp1) %*% comp1[,"yhat"] names(decom) <- c(term.label,"yhat") decom <- decom[term.label]/decom["yhat"] ## Obtain kappa, norm, and cosines corr <- t(comp)%*%comp corr <- t(corr/sqrt(diag(corr)))/sqrt(diag(corr)) norm <- apply(comp,2,function(x){sqrt(sum(x^2))}) cosines <- rbind(corr[c("y","e"),],norm) rownames(cosines) <- c("cos.y","cos.e","norm") corr <- corr[term.label,term.label,drop=FALSE] if (qr(corr)$rankmx)) stop("gss error in hzdcurve.sshzd: time range beyond the domain") if (length(xnames)) { xx <- covariates[,xnames,drop=FALSE] xy <- data.frame(matrix(0,length(time),length(xnames)+1)) names(xy) <- c(tname,xnames) xy[,tname] <- time } else xx <- NULL if (!se) { if (is.null(xx)) zz <- hzdrate.sshzd(object,time) else { zz <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] zz <- cbind(zz,hzdrate.sshzd(object,xy)) } zz <- zz[,,drop=TRUE] } zz } else { if (is.null(xx)) zz <- hzdrate.sshzd(object,time,TRUE) else { fit <- se.fit <- NULL for (i in 1:dim(xx)[1]) { xy[,xnames] <- xx[rep(i,length(time)),] wk <- hzdrate.sshzd(object,xy,TRUE) fit <- cbind(fit,wk$fit) se.fit <- cbind(se.fit,wk$se.fit) } zz <- list(fit=fit[,,drop=TRUE],se.fit=se.fit[,,drop=TRUE]) } zz } } survexp.sshzd <- ## Compute expected survival function(object,time,covariates=NULL,start=0) { tname <- object$tname xnames <- object$xnames ## Check inputs if (!any(class(object)=="sshzd")) stop("gss error in survexp.sshzd: not a sshzd object") if (length(xnames)&&(!all(xnames%in%names(covariates)))) stop("gss error in survexp.sshzd: missing covariates") lmt <- cbind(start,time) if (any(lmt[,1]>lmt[,2])) stop("gss error in survexp.sshzd: start after follow-up time") nt <- dim(lmt)[1] if (is.null(covariates)) ncov <- 1 else ncov <- dim(covariates)[1] mn <- min(object$tdomain) mx <- max(object$tdomain) if ((min(start)mx)) stop("gss error in survexp.sshzd: time range beyond the domain") ## Calculate qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) if (is.null(covariates)) { zz <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz <- c(zz,wk) } } else { zz <- NULL for (j in 1:ncov) { zz.wk <- NULL d.qd <- hzdcurve.sshzd(object,qd$pt,covariates[j,,drop=FALSE]) for (i in 1:nt) { ind <- (1:(2*qd.hize))[(qd$ptlmt[i,1])] if (length(ind)) { wk <- sum(d.qd[ind]*qd$wt[ind]) id.mx <- max(ind) if (lmt[i,2]<=brk[id.mx+1]) wk <- wk-d.qd[id.mx]*qd$wt[id.mx]*(brk[id.mx+1]-lmt[i,2])/gap[id.mx] else wk <- wk+d.qd[id.mx+1]*qd$wt[id.mx+1]*(lmt[i,2]-brk[id.mx+1])/gap[id.mx+1] id.mn <- min(ind) if (lmt[i,1]=qd$pt[2*qd.hize]) wk <- d.qd[2*qd.hize]*qd$wt[2*qd.hize]*(lmt[i,2]-lmt[i,1])/gap[2*qd.hize] if ((lmt[i,1]>qd$pt[1])&(lmt[i,1]lmt[i,1]]) if (brk[i.wk]<=lmt[i,1]) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-lmt[i,1])/gap[i.wk] if (brk[i.wk]>=lmt[i,2]) wk <- d.qd[i.wk-1]*qd$wt[i.wk-1]*(lmt[i,2]-lmt[i,1])/gap[i.wk-1] if ((brk[i.wk]lmt[i,1])) wk <- d.qd[i.wk]*qd$wt[i.wk]*(lmt[i,2]-brk[i.wk])/gap[i.wk]+ d.qd[i.wk-1]*qd$wt[i.wk-1]*(brk[i.wk]-lmt[i,1])/gap[i.wk-1] } } zz.wk <- c(zz.wk,wk) } zz <- cbind(zz,as.vector(zz.wk)) } if (ncov==1) zz <- as.vector(zz) } exp(-zz) } gss/R/print.R0000644000175100001440000001573412355360640012562 0ustar hornikusers## Print function for ssanova objects print.ssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV " if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL " if (x$method=="m") cat("Smoothing parameters are selected by",Method) else cat("Smoothing parameters are selected by ",Method,"with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssanova0 objects print.ssanova0 <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") if (x$method=="v") Method <- "GCV.\n" if (x$method=="m") Method <- "GML.\n" if (x$method=="u") Method <- "Mallows CL.\n" cat("Smoothing parameters are selected by",Method) cat("\n") ## the rest are suppressed invisible() } ## Print function for gssanova objects print.gssanova <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssden objects print.ssden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sscden objects print.sscden <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sshzd <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for sshzd objects print.sscox <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(c(x$terms$labels,x$lab.p)) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for ssllrm objects print.ssllrm <- function(x,...) { ## call cat("\nCall:\n",deparse(x$call),"\n\n",sep="") ## terms cat("Terms:\n") print.default(x$terms$labels) cat("\n") ## terms overview cat("Number of unpenalized and penalized terms:\n\n") print.default(x$desc) cat("\n") cat("Smoothing parameters are selected by CV with alpha=",x$alpha,".",sep="") cat("\n") ## the rest are suppressed invisible() } ## Print function for summary.ssanova objects print.summary.ssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") cat("\nEstimate of error standard deviation:",x$sigma,"\n") ## residuals res <- x$res cat("\nResiduals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss) cat("\nR square:",x$r.squared) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$family%in%c("Gamma","inverse.gaussian")) { cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") } else { cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") } ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\n") invisible() } ## Print function for summary.gssanova objects print.summary.gssanova0 <- function (x,digits=6,...) { ## call cat("\nCall:\n",deparse(x$call),"\n",sep="") if (x$method=="u") cat("\n(Dispersion parameter for ",x$family, " family taken to be ",format(x$dispersion),")\n\n",sep="") if (x$method=="v") cat("\n(Dispersion parameter for ",x$family, " family estimated to be ",format(x$dispersion),")\n\n",sep="") ## residuals res <- x$res cat("Working residuals (weighted):\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Residual sum of squares:",x$rss,"\n") ## deviance residuals res <- x$dev.res cat("\nDeviance residuals:\n") nam <- c("Min", "1Q", "Median", "3Q", "Max") rq <- structure(quantile(res), names = nam) print(rq,digits=digits) cat("Deviance:",x$deviance) cat("\nNull deviance:",x$dev.null) ## selected summaries cat("\n\nPenalty associated with the fit:",x$pen) cat("\n\nNumber of performance-oriented iterations:",x$iter) cat("\n\n") invisible() } gss/R/ssllrm.R0000644000175100001440000006032412355360640012735 0ustar hornikusers## Fit log-linear regression model ssllrm <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssllrm: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in ssllrm: response missing in model") for (ylab in ynames) { if (!is.factor(mf[,ylab])) stop("gss error in ssllrm: response not a factor") } xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in ssllrm: missing covariate") ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature qd.pt <- data.frame(levels(mf[,ynames[1]])) if (length(ynames)>1) { for (ylab in ynames[-1]) { wk <- expand.grid(levels(mf[,ylab]),1:dim(qd.pt)[1]) qd.pt <- data.frame(qd.pt[wk[,2],],wk[,1]) } } colnames(qd.pt) <- ynames nmesh <- dim(qd.pt)[1] x <- mf[,xnames,drop=FALSE] ## obtain unique covariate observations xx <- mf[,xnames,drop=FALSE] if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) xx <- cbind(xx,random$z) } xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate Random if (!is.null(random)) { ## z and qd.z z <- qd.z <- nlvl <- NULL for (ylab in ynames) { y.wk <- mf[,ylab] pt.wk <- qd.pt[,ylab] lvl.wk <- levels(y.wk) nlvl.wk <- length(lvl.wk) nlvl <- c(nlvl,nlvl.wk) z.aux <- diag(1,nlvl.wk-1) z.aux <- rbind(z.aux,rep(-1,nlvl.wk-1)) rownames(z.aux) <- lvl.wk for (i in 1:(nlvl.wk-1)) { z <- cbind(z,z.aux[y.wk,i]*random$z) for (j in 1:nmesh) { qd.z <- cbind(qd.z,z.aux[pt.wk[j],i]*random$z[!x.dup.ind,]) } } } nz <- dim(random$z)[2] nZ <- sum(nlvl-1)*nz qd.z <- aperm(array(qd.z,c(nx,nz,nmesh,nZ/nz)),c(3,1,2,4)) qd.z <- array(qd.z,c(nmesh,nx,nZ)) ## Sigma env <- list(sigma=random$sigma,nzeta=length(random$init),nz=nz,nlvl=nlvl) fun <- function(zeta,env) { ny <- length(env$nlvl) nze <- env$nzeta sigma <- env$sigma dm <- cumsum(env$nlvl-1)*env$nz zz <- matrix(0,dm[ny],dm[ny]) dm <- c(0,dm) for (i in 1:ny) { nlvl.wk <- nlvl[i] wk <- kronecker(diag(1,nlvl.wk-1)+1, sigma$fun(zeta[nze*(i-1)+(1:nze)],sigma$env)) zz[(dm[i]+1):dm[i+1],(dm[i]+1):dm[i+1]] <- wk } zz } Sigma <- list(fun=fun,env=env) ## init init <- rep(random$init,length(nlvl)) ## assemble Random <- list(z=z,qd.z=qd.z,sigma=Sigma,init=init) } else Random <- NULL ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.s.wk <- function(lambda) cv.scale*cv.s(lambda)+cv.shift cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { r.wk0 <- cbind(r.wk0,10^ran.scal*random$z) q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) if (!is.null(random)) { qd.r.wk0 <- array(c(qd.r.wk0,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("llrmnewton", cd=as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in ssllrm: Newton iteration diverges") if (fit$info==2) warning("gss warning in ssllrm: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } else ran.scal <- NULL theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (nq==1) { if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } if (!is.null(random)) { vv.z <- 0 for (i in 1:nx) { mu.z <- apply(random$qd.z[,i,,drop=FALSE],2,sum)/nqd v.z <- apply(random$qd.z[,i,,drop=FALSE]^2,2,sum)/nqd v.z <- v.z - mu.z^2 vv.z <- vv.z + xx.wt[i]*v.z } ran.scal <- theta.wk - log10(sum(vv.z)/nz/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (!is.null(random)) r.wk <- cbind(r.wk,10^ran.scal*random$z) log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv.s(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.s.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: iteration for model selection fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } cv <- zz$min } if (is.null(random)) { lambda <- zz$est zeta <- NULL } else { lambda <- zz$est[1] zeta <- zz$est[-1] } ## early return if (skip.iter) { if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta if (!is.null(random)) theta <- c(theta,zeta) tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssllrm: CV iteration fails to converge") break } } cv <- (zz$min-cv.shift)/cv.scale if (is.null(random)) { theta <- zz$est zeta <- NULL } else { theta <- zz$est[1:nq] zeta <- zz$est[-(1:nq)] } ## return q.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { q.wk <- q.wk + 10^theta[i]*r[id.basis,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (is.null(random)) q.wk0 <- 10^(lambda)*q.wk else { q.wk0 <- matrix(0,nxiz,nxiz) q.wk0[1:nxi,1:nxi] <- 10^(lambda)*q.wk q.wk0[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(zeta,random$sigma$env) } qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) if (!is.null(random)) { qd.r.wk <- array(c(qd.r.wk,10^ran.scal*random$qd.z),c(nqd,nx,nxiz)) } qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) se.aux <- .Fortran("llrmaux", as.double(cd), as.integer(nn), as.double(q.wk0), as.integer(nxiz), as.double(qd.r.wk), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(.Machine$double.eps), double(nqd*nx), double(nx), double(nn), v=double(nn*nn), double(nn*nn), jpvt=integer(nn), PACKAGE="gss")[c("v","jpvt")] c <- cd[1:nxi] if (nz) b <- 10^ran.scal*cd[nxi+(1:nz)] else b <- NULL if (nnull) d <- cd[nxiz+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,zeta=zeta,theta=theta,ran.scal=ran.scal, c=c,b=b,d=d,cv=cv,fit=t(eta),se.aux=se.aux)) } gss/R/mkran.R0000644000175100001440000000334512355360640012531 0ustar hornikusers## Make random effects for mixed-effect models mkran <- function(formula,data) { with(data,{ ## decipher formula form.wk <- terms.formula(formula)[[2]] if (!("|"%in%strsplit(deparse(form.wk),'')[[1]])) stop("gss error in mkran: missing | in grouping formula") term.wk <- strsplit(deparse(form.wk),' \\| ')[[1]] ## make matrix Z z2.wk <- eval(parse(text=term.wk[2])) if (!is.factor(z2.wk)) stop(paste("gss error in mkran: ", term.wk[2], " should be a factor")) z <- NULL lvl.z2 <- levels(z2.wk) for (i in lvl.z2) z <- cbind(z,as.numeric(z2.wk==i)) ## make sigma function if (term.wk[1]=="1") { init <- 0 env <- length(levels(z2.wk)) fun <- function(zeta,env) diag(10^(-zeta),env) sigma <- list(fun=fun,env=env) } else { z1.wk <- eval(parse(text=term.wk[1])) if (!is.factor(z1.wk)) stop(paste("gss error in mkran: ", term.wk[1], " should be a factor")) ind <- lvl.wk <- NULL nz <- length(lvl.z2) nsig <- length(levels(z1.wk)) for (i in levels(z1.wk)) { zz.wk <- z2.wk[z1.wk==i,drop=TRUE] ind <- c(ind,list((1:nz)[lvl.z2%in%levels(zz.wk)])) lvl.wk <- c(lvl.wk,levels(zz.wk)) } if (max(table(lvl.wk)>1)) stop("gss error in mkran: ", term.wk[2], " should be nested under ", term.wk[1]) init <- rep(0, length(levels(z1.wk))) env <- list(size=nz,nsig=nsig,ind=ind) fun <- function(zeta,env) { wk <- rep(0,env$size) for (i in 1:env$nsig) wk[env$ind[[i]]] <- 10^(-zeta[i]) diag(wk) } sigma <- list(fun=fun,env=env) } list(z=z,sigma=sigma,init=init) }) } gss/R/ssanova0.R0000644000175100001440000002370512355360640013155 0ustar hornikusers## Fit ssanova model ssanova0 <- function(formula,type=NULL,data=list(),weights,subset, offset,na.action=na.omit,partial=NULL, method="v",varht=1,prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate terms term <- mkterm(mf,type) ## Generate s, q, and y nobs <- dim(mf)[1] s <- q <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 q <- array(c(q,rk$fun(x,x,nu=i,env=rk$env,out=TRUE)),c(nobs,nobs,nq)) } } } ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL ## Prepare the data y <- model.response(mf,"numeric") w <- model.weights(mf) offset <- model.offset(mf) if (!is.null(offset)) { term$labels <- c(term$labels,"offset") term$offset <- list(nphi=0,nrk=0) y <- y - offset } if (!is.null(w)) { w <- sqrt(w) y <- w*y s <- w*s for (i in 1:nq) q[,,i] <- w*t(w*q[,,i]) } if (qr(s)$rank=nnull)&(nnull>0))) { stop("gss error in sspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DSIDR z <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(q), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in sspreg: matrix s is rank deficient") if (info==-2) stop("gss error in sspreg: matrix q is indefinite") if (info==-1) stop("gss error in sspreg: input data have wrong dimensions") if (info==-3) stop("gss error in sspreg: unknown method for smoothing parameter selection.") } ## Return the fit c(list(method=method,theta=0), z[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Fit Multiple Smoothing Parameter REGression mspreg0 <- function(s,q,y,method="v",varht=1,prec=1e-7,maxiter=30) { ## Check inputs if (is.vector(s)) s <- as.matrix(s) if (!(is.matrix(s)&is.array(q)&(length(dim(q))==3) &is.vector(y)&is.character(method))) { stop("gss error in mspreg: inputs are of wrong types") } nobs <- length(y) nnull <- dim(s)[2] nq <- dim(q)[3] if (!((dim(s)[1]==nobs)&(dim(q)[1]==nobs)&(dim(q)[2]==nobs) &(nobs>=nnull)&(nnull>0)&(nq>1))) { stop("gss error in mspreg: inputs have wrong dimensions") } ## Set method for smoothing parameter selection code <- (1:3)[c("v","m","u")==method] if (!length(code)) { stop("gss error: unsupported method for smoothing parameter selection") } ## Call RKPACK driver DMUDR z <- .Fortran("dmudr0", as.integer(code), as.double(s), # s as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(q), # q as.integer(nobs), as.integer(nobs), as.integer(nq), as.double(y), # y as.double(0), as.integer(0), as.double(prec), as.integer(maxiter), theta=double(nq), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), double(nobs*nobs*(nq+2)), info=integer(1),PACKAGE="gss")[c("theta","info")] ## Check info for error if (info<-z$info) { if (info>0) stop("gss error in mspreg: matrix s is rank deficient") if (info==-2) stop("gss error in mspreg: matrix q is indefinite") if (info==-1) stop("gss error in mspreg: input data have wrong dimensions") if (info==-3) stop("gss error in mspreg: unknown method for smoothing parameter selection.") if (info==-4) stop("gss error in mspreg: iteration fails to converge, try to increase maxiter") if (info==-5) stop("gss error in mspreg: iteration fails to find a reasonable descent direction") } qwk <- 10^z$theta[1]*q[,,1] for (i in 2:nq) qwk <- qwk + 10^z$theta[i]*q[,,i] ## Call RKPACK driver DSIDR zz <- .Fortran("dsidr0", as.integer(code), swk=as.double(s), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(y), qwk=as.double(qwk), as.integer(nobs), as.double(0), as.integer(0), double(2), nlambda=double(1), score=double(1), varht=as.double(varht), c=double(nobs), d=double(nnull), qraux=double(nnull), jpvt=integer(nnull), double(3*nobs), info=integer(1),PACKAGE="gss") ## Return the fit c(list(method=method,theta=z$theta), zz[c("c","d","nlambda","score","varht","swk","qraux","jpvt","qwk")]) } ## Obtain c & d for new y's getcrdr <- function(obj,r) { ## Check inputs if (is.vector(r)) r <- as.matrix(r) if (!(any(class(obj)=="ssanova0")&is.matrix(r))) { stop("gss error in getcrdr: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) nr <- dim(r)[2] if (!((dim(r)[1]==nobs)&(nr>0))) { stop("gss error in getcrdr: inputs have wrong dimensions") } ## Call RKPACK ulitity DCRDR z <- .Fortran("dcrdr", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.double(obj$qraux), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), as.double(r), as.integer(nobs), as.integer(nr), cr=double(nobs*nr), as.integer(nobs), dr=double(nnull*nr), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")[c("cr","dr")] ## Return cr and dr z$cr <- matrix(z$cr,nobs,nr) z$dr <- matrix(z$dr,nnull,nr) z } ## Obtain var-cov matrix for unpenalized terms getsms <- function(obj) { ## Check input if (!any(class(obj)=="ssanova0")) { stop("gss error in getsms: inputs are of wrong types") } nobs <- length(obj$c) nnull <- length(obj$d) ## Call RKPACK ulitity DSMS z <- .Fortran("dsms", as.double(obj$swk), as.integer(nobs), as.integer(nobs), as.integer(nnull), as.integer(obj$jpvt), as.double(obj$qwk), as.integer(nobs), as.double(obj$nlambda), sms=double(nnull*nnull), as.integer(nnull), double(2*nobs), integer(1),PACKAGE="gss")["sms"] ## Return the nnull-by-nnull matrix matrix(z$sms,nnull,nnull) } gss/R/dsscden.R0000644000175100001440000001773012355360640013047 0ustar hornikusersdsscden <- ## Evaluate conditional density estimate function (object,y,x) { ## check input if (!("sscden"%in%class(object))) stop("gss error in dsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in dsscden: mismatched x variable names") if (length(object$ynames)==1&is.vector(y)) { y <- data.frame(y) colnames(y) <- object$ynames } if (!all(sort(object$ynames)==sort(colnames(y)))) stop("gss error in dsscden: mismatched y variable names") if ("sscden1"%in%class(object)) { qd.pt <- object$rho$env$qd.pt qd.wt <- object$rho$env$qd.wt d.qd <- d.sscden1(object,x,qd.pt,scale=FALSE) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden1(object,x,y,scale=FALSE))/int)) } else { qd.pt <- object$yquad$pt qd.wt <- object$yquad$wt d.qd <- d.sscden(object,x,qd.pt) int <- apply(d.qd*qd.wt,2,sum) return(t(t(d.sscden(object,x,y))/int)) } } psscden <- ## Compute cdf for univariate density estimate function(object,q,x) { if (!("sscden"%in%class(object))) stop("gss error in psscden: not a sscden object") if (length(object$ynames)!=1) stop("gss error in psscden: y is not 1-D") if (("sscden1"%in%class(object))&!is.numeric(object$mf[,object$ynames])) stop("gss error in qssden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[object$ynames]]) mx <- max(ydomain[[object$ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- object$ynames d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk2) { ## phi nphi <- 0 ## rk rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=fun.env) } else { ## phi phi.fun <- function(x,nu=1,env) { wk <- as.factor(names(env$env$code)[1]) env$fun(x,wk,env$env) } nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=fun.env) ## rk nrk <- 0 } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.cubic(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.cubic(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## phi nphi <- 0 ## rk if (type.wk=="cubic.per") rk.env <- mkrk.cubic.per(range) if (type.wk=="linear") rk.env <- mkrk.linear(range) if (type.wk=="linear.per") rk.env <- mkrk.linear.per(range) if (type.wk=="sphere") rk.env <- mkrk.sphere(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist]][[2]] ## phi phi.env <- mkphi.trig(range) phi.fun <- function(x,nu=1,env) env$fun(x,nu,env$env) nphi <- 2 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.trig(range) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.env <- mkphi.tp(xdim,order,mesh,weight) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } nphi <- choose(xdim+order-1,xdim)-1 iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) ## rk rk.env <- mkrk.tp(xdim,order,mesh,weight) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.env <- par$mkphi(par$env) phi.fun <- function(x,nu=1,env) { env$fun(x,nu,env$env) } iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } rk.env <- par$mkrk(par$env) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { env$fun(x,y,env$env,outer.prod) } nrk <- 1 irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="trig") { ## trigonometric splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.trig(range) n.phi <- c(n.phi,2) ## rk rk.wk <- mkrk.trig(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi if (!all(as.logical(n.phi+bin.fac))) nphi <- 0 else { phi.env <- list(dim=dm,phi=phi.list,n.phi=n.phi,bin.fac=bin.fac) phi.fun <- function(x,nu=1,env) { ind <- nu - 1 z <- 1 for (i in 1:env$dim) { if (env$bin.fac[i]) { wk <- as.factor(names(env$phi[[i]]$env$code)[1]) z <- z * env$phi[[i]]$fun(x[[i]],wk,env$phi[[i]]$env) } else { code <- ind%%env$n.phi[i] + 1 ind <- ind%/%env$n.phi[i] z <- z * env$phi[[i]]$fun(x[[i]],code,env$phi[[i]]$env) } } z } nphi <- prod(n.phi+bin.fac) iphi <- iphi.wk iphi.wk <- iphi.wk + nphi phi <- list(fun=phi.fun,env=phi.env) } ## rk rk.env <- list(dim=dm,n.phi=n.phi,nphi=nphi, phi=phi.list,rk=rk.list) rk.fun <- function(x,y,nu=1,env,outer.prod=FALSE) { n.rk <- ifelse(env$n.phi,2,1) ind <- nu - !env$nphi z <- 1 for (i in 1:env$dim) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] if (code==n.rk[i]) { z <- z * env$rk[[i]]$fun(x[[i]],y[[i]], env$rk[[i]]$env,outer.prod) } else { z.wk <- 0 for (j in 1:env$n.phi[i]) { phix <- env$phi[[i]]$fun(x[[i]],j,env$phi[[i]]$env) phiy <- env$phi[[i]]$fun(y[[i]],j,env$phi[[i]]$env) if (outer.prod) z.wk <- z.wk + outer(phix,phiy) else z.wk <- z.wk + phix * phiy } z <- z * z.wk } } z } n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) irk <- irk.wk irk.wk <- irk.wk + nrk rk <- list(fun=rk.fun,env=rk.env) } term[[label]] <- list(vlist=vlist, iphi=iphi,nphi=nphi,phi=phi, irk=irk,nrk=nrk,rk=rk) } term } gss/R/ssanova9.R0000644000175100001440000004141212355360640013161 0ustar hornikusers## Fit ssanova model with correlated data ssanova9 <- function(formula,type=NULL,data=list(),subset, offset,na.action=na.omit,partial=NULL, method="v",alpha=1.4,varht=1, id.basis=NULL,nbasis=NULL,seed=NULL,cov, skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$cov <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova9: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate cov if (is.null(cov$fun)) { type <- cov[[1]] if (type=="arma") { pq <- cov[[2]] cov <- mkcov.arma(pq[1],pq[2],nobs) } if (type=="long") { if (nobsalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta ## lambda search fit <- NULL la <- c(log.la0,cov$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } } else { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return lambda <- zz$est jk1 <- cv(lambda) q.wk <- 10^(theta)*q if (length(lambda)-1) ww <- cov$fun(lambda[-1],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r) se.aux <- regaux(s.wk,10^theta*r.wk,q.wk,lambda[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta,c=c,d=d,nlambda=lambda[1],zeta=lambda[-1]), fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg91 <- function(s,r,id.basis,y,cov,method,alpha,varht,skip.iter) { ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 nn <- nxi + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } q.wk <- 10^nlambda*r.wk0[id.basis,] if (length(theta)-nq) { ww <- cov$fun(theta[-(1:nq)],cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } r.wk0 <- forwardsolve(t(ww),r.wk0) z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxi), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxi))), wk=double(3*nobs+nnull), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova9: evaluation of GML score fails") if (!nnull|method%in%c("u","v")) detw <- 2*sum(log(diag(ww))) else { wk <- qr.qty(qr(s),t(ww))[-(1:nnull),] detw <- sum(log(eigen(wk%*%t(wk))$value)) } if (method=="m") score <- z$score*exp(detw/(nobs-nnull)) if (method=="u") score <- z$wk[1]/varht+detw/nobs+2*alpha*z$wk[2] if (method=="v") score <- log(z$wk[1])+detw/nobs+2*alpha*z$wk[2]/(1-z$wk[2]) alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*z$wk[2] if (method=="v") score <- score + (alpha.wk-alpha)*2*z$wk[2]/(1-z$wk[2]) } z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } log.la0 <- log10(sum(r.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg91(s,r.wk,r.wk[id.basis,],y,cov,method,alpha,varht) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta theta <- c(theta,z$zeta) ## scale and shift cv if (length(theta)==nq) { ww <- cov$fun(cov$env) ww <- chol(ww) y.wk <- forwardsolve(t(ww),y) s.wk <- forwardsolve(t(ww),s) } tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova9: iteration for model selection fails to converge") break } } ## return theta <- zz$est jk1 <- cv(theta) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] if (length(theta)-nq) ww <- cov$fun(theta[-(1:nq)],cov$env) else ww <- cov$fun(cov$env) ww <- chol(ww) s.wk <- forwardsolve(t(ww),s) r.wk <- forwardsolve(t(ww),r.wk) se.aux <- regaux(s.wk,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL c(list(method=method,theta=theta[1:nq],c=c,d=d,nlambda=nlambda, zeta=theta[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } mkcov.arma <- function(p,q,n) { ## check inputs if ((p<0)|(q<0)) stop("gss error in mkcov.arma: ARMA orders must be non-negative") if (p+q==0) stop("gss error in mkcov.arma: use ssanova for independent data") if (n<(p+1)) stop("gss error in mkcov.arma: AR order too high") env <- list(p=p,q=q,n=n) init <- rep(0,p+q) fun <- function(x,env) { p <- env$p q <- env$q n <- env$n ## arma coefficients if (p) { a <- (1-exp(-x[1:p]))/(1+exp(-x[1:p])) if (p-1) { for (j in 2:p) a[1:(j-1)] <- a[1:(j-1)]-a[j]*a[(j-1):1] } } else a <- NULL if (q) { b <- (1-exp(-x[p+(1:q)]))/(1+exp(-x[p+(1:q)])) if (q-1) { for (j in 2:q) b[1:(j-1)] <- b[1:(j-1)]-b[j]*b[(j-1):1] } } else b <- NULL ## psi psi <- 1 if (qq <- max(p-1,q)) { for(i in 1:qq) { wk <- ifelse(i<=q,-b[i],0) if(p) { for(j in 1:min(i,p)) wk <- wk + a[j]*psi[i-j+1] } psi<-c(psi,wk) } } ## autocovariance aa <- bb <- 1 if (p) aa <- c(aa,-a) if (q) bb <- c(bb,-b) if (length(bb)10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { z <- .Fortran("cdenrkl", cd=as.double(d), as.integer(nnull), as.double(aperm(qd.s,c(1,3,2))), as.integer(nmesh), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(t(fit0)), as.double(.Machine$double.eps), wt=double(nmesh*nx), double(nmesh*nx), double(nnull), double(nnull), double(nnull*nnull), double(nnull*nnull), integer(nnull), double(nnull), as.double(1e-6), as.integer(30), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.sscden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.sscden: Newton iteration fails to converge") kl <- z$wt[1] } ## cfit cfit <- matrix(1,nmesh,nx) for (ylab in object$ynames) { y <- object$mf[[ylab]] if (is.factor(y)) { lvl <- levels(y) if (is.null(object$cnt)) wk <- table(y) else wk <- table(rep(y,object$cnt)) wk <- wk/sum(wk) nlvl <- length(wk) for (j in 1:nlvl) { id <- (1:nmesh)[qd.pt[,ylab]==lvl[j]] cfit[id,] <- cfit[id,]*wk[j] } } else { if (!is.vector(y)) qd.wk <- object$yquad else qd.wk <- NULL qd.wk <- object$yquad form <- as.formula(paste("~",ylab)) wk <- ssden(form,data=object$mf,quad=qd.wk, domain=object$ydomain,alpha=object$alpha, id.basis=object$id.basis) cfit <- cfit*dssden(wk,qd.pt[ylab]) } } cfit <- t(cfit*qd.wt) ## return kl0 <- 0 for (i in 1:nx) { wk <- sum(log(fit0[i,]/cfit[i,])*fit0[i,]) kl0 <- kl0 + xx.wt[i]*wk } list(ratio=kl/kl0,kl=kl) } gss/R/project.ssden1.R0000644000175100001440000003771512355360640014273 0ustar hornikusers## Calculate square error projection from ssden1 objects project.ssden1 <- function(object,include,drop1=FALSE,...) { ## calculate log(rho) and integrals rho1 <- sum(object$rho.int) rho2 <- rho1^2-sum(object$rho.int^2)+sum(object$rho.int2) ## calculate cross integrals of rho, phi, and rk s <- object$int$s r <- object$int$r s.rho <- object$int$s.rho - s*rho1 r.rho <- object$int$r.rho - r*rho1 ## obtain ss, sr, rr int2 <- mkint2(object$mf,object$int$var.type, object$id.basis,object$quad,object$terms) ss <- int2$ss sr <- int2$sr rr <- int2$rr ## evaluate full model d <- object$d c <- object$c theta <- object$theta nq <- length(theta) s.eta <- ss%*%d r.eta <- tmp <- NULL r.wk <- r.rho.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d r.wk <- r.wk + 10^theta[i]*r[,i] r.rho.wk <- r.rho.wk + 10^theta[i]*r.rho[,i] sr.wk <- sr.wk + 10^theta[i]*sr[,,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } s.eta <- s.eta - s*(sum(s*d)+sum(r.wk*c)) r.eta <- r.eta - r*(sum(s*d)+sum(r.wk*c)) ss <- ss - outer(s,s,"*") sr.wk <- sr.wk - outer(s,r.wk,"*") rr.wk <- rr.wk - outer(r.wk,r.wk,"*") rho.eta <- sum(s.rho*d) + sum(r.rho.wk*c) eta2 <- sum(c*(rr.wk%*%c)) + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 + rho2-rho1^2 + 2*rho.eta ## calculate projection rkl <- function(include) { inc.wk <- union(names(object$mf),include) id.s <- id.q <- NULL for (label in inc.wk) { if (!any(label==object$terms$labels)) next term <- object$terms[[label]] if (term$nphi>0) id.s <- c(id.s,term$iphi+(1:term$nphi)-2) if (term$nrk>0) id.q <- c(id.q,term$irk+(1:term$nrk)-1) } ss.wk <- ss[id.s,id.s] r.eta.wk <- r.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta[i]*r.eta[,i] r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } } sr.wk <- sr.wk - outer(s[id.s],r.wk,"*") rr.wk <- rr.wk - outer(r.wk,r.wk,"*") v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } ## projection if (drop1) { se <- NULL for (i in 1:length(include)) se <- c(se,rkl(include[-i])) ratio <- se/mse names(se) <- names(ratio) <- include } else se <- rkl(include) ratio <- se/mse list(ratio=ratio,se=se) } ## Calculate integrals of phi and rk for ssden1 mkint2 <- function(mf,type,id.basis,quad,term) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Create phi and rk nbasis <- length(id.basis) phi.term <- rk.term <- list(NULL) nvar <- length(names(mf)) ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk phi.term[[label]] <- rk.term[[label]] <- list(NULL) vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } phi.term[[label]][[vlist]] <- phi if (is.null(rk)) rk.term[[label]][[vlist]] <- rk else { nmesh <- length(quad[[vlist]]$wt) rk.term[[label]][[vlist]] <- array(rk,c(nmesh,nbasis,1)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } phi.term[[label]][[vlist[i]]] <- cbind(phi.term[[label]][[vlist[i]]],phi) } } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } nmesh <- length(quad[[vlist[i]]]$wt) rk.term[[label]][[vlist[i]]] <- array(c(rk.term[[label]][[vlist[i]]],rk), c(nmesh,nbasis,nu)) } } } } } ## create arrays ss <- matrix(1,ns,ns) sr <- array(1,c(ns,nbasis,nq)) rr <- array(1,c(nbasis,nbasis,nq,nq)) for (label1 in term.labels) { if (!term[[label1]]$nphi) id.s1 <- NULL else id.s1 <- term[[label1]]$iphi+(1:term[[label1]]$nphi)-2 if (!term[[label1]]$nrk) id.r1 <- NULL else id.r1 <- term[[label1]]$irk+(1:term[[label1]]$nrk)-1 irk1 <- term[[label1]]$irk for (label2 in term.labels) { if (!term[[label2]]$nphi) id.s2 <- NULL else id.s2 <- term[[label2]]$iphi+(1:term[[label2]]$nphi)-2 if (!term[[label2]]$nrk) id.r2 <- NULL else id.r2 <- term[[label2]]$irk+(1:term[[label2]]$nrk)-1 irk2 <- term[[label2]]$irk for (xlab in names(mf)) { wmesh <- quad[[xlab]]$wt phi1 <- phi.term[[label1]][[xlab]] phi2 <- phi.term[[label2]][[xlab]] rk1 <- rk.term[[label1]][[xlab]] rk2 <- rk.term[[label2]][[xlab]] ## ss if (!is.null(id.s1)&!is.null(id.s2)) { if ((!is.null(phi1))&(!is.null(phi2))) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*(t(wmesh*phi1)%*%phi2) } else { if (!is.null(phi1)) { ss[id.s1,id.s2] <- ss[id.s1,id.s2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(phi2)) { ss[id.s1,id.s2] <- t(t(ss[id.s1,id.s2])* apply(wmesh*matrix(phi2),2,sum)) } } } } ## sr if (!is.null(id.s1)&!is.null(id.r2)) { if ((!is.null(phi1))&(!is.null(rk2))) { for (i in id.r2) { sr[id.s1,,i] <- sr[id.s1,,i]*(t(wmesh*phi1)%*%rk2[,,i-irk2+1]) } } else { if (!is.null(phi1)) { sr[id.s1,,id.r2] <- sr[id.s1,,id.r2]*apply(wmesh*matrix(phi1),2,sum) } else { if (!is.null(rk2)) { for (i in id.r2) { sr[id.s1,,i] <- t(t(sr[id.s1,,i])* apply(wmesh*rk2[,,i-irk2+1],2,sum)) } } } } } ## rr if (!is.null(id.r1)&!is.null(id.r2)) { if ((!is.null(rk1))&(!is.null(rk2))) { for (i in id.r1) { for (j in id.r2) { rr[,,i,j] <- rr[,,i,j]*(t(wmesh*rk1[,,i-irk1+1])%*%rk2[,,j-irk2+1]) } } } else { if (!is.null(rk1)) { for (i in id.r1) { rr[,,i,id.r2] <- rr[,,i,id.r2]*apply(wmesh*rk1[,,i-irk1+1],2,sum) } } else { if (!is.null(rk2)) { for (j in id.r2) { rr[,,id.r1,j] <- aperm(aperm(rr[,,id.r1,j,drop=FALSE],c(2,1,3,4))* apply(wmesh*rk2[,,j-irk2+1],2,sum),c(2,1,3,4)) } } } } } } } } list(ss=ss,sr=sr,rr=rr) } gss/R/ssden1.R0000644000175100001440000005411412355360640012616 0ustar hornikusers## Fit density model ssden1 <- function(formula,type=NULL,data=list(),alpha=1.4, weights=NULL,subset,na.action=na.omit, id.basis=NULL,nbasis=NULL,seed=NULL, domain=as.list(NULL),quad=NULL, prec=1e-7,maxiter=30) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$domain <- mf$quad <- mf$quad <- NULL mf$prec <- mf$maxiter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,sys.frame(sys.parent())) cnt <- model.weights(mf) mf$"(weights)" <- NULL ## Use ssden for 1-D estimation if (dim(mf)[2]==1) stop("use ssden to estimate 1-D density") ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssden1: id.basis out of range") nbasis <- length(id.basis) } ## Set domain and type, generate rho and quadrature if (is.null(quad)) quad <- as.list(NULL) rho <- rho.log <- as.list(NULL) rho.int <- rho.int2 <- NULL for (xlab in names(mf)) { x <- mf[[xlab]] if (is.factor(x)) { ## factor variable domain[[xlab]] <- NULL wt <- as.numeric(table(x)) rho[[xlab]] <- wt/sum(wt) quad[[xlab]] <- list(pt=unique(x),wt=rho[[xlab]]) rho.log[[xlab]] <- log(rho[[xlab]]) rho.int <- c(rho.int,sum(rho[[xlab]]*log(rho[[xlab]]))) rho.int2 <- c(rho.int2,sum(rho[[xlab]]*(log(rho[[xlab]]))^2)) } if (is.vector(x)&!is.factor(x)) { ## numerical vector if (is.null(domain[[xlab]])) { mn <- min(x) mx <- max(x) domain[[xlab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else domain[[xlab]] <- c(min(domain[[xlab]]),max(domain[[xlab]])) if (is.null(type[[xlab]])) type[[xlab]] <- list("cubic",domain[[xlab]]) else { if (length(type[[xlab]])==1) type[[xlab]] <- list(type[[xlab]][[1]],domain[[xlab]]) } form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab], domain=data.frame(domain[xlab]), alpha=2,id.basis=id.basis) qd.wk <- rho[[xlab]]$quad rho.wk <- dssden(rho[[xlab]],qd.wk$pt) qd.wk$pt <- qd.wk$pt[[1]] qd.wk$wt <- rho.wk*qd.wk$wt quad[[xlab]] <- qd.wk rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*qd.wk$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*qd.wk$wt)) } if (is.matrix(x)) { ## numerical matrix if (is.null(quad[[xlab]])|is.null(quad)) stop("gss error in ssden1: no default quadrature") else { qd.wk <- quad[[xlab]] qd.wk$pt <- data.frame(I(qd.wk$pt)) colnames(qd.wk$pt) <- xlab form <- as.formula(paste("~",xlab)) rho[[xlab]] <- ssden(form,data=mf,type=type[xlab],quad=qd.wk, alpha=2,id.basis=id.basis) rho.wk <- dssden(rho[[xlab]],qd.wk$pt) quad[[xlab]]$wt <- rho.wk*quad[[xlab]]$wt rho.log[[xlab]] <- log(rho.wk) rho.int <- c(rho.int,sum(log(rho.wk)*quad[[xlab]]$wt)) rho.int2 <- c(rho.int2,sum((log(rho.wk))^2*quad[[xlab]]$wt)) } } } ## Generate terms term <- mkterm(mf,type) term$labels <- term$labels[term$labels!="1"] int <- mkint(mf,type,id.basis,quad,term,rho.log,rho.int) ## Generate s, r, and q s <- r <- NULL nq <- 0 for (label in term$labels) { x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (!is.null(s)) { nnull <- dim(s)[2] ## Check s rank if (qr(s)$rankalpha,(alpha.wk-alpha)*trc,0) cv+adj } ## initialization mu.r <- apply(wt*r,2,sum) v.r <- apply(wt*r^2,2,sum) mu.s <- apply(wt*s,2,sum) v.s <- apply(wt*s^2,2,sum) if (is.null(s)) theta <- 0 else theta <- log10(sum(v.s-mu.s^2)/nnull/sum(v.r-mu.r^2)*nxi) / 2 log.la0 <- log10(sum(v.r-mu.r^2)/sum(diag(q))) + theta ## lambda search cd <- rep(0,nxi+nnull) la <- log.la0 tol <- 0 scal <- NULL mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } ## return jk1 <- cv(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL list(lambda=zz$est,theta=theta,c=c,d=d,scal=scal,cv=zz$min) } ## Calculate integrals of phi and rk for ssden1 mkint <- function(mf,type,id.basis,quad,term,rho,rho.int) { ## Obtain model terms mt <- attr(mf,"terms") xvars <- as.character(attr(mt,"variables"))[-1] xfacs <- attr(mt,"factors") term.labels <- labels(mt) vlist <- xvars[as.logical(apply(xfacs,1,sum))] ## Set types for marginals var.type <- NULL for (xlab in vlist) { x <- mf[,xlab] if (!is.null(type[[xlab]])) { ## Check consistency and set default parameters type.wk <- type[[xlab]][[1]] if (!(type.wk%in%c("ordinal","nominal","cubic","linear","per", "cubic.per","linear.per","tp","sphere","custom"))) stop("gss error in mkint: unknown type") if (type.wk%in%c("ordinal","nominal")) { par.wk <- NULL if (!is.factor(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("cubic","linear")) { if (length(type[[xlab]])==1) { mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk%in%c("per","cubic.per","linear.per")) { if (type.wk=="per") type.wk <- "cubic.per" if (length(type[[xlab]])==1) stop("gss error in mkint: missing domain of periodicity") else par.wk <- type[[xlab]][[2]] if (is.factor(x)|!is.vector(x)) stop("gss error in mkint: wrong type") } if (type.wk=="tp") { if (length(type[[xlab]])==1) par.wk <- list(order=2,mesh=x,weight=1) else { par.wk <- par.wk1 <- type[[xlab]][[2]] if (length(par.wk1)==1) par.wk <- list(order=par.wk1,mesh=x,weight=1) if (is.null(par.wk$mesh)) par.wk$mesh <- x if (is.null(par.wk$weight)) par.wk$weight <- 1 } if (dim(as.matrix(x))[2]!=dim(as.matrix(par.wk$mesh))[2]) stop("gss error in mkint: wrong dimension in normalizing mesh") } if (type.wk=="sphere") { if (length(type[[xlab]])==1) par.wk <- 2 else par.wk <- type[[xlab]][[2]] if (!(par.wk%in%(2:4))) stop("gss error in mkint: spherical order not implemented") } if (type.wk=="custom") par.wk <- type[[xlab]][[2]] } else { ## Set default types if (is.factor(x)) { ## categorical variable if (is.ordered(x)) type.wk <- "ordinal" else type.wk <- "nominal" par.wk <- NULL } else { ## numerical variable if (is.vector(x)) { type.wk <- "cubic" mn <- min(x) mx <- max(x) par.wk <- c(mn,mx)+c(-1,1)*.05*(mx-mn) } else { type.wk <- "tp" par.wk <- list(order=2,mesh=x,weight=1) } } } var.type[[xlab]] <- list(type.wk,par.wk) } ## Create phi and rk nbasis <- length(id.basis) nvar <- length(names(mf)) s <- r <- s.rho <- r.rho <- NULL ns <- nq <- 0 for (label in term.labels) { ns <- ns+term[[label]]$nphi nq <- nq+term[[label]]$nrk vlist <- xvars[as.logical(xfacs[,label])] x <- mf[,vlist] dm <- length(vlist) phi <- rk <- NULL if (dm==1) { type.wk <- var.type[[vlist]][[1]] xx <- mf[id.basis,vlist] xmesh <- quad[[vlist]]$pt if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") fun <- mkrk.nominal(levels(x)) else fun <- mkrk.ordinal(levels(x)) if (nlevels(x)>2) { ## rk rk <- fun$fun(xmesh,xx,fun$env,TRUE) } else { ## phi wk <- as.factor(names(fun$env$code)[1]) phi <- fun$fun(xmesh,wk,fun$env) } } if (type.wk=="cubic") { ## cubic splines range <- var.type[[vlist]][[2]] ## phi phi.fun <- mkphi.cubic(range) phi <- phi.fun$fun(xmesh,1,phi.fun$env) ## rk rk.fun <- mkrk.cubic(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, and linear periodic splines range <- var.type[[vlist]][[2]] ## rk if (type.wk=="cubic.per") rk.fun <- mkrk.cubic.per(range) if (type.wk=="linear") rk.fun <- mkrk.linear(range) if (type.wk=="linear.per") rk.fun <- mkrk.linear.per(range) if (type.wk=="sphere") rk.fun <- mkrk.sphere(range) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x)) xdim <- 1 else xdim <- dim(x)[2] ## phi phi.fun <- mkphi.tp(xdim,order,mesh,weight) nphi <- choose(xdim+order-1,xdim)-1 if (nphi>0) { for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } ## rk rk.fun <- mkrk.tp(xdim,order,mesh,weight) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist]][[2]] nphi <- par$nphi if (nphi>0) { phi.fun <- par$mkphi(par$env) for (nu in 1:nphi) { phi <- cbind(phi,phi.fun$fun(xmesh,nu,phi.fun$env)) } } rk.fun <- par$mkrk(par$env) rk <- rk.fun$fun(xmesh,xx,rk.fun$env,TRUE) } wmesh <- quad[[vlist]]$wt if (!is.null(phi)) { s.rho.wk <- rho.int*sum(wmesh*phi) s.rho.wk[names(mf)==vlist] <- sum(wmesh*rho[[vlist]]*phi) s <- c(s,sum(wmesh*phi)) s.rho <- c(s.rho,sum(s.rho.wk)) } if (!is.null(rk)) { r.rho.wk <- outer(apply(wmesh*rk,2,sum),rho.int) r.rho.wk[,names(mf)==vlist] <- apply(wmesh*rho[[vlist]]*rk,2,sum) r <- cbind(r,apply(wmesh*rk,2,sum)) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } else { bin.fac <- n.phi <- phi.list <- rk.list <- NULL for (i in 1:dm) { type.wk <- var.type[[vlist[i]]][[1]] if (type.wk%in%c("nominal","ordinal")) { ## factor variable if (type.wk=="nominal") rk.wk <- mkrk.nominal(levels(x[[i]])) else rk.wk <- mkrk.ordinal(levels(x[[i]])) phi.wk <- rk.wk n.phi <- c(n.phi,0) bin.fac <- c(bin.fac,!(nlevels(x[[i]])>2)) } if (type.wk=="cubic") { ## cubic or linear splines range <- var.type[[vlist[i]]][[2]] ## phi phi.wk <- mkphi.cubic(range) n.phi <- c(n.phi,1) ## rk rk.wk <- mkrk.cubic(range) bin.fac <- c(bin.fac,0) } if (type.wk%in%c("cubic.per","linear","linear.per","sphere")) { ## cubic periodic, linear, or linear periodic splines range <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,0) phi.wk <- NULL if (type.wk=="cubic.per") rk.wk <- mkrk.cubic.per(range) if (type.wk=="linear") rk.wk <- mkrk.linear(range) if (type.wk=="linear.per") rk.wk <- mkrk.linear.per(range) if (type.wk=="sphere") rk.wk <- mkrk.sphere(range) bin.fac <- c(bin.fac,0) } if (type.wk=="tp") { ## thin-plate splines par <- var.type[[vlist[i]]][[2]] order <- par$order mesh <- par$mesh weight <- par$weight if (is.vector(x[[i]])) xdim <- 1 else xdim <- dim(x[[i]])[2] phi.wk <- mkphi.tp(xdim,order,mesh,weight) n.phi <- c(n.phi,choose(xdim+order-1,xdim)-1) rk.wk <- mkrk.tp(xdim,order,mesh,weight) bin.fac <- c(bin.fac,0) } if (type.wk=="custom") { ## user-defined par <- var.type[[vlist[i]]][[2]] n.phi <- c(n.phi,par$nphi) if (par$nphi>0) phi.wk <- par$mkphi(par$env) else phi.wk <- NULL rk.wk <- par$mkrk(par$env) bin.fac <- c(bin.fac,0) } phi.list <- c(phi.list,list(phi.wk)) rk.list <- c(rk.list,list(rk.wk)) } ## phi id0 <- names(mf)%in%vlist nphi <- term[[label]]$nphi iphi <- term[[label]]$iphi if (nphi>0) { for (nu in 1:nphi) { ind <- nu - 1 s.wk <- 1 s.rho.wk <- rho.int s.rho.wk[id0] <- 1 for (i in 1:dm) { phi.wk <- phi.list[[i]] xmesh <- quad[[vlist[i]]]$pt if (bin.fac[i]) { wk <- as.factor(names(phi.wk$env$code)[1]) phi <- phi.wk$fun(xmesh,wk,phi.wk$env) } else { code <- ind%%n.phi[i] + 1 ind <- ind%/%n.phi[i] phi <- phi.wk$fun(xmesh,code,phi.wk$env) } wmesh <- quad[[vlist[i]]]$wt s.wk <- s.wk*sum(wmesh*phi) id1 <- names(mf)==vlist[i] s.rho.wk[id1] <- s.rho.wk[id1]*sum(wmesh*rho[[vlist[i]]]*phi) s.rho.wk[!id1] <- s.rho.wk[!id1]*sum(wmesh*phi) } s <- c(s,s.wk) s.rho <- c(s.rho,sum(s.rho.wk)) } } ## rk n.rk <- ifelse(n.phi,2,1) nrk <- prod(n.rk) - as.logical(nphi) if (nrk>0) { for (nu in 1:nrk) { ind <- nu - !nphi r.wk <- 1 r.rho.wk <- outer(rep(1,nbasis),rho.int) r.rho.wk[,id0] <- 1 for (i in 1:dm) { code <- ind%%n.rk[i] + 1 ind <- ind%/%n.rk[i] xx <- mf[id.basis,vlist[[i]]] xmesh <- quad[[vlist[i]]]$pt if (code==n.rk[i]) { rk.wk <- rk.list[[i]] rk <- rk.wk$fun(xmesh,xx,rk.wk$env,TRUE) } else { rk <- 0 phi.wk <- phi.list[[i]] for (j in 1:n.phi[i]) { phix <- phi.wk$fun(xmesh,j,phi.wk$env) phiy <- phi.wk$fun(xx,j,phi.wk$env) rk <- rk + outer(phix,phiy) } } wmesh <- quad[[vlist[i]]]$wt r.wk <- r.wk*apply(wmesh*rk,2,sum) id1 <- names(mf)==vlist[i] r.rho.wk[,id1] <- r.rho.wk[,id1]*apply(wmesh*rho[[vlist[i]]]*rk,2,sum) r.rho.wk[,!id1] <- r.rho.wk[,!id1]*apply(wmesh*rk,2,sum) } r <- cbind(r,r.wk) r.rho <- cbind(r.rho,apply(r.rho.wk,1,sum)) } } } } list(s=s,r=r,s.rho=s.rho,r.rho=r.rho,var.type=var.type) } gss/R/sscden.R0000644000175100001440000003735112355360640012704 0ustar hornikusers## Fit log-linear regression model sscden <- function(formula,response,type=NULL,data=list(),weights, subset,na.action=na.omit,alpha=1.4, id.basis=NULL,nbasis=NULL,seed=NULL, ydomain=as.list(NULL),yquad=NULL, prec=1e-7,maxiter=30,skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$response <- mf$type <- mf$alpha <- NULL mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$ydomain <- mf$yquad <- NULL mf$prec <- mf$maxiter <- mf$skip.iter <- NULL term.wk <- terms.formula(formula) ynames <- as.character(attr(terms(response),"variables"))[-1] mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) nobs <- nrow(mf) cnt <- model.weights(mf) if (is.null(cnt)) data$cnt <- rep(1,nobs) else { data$cnt <- cnt mf$"(weights)" <- NULL } ## Generate sub-basis nobs <- nrow(mf) if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=cnt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in sscden: id.basis out of range") nbasis <- length(id.basis) } ## Check inputs mt <- attr(mf,"terms") vars <- as.character(attr(mt,"variables"))[-1] if(!all(ynames%in%vars)) stop("gss error in sscden: response missing in model") xnames <- vars[!(vars%in%ynames)] if (is.null(xnames)) stop("gss error in sscden: missing covariate") ## Set ydomain and type mtrx.y <- FALSE for (ylab in ynames) { y <- mf[[ylab]] if (!is.factor(y)) { if (is.vector(y)) { if (is.null(ydomain[[ylab]])) { mn <- min(y) mx <- max(y) ydomain[[ylab]] <- c(mn,mx)+c(-1,1)*(mx-mn)*.05 } else ydomain[[ylab]] <- c(min(ydomain[[ylab]]),max(ydomain[[ylab]])) if (is.null(type[[ylab]])) type[[ylab]] <- list("cubic",ydomain[[ylab]]) else { if (length(type[[ylab]])==1) type[[ylab]] <- list(type[[ylab]][[1]],ydomain[[ylab]]) } } else mtrx.y <- TRUE } } ydomain <- data.frame(ydomain) ## Generate terms term <- mkterm(mf,type) term.labels <- labels(mt) facs <- attr(mt,"factors") ind.wk <- NULL for (lab in term.labels) ind.wk <- c(ind.wk,any(facs[ynames,lab])) term$labels <- term.labels[ind.wk] ## Generate quadrature if (is.null(yquad)) { if (mtrx.y) stop("gss error in sscden: no default quadrature") yquad <- ssden(response,id.basis=id.basis,data=data,weights=cnt, alpha=2,domain=ydomain)$quad } qd.pt <- yquad$pt qd.wt <- yquad$wt nmesh <- length(qd.wt) ## obtain unique covariate observations x <- xx <- mf[,xnames,drop=FALSE] xx <- apply(xx,1,function(x)paste(x,collapse="\r")) x.dup.ind <- duplicated(xx) if (!is.null(cnt)) xx <- rep(xx,cnt) xx.wt <- as.vector(table(xx)[unique(xx)]) xx.wt <- xx.wt/sum(xx.wt) nx <- length(xx.wt) ## Generate s, r, qd.s, and qd.r s <- r <- qd.s <- NULL qd.r <- as.list(NULL) nu <- nq <- 0 for (label in term$labels) { vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] y.list <- ynames[ynames%in%vlist] xy <- mf[,vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist qd.xy[,y.list] <- qd.pt[,y.list] if (length(x.list)) xx <- x[!x.dup.ind,x.list,drop=FALSE] else xx <- NULL nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { nu <- nu+1 s.wk <- phi$fun(xy,nu=i,env=phi$env) s <- cbind(s,s.wk) if (is.null(xx)) { qd.s.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.wk <- matrix(qd.s.wk,nmesh,nx) } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- cbind(qd.wk,phi$fun(qd.xy,i,phi$env)) } } qd.s <- array(c(qd.s,qd.wk),c(nmesh,nx,nu)) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r.wk <- rk$fun(xy,xy.basis,nu=i,env=rk$env,out=TRUE) r <- array(c(r,r.wk),c(nobs,nbasis,nq)) if (is.null(xx)) { qd.r.wk <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,nu=i,env=rk$env,out=TRUE) qd.r[[nq]] <- qd.r.wk } else { qd.wk <- NULL for (j in 1:nx) { qd.xy[,x.list] <- xx[rep(j,nmesh),] qd.wk <- array(c(qd.wk,rk$fun(qd.xy,xy.basis,i,rk$env,TRUE)), c(nmesh,nbasis,j)) } qd.r[[nq]] <- qd.wk } } } } ## Check s rank if (!is.null(s)) { nnull <- dim(s)[2] if (qr(s)$rankalpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 qd.r.wk0 <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + 10^theta[i]*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(10^theta[i]*qd.r[[i]]) } assign("r.wk",r.wk0+0,inherits=TRUE) assign("qd.r.wk",qd.r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk qd.r.wk0 <- qd.r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk0 <- qd.r.wk0 + theta.wk*qd.r[[i]] else qd.r.wk0 <- qd.r.wk0 + as.vector(theta.wk*qd.r[[i]]) } } q.wk <- 10^(lambda)*r.wk0[id.basis,] qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) qd.r.wk0 <- array(c(qd.r.wk0,qd.s),c(nqd,nx,nn)) qd.r.wk0 <- aperm(qd.r.wk0,c(1,3,2)) fit <- .Fortran("cdennewton", cd=as.double(cd), as.integer(nn), as.double(q.wk), as.integer(nxi), as.double(t(cbind(r.wk0,s))), as.integer(nobs), as.integer(sum(cnt)), as.integer(cnt), as.double(qd.r.wk0), as.integer(nqd), as.integer(nx), as.double(xx.wt), as.double(qd.wt), as.double(prec), as.integer(maxiter), as.double(.Machine$double.eps), integer(nn), wk=double(2*(nqd+1)*nx+2*nobs+nn*(2*nn+5)), info=integer(1),PACKAGE="gss") if (fit$info==1) stop("gss error in sscden: Newton iteration diverges") if (fit$info==2) warning("gss warning in sscden: Newton iteration fails to converge") assign("eta",fit$wk[1:(nqd*nx)],inherits=TRUE) assign("cd",fit$cd,inherits=TRUE) cv <- alpha*fit$wk[nqd*nx+2]-fit$wk[nqd*nx+1] alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) adj <- ifelse (alpha.wk>alpha,(alpha.wk-alpha)*fit$wk[nqd*nx+2],0) cv+adj } cv.m.wk <- function(theta) cv.scale*cv.m(theta)+cv.shift ## Initialization theta <- -log10(apply(r[id.basis,,,drop=FALSE],3,function(x)sum(diag(x)))) nq <- length(theta) qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk ## fixed theta iteration eta <- NULL cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } if (nq==1) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta adjustment qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(cd[1:nxi])%*%r[id.basis,,i]%*%cd[1:nxi]) if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } if (!nnull) { vv.r <- 0 for (i in 1:nx) { mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- 0 } else { vv.s <- vv.r <- 0 for (i in 1:nx) { mu.s <- apply(qd.s[,i,,drop=FALSE],2,sum)/nqd v.s <- apply(qd.s[,i,,drop=FALSE]^2,2,sum)/nqd v.s <- v.s - mu.s^2 mu.r <- apply(qd.r.wk[,,i,drop=FALSE],2,sum)/nqd v.r <- apply(qd.r.wk[,,i,drop=FALSE]^2,2,sum)/nqd v.r <- v.r - mu.r^2 vv.s <- vv.s + xx.wt[i]*v.s vv.r <- vv.r + xx.wt[i]*v.r } theta.wk <- log10(sum(vv.s)/nnull/sum(vv.r)*nxi) / 2 } theta <- theta + theta.wk qd.r.wk <- aperm(10^theta.wk*qd.r.wk,c(1,3,2)) qd.r.wk <- array(c(qd.r.wk,qd.s),c(nqd,nx,nn)) qd.r.wk <- aperm(qd.r.wk,c(1,3,2)) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } q.wk <- r.wk[id.basis,] log.la0 <- log10(sum(vv.r)/sum(diag(q.wk))) + 2*theta.wk log.th0 <- theta-log.la0 ## fixed theta iteration cd <- rep(0,nn) la <- log.la0 mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv.s,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } lambda <- zz$est ## early return if (skip.iter) { jk1 <- cv.s(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=zz$est,theta=theta,c=c,d=d,cv=jk1,fit=t(eta))) } ## theta search counter <- 0 r.wk <- 0 qd.r.wk <- array(0,c(nqd,nxi,nx)) for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] if (length(dim(qd.r[[i]]))==3) qd.r.wk <- qd.r.wk + 10^theta[i]*qd.r[[i]] else qd.r.wk <- qd.r.wk + as.vector(10^theta[i]*qd.r[[i]]) } theta.old <- theta tmp <- abs(cv.m(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.m.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in sscden: CV iteration fails to converge") break } } ## return jk1 <- cv.m(zz$est) c <- cd[1:nxi] if (nnull) d <- cd[nxi+(1:nnull)] else d <- NULL eta <- matrix(eta,nqd,nx) for (i in 1:nx) eta[,i] <- eta[,i]/sum(eta[,i]) return(list(lambda=lambda,theta=zz$est,c=c,d=d,cv=jk1,fit=t(eta))) } gss/R/project.gssanova.R0000644000175100001440000002750112355360640014707 0ustar hornikusers## Calculate Kullback-Leibler projection from gssanova objects project.gssanova <- function(object,include,...) { if (class(object)[1]=="gssanova0") stop("gss error: Kullback-Leibler projection is not implemented for gssanova0") nobs <- nrow(object$mf) nxi <- length(object$id.basis) labels.p <- object$lab.p ## evaluate full model family <- object$family eta <- object$eta y <- model.response(object$mf,"numeric") wt <- model.weights(object$mf) if(is.null(wt)) wt <- rep(1,nobs) offset <- model.offset(object$mf) if (!is.null(object$random)) { if (is.null(offset)) offset <- 0 offset <- offset + object$random$z%*%object$b } nu <- object$nu y0 <- switch(family, binomial=y0.binomial(y,eta,wt), poisson=y0.poisson(eta), Gamma=y0.Gamma(eta), inverse.gaussian=y0.inverse.gaussian(eta), nbinomial=y0.nbinomial(y,eta,nu), weibull=y0.weibull(y,eta,nu), lognorm=y0.lognorm(y,eta,nu), loglogis=y0.loglogis(y,eta,nu)) # calculate constant fit cfit <- switch(family, binomial=cfit.binomial(y,wt,offset), poisson=cfit.poisson(y,wt,offset), Gamma=cfit.Gamma(y,wt,offset), inverse.gaussian=cfit.inverse.gaussian(y,wt,offset), nbinomial=cfit.nbinomial(y,wt,offset,nu), weibull=cfit.weibull(y,wt,offset,nu), lognorm=cfit.lognorm(y,wt,offset,nu), loglogis=cfit.loglogis(y,wt,offset,nu)) # calculate total entropy kl0 <- switch(family, binomial=kl.binomial(eta,cfit,y0$wt), poisson=kl.poisson(eta,cfit,wt), Gamma=kl.Gamma(eta,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta,cfit,wt), nbinomial=kl.nbinomial(eta,cfit,wt,y0$nu), weibull=kl.weibull(eta,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta,cfit,wt,nu,y0), loglogis=kl.loglogis(eta,cfit,wt,nu,y0)) ## extract terms in subspace s <- matrix(1,nobs,1) philist <- object$term[["1"]]$iphi r <- NULL theta <- NULL nq.wk <- nq <- 0 for (label in object$terms$labels) { if (label=="1") next if (label%in%labels.p) next x <- object$mf[,object$term[[label]]$vlist] x.basis <- object$mf[object$id.basis,object$term[[label]]$vlist] nphi <- object$term[[label]]$nphi nrk <- object$term[[label]]$nrk if (nphi) { phi <- object$term[[label]]$phi for (i in 1:nphi) { if (!any(label==include)) next philist <- c(philist,object$term[[label]]$iphi+(i-1)) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } } if (nrk) { rk <- object$term[[label]]$rk for (i in 1:nrk) { nq.wk <- nq.wk + 1 if (!any(label==include)) next nq <- nq + 1 theta <- c(theta,object$theta[nq.wk]) r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)), c(nobs,nxi,nq)) } } } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) matx.p <- model.matrix(object$partial$mt,object$mf)[,-1,drop=FALSE] matx.p <- scale(matx.p) for (label in labels.p) { nu <- nu+1 if (!any(label==include)) next philist <- c(philist,nu) s <- cbind(s,matx.p[,label]) } } ## calculate projection my.wls <- function(theta1=NULL) { if (!nq) { q <- matrix(0) sr <- cbind(s,0) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } else { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq-1) theta.wk[-fix] <- theta1 sr <- 0 for (i in 1:nq) sr <- sr + 10^theta.wk[i]*r[,,i] q <- sr[object$id.basis,] sr <- cbind(s,sr) z <- ngreg.proj(dc,family,sr,q,y0,wt,offset,nu) } assign("dc",z$dc,inherits=TRUE) assign("eta1",z$eta,inherits=TRUE) z$kl } cv.wk <- function(theta) cv.scale*my.wls(theta)+cv.shift ## initialization if (nq) { r.wk <- 0 for (i in 1:nq) r.wk <- r.wk + 10^theta[i]*r[,,i] if (is.null(s)) theta.wk <- 0 else theta.wk <- log10(sum(s^2)/ncol(s)/sum(r.wk^2)*nxi) / 2 theta <- theta + theta.wk tmp <- NULL for (i in 1:nq) tmp <- c(tmp,10^theta[i]*sum(r[cbind(object$id.basis,1:nxi,i)])) fix <- rev(order(tmp))[1] } ## projection if (nq) dc <- c(object$d[philist],10^(-theta.wk)*object$c) else dc <- c(object$d[philist],0) eta1 <- NULL if (nq>1) { if (object$skip.iter) kl <- my.wls(theta[-fix]) else { ## scale and shift cv tmp <- abs(my.wls(theta[-fix])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=1,ndigit=7) kl <- my.wls(zz$est) } } else kl <- my.wls() ## check kl1 <- switch(family, binomial=kl.binomial(eta1,cfit,y0$wt), poisson=kl.poisson(eta1,cfit,wt), Gamma=kl.Gamma(eta1,cfit,wt), inverse.gaussian=kl.inverse.gaussian(eta1,cfit,wt), nbinomial=kl.nbinomial(eta1,cfit,wt,y0$nu), weibull=kl.weibull(eta1,cfit,wt,nu,y0$int), lognorm=kl.lognorm(eta1,cfit,wt,nu,y0), loglogis=kl.loglogis(eta1,cfit,wt,nu,y0)) list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) } ## KL projection with Non-Gaussian regression ngreg.proj <- function(dc,family,sr,q,y0,wt,offset,nu) { ## initialization q <- 10^(-5)*q eta <- sr%*%dc nobs <- length(eta) nn <- ncol(as.matrix(sr)) nxi <- ncol(q) nnull <- nn-nxi if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl+t(dc[-(1:nnull)])%*%q%*%dc[-(1:nnull)]/2 ## Newton iteration dc.new <- eta.new <- NULL kl.line <- function(x) { assign("dc.new",dc+x*dc.diff,inherits=TRUE) eta.wk <- sr%*%dc.new if (!is.null(offset)) eta.wk <- eta.wk + offset assign("eta.new",eta.wk,inherits=TRUE) fit.wk <- switch(family, binomial=proj0.binomial(y0,eta.new,offset), poisson=proj0.poisson(y0,eta.new,wt,offset), Gamma=proj0.Gamma(y0,eta.new,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta.new,wt,offset), nbinomial=proj0.nbinomial(y0,eta.new,wt,offset), weibull=proj0.weibull(y0,eta.new,wt,offset,nu), lognorm=proj0.lognorm(y0,eta.new,wt,offset,nu), loglogis=proj0.loglogis(y0,eta.new,wt,offset,nu)) assign("fit1",fit.wk,inherits=TRUE) fit1$kl+t(dc.new[-(1:nnull)])%*%q%*%dc.new[-(1:nnull)]/2 } iter <- 0 flag <- 0 flag2 <- 0 repeat { iter <- iter+1 ## weighted least squares fit if (!is.finite(sum(fit1$wt,fit1$ywk))) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl iter <- 0 flag <- 1 next } mumax <- max(abs(t(sr)%*%fit1$u+c(rep(0,nnull),q%*%dc[-(1:nnull)]))) w <- sqrt(as.vector(fit1$wt)) z <- .Fortran("reg", as.double(w*sr), as.integer(nobs), as.integer(nnull), as.double(q), as.integer(nxi), as.double(w*fit1$ywk), as.integer(4), double(1), double(1), double(1), dc=double(nn), as.double(.Machine$double.eps), double(nn*nn), double(nn), as.integer(rep(0,nn)), double(max(nobs,nn)), integer(1), integer(1), PACKAGE="gss")["dc"] dc.diff <- z$dc-dc repeat { kl.new <- kl.line(1) if (!is.finite(kl.new)) { dc.diff <- dc.diff/2 next } if (!flag2) { if (kl.new-kl<1e-7*(1+abs(kl))) break } zz <- nlm0(kl.line,c(0,1),1e-3) kl.new <- kl.line(zz$est) break } disc0 <- max((mumax/(1+kl))^2,abs(kl.new-kl)/(1+kl)) disc <- sum(fit1$wt*((eta-eta.new)/(1+abs(eta)))^2)/sum(fit1$wt) if (is.nan(disc)) { if (flag) stop("gss error in project.gssanova: Newton iteration diverges") dc <- rep(0,nn) eta <- rep(0,nobs) if (!is.null(offset)) eta <- eta + offset fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new kl <- kl.new if (min(disc0,disc)<1e-5) break if (iter<=30) next if (!flag2) { flag2 <- 1 iter <- 0 next } warning("gss warning in gssanova: Newton iteration fails to converge") break } fit1 <- switch(family, binomial=proj0.binomial(y0,eta,offset), poisson=proj0.poisson(y0,eta,wt,offset), Gamma=proj0.Gamma(y0,eta,wt,offset), inverse.gaussian=proj0.inverse.gaussian(y0,eta,wt,offset), nbinomial=proj0.nbinomial(y0,eta,wt,offset), weibull=proj0.weibull(y0,eta,wt,offset,nu), lognorm=proj0.lognorm(y0,eta,wt,offset,nu), loglogis=proj0.loglogis(y0,eta,wt,offset,nu)) kl <- fit1$kl list(dc=dc,eta=eta,kl=kl) } gss/R/family.cv.R0000644000175100001440000001544212440620154013304 0ustar hornikusers##%%%%%%%%%% Binomial Family %%%%%%%%%% ## Calculate CV score for binomial regression cv.binomial <- function(y,eta,wt,hat,alpha) { if (is.vector(y)) y <- as.matrix(y) if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (dim(y)[2]==1) { if ((max(y)>1)|(min(y)<0)) stop("gss error: binomial responses should be between 0 and 1") m <- rep(1,dim(y)[1]) } else { if (min(y)<0) stop("gss error: paired binomial response should be nonnegative") m <- y[,1]+y[,2] y <- y[,1]/m } wtt <- wt * m odds <- exp(eta) p <- odds/(1+odds) w <- p/(1+odds) lkhd <- -sum(wtt*(y*eta-log(1+odds)))/sum(wtt) aux1 <- sum(hat/w)/(sum(wtt)-sum(hat)) aux2 <- sum(wtt*y/(1+odds))/sum(wtt) list(score=lkhd+abs(alpha)*aux1*aux2,varht=1,w=as.vector(wtt*w)) } ##%%%%%%%%%% Poisson Family %%%%%%%%%% ## Calculate CV score for Poisson regression cv.poisson <- function(y,eta,wt,hat,alpha,sr,q) { if (is.null(wt)) wt <- rep(1,length(y)) if (min(y)<0) stop("gss error: Poisson response should be nonnegative") nxi <- ncol(q) nn <- ncol(sr) nnull <- nn-nxi lambda <- exp(eta) w <- as.vector(lambda) lkhd <- -sum(wt*(y*eta-lambda))/sum(wt*y) ## matrix H mu <- apply(wt*w*sr,2,sum)/sum(wt*w) v <- t(sr)%*%(wt*w*sr)/sum(wt*w)-outer(mu,mu) v[(nnull+1):nn,(nnull+1):nn] <- v[(nnull+1):nn,(nnull+1):nn]+q/sum(wt*y) ## Cholesky decomposition of H z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") while (v[rkv,rkv]=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") u <- nu*(delta-(xx^nu-zz^nu)*exp(-nu*eta)) w <- nu^2*(xx^nu-zz^nu)*exp(-nu*eta) lkhd <- sum(wt*((xx^nu-zz^nu)*exp(-nu*eta)-delta*(nu*(log(xx)-eta)+log(nu))))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Calculate CV score for log normal regression cv.lognorm <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*abs((s.xx-xx)*u))/sum(wt) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+1/xx)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+1/zz)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) lkhd <- sum(wt*(delta*(xx^2/2+s.xx-log(nu))+s.zz-s.xx))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Calculate CV score for log logistic regression cv.loglogis <- function(y,eta,wt,hat,nu,alpha) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") xx <- 1/(1+exp(nu*(log(xx)-eta))) zz <- 1/(1+exp(nu*(log(zz)-eta))) u <- nu*(delta*xx-(zz-xx)) w <- nu^2/2*(zz^2-xx^2) lkhd <- sum(wt*(delta*(-log(1-xx)-log(nu))+log(zz)-log(xx)))/sum(wt) aux1 <- sum(hat/w)/(sum(wt)-sum(hat)) aux2 <- sum(wt*nu*delta*xx*abs(u))/sum(wt) list(score=lkhd+alpha*aux1*aux2,varht=1,w=as.vector(wt*w)) } gss/R/project.sshzd1.R0000644000175100001440000001432012355360640014275 0ustar hornikusers## Calculate square error projection from sshzd1 objects project.sshzd1 <- function(object,include,...) { if (!(object$tname%in%include)) stop("gss error in project.sshzd1: time main effect missing in included terms") ## Initialization term <- object$term mf <- object$mf xnames <- object$xnames tname <- object$tname id.basis <- object$id.basis yy <- object$yy quad <- object$quad x.pt <- object$x.pt qd.wt <- object$qd.wt ## Calculate cross integrals of phi and rk s <- object$int.s r <- object$int.r ns <- length(s) nq <- length(object$theta) nx <- dim(qd.wt)[2] nbasis <- dim(r)[1] ## create arrays ss <- 0 sr <- array(0,c(ns,nbasis,nq)) rr <- array(0,c(nbasis,nbasis,nq,nq)) for (k in 1:nx) { ind <- (1:length(quad$pt))[qd.wt[,k]>0] nmesh <- length(ind) if (!nmesh) next qd.wt.wk <- qd.wt[ind,k] qd.s <- NULL qd.r <- as.list(NULL) iq <- 0 for (label in term$labels) { if (label=="1") { qd.wk <- rep(1,nmesh) qd.s <- cbind(qd.s,qd.wk) next } vlist <- term[[label]]$vlist x.list <- xnames[xnames%in%vlist] xy.basis <- mf[id.basis,vlist] qd.xy <- data.frame(matrix(0,nmesh,length(vlist))) names(qd.xy) <- vlist if (tname%in%vlist) qd.xy[,tname] <- quad$pt[ind] if (length(x.list)) qd.xy[,x.list] <- x.pt[rep(k,nmesh),x.list,drop=FALSE] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) { qd.wk <- phi$fun(qd.xy[,,drop=TRUE],nu=i,env=phi$env) qd.s <- cbind(qd.s,qd.wk) } } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { iq <- iq+1 qd.r[[iq]] <- rk$fun(qd.xy[,,drop=TRUE],xy.basis,i,rk$env,out=TRUE) } } } if (!is.null(object$partial)) { wk <- object$partial$pt[k,] qd.s <- cbind(qd.s,t(matrix(wk,length(wk),nmesh))) } ss <- ss + t(qd.wt.wk*qd.s)%*%qd.s for (i in 1:nq) { sr[,,i] <- sr[,,i] + t(qd.wt.wk*qd.s)%*%qd.r[[i]] for (j in 1:i) { rr.wk <- t(qd.wt.wk*qd.r[[i]])%*%qd.r[[j]] rr[,,i,j] <- rr[,,i,j] + rr.wk if (i-j) rr[,,j,i] <- rr[,,j,i] + t(rr.wk) } } } ## evaluate full model cfit <- log(object$cfit) d <- object$d c <- object$c theta <- object$theta s.eta <- ss%*%d r.eta <- tmp <- NULL r.wk <- sr.wk <- rr.wk <- 0 for (i in 1:nq) { tmp <- c(tmp,10^(2*theta[i])*sum(diag(rr[,,i,i]))) s.eta <- s.eta + 10^theta[i]*sr[,,i]%*%c if (length(d)==1) r.eta.wk <- sr[,,i]*d else r.eta.wk <- t(sr[,,i])%*%d r.wk <- r.wk + 10^theta[i]*r[,i] sr.wk <- sr.wk + 10^theta[i]*sr[,,i] for (j in 1:nq) { r.eta.wk <- r.eta.wk + 10^theta[j]*rr[,,i,j]%*%c rr.wk <- rr.wk + 10^(theta[i]+theta[j])*rr[,,i,j] } r.eta <- cbind(r.eta,r.eta.wk) } eta2 <- sum(c*(rr.wk%*%c)) + sum(d*(ss%*%d)) + 2*sum(d*(sr.wk%*%c)) mse <- eta2 - 2*sum(c(d,c)*c(s,r.wk))*cfit + cfit^2*sum(qd.wt) ## extract terms in subspace id.s <- id.q <- NULL for (label in term$labels) { if (label=="1") { id.s <- c(id.s,1) next } if (!any(label==include)) next term.wk <- term[[label]] if (term.wk$nphi>0) id.s <- c(id.s,term.wk$iphi+(1:term.wk$nphi)-1) if (term.wk$nrk>0) id.q <- c(id.q,term.wk$irk+(1:term.wk$nrk)-1) } if (!is.null(object$partial)) { nu <- length(object$d)-length(object$lab.p) for (label in object$lab.p) { nu <- nu+1 if (!any(label==include)) next id.s <- c(id.s,nu) } } ## calculate projection rkl <- function(theta1=NULL) { theta.wk <- 1:nq theta.wk[fix] <- theta[fix] if (nq0-1) theta.wk[id.q0] <- theta1 ## ss.wk <- ss[id.s,id.s] r.eta.wk <- sr.wk <- rr.wk <- 0 for (i in id.q) { r.eta.wk <- r.eta.wk + 10^theta.wk[i]*r.eta[,i] sr.wk <- sr.wk + 10^theta.wk[i]*sr[id.s,,i] for (j in id.q) { rr.wk <- rr.wk + 10^(theta.wk[i]+theta.wk[j])*rr[,,i,j] } } v <- cbind(rbind(ss.wk,t(sr.wk)),rbind(sr.wk,rr.wk)) mu <- c(s.eta[id.s],r.eta.wk) nn <- length(mu) z <- chol(v,pivot=TRUE) v <- z rkv <- attr(z,"rank") m.eps <- .Machine$double.eps while (v[rkv,rkv]<2*sqrt(m.eps)*v[1,1]) rkv <- rkv - 1 if (rkvrkv,(1:nn)>rkv] <- diag(v[1,1],nn-rkv) mu <- backsolve(v,mu[attr(z,"pivot")],transpose=TRUE) eta2 - sum(mu[1:rkv]^2) } cv.wk <- function(theta) cv.scale*rkl(theta)+cv.shift ## initialization nq0 <- length(id.q) tmp[-id.q] <- 0 fix <- rev(order(tmp))[1] ## projection if (nq0-1) { id.q0 <- id.q[id.q!=fix] if (object$skip.iter) se <- rkl(theta[id.q0]) else { if (nq0-2) { ## scale and shift cv tmp <- abs(rkl(theta[id.q0])) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[id.q0],stepmax=.5,ndigit=7) } else { the.wk <- theta[id.q0] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } se <- rkl(zz$est) } } else se <- rkl() list(ratio=se/mse,se=se) } gss/R/cdsscden.R0000644000175100001440000001716412355360640013213 0ustar hornikuserscdsscden <- ## Evaluate conditional density estimate function (object,y,x,cond,int=NULL) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cdsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cdsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cdsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (any(length(ynames)==c(0,length(object$ynames)))) stop("gss error in cdsscden: not a conditional density") if (length(ynames)==1&is.vector(y)) { y <- data.frame(y) colnames(y) <- ynames } if (!all(sort(ynames)==sort(colnames(y)))) stop("gss error in cdsscden: mismatched y variable names") ## Calculate normalizing constant if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain while (is.null(int)) { fac.list <- NULL num.list <- NULL for (ylab in ynames) { if (is.factor(y.wk <- y[[ylab]])) fac.list <- c(fac.list,ylab) else { if (!is.vector(y.wk)|is.null(ydomain[[ylab]])) { warning("gss warning in cdsscden: int set to 1") int <- 1 next } else num.list <- c(num.list,ylab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(ydomain[,num.list]) mx <- max(ydomain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- ydomain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { ylab <- colnames(domain.wk)[i] wk <- object$mf[[ylab]] jk <- ssden(~wk,domain=data.frame(wk=domain.wk[,i]),alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- wk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad.pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } ymesh <- quad$pt[,ynames,drop=FALSE] yy <- cond[rep(1,nrow(ymesh)),,drop=FALSE] int <- apply(dsscden(object,cbind(ymesh,yy),x)*quad$wt,2,sum) } ## Return value yy <- cond[rep(1,nrow(y)),,drop=FALSE] list(pdf=t(t(dsscden(object,cbind(y,yy),x))/int),int=int) } cpsscden <- ## Compute cdf for univariate conditional density function(object,q,x,cond) { ## check inputs if (!("sscden"%in%class(object))) stop("gss error in cpsscden: not a sscden object") if (!all(sort(object$xnames)==sort(colnames(x)))) stop("gss error in cpsscden: mismatched x variable names") if (nrow(cond)!=1) stop("gss error in cpsscden: condition has to be a single point") ynames <- NULL for (i in object$ynames) if (all(i!=colnames(cond))) ynames <- c(ynames,i) if (length(ynames)!=1) stop("gss error in cpsscden: y is not 1-D") if (is.factor(object$mf[,ynames])) stop("gss error in cpsscden: y is not continuous") if ("sscden1"%in%class(object)) ydomain <- object$rho$env$ydomain else ydomain <- object$ydomain mn <- min(ydomain[[ynames]]) mx <- max(ydomain[[ynames]]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) y.wk <- data.frame(qd$pt) colnames(y.wk) <- ynames y.wk <- cbind(y.wk,cond) d.qd <- dsscden(object,y.wk,x) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(p))[p>0&p<1] z <- NULL for (k in 1:dim(x)[1]) { d.qd.wk <- d.qd[,k]/sum(d.qd[,k]*qd$wt) p.wk <- cumsum(d.qd.wk*qd$wt) for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } zz <- nlm(cv.wk,theta[-fix],stepmax=.5,ndigit=7) } else { the.wk <- theta[-fix] repeat { mn <- the.wk-1 mx <- the.wk+1 zz <- nlm0(rkl,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) break else the.wk <- zz$est } } kl <- rkl(zz$est) } } else kl <- rkl() } else { nn <- nrow(qd.s) z <- .Fortran("drkl", cd=as.double(d), as.integer(nn), as.double(qd.s), as.integer(nqd), as.integer(bias$nt), as.double(bias$wt), as.double(t(qd.wt)), mesh=as.double(mesh0), as.double(.Machine$double.eps), as.double(1e-6), as.integer(30), integer(nn), double(2*bias$nt*(nqd+1)+nn*(2*nn+4)), info=integer(1), PACKAGE="gss") if (z$info==1) stop("gss error in project.ssden: Newton iteration diverges") if (z$info==2) warning("gss warning in project.ssden: Newton iteration fails to converge") mesh1 <- z$mesh kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) } kl0 <- sum(bias$wt*(apply(qd.wt*log(mesh0)*mesh0,2,sum)+ log(apply(qd.wt,2,sum)))) kl <- sum(bias$wt*(apply(qd.wt*log(mesh0/mesh1)*mesh0,2,sum)+ log(apply(qd.wt*mesh1,2,sum)))) wt.wk <- t(t(qd.wt)/apply(qd.wt*mesh1,2,sum)) kl1 <- sum(bias$wt*(apply(wt.wk*log(mesh1)*mesh1,2,sum)+ log(apply(wt.wk,2,sum)))) obj <- list(ratio=kl/kl0,kl=kl,check=(kl+kl1)/kl0) if (mesh) obj$mesh <- mesh1 obj } gss/R/dssden.R0000644000175100001440000001223112355360640012673 0ustar hornikusersdssden <- ## Evaluate density estimate function (object,x) { ## check input if (!("ssden"%in%class(object))) stop("gss error in dssden: not a ssden object") if ("ssden1"%in%class(object)) return(d.ssden1(object,x)) else return(d.ssden(object,x)) } pssden <- ## Compute cdf for univariate density estimate function(object,q) { if (!("ssden"%in%class(object))) stop("gss error in pssden: not a ssden object") if (dim(object$mf)[2]!=1) stop("gss error in pssden: not a 1-D density") mn <- min(object$domain) mx <- max(object$domain) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- dssden(object,qd$pt) gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wk=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) -sum(wt*(delta*(nu*(log(xx)-eta)+log.nu) -(xx^nu-zz^nu)*exp(-nu*eta))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } u <- nu[[1]]*(delta-(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta)) w <- nu[[1]]^2*(xx^nu[[1]]-zz^nu[[1]])*exp(-nu[[1]]*eta) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for Weibull regression dev.resid.weibull <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) as.numeric(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ## Calculate null deviance for Weibull regression dev.null.weibull <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (is.null(offset)) offset <- rep(0,length(xx)) eta <- log(sum(wt*(xx^nu-zz^nu)*exp(-nu*offset))/sum(wt*delta))/nu eta <- eta + offset z <- -delta*nu*(log(xx)-eta)+(xx^nu-zz^nu)*exp(-nu*eta) sum(2*wt*(z+delta*(log(xx^nu)-log(xx^nu-zz^nu)-1))) } ##%%%%%%%%%% Log Normal Family %%%%%%%%%% ## Make pseudo data for log normal regression mkdata.lognorm <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))+log.nu) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- nu[[1]]*(log(xx)-eta) zz <- nu[[1]]*(log(zz)-eta) s.xx <- ifelse(xx<7,dnorm(xx)/(1-pnorm(xx)),xx+1/xx) s.zz <- ifelse(zz<7,dnorm(zz)/(1-pnorm(zz)),zz+1/zz) s.xx <- pmax(s.xx,s.zz) u <- nu[[1]]*(delta*(s.xx-xx)-(s.xx-s.zz)) w <- (s.xx^2/2-xx*s.xx+xx^2/2+log(s.xx)+log(2*pi)/2) w <- nu[[1]]^2*(w-ifelse(s.zz==0,0,(s.zz^2/2-zz*s.zz+zz^2/2+log(s.zz)+log(2*pi)/2))) w <- ifelse(w<1e-6,1e-6,w) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log normal regression dev.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- log(1-pnorm(xx)) s.zz <- log(1-pnorm(zz)) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*(z-dev0)) } dev0.resid.lognorm <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) s.xx <- ifelse(xx<7,log(1-pnorm(xx)),-xx^2/2-log(xx+.15)-log(2*pi)/2) s.zz <- ifelse(zz<7,log(1-pnorm(zz)),-zz^2/2-log(zz+.15)-log(2*pi)/2) s.xx <- pmin(s.xx,s.zz) z <- -delta*(-xx^2/2-s.xx)-s.xx+s.zz as.numeric(2*wt*z) } ## Calculate null deviance for log normal regression dev.null.lognorm <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]|!zz[i]) dev0 <- c(dev0,0) else { fun.wk <- function(eta) { (nu*(log(xx[i])-eta))^2/2+log(1-pnorm(nu*(log(zz[i])-eta))) } dev0 <- c(dev0,nlm(fun.wk,log(xx[i]),stepmax=1)$min) } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(-xx.wk^2/2-log(1-pnorm(xx.wk))) +log((1-pnorm(xx.wk))/(1-pnorm(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset),stepmax=1)$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(-xx^2/2-log(1-pnorm(xx)))-log((1-pnorm(xx))/(1-pnorm(zz))) sum(2*wt*(z-dev0)) } ##%%%%%%%%%% Log Logistic Family %%%%%%%%%% ## Make pseudo data for log logistic regression mkdata.loglogis <- function(y,eta,wt,offset,nu) { if (is.vector(y)) stop("gss error: missing censoring indicator") if (is.null(wt)) wt <- rep(1,dim(y)[1]) if (is.null(offset)) offset <- rep(0,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) if (any(zz<0)|any(zz>=xx)) stop("gss error: inconsistent life time data") if (nu[[2]]) { lkhd <- function(log.nu) { nu <- exp(log.nu) xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))+log.nu) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } if (is.null(nu[[1]])) nu[[1]] <- 1 nu[[1]] <- exp(nlm(lkhd,log(nu[[1]]),stepmax=.5)$est) } xx <- 1/(1+exp(nu[[1]]*(log(xx)-eta))) zz <- 1/(1+exp(nu[[1]]*(log(zz)-eta))) u <- nu[[1]]*(delta*xx-(zz-xx)) w <- nu[[1]]^2/2*(zz^2-xx^2) w <- pmax(w,1e-6) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu,u=u*wt) } ## Calculate deviance residuals for log logistic regression dev.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*(z-dev0)) } dev0.resid.loglogis <- function(y,eta,wt,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) as.numeric(2*wt*z) } ## Calculate null deviance for log logistic regression dev.null.loglogis <- function(y,wt,offset,nu) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) xx <- y[,1] delta <- as.logical(y[,2]) if (dim(y)[2]>=3) zz <- y[,3] else zz <- rep(0,length(xx)) dev0 <- NULL for (i in 1:length(xx)) { if (!delta[i]) dev0 <- c(dev0,0) else { if (!zz[i]) dev0 <- c(dev0,2*log(2)) else { if ((xx[i]/zz[i])^nu<=2) dev0 <- c(dev0,nu*log(xx[i]/zz[i])) else dev0 <- c(dev0,2*log(2)-log(xx[i]^nu/(xx[i]^nu-zz[i]^nu))) } } } if (is.null(offset)) offset <- rep(0,length(xx)) lkhd <- function(eta) { eta <- eta + offset xx.wk <- nu*(log(xx)-eta) zz.wk <- nu*(log(zz)-eta) -sum(wt*(delta*(xx.wk-log(1+exp(xx.wk))) -log((1+exp(xx.wk))/(1+exp(zz.wk))))) } eta <- nlm(lkhd,mean(log(xx)-offset))$est + offset xx <- nu*(log(xx)-eta) zz <- nu*(log(zz)-eta) z <- -delta*(xx-log(1+exp(xx)))+log((1+exp(xx))/(1+exp(zz))) sum(2*wt*(z-dev0)) } gss/R/cdssden.R0000644000175100001440000001421512355360640013042 0ustar hornikuserscdssden <- ## Evaluate conditional density function (object,x,cond,int=NULL) { if (!("ssden"%in%class(object))) stop("gss error in cdssden: not a ssden object") if (nrow(cond)!=1) stop("gss error in cdssden: condition has to be a single point") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if (any(length(xnames)==c(0,ncol(object$mf)))) stop("gss error in cdssden: not a conditional density") if (length(xnames)==1&is.vector(x)) { x <- data.frame(x) colnames(x) <- xnames } if (!all(sort(xnames)==sort(colnames(x)))) stop("gss error in cdssden: mismatched variable names") ## Calculate normalizing constant while (is.null(int)) { fac.list <- NULL num.list <- NULL for (xlab in xnames) { if (is.factor(x.wk <- x[[xlab]])) fac.list <- c(fac.list,xlab) else { if (!is.vector(x.wk)|is.null(object$domain[[xlab]])) { warning("gss warning in cdssden: int set to 1") int <- 1 next } else num.list <- c(num.list,xlab) } } ## Generate quadrature for numerical variables if (!is.null(num.list)) { if (length(num.list)==1) { ## Gauss-Legendre quadrature mn <- min(object$domain[,num.list]) mx <- max(object$domain[,num.list]) quad <- gauss.quad(200,c(mn,mx)) quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- num.list } else { ## Smolyak cubature domain.wk <- object$domain[,num.list] code <- c(15,14,13) quad <- smolyak.quad(ncol(domain.wk),code[ncol(domain.wk)-1]) for (i in 1:ncol(domain.wk)) { xlab <- colnames(domain.wk)[i] form <- as.formula(paste("~",xlab)) jk <- ssden(form,data=object$mf,domain=domain.wk[i],alpha=2, id.basis=object$id.basis) quad$pt[,i] <- qssden(jk,quad$pt[,i]) quad$wt <- quad$wt/dssden(jk,quad$pt[,i]) } jk <- NULL quad$pt <- data.frame(quad$pt) colnames(quad$pt) <- colnames(domain.wk) } } else quad <- list(pt=data.frame(dum=1),wt=1) ## Incorporate factors in quadrature if (!is.null(fac.list)) { for (i in 1:length(fac.list)) { wk <- expand.grid(levels(object$mf[[fac.list[i]]]),1:length(quad$wt)) quad$wt <- quad$wt[wk[,2]] col.names <- c(fac.list[i],colnames(quad$pt)) quad$pt <- data.frame(wk[,1],quad$pt[wk[,2],]) colnames(quad$pt) <- col.names } } xmesh <- quad$pt[,xnames,drop=FALSE] xx <- cond[rep(1,nrow(xmesh)),,drop=FALSE] int <- sum(dssden(object,cbind(xmesh,xx))*quad$wt) } ## Return value xx <- cond[rep(1,nrow(x)),,drop=FALSE] list(pdf=dssden(object,cbind(x,xx))/int,int=int) } cpssden <- ## Compute cdf for univariate conditional density function(object,q,cond) { if (!("ssden"%in%class(object))) stop("gss error in cpssden: not a ssden object") xnames <- NULL for (i in colnames(object$mf)) if (all(i!=colnames(cond))) xnames <- c(xnames,i) if ((length(xnames)!=1)|!is.vector(object$mf[,xnames])) stop("gss error in cpssden: not a 1-D conditional density") mn <- min(object$domain[,xnames]) mx <- max(object$domain[,xnames]) order.q <- rank(q) p <- q <- sort(q) q.dup <- duplicated(q) p[q<=mn] <- 0 p[q>=mx] <- 1 qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) kk <- (1:length(q))[q>mn&q=1] <- mx qd.hize <- 200 qd <- gauss.quad(2*qd.hize,c(mn,mx)) d.qd <- cdssden(object,qd$pt,cond)$pdf gap <- diff(qd$pt) g.wk <- gap[qd.hize]/2 for (i in 1:(qd.hize-2)) g.wk <- c(g.wk,gap[qd.hize+i]-g.wk[i]) g.wk <- 2*g.wk g.wk <- c(g.wk,(mx-mn)/2-sum(g.wk)) gap[qd.hize:1] <- gap[qd.hize+(1:qd.hize)] <- g.wk brk <- cumsum(c(mn,gap)) p.wk <- cumsum(d.qd*qd$wt) kk <- (1:length(p))[p>0&p<1] for (i in kk) { if (p.dup[i]) { q[i] <- q.dup next } ind <- (1:(2*qd.hize))[p.wkdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkrk.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkrk.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Obtain orthonormal basis phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } if (xor(is.vector(mesh),dm==1) |xor(is.matrix(mesh),dm>=2)) { stop("gss error in mkphi.tp: mismatched inputs") } if ((min(weight)<0)|(max(weight)<=0)) { stop("gss error in mkphi.tp: negative weights") } ## Set weights if (is.vector(mesh)) N <- length(mesh) else N <- dim(mesh)[1] weight <- rep(weight,len=N) weight <- sqrt(weight/sum(weight)) ## Create the environment phi.p <- mkphi.tp.p(dm,order) nnull <- choose(dm+order-1,dm) s <- NULL for (nu in 1:nnull) s <- cbind(s,phi.p$fun(mesh,nu,phi.p$env)) s <- qr(weight*s) if (s$rankdm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment if (dm%%2) { theta <- gamma(dm/2-order)/2^(2*order)/pi^(dm/2)/gamma(order) } else { theta <- (-1)^(dm/2+order+1)/2^(2*order-1)/pi^(dm/2)/ gamma(order)/gamma(order-dm/2+1) } env <- list(dim=dm,order=order,theta=theta) ## Create the rk.p function fun <- function(x,y,env,outer.prod=FALSE) { ## Check inputs if (env$dim==1) { if (!(is.vector(x)&is.vector(y))) { stop("gss error in rk: inputs are of wrong types") } } else { if (is.vector(x)) x <- t(as.matrix(x)) if (env$dim!=dim(x)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } if (is.vector(y)) y <- t(as.matrix(y)) if (env$dim!=dim(y)[2]) { stop("gss error in rk: inputs are of wrong dimensions") } } ## Return the results if (outer.prod) { if (env$dim==1) { fn1 <- function(x,y) abs(x-y) d <- outer(x,y,fn1) } else { fn2 <- function(x,y) sqrt(sum((x-y)^2)) d <- NULL for (i in 1:dim(y)[1]) d <- cbind(d,apply(x,1,fn2,y[i,])) } } else { if (env$dim==1) d <- abs(x-y) else { N <- max(dim(x)[1],dim(y)[1]) x <- t(matrix(t(x),env$dim,N)) y <- t(matrix(t(y),env$dim,N)) fn <- function(x) sqrt(sum(x^2)) d <- apply(x-y,1,fn) } } power <- 2*env$order-env$dim switch(1+env$dim%%2, env$theta*d^power*log(ifelse(d>0,d,1)), env$theta*d^power) } ## Return the function and the environment list(fun=fun,env=env) } ## Make pseudo phi function for thin-plate splines mkphi.tp.p <- function(dm,order) { ## Check inputs if (!((2*order>dm)&(dm>=1))) { stop("gss error: thin-plate spline undefined for the parameters") } ## Create the environment pol.code <- NULL for (i in 0:(order^dm-1)) { ind <- i; code <- NULL for (j in 1:dm) { code <- c(code,ind%%order) ind <- ind%/%order } if (sum(code)90)|(max(abs(x[,2]),abs(y[,2]))>180)) { stop("gss error in rk: inputs are out of range") } ##% Convert to radian lat.x <- x[,1]/180*pi; lon.x <- x[,2]/180*pi lat.y <- y[,1]/180*pi; lon.y <- y[,2]/180*pi ##% Return the result rk <- function(lat.x,lon.x,lat.y,lon.y,order) { z <- cos(lat.x)*cos(lat.y)*cos(lon.x-lon.y)+sin(lat.x)*sin(lat.y) W <- ifelse(z<1-10^(-10),(1-z)/2,0) A <- ifelse(W>0,log(1+1/sqrt(W)),0) C <- ifelse(W>0,2*sqrt(W),0) switch(order-1, (A*4*W*(3*W-1)+6*W*(1-C)+1)/2, (W*W*(A*((840*W-720)*W+72)+420*W*(1-C)+220*C-150)-4*W+3)/12, (W*W*W*(A*(((27720*W-37800)*W+12600)*W-600)+ (13860*(1-C)*W+14280*C-11970)*W-2772*C+1470)+ 15*W*W-3*W+5)/30) - 1/(2*order-1) } if (outer.prod) { zz <- NULL for (i in 1:length(lat.y)) zz <- cbind(zz,rk(lat.x,lon.x,lat.y[i],lon.y[i],env$order)) } else zz <- rk(lat.x,lon.x,lat.y,lon.y,env$order) zz } ## Return the function and the environment list(fun=fun,env=env) } gss/R/ssanova.R0000644000175100001440000004551612355360640013101 0ustar hornikusers## Fit ssanova model ssanova <- function(formula,type=NULL,data=list(),weights,subset, offset,na.action=na.omit,partial=NULL, method="v",alpha=1.4,varht=1, id.basis=NULL,nbasis=NULL,seed=NULL,random=NULL, skip.iter=FALSE) { ## Obtain model frame and model terms mf <- match.call() mf$type <- mf$method <- mf$varht <- mf$partial <- NULL mf$alpha <- mf$id.basis <- mf$nbasis <- mf$seed <- NULL mf$random <- mf$skip.iter <- NULL mf[[1]] <- as.name("model.frame") mf <- eval(mf,parent.frame()) wt <- model.weights(mf) ## Generate sub-basis nobs <- dim(mf)[1] if (is.null(id.basis)) { if (is.null(nbasis)) nbasis <- max(30,ceiling(10*nobs^(2/9))) if (nbasis>=nobs) nbasis <- nobs if (!is.null(seed)) set.seed(seed) id.basis <- sample(nobs,nbasis,prob=wt) } else { if (max(id.basis)>nobs|min(id.basis)<1) stop("gss error in ssanova: id.basis out of range") nbasis <- length(id.basis) } ## Generate terms term <- mkterm(mf,type) ## Generate random if (!is.null(random)) { if (class(random)=="formula") random <- mkran(random,data) } ## Generate s, r, and y s <- r <- NULL nq <- 0 for (label in term$labels) { if (label=="1") { s <- cbind(s,rep(1,len=nobs)) next } x <- mf[,term[[label]]$vlist] x.basis <- mf[id.basis,term[[label]]$vlist] nphi <- term[[label]]$nphi nrk <- term[[label]]$nrk if (nphi) { phi <- term[[label]]$phi for (i in 1:nphi) s <- cbind(s,phi$fun(x,nu=i,env=phi$env)) } if (nrk) { rk <- term[[label]]$rk for (i in 1:nrk) { nq <- nq+1 r <- array(c(r,rk$fun(x,x.basis,nu=i,env=rk$env,out=TRUE)),c(nobs,nbasis,nq)) } } } if (is.null(r)) stop("gss error in ssanova: use lm for models with only unpenalized terms") ## Add the partial term if (!is.null(partial)) { mf.p <- model.frame(partial,data) for (lab in colnames(mf.p)) mf[,lab] <- mf.p[,lab] mt.p <- attr(mf.p,"terms") lab.p <- labels(mt.p) matx.p <- model.matrix(mt.p,data)[,-1,drop=FALSE] if (dim(matx.p)[1]!=dim(mf)[1]) stop("gss error in ssanova: partial data are of wrong size") matx.p <- scale(matx.p) center.p <- attr(matx.p,"scaled:center") scale.p <- attr(matx.p,"scaled:scale") s <- cbind(s,matx.p) part <- list(mt=mt.p,center=center.p,scale=scale.p) } else part <- lab.p <- NULL if (qr(s)$rankalpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s,10^theta*r)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,log.la0-lambda[1]-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(lambda) cv.scale*cv(lambda)+cv.shift ## initialization tmp <- sum(r^2) if (is.null(s)) theta <- 0 else theta <- log10(sum(s^2)/nnull/tmp*nxi) / 2 log.la0 <- log10(tmp/sum(diag(q))) + theta if (!is.null(random)) { ran.scal <- theta - log10(sum(random$z^2)/nz/tmp*nxi) / 2 r <- cbind(r,10^(ran.scal-theta)*random$z) } else ran.scal <- NULL ## lambda search return.fit <- FALSE fit <- NULL if (is.null(random)) la <- log.la0 else la <- c(log.la0,random$init) if (length(la)-1) { counter <- 0 ## scale and shift cv tmp <- abs(cv(la)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,la,stepmax=1,ndigit=7) if (zz$code<=3) break la <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } } else { mn0 <- log.la0-6 mx0 <- log.la0+6 repeat { mn <- max(la-1,mn0) mx <- min(la+1,mx0) zz <- nlm0(cv,c(mn,mx)) if ((min(zz$est-mn,mx-zz$est)>=1e-1)|| (min(zz$est-mn0,mx0-zz$est)<1e-1)) break else la <- zz$est } } ## return return.fit <- TRUE jk1 <- cv(zz$est) if (is.null(random)) q.wk <- 10^theta*q else { q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^theta*q q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-zz$est[1])*random$sigma$fun(zz$est[-1],random$sigma$env) } se.aux <- regaux(s,10^theta*r,q.wk,zz$est[1],fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=theta,ran.scal=ran.scal,c=c,d=d,b=b, nlambda=zz$est[1],zeta=zz$est[-1]),fit[-3],list(se.aux=se.aux)) } ## Fit Multiple Smoothing Parameter (Gaussian) REGression mspreg1 <- function(s,r,id.basis,y,wt,method,alpha,varht,random,skip.iter) { qr.trace <- FALSE if ((alpha<0)&(method%in%c("u","v"))) qr.trace <- TRUE alpha <- abs(alpha) ## get dimensions nobs <- nrow(r) nxi <- ncol(r) if (!is.null(s)) { if (is.vector(s)) nnull <- 1 else nnull <- ncol(s) } else nnull <- 0 if (!is.null(random)) nz <-ncol(as.matrix(random$z)) else nz <- 0 nxiz <- nxi + nz nn <- nxiz + nnull nq <- dim(r)[3] ## cv function cv <- function(theta) { ind.wk <- theta[1:nq]!=theta.old if (sum(ind.wk)==nq) { r.wk0 <- 0 for (i in 1:nq) { r.wk0 <- r.wk0 + 10^theta[i]*r[,,i] } assign("r.wk",r.wk0+0,inherits=TRUE) assign("theta.old",theta[1:nq]+0,inherits=TRUE) } else { r.wk0 <- r.wk for (i in (1:nq)[ind.wk]) { theta.wk <- (10^(theta[i]-theta.old[i])-1)*10^theta.old[i] r.wk0 <- r.wk0 + theta.wk*r[,,i] } } qq.wk <- r.wk0[id.basis,] if (is.null(random)) q.wk <- 10^nlambda*qq.wk else { r.wk0 <- cbind(r.wk0,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- 10^nlambda*qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal)*random$sigma$fun(theta[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { y.wk <- wt*y s.wk <- wt*s r.wk0 <- wt*r.wk0 } if (qr.trace) { qq.wk <- chol(q.wk,pivot=TRUE) sr <- cbind(s.wk,r.wk0[,attr(qq.wk,"pivot")]) sr <- rbind(sr,cbind(matrix(0,nxiz,nnull),qq.wk)) sr <- qr(sr,tol=0) rss <- mean(qr.resid(sr,c(y.wk,rep(0,nxiz)))[1:nobs]^2) trc <- sum(qr.Q(sr)[1:nobs,]^2)/nobs if (method=="u") score <- rss + alpha*2*varht*trc if (method=="v") score <- rss/(1-alpha*trc)^2 alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*trc if (method=="v") score <- rss/(1-alpha.wk*trc)^2 } if (return.fit) { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] z$score <- score assign("fit",z[c(1:5,7)],inherits=TRUE) } } else { z <- .Fortran("reg", as.double(cbind(s.wk,r.wk0)), as.integer(nobs), as.integer(nnull), as.double(q.wk), as.integer(nxiz), as.double(y.wk), as.integer(switch(method,"u"=1,"v"=2,"m"=3)), as.double(alpha), varht=as.double(varht), score=double(1), dc=double(nn), as.double(.Machine$double.eps), chol=double(nn*nn), double(nn), jpvt=as.integer(c(rep(1,nnull),rep(0,nxiz))), wk=double(3*nobs+nnull+nz), rkv=integer(1), info=integer(1), PACKAGE="gss")[c("score","varht","dc","chol","jpvt","wk","rkv","info")] if (z$info) stop("gss error in ssanova: evaluation of GML score fails") assign("fit",z[c(1:5,7)],inherits=TRUE) score <- z$score alpha.wk <- max(0,theta[1:nq]-log.th0-5)*(3-alpha) + alpha alpha.wk <- min(alpha.wk,3) if (alpha.wk>alpha) { if (method=="u") score <- score + (alpha.wk-alpha)*2*varht*z$wk[2] if (method=="v") score <- z$wk[1]/(1-alpha.wk*z$wk[2])^2 } } score } cv.wk <- function(theta) cv.scale*cv(theta)+cv.shift ## initialization theta <- -log10(apply(r[id.basis,,],3,function(x)sum(diag(x)))) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } ## theta adjustment return.fit <- FALSE z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) theta <- theta + z$theta r.wk <- 0 for (i in 1:nq) { theta[i] <- 2*theta[i] + log10(t(z$c)%*%r[id.basis,,i]%*%z$c) r.wk <- r.wk + 10^theta[i]*r[,,i] } if (!is.null(wt)) q.wk <- wt*r.wk else q.wk <- r.wk log.la0 <- log10(sum(q.wk^2)/sum(diag(r.wk[id.basis,]))) log.th0 <- theta-log.la0 ## lambda search z <- sspreg1(s,r.wk,r.wk[id.basis,],y,wt,method,alpha,varht,random) nlambda <- z$nlambda log.th0 <- log.th0 + z$nlambda theta <- theta + z$theta if (!is.null(random)) ran.scal <- z$ran.scal ## early return if (skip.iter) { z$theta <- theta return(z) } ## theta search fit <- NULL counter <- 0 y.wk <- y s.wk <- s r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^theta[i]*r[,,i] } theta.old <- theta if (!is.null(random)) theta <- c(theta,z$zeta) ## scale and shift cv tmp <- abs(cv(theta)) cv.scale <- 1 cv.shift <- 0 if (tmp<1&tmp>10^(-4)) { cv.scale <- 10/tmp cv.shift <- 0 } if (tmp<10^(-4)) { cv.scale <- 10^2 cv.shift <- 10 } repeat { zz <- nlm(cv.wk,theta,stepmax=1,ndigit=7) if (zz$code<=3) break theta <- zz$est counter <- counter + 1 if (counter>=5) { warning("gss warning in ssanova: iteration for model selection fails to converge") break } } ## return return.fit <- TRUE jk1 <- cv(zz$est) r.wk <- 0 for (i in 1:nq) { r.wk <- r.wk + 10^zz$est[i]*r[,,i] } qq.wk <- r.wk[id.basis,] if (is.null(random)) q.wk <- qq.wk else { r.wk <- cbind(r.wk,10^(ran.scal)*random$z) q.wk <- matrix(0,nxiz,nxiz) q.wk[1:nxi,1:nxi] <- qq.wk q.wk[(nxi+1):nxiz,(nxi+1):nxiz] <- 10^(2*ran.scal-nlambda)*random$sigma$fun(zz$est[-(1:nq)],random$sigma$env) } if (!is.null(wt)) { s <- wt*s r.wk <- wt*r.wk } se.aux <- regaux(s,r.wk,q.wk,nlambda,fit) c <- fit$dc[nnull+(1:nxi)] if (nnull) d <- fit$dc[1:nnull] else d <- NULL if (nz) b <- 10^(ran.scal)*fit$dc[nnull+nxi+(1:nz)] else b <- NULL c(list(method=method,theta=zz$est[1:nq],c=c,d=d,b=b,nlambda=nlambda, zeta=zz$est[-(1:nq)]),fit[-3],list(se.aux=se.aux)) } ## Auxiliary Quantities for Standard Error Calculation regaux <- function(s,r,q,nlambda,fit) { nnull <- dim(s)[2] nn <- nnull + dim(q)[1] zzz <- eigen(q,symmetric=TRUE) rkq <- min(fit$rkv-nnull,sum(zzz$val/zzz$val[1]>sqrt(.Machine$double.eps))) val <- zzz$val[1:rkq] vec <- zzz$vec[,1:rkq,drop=FALSE] if (nnull) { wk1 <- qr(s) wk1 <- (qr.qty(wk1,r%*%vec))[-(1:nnull),] } else wk1 <- r%*%vec wk2 <- t(t(wk1)/sqrt(val)) wk2 <- t(wk2)%*%wk2 wk2 <- solve(wk2+diag(10^nlambda,dim(wk2)[1]),wk2) wk2 <- (wk2+t(wk2))/2 wk2 <- t(wk2/sqrt(val))/sqrt(val) wk2 <- diag(1/val,dim(wk2)[1])-wk2 z <- .Fortran("regaux", as.double(fit$chol), as.integer(nn), as.integer(fit$jpvt), as.integer(fit$rkv), drcr=as.double(t(cbind(s,r))%*%r%*%vec), as.integer(rkq), sms=double(nnull^2), as.integer(nnull), double(nn*nnull), PACKAGE="gss")[c("drcr","sms")] drcr <- matrix(z$drcr,nn,rkq) dr <- drcr[1:nnull,,drop=FALSE] sms <- 10^nlambda*matrix(z$sms,nnull,nnull) wk1 <- matrix(0,nnull+rkq,nnull+rkq) wk1[1:nnull,1:nnull] <- sms wk1[1:nnull,nnull+(1:rkq)] <- -t(t(dr)/val) wk1[nnull+(1:rkq),nnull+(1:rkq)] <- wk2 z <- chol(wk1,pivot=TRUE) wk1 <- z rkw <- attr(z,"rank") while (wk1[rkw,rkw]col(wk1)] <- 0 if (rkw Maintainer: Chong Gu Depends: R (>= 2.14.0), stats Description: A comprehensive package for structural multivariate function estimation using smoothing splines. License: GPL (>= 2) Packaged: 2015-07-02 14:52:18 UTC; chong NeedsCompilation: yes Repository: CRAN Date/Publication: 2015-07-02 18:31:30 gss/ChangeLog0000644000175100001440000003723112545247777012670 0ustar hornikusersThu Jul 2 10:51:16 EDT 2015, Chong Gu * DESCRIPTION: Version 2.1-5. * NAMESPACE: Added 'importFrom(stats, ...)'. Sat Dec 6 10:36:46 EST 2014, Chong Gu * DESCRIPTION: Version 2.1-4. * R: Along with a bug fix, edited utility functions for the nbinomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. Mon Jul 21 00:14:45 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-3. * R: Edited utility functions for the binomial family in the gssanova suite, eliminating unnecessary subtractions to preserve numerical precision. Tue Jun 10 18:52:28 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-2. * inst: created the directory and added CITATION. * man: Updated references. Wed May 28 11:25:14 EDT 2014, Chong Gu * DESCRIPTION: Version 2.1-1. * R: i) Tuned Newton iteration algorithms in ngreg and ngreg.proj. ii) Bug fixes in routines involving univariate minimization via nlm0. iii) Minor changes in makedata.x's. Tue Dec 3 01:02:41 EST 2013, Chong Gu * DESCRIPTION: Version 2.1-0. * R: i) Changed time domain specification in sshzd/sshzd1. ii) Removed from sshzd1 the option of external rho. * man: Minor edit in sshzd.Rd. Fri Nov 15 17:19:59 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-16. * R: i) Bug fix in survexp.sshzd. ii) Modified default values of qdsz.depth in ssden. * man: i) Updated references. ii) Added note in ssden.Rd. Wed Oct 9 11:44:05 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-15. * R: Bug fixes in summary.gssanova, summary.ssanova, and summary.ssanova9. Tue May 14 14:51:58 EDT 2013, Chong Gu * DESCRIPTION: Version 2.0-14. * R: Bug fixes in ssden1, sscden, sscden1 suites. Fri Mar 8 16:04:21 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-13. * R: Replaced direct calls to LINPACK dchdc by chol(), in ssanova, cv.poisson, project.ssden1, project.sscden1, and project.sshzd1. Tue Feb 26 14:42:15 EST 2013, Chong Gu * DESCRIPTION: Version 2.0-12. * R: i) Bug fixes in summary.gssanova and project.gssanova. ii) Changes in ssanova and ssanova9 to supply sufficient work array for altered reg.f. iii) Replaced 'attach/detach' by 'with' in mkran, sscox, sshzd, and sshzd1 following suggestion by Professor Brian Ripley. * src: Replaced EISPACK routine rs by LAPACK routine dsyev in reg.f, and added $(LAPACK_LIBS) to Makevars. Tue Aug 28 18:28:31 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-11. * R: Bug fixes in fitting functions to prevent overflow in oversmoothing cases. Sat May 12 19:52:54 EDT 2012, Chong Gu * DESCRIPTION: Version 2.0-10. * R: Bug fixes in project.x to allow projections into spaces with only unpenalized terms. Tue Jan 24 09:35:43 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-9. * R: Removed the .First.lib function. * man: Edited documentation for Sachs. Fri Jan 6 12:39:56 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-8. * NAMESPACE: Manually created the file. * data: Added Sachs. * man: Added documentation for Sachs. Mon Jan 2 18:39:24 EST 2012, Chong Gu * DESCRIPTION: Version 2.0-7. * R: i) Bug fixes in sscden. ii) Reworked survexp.sshzd. * man: Updated to reflect changes in R. Tue Dec 20 15:44:32 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-6. * R: Reworked the sshzd1 suite. * man: Updated to reflect changes in R. Tue Nov 15 21:47:30 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-5. * R: Reworked the ssden1 suite to improve memory management. * man: Updated to reflect changes in R. Mon Nov 14 00:35:22 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-4. * R: Bug fixes in ssden and ssden1. * data: Added NO2. * man: Added documentation for NO2. Tue Nov 8 14:09:09 EST 2011, Chong Gu * DESCRIPTION: Version 2.0-3. * R: Added the ssden1 suite. * man: Updated to reflect changes in R. * src: Added dnewton10. Sun Sep 18 10:34:49 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-2. * R: Reworked the sscden1 suite. * man: Updated to reflect changes in R. Sun Jul 31 01:03:45 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-1. * R: Bug fix in gssanova1. * src: Bug fix in drkl. Sun Jul 24 12:26:15 EDT 2011, Chong Gu * DESCRIPTION: Version 2.0-0. * R: i) Added the ssanova9, gssanova1, sscox, sscden, and sscden1 suites. ii) Reworked part of the gssanova suite. iii) Reworked the ssden suite to allow sampling bias. iv) Changed the syntax concerning partial terms, and added partial in sshzd and sshzd1 suites. v) Minor changes in cpssden and cqssden. * data: i) Added ColoCan. ii) Reformatted clim, LakeAcidity, and penny. * man: Expanded and updated to reflect changes in R. * src: i) Added cdennewton, cdenrkl, cdennewton10. ii) Changes in dnewton and drkl. Wed Jan 12 11:58:55 EST 2011, Chong Gu * DESCRIPTION: Version 1.1-7. * R: Set alpha=1 as default in ssllrm. * data: Added eyetrack. * man: Added documentation for eyetrack. Wed Oct 13 18:00:47 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-6. * R: Bug fixes in sshzd and sshzd1 concerning subset in call. * src: Bug fix in llrmnewton. Mon Jul 5 15:28:48 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-5. * R: Reworked qssden and cqssden to eliminate calls to pssden and cpssden, and removed a now redundant operation in cpssden; qssden and cqssden now run much faster. * data: Added esc. * man: i) Added documentation for esc. ii) Removed the warning for the slowness of cpssden and cqssden, as the new versions are no longer slow. Wed Jun 23 10:59:50 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-4. * R: i) Bug fixes in project.ssanova, ssden, sshzd, and sshzd1, and minor tweaking in project.gssanova, mostly concerning weighted data. ii) Added support of random effects to the sshzd and sshzd1 suites for frailty models. * man: Updated to reflect changes in R. * src: Minor change in hzdnewton10. Sun Jun 13 17:28:13 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-3. * R: i) Fixed bugs and inefficient code in ssllrm. ii) Fixed a bug in project.ssllrm. iii) Minor changes in sshzd and sshzd1. * man: Updated to reflect changes in R. * src: Changes in llrmnewton triggered by ssllrm. Thu May 27 19:52:17 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-2. * R: Fixed bugs in the ssanova suite introduced in 1.1-0. * man: Updated to reflect changes in R. Wed May 19 22:38:22 EDT 2010, Chong Gu * DESCRIPTION: Version 1.1-1. * R: i) Added support of random effects to the ssllrm suite. ii) Fixed bugs in mspreg1 and mspngreg introduced in 1.1-0. * man: Updated to reflect changes in R. Mon Nov 23 12:52:38 EST 2009, Chong Gu * DESCRIPTION: Version 1.1-0. * INDEX: Edited to reflect changes in R. * R: i) Added sshzd1 and project.sshzd1. ii) Added ssllrm, predict.ssllrm, and project.ssllrm. iii) Removed the dimension limit in ssden and added user-control of quadrature size via qdsz.depth. iv) Added skip.iter to fitting functions, and rearranged computation to speed up theta iteration. This affect all but the legacy fitting functions ssanova0 and gssanova0. v) reworked quadrature in pssden and cpssden to guarantee monotonicity. * man: Updated to reflect changes in R. Mon Mar 9 15:53:42 EDT 2009, Chong Gu * DESCRIPTION: Version 1.0-5. * R: Fixed a bug in regaux. Wed Mar 4 16:42:23 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-4. * INDEX: Edited to reflect changes in R. * R: Further tweaking of the calculations concerning standard errors in predict.ssanova; added internal function regaux. * man: Updated to reflect changes in R. Wed Mar 4 00:22:21 EST 2009, Chong Gu * DESCRIPTION: Version 1.0-3. * R: Redesigned the calculations concerning standard errors in predict.ssanova. Sun Sep 7 14:42:33 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-2. * R: Fixed a bug in predict.ssanova. Fri Jun 27 17:10:27 EDT 2008, Chong Gu * DESCRIPTION: Version 1.0-1. * R: Installed more stable calculations concerning standard errors in predict.ssanova. * man: Fixed format for documentation of methods. * src: Fixed a bug in reg (undeclared dasum), which was forgiven by g77 and also by gfortran on (some) 32-bit machines; revealed by gfortran on 64-bit. Mon Aug 6 21:21:47 EDT 2007, Chong Gu * DESCRIPTION: Version 1.0-0. * INDEX: Edited to reflect changes in R. * R: i) Added mkterm to replace multiple mkterm.x in earlier versions, and modified the fitting functions accordingly. ii) Renamed ssanova to ssanova0, ssanova1 to ssanova, gssanova to gssanova0, and gssanova1 to gssanova; renamed the respective methods accordingly. iii) Added support of factor variables in ssden. * man: Extensive editing was done to reflect changes in R, to update references, and to improve readability. * src: i) Fixed bugs in hzdnewton1 and dnewton1. ii) Pushed ratfor source code to a subdirectory ratfor. Thu Sep 23 16:27:00 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-3. * man: Fixed formatting bugs in ssden.Rd and sshzd.Rd. Fri Mar 26 10:40:04 EST 2004, Chong Gu * DESCRIPTION: Version 0.9-2. * R: Added SE calculations to the sshzd suite. * man: Updated hzdrate.sshzd.Rd to reflect the added SE functionality. * src: Added support for the SE calculations in the sshzd suite. Sun Oct 19 23:16:01 EST 2003, Chong Gu * DESCRIPTION: Version 0.9-1. * INDEX: Added new utility functions for gssanova1 and project.gssanova1. * R: i) Added supports of nbinomial, weibull, lognorm, and loglogis families to gssanova1. ii) Restructured project.gssanova1 along with added family supports. * man: Added to family.Rd the new utility functions for gssanova1 and project.gssanova1. Sat Aug 16 01:31:27 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-6. * R: i) Added mkran and released the mixed-effect model functionality in ssanova1 and gssanova1. ii) Fixed project.ssanova1 and project.gssanova1 to treat random effects (in mixed-effect models) as offset. * data: Added bacteriuria. * man: i) Added mkran.Rd. ii) Added mixed-effect example in gssanova1.Rd. iii) To avoid confusion with the random effects in mixed-effect models, changed "fixed effects" to "unpenalized terms" and "random effects" to "penalized terms" throughout. Mon Jul 14 13:59:43 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-5. * R: i) Added stable GCV evaluation in rkpk1.R. ii) Improved the reliability of nlm calls in numerous functions. iii) Bug fix in sshzd. * man: Blocked out time-consuming examples from auto executions and added warnings. Thu Jun 26 16:39:30 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-4. * R: Bug fix in project.sshzd. Thu Jun 26 11:31:14 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-3. * R: i) Bug fixes in sshzd and project.sshzd. ii) Miner fixes in documentation. Sun Mar 2 10:43:35 EST 2003, Chong Gu * DESCRIPTION: Version 0.8-2. * INDEX: Added gssanova1, sshzd, project.x, and related functions. * R: i) Added the gssanova1 suite for scalable non Gaussian regression. ii) Added the sshzd suite for hazard estimation. iii) Added code for Kullback-Leibler projection model diagnostics. iv) Code modifications and bug fixes in ssanova1 and ssden suites; added nlm0 for univariate optimization. * data: Added gastric. * man: Added documentations for the new entries in R. * src: Added routines to support the gssanova1 suite, the sshzd suite, and the projection code. Tue Dec 31 10:16:37 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-4. * INDEX: Added ssanova1 and related functions. * R: i) Added the ssanova1 suite for scalable Gaussian regression, with modifications in fitted.R to accommodate ssanova1. ii) Minor bug fixes in ssden suite. * man: Added documentations for the new entries in R. * src: Added routines to support the ssanova1 suite. Thu Jun 27 12:03:26 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-3. * R: Minor changes in ssden and related functions. * man: Minor changes to reflect code change. * src: Removed dchdc.f and dtrsl.f. Added an include line in smolyak.c as suggested by Kurt Hornik. Mon Jun 24 16:44:38 EST 2002, Chong Gu * DESCRIPTION: Version 0.7-2. * INDEX: Added ssden and related functions. * R: Added the ssden suite for density estimation. * data: Added buffalo, aids. * man: Added documentations for the new entries in R and data. * src: Added routines to support the ssden suite. Tue May 14 06:35:45 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-5. * src: Removed BLAS routines, as suggested by Brian Ripley. Thu Apr 25 23:41:09 EST 2002, Chong Gu * DESCRIPTION: Version 0.6-4. * R: Cosmetic changes to conform with the formats of generic methods. * man: Minor changes to reflect the code change and to meet R-1.5.0 CMD check standard. * src: Added the file Makevars, as suggested by Martin Maechler. Thu Jul 9 22:10:07 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-3. * R: Minor changes to correctly reflect documentations. * man: Minor changes to meet R-1.3.0 CMD check standard. Thu Jul 5 16:05:21 EST 2001, Chong Gu * DESCRIPTION: Version 0.6-2. * INDEX: Added mkdata.x, dev.resid.x, and dev.null.x for weibull, lognorm, and loglogis. * R: Added support for accelerated life model families weibull, lognorm, and loglogis for censored data regression. * data: Added ozone, stan, wesdr. * man: Revised relevant files to reflect the added support for accelerated life model families. Mon May 14 13:18:12 EST 2001, Chong Gu * DESCRIPTION: Version 0.5-3. Added Maintainer field per the new format requirement by R-1.2.1. * man: Fixed keywords in a few files. Thu Dec 21 19:35:38 EST 2000, Chong Gu * DESCRIPTION: Version 0.5-2. Moved the Title in here according to the new format requirement by R-1.2.0. * INDEX: Added new functions mkrk.nominal and mkrk.ordinal. * R: i) Added support for factors; ii) corrected minor bugs; iii) grouped functions into smaller number of files. * data: Replaced lake.acid by LakeAcidity. Added Nox. * man: Expanded to cover all objects. Revised existing ones to reflect code expansion/revision. * src: Fixed an inconsequential bug in dmudr1.f. Wed Jun 23 20:22:12 EST 1999, Chong Gu * DESCRIPTION (Version): First Public Release is 0.4-1 * INDEX: Expanded and reorganized. * R: i) Added support for partial and offset terms; ii) added linear splines; iii) added the gssanova suite for non Gaussian regression. * man: Expanded/revised to reflect the code expansion/revision. Fri May 28 00:31:24 EST 1999, Chong Gu * DESCRIPTION (Version): First Release is 0.3-1 gss/man/0000755000175100001440000000000012345727342011650 5ustar hornikusersgss/man/bacteriuria.Rd0000644000175100001440000000207412355360640014427 0ustar hornikusers\name{bacteriuria} \alias{bacteriuria} \title{Treatment of Bacteriuria} \description{ Bacteriuria patients were randomly assigned to two treatment groups. Weekly binary indicator of bacteriuria was recorded for every patient over 4 to 16 weeks. A total of 72 patients were represented in the data, with 36 each in the two treatment groups. } \usage{data(bacteriuria)} \format{ A data frame containing 820 observations on the following variables. \tabular{ll}{ \code{id} \tab Identification of patients, a factor.\cr \code{trt} \tab Treatments 1 or 2, a factor.\cr \code{time} \tab Weeks after randomization.\cr \code{infect} \tab Binary indicator of bacteriuria (bacteria in urine). } } \source{ Joe, H. (1997), \emph{Multivariate Models and Dependence Concepts}. London: Chapman and Hall. } \references{ Gu, C. and Ma, P. (2005), Generalized nonparametric mixed-effect models: computation and smoothing parameter selection. \emph{Journal of Computational and Graphical Statistics}, \bold{14}, 485--504. } \keyword{datasets} gss/man/fitted.ssanova.Rd0000644000175100001440000000161212355360641015063 0ustar hornikusers\name{fitted.ssanova} \alias{fitted.ssanova} \alias{residuals.ssanova} \alias{fitted.gssanova} \alias{residuals.gssanova} \title{Fitted Values and Residuals from Smoothing Spline ANOVA Fits} \description{ Methods for extracting fitted values and residuals from smoothing spline ANOVA fits. } \usage{ \method{fitted}{ssanova}(object, ...) \method{residuals}{ssanova}(object, ...) \method{fitted}{gssanova}(object, ...) \method{residuals}{gssanova}(object, type="working", ...) } \arguments{ \item{object}{Object of class \code{"ssanova"} or \code{"gssanova"}.} \item{type}{Type of residuals desired, with two alternatives \code{"working"} (default) or \code{"deviance"}.} \item{...}{Ignored.} } \details{ The fitted values for \code{"gssanova"} objects are on the link scale, so are the \code{"working"} residuals. } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/ssllrm.Rd0000644000175100001440000001242212355360640013447 0ustar hornikusers\name{ssllrm} \alias{ssllrm} \title{Fitting Smoothing Spline Log-Linear Regression Models} \description{ Fit smoothing spline log-linear regression models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}. } \usage{ ssllrm(formula, response, type=NULL, data=list(), weights, subset, na.action=na.omit, alpha=1, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{response}{Formula listing response variables.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{alpha}{Parameter modifying GCV or Mallows' CL; larger absolute values yield smoother fits; negative value invokes a stable and more accurate GCV/CL evaluation algorithm but may take two to five times as long. Ignored when \code{method="m"} are specified.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed to be used for the random generation of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model is specified via \code{formula} and \code{response}, where \code{response} lists the response variables. For example, \code{ssllrm(~y1*y2*x,~y1+y2)} prescribe a model of the form \deqn{ log f(y1,y2|x) = g_{1}(y1) + g_{2}(y2) + g_{12}(y1,y2) + g_{x1}(x,y1) + g_{x2}(x,y2) + g_{x12}(x,y1,y2) + C(x) } with the terms denoted by \code{"y1"}, \code{"y2"}, \code{"y1:y2"}, \code{"y1:x"}, \code{"y2:x"}, and \code{"y1:y2:x"}; the term(s) not involving response(s) are removed and the constant \code{C(x)} is determined by the fact that a conditional density integrates (adds) to one on the \code{y} axis. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ The responses, or y-variables, must be factors, and there must be at least one numerical x's. For \code{response}, there is no difference between \code{~y1+y2} and \code{~y1*y2}. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssllrm} returns a list object of class \code{"ssllrm"}. The method \code{\link{predict.ssllrm}} can be used to evaluate \code{f(y|x)} at arbitrary x, or contrasts of \code{log{f(y|x)}} such as the odds ratio along with standard errors. The method \code{\link{project.ssllrm}} can be used to calculate the Kullback-Leibler projection for model selection. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. and Ma, P. (2011), Nonparametric regression with cross-classified responses. \emph{The Canadian Journal of Statistics}, \bold{39}, 591--609. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Simulate data test <- function(x) {.3*(1e6*(x^11*(1-x)^6)+1e4*(x^3*(1-x)^10))-2} x <- (0:100)/100 p <- 1-1/(1+exp(test(x))) y <- rbinom(x,3,p) y1 <- as.ordered(y) y2 <- as.factor(rbinom(x,1,p)) ## Fit model fit <- ssllrm(~y1*y2*x,~y1+y2) ## Evaluate f(y|x) est <- predict(fit,data.frame(x=x), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4)))) ## f(y|x) at all y values (fit$qd.pt) est <- predict(fit,data.frame(x=x)) ## Evaluate contrast of log f(y|x) est <- predict(fit,data.frame(x=x),odds=c(-1,.5,.5,0), data.frame(y1=as.factor(0:3),y2=as.factor(rep(0,4))),se=TRUE) ## Odds ratio log{f(0,0|x)/f(3,0|x)} est <- predict(fit,data.frame(x=x),odds=c(1,-1), data.frame(y1=as.factor(c(0,3)),y2=as.factor(c(0,1))),se=TRUE) ## KL projection kl <- project(fit,include=c("y2:x","y1:y2","y1:x","y2:x")) ## Clean up \dontrun{rm(test,x,p,y,y1,y2,fit,est,kl) dev.off()} } \keyword{smooth} \keyword{models} \keyword{regression} gss/man/penny.Rd0000644000175100001440000000142112355360641013262 0ustar hornikusers\name{penny} \alias{penny} \title{Thickness of US Lincoln Pennies} \description{ Thickness of US Lincoln pennies minted during years 1945 through 1989. } \usage{data(nox)} \format{ A data frame containing 90 observations on the following variables. \tabular{ll}{ \code{year} \tab Year minted.\cr \code{mil} \tab Thickness in mils. } } \source{ Scott, D. W. (1992), \emph{Multivariate Density Estimation: Theory, Practice and Visualization}. New York: Wiley. } \references{ Gu, C. (1995), Smoothing spline density estimation: Conditional distribution, \emph{Statistica Sinica}, \bold{5}, 709--726. Scott, D. W. (1992), \emph{Multivariate Density Estimation: Theory, Practice and Visualization}. New York: Wiley. } \keyword{datasets} gss/man/ColoCan.Rd0000644000175100001440000000323312355360641013452 0ustar hornikusers\name{ColoCan} \alias{ColoCan} \title{Colorectal Cancer Mortality Rate in Indiana Counties} \description{ County-wise death counts of colorectal cancer patients in Indiana during years 2000 through 2004. } \usage{data(ColoCan)} \format{ A data frame containing 184 observations on the following variables. \tabular{ll}{ \code{event} \tab Death counts.\cr \code{pop} \tab Population from Census 2000.\cr \code{sex} \tab Gender of population.\cr \code{wrt} \tab Proportion of Whites.\cr \code{brt} \tab Proportion of Blacks.\cr \code{ort} \tab Proportion of other minorities.\cr \code{lat} \tab Latitude.\cr \code{lon} \tab Longitude.\cr \code{geog} \tab Geographic location, derived from \code{lat} and \code{lon}.\cr \code{scrn} \tab Colorectal cancer screening rate.\cr \code{name} \tab County name. } } \details{ \code{geog} was generated from \code{lat} and \code{lon} using the code given in the example section. } \source{ Dr. Tonglin Zhang. } \references{ Zhang, T. and Lin, G. (2009), Cluster detection based on spatial associations and iterated residuals in generalized linear mixed models. \emph{Biometrics}, \bold{65}, 353--360. } \examples{ ## Converting latitude and longitude to x-y coordinates ## The 49th county is Marion, where Indianapolis is located. \dontrun{ltln2xy <- function(latlon,latlon0) { lat <- latlon[,1]*pi/180; lon <- latlon[,2]*pi/180 lt0 <- latlon0[1]*pi/180; ln0 <- latlon0[2]*pi/180 x <- cos(lt0)*sin(lon-ln0); y <- sin(lat-lt0) cbind(x,y) } data(ColoCan) latlon <- as.matrix(ColoCan[,c("lat","lon")]) ltln2xy(latlon,latlon[49,]) ## Clean up rm(ltln2xy,ColoCan,latlon)} } \keyword{datasets} gss/man/gastric.Rd0000644000175100001440000000126312355360641013571 0ustar hornikusers\name{gastric} \alias{gastric} \title{Gastric Cancer Data} \description{ Survival of gastric cancer patients under chemotherapy and chemotherapy-radiotherapy combination. } \usage{data(gastric)} \format{ A data frame containing 90 observations on the following variables. \tabular{ll}{ \code{futime} \tab Follow-up time, in days.\cr \code{status} \tab Censoring status.\cr \code{trt} \tab Factor indicating the treatments: 1 -- chemothrapy, 2 -- combination. } } \source{ Moreau, T., O'Quigley, J., and Mesbah, M. (1985), A global goodness-of-fit statistic for the proportional hazards model. \emph{Applied Statistics}, \bold{34}, 212-218. } \keyword{datasets} gss/man/buffalo.Rd0000644000175100001440000000065712355360641013561 0ustar hornikusers\name{buffalo} \alias{buffalo} \title{Buffalo Annual Snowfall} \description{ Annual snowfall accumulations in Buffalo, NY from 1910 to 1973. } \usage{data(buffalo)} \format{ A vector of 63 numerical values. } \source{ Scott, D. W. (1985), Average shifted histograms: Effective nonparametric density estimators in several dimensions. \emph{The Annals of Statistics}, \bold{13}, 1024--1040. } \keyword{datasets} gss/man/dsscden.Rd0000644000175100001440000000300612355360641013555 0ustar hornikusers\name{dsscden} \alias{dsscden} \alias{psscden} \alias{qsscden} \alias{d.sscden} \alias{d.sscden1} \title{Evaluating PDF, CDF, and Quantiles of Smoothing Spline Conditional Density Estimates} \description{ Evaluate pdf, cdf, and quantiles for smoothing spline conditional density estimates. } \usage{ dsscden(object, y, x) psscden(object, q, x) qsscden(object, p, x) d.sscden(object, x, y) d.sscden1(object, x, y, scale=TRUE) } \arguments{ \item{object}{Object of class \code{"sscden"} or \code{"sscden1"}.} \item{x}{Data frame of x values on which conditional density f(y|x) is to be evaluated.} \item{y}{Data frame or vector of points on which conditional density f(y|x) is to be evaluated.} \item{q}{Vector of points on which cdf is to be evaluated.} \item{p}{Vector of probabilities for which quantiles are to be calculated.} \item{scale}{Flag indicating whether to use approximate scaling without quadrature.} } \value{ A matrix or vector of pdf, cdf, or quantiles of f(y|x), with each column corresponding to a distinct x value. } \details{ The arguments \code{x} and \code{y} are of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but \code{y} in \code{dsscden} can take a vector for 1-D responses. \code{psscden} and \code{qsscden} naturally only work for 1-D responses. } \seealso{ Fitting function \code{\link{sscden}} and \code{\link{cdsscden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/Sachs.Rd0000644000175100001440000000256312355360640013201 0ustar hornikusers\name{Sachs} \alias{Sachs} \title{Protein Expression in Human Immune System Cells} \description{ Data concerning protein expression levels in human immune system cells under stimulations. } \usage{data(Sachs)} \format{ A data frame containing 7466 cells, with flow cytometry measurements of 11 phosphorylated proteins and phospholipids, on the \code{log10} scale of the original. \tabular{ll}{ \code{praf} \tab Raf phosphorylated at S259.\cr \code{pmek} \tab Mek1/mek2 phosphorylated at S217/S221.\cr \code{plcg} \tab Phosphorylation of phospholipase \eqn{C-\gamma} on Y783.\cr \code{pip2} \tab Phophatidylinositol 4,5-biphosphate.\cr \code{pip3} \tab Phophatidylinositol 3,4,5-triphosphate.\cr \code{p44.42} \tab Erk1/erk2 phosphorylated at T202/Y204.\cr \code{pakts473} \tab AKT phosphorylated at S473.\cr \code{pka} \tab Phosphorylation of of protein kinase A substrates on 3 sites.\cr \code{pkc} \tab Phosphorylation of of protein kinase C substrates on S660.\cr \code{p38} \tab Erk1/erk2 phosphorylated at T180/Y182.\cr \code{pjnk} \tab Erk1/erk2 phosphorylated at T183/Y185.\cr } } \source{ Sachs, K., Perez, O., Pe'er, D., Lauffenburger, D. A., and Nolan, G. P. (2005), Causal protein-signaling networks derived from multiparameter single-cell data. \emph{Science}, \bold{308 (5732)}, 523--529. } \keyword{datasets} gss/man/predict.sscox.Rd0000644000175100001440000000313712355360641014727 0ustar hornikusers\name{predict.sscox} \alias{predict.sscox} \title{Evaluating Smoothing Spline ANOVA Estimate of Relative Risk} \description{ Evaluate terms in a smoothing spline ANOVA estimate of relative risk at arbitrary points. Standard errors of the terms can be requested for use in constructing Bayesian confidence intervals. } \usage{ \method{predict}{sscox}(object, newdata, se.fit=FALSE, include=c(object$terms$labels,object$lab.p), ...) } \arguments{ \item{object}{Object of class \code{"sscox"}.} \item{newdata}{Data frame or model frame in which to predict.} \item{se.fit}{Flag indicating if standard errors are required.} \item{include}{List of model terms to be included in the prediction.} \item{...}{Ignored.} } \value{ For \code{se.fit=FALSE}, \code{predict.sscox} returns a vector of the evaluated relative risk. For \code{se.fit=TRUE}, \code{predict.sscox} returns a list consisting of the following components. \item{fit}{Vector of evaluated relative risk.} \item{se.fit}{Vector of standard errors for log relative risk.} } \note{ For mixed-effect models through \code{\link{sscox}}, the Z matrix is set to 0 if not supplied. To supply the Z matrix, add a component \code{random=I(...)} in \code{newdata}, where the as-is function \code{I(...)} preserves the integrity of the Z matrix in data frame. } \seealso{ Fitting functions \code{\link{sscox}} and method \code{\link{project.sscox}}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \keyword{models} \keyword{regression} \keyword{smooth} \keyword{survival} gss/man/gssanova0.Rd0000644000175100001440000002044412355360641014040 0ustar hornikusers\name{gssanova0} \alias{gssanova0} \alias{gssanova1} \title{Fitting Smoothing Spline ANOVA Models with Non-Gaussian Responses} \description{ Fit smoothing spline ANOVA models in non-Gaussian regression. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}} and \code{\link{glm}}. } \usage{ gssanova0(formula, family, type=NULL, data=list(), weights, subset, offset, na.action=na.omit, partial=NULL, method=NULL, varht=1, nu=NULL, prec=1e-7, maxiter=30) gssanova1(formula, family, type=NULL, data=list(), weights, subset, offset, na.action=na.omit, partial=NULL, method=NULL, varht=1, alpha=1.4, nu=NULL, id.basis=NULL, nbasis=NULL, seed=NULL, random=NULL, skip.iter=FALSE) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{family}{Description of the error distribution. Supported are exponential families \code{"binomial"}, \code{"poisson"}, \code{"Gamma"}, \code{"inverse.gaussian"}, and \code{"nbinomial"}. Also supported are accelerated life model families \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{weights}{Optional vector of weights to be used in the fitting process.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{offset}{Optional offset term with known parameter 1.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{partial}{Optional symbolic description of parametric terms in partial spline models.} \item{method}{Score used to drive the performance-oriented iteration. Supported are \code{method="v"} for GCV, \code{method="m"} for GML, and \code{method="u"} for Mallows' CL.} \item{varht}{Dispersion parameter needed for \code{method="u"}. Ignored when \code{method="v"} or \code{method="m"} are specified.} \item{nu}{Inverse scale parameter in accelerated life model families. Ignored for exponential families.} \item{prec}{Precision requirement for the iterations.} \item{maxiter}{Maximum number of iterations allowed for performance-oriented iteration, and for inner-loop multiple smoothing parameter selection when applicable.} \item{alpha}{Tuning parameter modifying GCV or Mallows' CL.} \item{id.basis}{Index designating selected "knots".} \item{nbasis}{Number of "knots" to be selected. Ignored when \code{id.basis} is supplied.} \item{seed}{Seed for reproducible random selection of "knots". Ignored when \code{id.basis} is supplied.} \item{random}{Input for parametric random effects in nonparametric mixed-effect models. See \code{\link{mkran}} for details.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is intuitive. For example, \code{y~x1*x2} yields a model of the form \deqn{ y = C + f_{1}(x1) + f_{2}(x2) + f_{12}(x1,x2) + e } with the terms denoted by \code{"1"}, \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}. The model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. Only one link is implemented for each \code{family}. It is the logit link for \code{"binomial"}, and the log link for \code{"poisson"}, \code{"Gamma"}, and \code{"inverse.gaussian"}. For \code{"nbinomial"}, the working parameter is the logit of the probability \eqn{p}; see \code{\link{NegBinomial}}. For \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}, it is the location parameter for the log lifetime. The models are fitted by penalized likelihood method through the performance-oriented iteration as described in the reference. For \code{family="binomial"}, \code{"poisson"}, \code{"nbinomial"}, \code{"weibull"}, \code{"lognorm"}, and \code{"loglogis"}, the score driving the performance-oriented iteration defaults to \code{method="u"} with \code{varht=1}. For \code{family="Gamma"} and \code{"inverse.gaussian"}, the default is \code{method="v"}. \code{gssanova0} uses the algorithm of \code{\link{ssanova0}} for the iterated penalized least squares problems, whereas \code{gssanova1} uses the algorithm of \code{\link{ssanova}}. In \code{gssanova1}, a subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \section{Responses}{ For \code{family="binomial"}, the response can be specified either as two columns of counts or as a column of sample proportions plus a column of total counts entered through the argument \code{weights}, as in \code{\link{glm}}. For \code{family="nbinomial"}, the response may be specified as two columns with the second being the known sizes, or simply as a single column with the common unknown size to be estimated through the maximum likelihood. For \code{family="weibull"}, \code{"lognorm"}, or \code{"loglogis"}, the response consists of three columns, with the first giving the follow-up time, the second the censoring status, and the third the left-truncation time. For data with no truncation, the third column can be omitted. } \value{ \code{gssanova0} returns a list object of class \code{c("gssanova0","ssanova0","gssanova")}. \code{gssanova1} returns a list object of class \code{c("gssanova","ssanova")}. The method \code{\link{summary.gssanova0}} or \code{\link{summary.gssanova}} can be used to obtain summaries of the fits. The method \code{\link{predict.ssanova0}} or \code{\link{predict.ssanova}} can be used to evaluate the fits at arbitrary points along with standard errors, on the link scale. The methods \code{\link{residuals.gssanova}} and \code{\link{fitted.gssanova}} extract the respective traits from the fits. } \note{ The direct cross-validation of \code{\link{gssanova}} can be more effective, and more stable for complex models. For large sample sizes, the approximate solutions of \code{\link{gssanova1}} and \code{\link{gssanova}} can be faster than \code{\link{gssanova0}}. The results from \code{gssanova1} may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. The method \code{\link{project}} is not implemented for \code{gssanova0}, nor is the mixed-effect model support through \code{\link{mkran}}. In \emph{gss} versions earlier than 1.0, \code{gssanova0} was under the name \code{gssanova}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (1992), Cross-validating non Gaussian data. \emph{Journal of Computational and Graphical Statistics}, \bold{1}, 169-179. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. GU, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## Fit a cubic smoothing spline logistic regression model test <- function(x) {.3*(1e6*(x^11*(1-x)^6)+1e4*(x^3*(1-x)^10))-2} x <- (0:100)/100 p <- 1-1/(1+exp(test(x))) y <- rbinom(x,3,p) logit.fit <- gssanova0(cbind(y,3-y)~x,family="binomial") ## The same fit logit.fit1 <- gssanova0(y/3~x,"binomial",weights=rep(3,101)) ## Obtain estimates and standard errors on a grid est <- predict(logit.fit,data.frame(x=x),se=TRUE) ## Plot the fit and the Bayesian confidence intervals plot(x,y/3,ylab="p") lines(x,p,col=1) lines(x,1-1/(1+exp(est$fit)),col=2) lines(x,1-1/(1+exp(est$fit+1.96*est$se)),col=3) lines(x,1-1/(1+exp(est$fit-1.96*est$se)),col=3) ## Clean up \dontrun{rm(test,x,p,y,logit.fit,logit.fit1,est) dev.off()} } \keyword{models} \keyword{regression} \keyword{smooth} gss/man/mkcov.Rd0000644000175100001440000000257312355360640013260 0ustar hornikusers\name{mkcov} \alias{mkcov} \alias{mkcov.arma} \alias{mkcov.long} \alias{mkcov.known} \title{ Generating Covariance for Correlated Data } \description{ Generate entries of covariance functions for correlated data. } \usage{ mkcov.arma(p, q, n) mkcov.long(id) mkcov.known(w) } \arguments{ \item{p}{Order of AR terms.} \item{q}{Order of MA terms.} \item{n}{Dimension of covariance matrix.} \item{id}{Factor of subject ID.} \item{w}{Covariance matrix; only the upper triangular part is used.} } \details{ \code{mkcov.arma} generates covariance functions for ARMA(p,q) model. \code{mkcov.long} generates covariance functions for longitudinal data. \code{mkcov.known} allows one to use a known covariance matrix in \code{ssanova9}. } \value{ A list of three components. \item{fun}{Covariance matrix to be evaluated through \code{fun(gamma,env)} or \code{fun(env)}.} \item{env}{Constants in covariance function.} \item{init}{Initial values for correlation parameters.} } \note{ One may pass \code{list(fun=...,env=...,init=...)} directly to the argument \code{cov} in calls to \code{\link{ssanova9}}, or make use of the \code{mkcov.x} functions through \code{cov=list("arma",c(p,q))}, \code{cov=list("long",id)}, or \code{cov=list("known",w)}. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \keyword{internal} gss/man/ssden.Rd0000644000175100001440000002111012355360641013242 0ustar hornikusers\name{ssden} \alias{ssden} \alias{ssden1} \title{Estimating Probability Density Using Smoothing Splines} \description{ Estimate probability densities using smoothing spline ANOVA models. The symbolic model specification via \code{formula} follows the same rules as in \code{\link{lm}}, but with the response missing. } \usage{ ssden(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, qdsz.depth=NULL, bias=NULL, prec=1e-7, maxiter=30, skip.iter=FALSE) ssden1(formula, type=NULL, data=list(), alpha=1.4, weights=NULL, subset, na.action=na.omit, id.basis=NULL, nbasis=NULL, seed=NULL, domain=as.list(NULL), quad=NULL, prec=1e-7, maxiter=30) } \arguments{ \item{formula}{Symbolic description of the model to be fit.} \item{type}{List specifying the type of spline for each variable. See \code{\link{mkterm}} for details.} \item{data}{Optional data frame containing the variables in the model.} \item{alpha}{Parameter defining cross-validation score for smoothing parameter selection.} \item{weights}{Optional vector of bin-counts for histogram data.} \item{subset}{Optional vector specifying a subset of observations to be used in the fitting process.} \item{na.action}{Function which indicates what should happen when the data contain NAs.} \item{id.basis}{Index of observations to be used as "knots."} \item{nbasis}{Number of "knots" to be used. Ignored when \code{id.basis} is specified.} \item{seed}{Seed to be used for the random generation of "knots." Ignored when \code{id.basis} is specified.} \item{domain}{Data frame specifying marginal support of density.} \item{quad}{Quadrature for calculating integral. Mandatory if variables other than factors or numerical vectors are involved.} \item{qdsz.depth}{Depth to be used in \code{\link{smolyak.quad}} for the generation of quadrature.} \item{bias}{Input for sampling bias.} \item{prec}{Precision requirement for internal iterations.} \item{maxiter}{Maximum number of iterations allowed for internal iterations.} \item{skip.iter}{Flag indicating whether to use initial values of theta and skip theta iteration. See \code{\link{ssanova}} for notes on skipping theta iteration.} } \details{ The model specification via \code{formula} is for the log density. For example, \code{~x1*x2} prescribes a model of the form \deqn{ log f(x1,x2) = g_{1}(x1) + g_{2}(x2) + g_{12}(x1,x2) + C } with the terms denoted by \code{"x1"}, \code{"x2"}, and \code{"x1:x2"}; the constant is determined by the fact that a density integrates to one. The selective term elimination may characterize (conditional) independence structures between variables. For example, \code{~x1*x2+x1*x3} yields the conditional independence of x2 and x3 given x1. Parallel to those in a \code{\link{ssanova}} object, the model terms are sums of unpenalized and penalized terms. Attached to every penalized term there is a smoothing parameter, and the model complexity is largely determined by the number of smoothing parameters. The selection of smoothing parameters is through a cross-validation mechanism described in the references, with a parameter \code{alpha}; \code{alpha=1} is "unbiased" for the minimization of Kullback-Leibler loss but may yield severe undersmoothing, whereas larger \code{alpha} yields smoother estimates. A subset of the observations are selected as "knots." Unless specified via \code{id.basis} or \code{nbasis}, the number of "knots" \eqn{q} is determined by \eqn{max(30,10n^{2/9})}, which is appropriate for the default cubic splines for numerical vectors. } \note{ In \code{ssden}, default quadrature will be constructed for numerical vectors on a hyper cube, then outer product with factor levels will be taken if factors are involved. The sides of the hyper cube are specified by \code{domain}; for \code{domain$x} missing, the default is \code{c(min(x),max(x))+c(-1,1)*(max(x)-mimn(x))*.05}. In 1-D, the quadrature is the 200-point Gauss-Legendre formula returned from \code{\link{gauss.quad}}. In multi-D, delayed Smolyak cubatures from \code{\link{smolyak.quad}} are used on cubes with the marginals properly transformed; see Gu and Wang (2003) for the marginal transformations. For reasonable execution time in higher dimensions, set \code{skip.iter=TRUE} in call to \code{ssden}. If you get an error message from \code{ssden} stating \code{"Newton iteration diverges"}, try to use a larger \code{qdsz.depth} which will execute slower, or switch to \code{ssden1}. The default values of \code{qdsz.depth} for dimensions 4, 5, 6+ are 12, 11, 10. \code{ssden1} does not involve multi-D quadrature but does not perform as well as \code{ssden}. It can be used in very high dimensions where \code{ssden} is infeasible. The results may vary from run to run. For consistency, specify \code{id.basis} or set \code{seed}. } \value{ \code{ssden} returns a list object of class \code{"ssden"}. \code{ssden1} returns a list object of class \code{c("ssden1","ssden")}. \code{\link{dssden}} and \code{\link{cdssden}} can be used to evaluate the estimated joint density and conditional density; \code{\link{pssden}}, \code{\link{qssden}}, \code{\link{cpssden}}, and \code{\link{cqssden}} can be used to evaluate (conditional) cdf and quantiles. The method \code{\link{project.ssden}} can be used to calculate the Kullback-Leibler projection of \code{"ssden"} objects for model selection; \code{\link{project.ssden1}} can be used to calculate the square error projection of \code{"ssden1"} objects. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. and Wang, J. (2003), Penalized likelihood density estimation: Direct cross-validation and scalable approximation. \emph{Statistica Sinica}, \bold{13}, 811--826. Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. (2014), Smoothing Spline ANOVA Models: R Package gss. \emph{Journal of Statistical Software}, 58(5), 1-25. URL http://www.jstatsoft.org/v58/i05/. } \examples{ ## 1-D estimate: Buffalo snowfall data(buffalo) buff.fit <- ssden(~buffalo,domain=data.frame(buffalo=c(0,150))) plot(xx<-seq(0,150,len=101),dssden(buff.fit,xx),type="l") plot(xx,pssden(buff.fit,xx),type="l") plot(qq<-seq(0,1,len=51),qssden(buff.fit,qq),type="l") ## Clean up \dontrun{rm(buffalo,buff.fit,xx,qq) dev.off()} ## 2-D with triangular domain: AIDS incubation data(aids) ## rectangular quadrature quad.pt <- expand.grid(incu=((1:40)-.5)/40*100,infe=((1:40)-.5)/40*100) quad.pt <- quad.pt[quad.pt$incu<=quad.pt$infe,] quad.wt <- rep(1,nrow(quad.pt)) quad.wt[quad.pt$incu==quad.pt$infe] <- .5 quad.wt <- quad.wt/sum(quad.wt)*5e3 ## additive model (pre-truncation independence) aids.fit <- ssden(~incu+infe,data=aids,subset=age>=60, domain=data.frame(incu=c(0,100),infe=c(0,100)), quad=list(pt=quad.pt,wt=quad.wt)) ## conditional (marginal) density of infe jk <- cdssden(aids.fit,xx<-seq(0,100,len=51),data.frame(incu=50)) plot(xx,jk$pdf,type="l") ## conditional (marginal) quantiles of infe (TIME-CONSUMING) \dontrun{ cqssden(aids.fit,c(.05,.25,.5,.75,.95),data.frame(incu=50)) } ## Clean up \dontrun{rm(aids,quad.pt,quad.wt,aids.fit,jk,xx) dev.off()} ## One factor plus one vector data(gastric) gastric$trt fit <- ssden(~futime*trt,data=gastric) ## conditional density cdssden(fit,c("1","2"),cond=data.frame(futime=150)) ## conditional quantiles cqssden(fit,c(.05,.25,.5,.75,.95),data.frame(trt="1")) ## Clean up \dontrun{rm(gastric,fit)} ## Sampling bias ## (X,T) is truncated to Tt)&(x<1) while(m<-sum(!ok)) { t[!ok] <- runif(m) x[!ok] <- rnorm(m,.5,.15) ok <- (x>t)&(x<1) } cbind(x,t) } xt <- rbias(100) x <- xt[,1]; t <- xt[,2] ## length-biased bias1 <- list(t=1,wt=1,fun=function(t,x){x[,]}) fit1 <- ssden(~x,domain=list(x=c(0,1)),bias=bias1) plot(xx<-seq(0,1,len=101),dssden(fit1,xx),type="l") ## truncated bias2 <- list(t=t,wt=rep(1/100,100),fun=function(t,x){x[,]>t}) fit2 <- ssden(~x,domain=list(x=c(0,1)),bias=bias2) plot(xx,dssden(fit2,xx),type="l") ## Clean up \dontrun{rm(rbias,xt,x,t,bias1,fit1,bias2,fit2)} } \keyword{smooth} \keyword{models} \keyword{distribution} gss/man/nox.Rd0000644000175100001440000000211412355360640012734 0ustar hornikusers\name{nox} \alias{nox} \title{NOx in Engine Exhaust} \description{ Data from an experiment in which a single-cylinder engine was run with ethanol to see how the NOx concentration in the exhaust depended on the compression ratio and the equivalence ratio. } \usage{data(nox)} \format{ A data frame containing 88 observations on the following variables. \tabular{ll}{ \code{nox} \tab NOx concentration in exhaust.\cr \code{comp} \tab Compression ratio.\cr \code{equi} \tab Equivalence ratio. } } \source{ Brinkman, N. D. (1981), Ethanol fuel -- a single-cylinder engine study of efficiency and exhaust emissions. \emph{SAE Transactions}, \bold{90}, 1410--1424. } \references{ Cleveland, W. S. and Devlin, S. J. (1988), Locally weighted regression: An approach to regression analysis by local fitting. \emph{Journal of the American Statistical Association}, \bold{83}, 596--610. Breiman, L. (1991), The pi method for estimating multivariate functions from noisy data. \emph{Technometrics}, \bold{33}, 125--160. } \keyword{datasets} gss/man/cdssden.Rd0000644000175100001440000000320612355360640013556 0ustar hornikusers\name{cdssden} \alias{cdssden} \alias{cpssden} \alias{cqssden} \title{Evaluating Conditional PDF, CDF, and Quantiles of Smoothing Spline Density Estimates} \description{ Evaluate conditional pdf, cdf, and quantiles for smoothing spline density estimates. } \usage{ cdssden(object, x, cond, int=NULL) cpssden(object, q, cond) cqssden(object, p, cond) } \arguments{ \item{object}{Object of class \code{"ssden"}.} \item{x}{Data frame or vector of points on which conditional density is to be evaluated.} \item{cond}{One row data frame of conditioning variables.} \item{int}{Normalizing constant.} \item{q}{Vector of points on which conditional cdf is to be evaluated.} \item{p}{Vector of probabilities for which conditional quantiles are to be calculated.} } \value{ \code{cdssden} returns a list object with the following components. \item{pdf}{Vector of conditional pdf.} \item{int}{Normalizing constant.} \code{cpssden} and \code{cqssden} return a vector of conditional cdf or quantiles. } \details{ The argument \code{x} in \code{cdssden} is of the same form as the argument \code{newdata} in \code{\link{predict.lm}}, but can take a vector for 1-D conditional densities. \code{cpssden} and \code{cqssden} naturally only work for 1-D conditional densities of a numerical variable. } \note{ If variables other than factors or numerical vectors are involved in \code{x}, the normalizing constant can not be computed. } \seealso{ Fitting function \code{\link{ssden}} and \code{\link{dssden}}. } \keyword{models} \keyword{distribution} \keyword{smooth} gss/man/mkrk.nominal.Rd0000644000175100001440000000245112355360641014535 0ustar hornikusers\name{mkrk.nominal} \alias{mkrk.nominal} \alias{mkrk.ordinal} \title{ Crafting Building Blocks for Discrete Splines } \description{ Craft numerical functions to be used by \code{mkterm} to assemble model terms involving factors. } \usage{ mkrk.nominal(levels) mkrk.ordinal(levels) } \arguments{ \item{levels}{Levels of the factor.} } \details{ For a nominal factor with levels \eqn{1,2,\dots,k}, the level means \eqn{f(i)} will be shrunk towards each other through a penalty proportional to \deqn{(f(1)-f(.))^2+\dots+(f(k)-f(.))^2} where \eqn{f(.)=(f(1)+\dots+f(k))/k}. For a ordinal factor with levels \eqn{1<2<\dotsd}. \code{mkrk.tp.p} generates the pseudo kernel, and \code{mkphi.tp.p} generates the \eqn{(m+d-1)!/d!/(m-1)!} lower order polynomials with total order less than \eqn{m}. \code{mkphi.tp} generates normalized lower order polynomials orthonormal w.r.t. a norm specified by \code{mesh} and \code{weight}, and \code{mkrk.tp} conditions the pseudo kernel to generate the reproducing kernel orthogonal to the lower order polynomials w.r.t. the norm. \code{mkrk.sphere} implements the reproducing kernel construction of Wahba (1981) for \eqn{m=2,3,4}. } \value{ A list of two components. \item{fun}{Function definition.} \item{env}{Portable local constants derived from the arguments.} } \note{ \code{mkrk.tp} and \code{mkrk.sphere} create a bivariate function \code{fun(x,y,env,outer=FALSE)}, where \code{x}, \code{y} are real arguments and local constants can be passed in through \code{env}. \code{mkphi.tp} creates a collection of univariate functions \code{fun(x,nu,env)}, where \code{x} is the argument and \code{nu} is the index. } \author{Chong Gu, \email{chong@stat.purdue.edu}} \references{ Gu, C. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Wahba, G. (1981), Spline interpolation and smoothing on the sphere. \emph{SIAM Journal on Scientific and Statistical Computing}, \bold{2}, 5--16. } \seealso{ \code{\link{mkterm}}, \code{\link{mkfun.poly}}, and \code{\link{mkrk.nominal}}. } \keyword{internal} gss/INDEX0000644000175100001440000003171712355360640011673 0ustar hornikusers## SSANOVA, GSSANOVA, SSDEN, SSCDEN, SSLLRM, SSHZD, AND SSCOX SUITES ssanova Fitting smoothing spline ANOVA models predict.ssanova Predicting from ssanova fits summary.ssanova Summarizing ssanova fits project.ssanova Projecting ssanova fits for model diagnostic ssanova9 Fitting smoothing spline ANOVA models with correlated data summary.ssanova9 Summarizing ssanova9 fits project.ssanova9 Projecting ssanova9 fits for model diagnostic ssanova0 Fitting smoothing spline ANOVA models predict.ssanova0 Predicting from ssanova0 fits summary.ssanova0 Summarizing ssanova0 fits residuals.ssanova Extracting the residuals from ssanova objects fitted.ssanova Extracting the fitted values from ssanova objects print.ssanova Print function for ssanova objects print.ssanova0 Print function for ssanova0 objects print.summary.ssanova Print function for summary.ssanova objects gssanova Fitting smoothing spline ANOVA models with non Gaussian data gssanova1 Fitting smoothing spline ANOVA models with non Gaussian data summary.gssanova Summarizing gssanova fits project.gssanova Projecting gssanova1 fits for model diagnostic gssanova0 Fitting smoothing spline ANOVA models with non Gaussian data summary.gssanova0 Summarizing gssanova0 fits residuals.gssanova Extracting the residuals from gssanova objects fitted.gssanova Extracting the fitted values from gssanova objects print.gssanova Print function for gssanova objects print.summary.gssanova Print function for summary.gssanova objects print.summary.gssanova0 Print function for summary.gssanova0 objects ssden Estimating probability density using smoothing splines d.ssden Evaluating pdf of ssden estimates project.ssden Projecting ssden fits for model diagnostic ssden1 Estimating probability density using smoothing splines d.ssden1 Evaluating pdf of ssden1 estimates project.ssden1 Projecting ssden1 fits for model diagnostic dssden Evaluating pdf of ssden estimates pssden Evaluating cdf of 1-D ssden estimates qssden Evaluating quantiles of 1-D ssden estimates cdssden Evaluating conditional pdf of ssden estimates cpssden Evaluating 1-D conditional cdf of ssden estimates cqssden Evaluating 1-D conditional quantiles of ssden estimates print.ssden Print function for ssden objects sscden Estimating conditional density using smoothing splines d.sscden Evaluating pdf of sscden estimates project.sscden Projecting sscden fits for model diagnostic sscden1 Estimating conditional density using smoothing splines d.sscden1 Evaluating pdf of sscden1 estimates project.sscden1 Projecting sscden1 fits for model diagnostic dsscden Evaluating pdf of sscden estimates psscden Evaluating cdf of sscden estimates with 1-D Y qsscden Evaluating quantiles of ssden estimates with 1-D Y cdsscden Evaluating conditional pdf of sscden estimates cpsscden Evaluating 1-D conditional cdf of sscden estimates cqsscden Evaluating 1-D conditional quantiles of sscden estimates print.sscden Print function for sscden objects ssllrm Fitting smoothing spline log-linear regression models predict.ssllrm Evaluating log-linear regression model fits project.ssllrm Projecting ssllrm fits for model diagnostic print.ssllrm Print function for ssllrm objects sshzd Estimating hazard function using smoothing splines project.sshzd Projecting sshzd fits for model diagnostic sshzd1 Estimating hazard function using smoothing splines project.sshzd1 Projecting sshzd1 fits for model diagnostic hzdrate.sshzd Evaluating hazard estimates hzdcurve.sshzd Evaluating hazard curves survexp.sshzd Computing expected survivals print.sshzd Print function for sshzd objects sscox Estimating relative risk using smoothing splines predict.sscox Projecting sscox fits for model diagnostic project.sscox Predicting from sscox fits print.sscox Print function for sscox objects ## UTILITIES FOR MAKING MODEL TERMS mkterm Making model terms mkphi.cubic Making phi function for cubic splines mkrk.cubic Making RK function for cubic splines mkrk.cubic.per Making RK function for periodic cubic splines mkrk.linear Making RK function for linear splines mkrk.linear.per Making RK function for periodic linear splines mkphi.tp Making phi functions for thin-plate splines mkphi.tp.p Making pseudo phi functions for thin-plate splines mkrk.tp Making RK functions for thin-plate splines mkrk.tp.p Making pseudo RK functions for thin-plate splines mkrk.sphere Making RK functions for spherical splines mkrk.nominal Making RK function for nominal factors mkrk.ordinal Making RK function for ordinal factors mkran Generating random effects in mixed-effect models mkcov.arma Making covariance function for ARMA models mkcov.long Making covariance function for longitudinal data mkcov.known Passing known covariance function to ssanova9 mkint Generating integrals of basis terms for ssden1 suite mkint2 Generating integrals of basis terms for ssden1 suite ## UTILITIES FOR DISTRIBUTION FAMILIES mkdata.binomial Making pseudo data for logistic regression dev.resid.binomial Deviance residuals for logistic regression dev.null.binomial Null model deviance for logistic regression cv.binomial CV score for logistic regression y0.binomial Preparing for KL projection of logistic fit proj0.binomial Making pseudo data for projection of logistic fit kl.binomial Computing KL distance between logistic fits cfit.binomial Computing constant logistic fit mkdata.poisson Making pseudo data for Poisson regression dev.resid.poisson Deviance residuals for Poisson regression dev.null.poisson Null model deviance for Poisson regression cv.poisson CV score for Poisson regression y0.poisson Preparing for KL projection of Poisson fit proj0.poisson Making pseudo data for projection of Poisson fit kl.poisson Computing KL distance between Poisson fits cfit.poisson Computing constant Poisson fit mkdata.Gamma Making pseudo data for gamma regression dev.resid.Gamma Deviance residuals for gamma regression dev.null.Gamma Null model deviance for gamma regression cv.Gamma CV score for gamma regression y0.Gamma Preparing for KL projection of Gamma fit proj0.Gamma Making pseudo data for projection of Gamma fit kl.Gamma Computing KL distance between Gamma fits cfit.Gamma Computing constant Gamma fit mkdata.inverse.gaussian Making pseudo data for IG regression dev.resid.inverse.gaussian Deviance residuals for IG regression dev.null.inverse.gaussian Null model deviance for IG regression mkdata.nbinomial Making pseudo data for negative binomial regression dev.resid.nbinomial Deviance residuals for negative binomial regression dev.null.nbinomial Null model deviance for negative binomial regression cv.nbinomial CV score for negative binomial regression y0.nbinomial Preparing for KL projection of negative binomial fit proj0.nbinomial Making pseudo data for projection of negative binomial fit kl.nbinomial Computing KL distance between negative binomial fits cfit.nbinomial Computing constant negative binomial fit mkdata.weibull Making pseudo data for Weibull regression dev.resid.weibull Deviance residuals for Weibull regression dev.null.weibull Null model deviance for Weibull regression cv.weibull CV score for Weibull regression y0.weibull Preparing for KL projection of Weibull fit proj0.weibull Making pseudo data for projection of Weibull fit kl.weibull Computing KL distance between Weibull fits cfit.weibull Computing constant Weibull fit mkdata.lognorm Making pseudo data for log normal regression dev.resid.lognorm Deviance residuals for log normal regression dev0.resid.lognorm Pseudo deviance residuals for log normal regression dev.null.lognorm Null model deviance for log normal regression cv.lognorm CV score for log normal regression y0.lognorm Preparing for KL projection of log normal fit proj0.lognorm Making pseudo data for projection of log normal fit kl.lognorm Computing KL distance between log normal fits cfit.lognorm Computing constant log normal fit mkdata.loglogis Making pseudo data for log logistic regression dev.resid.loglogis Deviance residuals for log logistic regression dev0.resid.loglogis Pseudo deviance residuals for log logistic regression dev.null.loglogis Null model deviance for log logistic regression cv.loglogis CV score for log logistic regression y0.loglogis Preparing for KL projection of log logistic fit proj0.loglogis Making pseudo data for projection of log logistic fit kl.loglogis Computing KL distance between log logistic fits cfit.loglogis Computing constant log logistic fit ## UTILITIES FOR NUMERICAL INTEGRATION gauss.quad Generating Gauss-Legendre quadrature smolyak.quad Generating Smolyak cubature smolyak.size Getting the size of Smolyak cubature ## UTILITY FOR OPTIMIZATION nlm0 Minimizing univariate functions on finite intervals ## NUMERICAL ENGINE sspreg0 An interface to RKPACK driver DSIDR mspreg0 An interface to RKPACK driver DMUDR sspregpoi Performance-oriented iteration using RKPACK driver DSIDR mspregpoi Performance-oriented iteration using RKPACK driver DMUDR getcrdr An interface to RKPACK utility DCRDR getsms An interface to RKPACK utility DSMS sspreg1 Compute regression estimate with single smoothing parameter mspreg1 Compute regression estimate with multiple smoothing parameters sspreg91 Compute regression estimate with single smoothing parameter mspreg91 Compute regression estimate with multiple smoothing parameters sspngreg Compute NG regression estimate with single smoothing parameter mspngreg Compute NG regression estimate with single smoothing parameter ngreg Newton iteration for NG regression with fixed smoothing parameter ngreg1 Performance-oriented iteration using sspreg1 and mspreg1 regaux Obtain auxiliary information needed for se calculation ngreg.proj Calculate Kullback-Leibler projection for NG regression sspdsty Compute density estimate with single smoothing parameter mspdsty Compute density estimate with multiple smoothing parameters sspdsty1 Compute density estimate with single smoothing parameter mspdsty1 Compute density estimate with multiple smoothing parameters mspcdsty Compute conditional density estimate mspcdsty1 Compute conditional density estimate msphzd Compute hazard estimate with single or multiple smoothing parameters msphzd1 Compute hazard estimate with single or multiple smoothing parameters sspcox Compute relative risk estimate with single smoothing parameter mspcox Compute relative risk estimate with multiple smoothing parameters mspllrm Compute log-linear regression model with multiple smoothing parameters