gss/0000755000176000001440000000000012250404343011073 5ustar ripleyusersgss/src/0000755000176000001440000000000012247272074011674 5ustar ripleyusersgss/src/ddeev.f0000644000176000001440000002262612247272075013143 0ustar ripleyusersC 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.f0000644000176000001440000002033312247272075014065 0ustar ripleyusersC 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/Makevars0000644000176000001440000000005612144464546013374 0ustar ripleyusersPKG_LIBS=$(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) gss/src/smolyak.c0000644000176000001440000016503512247272075013532 0ustar ripleyusers/* 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.f0000644000176000001440000001647512247272075013015 0ustar ripleyusersC 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.f0000644000176000001440000001602612247272075014356 0ustar ripleyusersC 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.f0000644000176000001440000000364512247272075013200 0ustar ripleyusersC 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.f0000644000176000001440000000361212247272075013361 0ustar ripleyusers 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.f0000644000176000001440000000176412247272075013013 0ustar ripleyusers 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.f0000644000176000001440000000504212247272075013013 0ustar ripleyusersC 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.f0000644000176000001440000001613712247272075013250 0ustar ripleyusersC 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.f0000644000176000001440000003164312247272075013356 0ustar ripleyusersc 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.f0000644000176000001440000000376012247272075013217 0ustar ripleyusersC 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.f0000644000176000001440000002436712247272075013536 0ustar ripleyusersC 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.f0000644000176000001440000000456612247272075013155 0ustar ripleyusersC 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.f0000644000176000001440000002125612247272075013355 0ustar ripleyusersC 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.f0000644000176000001440000000262512247272075013131 0ustar ripleyusersC 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.f0000644000176000001440000000522312247272075013137 0ustar ripleyusersC 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.f0000644000176000001440000000444412247272075013146 0ustar ripleyusersC 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.f0000644000176000001440000000263512247272075013165 0ustar ripleyusersC 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.f0000644000176000001440000000252212247272075013347 0ustar ripleyusersC 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.f0000644000176000001440000000140012247272075013232 0ustar ripleyusersC 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.f0000644000176000001440000003621512247272075014217 0ustar ripleyusersC 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.f0000644000176000001440000000450512247272075013122 0ustar ripleyusersC 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.f0000644000176000001440000004221312247272075014247 0ustar ripleyusersC 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.f0000644000176000001440000001625212247272075013671 0ustar ripleyusersC 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.f0000644000176000001440000001234012247272075012621 0ustar ripleyusersC 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.f0000644000176000001440000000206112247272075013150 0ustar ripleyusersC 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.f0000644000176000001440000000133012247272075013226 0ustar ripleyusersC 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.f0000644000176000001440000000173512247272075013211 0ustar ripleyusersC 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/0000755000176000001440000000000012236246664013175 5ustar ripleyusersgss/src/ratfor/hzdnewton.r0000644000176000001440000001615511613066706015403 0ustar ripleyusers #::::::::::::::: # 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.r0000644000176000001440000000767710655757270014475 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000001013210655757270014525 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000000544010655757270014670 0ustar ripleyusers #:::::::::::: # 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.r0000644000176000001440000000524610655757270014465 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000001536010655757270014475 0ustar ripleyusers #:::::::::::: # 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.r0000644000176000001440000000660410655757270014467 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000002510010655757270014555 0ustar ripleyusers#::::::::::: # 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.r0000644000176000001440000001424711656516526015211 0ustar ripleyusers #::::::::::::::: # 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.r0000644000176000001440000000150010655761724014551 0ustar ripleyuserssubroutine 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.r0000644000176000001440000000152210655757270014550 0ustar ripleyuserssubroutine 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.r0000644000176000001440000001051410655757270014460 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000000676310655757270014345 0ustar ripleyusers #::::::::::: # 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.r0000644000176000001440000001551211560174072014657 0ustar ripleyusers #::::::::::::: # 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.f0000644000176000001440000001707112247272075014233 0ustar ripleyusersC 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.f0000644000176000001440000000246312247272075013144 0ustar ripleyusersC 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/NAMESPACE0000644000176000001440000000306212246632403012320 0ustar ripleyusersuseDynLib(gss) # export user functions 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) # 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/0000755000176000001440000000000012247272076012020 5ustar ripleyusersgss/data/LakeAcidity.rda0000644000176000001440000000740512247272075014700 0ustar ripleyusers‹]X 7¥Î½u¸wè{e‘CKäÐ ŽD\žàjÖy•ˆû†ò"ž[2x˳yÄhË3îj+ÝךPpŸˆ•ä/"ž[É_ݶïuƒ˜ôMÏ-!F}iZ‰±<+{É_ĘK¢5c# ÏåÇÌ'ÜËÓ &ÆÏä£PßëËaiâ÷¥($b/â2¾ 'JÄoŒy|·PW„õDBþ¡} †#Ì'Fݼ"¡Ž0"?AG1ê ÐCà‡uM@~×òùLPSÄm*øy›"…ß„:B]¯°©Ï<.ê3®ÓÁ¾©aýþ|=ª…ï õ ã¿òqÔ>/կףî¢Ú<ªÇÄ©‡:+c½)ü=õ ç50o;ß7ê3®³à㩈K÷7õ‘÷Õ¸Ú¿ 望_Oõòý zo'Æ ëÞñzRÏ0¾óã'¼ÿBžÏù}£àÿ•ןú€¸;p¾qwðºPÍ|?¨äÝŽþÖÁþ«ð÷ÔG¬#èÐõÞò~ ^¢~ZØwÛ.>¾õøÂï+ª×õ þ.Ìßçƒ úTù¶ñúR_ÐgJˆ÷9êо„|¿b¾OèS%äÝûOûj€ûÐ÷ñ`RàñŽðýp D=? ûa ±Ÿè#Å÷! ¿®j8^Lè‹<út‹ÉÌñ ]Á}n !t¥ÝÕê¶ZBŸ]âûaØBï×ý8w6¡ãJþ²ì’:¶»øÁ?¶„ŽçûCÇE?¼Ø¹œØyEo|âsœØMmyÓ=ó±³rÓ' »A~§*}»ìöòȽ„n8>iõÿÕ/Ø:ÿûiW†¸RjÝ;èá\ž/í§uÈ~Â.B{\ü>?‹Ã·Ù‘Y}Ì“Ð>ÏNîËCè5&^þî ¡\ø­j` ¡%?NûhÎü~¦mK¶sL=ŸOÃu“y¼4Ùîï3‹Ð¥È¿hfJD¿Ñ„Îã¢Bç”ÿžý ¡3q^†¸³øý@ïå}Bo»'skþDè]ÈSÐÉïÑ ÷½œNΣ´CTçz¡tNPD‡×,öoÕ“„v::n¢ä§ÿáLE]¥˜ßïgò¾¢É”Ò|«,Bß}t¬Gèhì_I{¿¸ —ˆú®Ìkd¨pú#Þ®ç"Oó;Äîòz‚ñw±Ïéüs:†÷!Zzè¬6¡ÛÚ-os'ôè©o'Ýãú¯¶æ\ÉvBˆç\GhÜ'ä3_‡4ðùI#¯y0ãAØšó„ü.=±è»Ý„ ¯Èé­§¿Un $gêžeó; ¹iœ{ù×jBOD=›78òš+÷?Dõ;s^rëÖÂé7&‚>&=ØW[ç Ÿs:ð¼éG¼~¤}›…xãxÝÈ}ô›õÑdí§M„ÜÕÖsi"¡g¡Ðä›ëþ[ mˆÐç¼.v‘¨›ê)âì¹™Ó9‚×ÁnHýÞº€éÄnlç²3rzå;ˆêú¯ö!Ëôp`™/!ªs­`%ý¹mÀ¶²ÌÑ÷çfËjX¦P^e.É÷Ë”ÍúSÿè8–¹q¿±“e*e= þÄ2W˜jÎÁ,Ãâóþ \žéòselï}]Ì2ëÕ~0,g™n®Í·¯²Ly›û°hM–yW4y‹î~–y%ß,óš¿— ŒúzñûV2¦oùù¹Á2±òó‹eâßµ©Ž¿Û°ÌÕwÍñÑOÔE&ß?,“øë0®LíõüX–)Îi…S.,“ß3¢×â.OZÜ¢¦é,s—çÁÜWònŒ)f™zù9Ê2µ}p¸¼M7~>âÊ2Õò>²-ÔcG2ˆï›D´þbì3–yzÿ±ˆ3—§ ñ“ïs–ù†ó~¨wn!õ²Ú”uº…} åë0)}ò;²LöÉ¿®ËÈ7NFô‰z<[–y›d=¶j ËÜcwéù¥s8Ð'··†Üÿ¬D•_'è!Ñ—ïo–á÷%+ÑÅþE~ä¾çîÑŸ+xœ=Ô9 qUòü%:¼%ØgÈ+ý‰ë5‘‡æÙÅ㨠.q§‚ÏÓyÿ1þ¸/Z°î|¼DK~.²N/q±’ÁˆŸÿC‹e¢û쨭ÀÁ\–Ÿpÿ'öíçm7½Þ¸nd#Ê-È]{‚vyc»g¹Ú'; …ˆ¸"ÍÛE;yAmèRˆÍnM¬c!Q6õÕ€C5¸8AÏm”7Ä·¶Å[DB|À»qV3}¨ŒÞ—òPñúRM*vÿ†|ײ3TÀC½ú!ËkÅ’´Ÿ áð•ÍI/!£ô½Mí¥~^ê“pˆ‚ôçsÓ†WÛ@Þ•Å–7Ù@ÁŠÍuê/  ǪâÝûB]ÏT÷9 ˯ö»1Òh›ó›Ï.„”ukÝN=‘AAØ€Ù[42'Žf¾ûlº ‰ñ±O|RWB¢î¤Š¥TÄ;$Øw5C¸ò„dOl9`d™<^’Ü–J¶«]Øðo_æÿFAäÖ†ç%¶aXø:ô·Ÿ!ñhÀpº¾¤¢iA“lªAêÕ1¿& ’çþ~ºb˜ìç×;ªl¤z/ôùSû?è<7ò†¬î|¡å yöü^¢Ü yÿ8÷8·€¬"|t³Æ6Ȩ¹8àöÝ`Ø¿sm¬èì.Èliy!®›»ã]2óÕ Û¥'2öÝJj]’ï½¶Ê6âmÿVë õ¤ìƒÕK®Ç,€_u ä‡eðßVsÄn2å ݰB©î9Ë™#²~Ïè×CNÛêÇÜBÈP²stî·¤ÎLà )da)¸&¼²öØÐ ¹÷öuuÍ¥Öx{ïV»0Õw¯¸î„ŸÕ%¶ø6 ufÌ2ÈY>±«øl„2´pnåÓbÑ2ÜøùúˆÏTò¥&‡U´&äéDûYZEÉ–š-¨~1²/ï[2rôd™­}Ûå gÓ§§ý ^Ú‘?<+pÄmPîx}’ò_aéâEy××±ìåæ1Ñ~ =¸b_QéÏéT`ë¼·iC")Ýy ±ïmÀ#¸ÒZâfÞ6VoõÕKÏ©ÂZÃÎ/FjàíáT+˘NeR¢$qýaJú´õHʃZJjü°V/ž¢â«{4vœÝDmU» ®QÛÿP*¹p¤Pßöͼu1¯^Âò\§O½–ÁÊ%_š]ú¿Ÿ·2ãò"SÇßKƒˆ°QJëÖyBH¦Õ٬䑮³¦\½Yvj\Ð0¨„¨ïÏÍÍ!ʫ̣vå4ˆZµnk^£#Äݵ(]{D™Óø‹?Äç¾qx”ñ.>(˜ 1NîGþ’¥Ö4Þ.Ù½—rÈö0uÒ­iqs~ý+ft©§€ã³“–7`B-sJN,ðô)™¢~)–‡é×J¼Ç¿±fãfØX¬vSRüB¡Óvæé[Ïú.ˆT9Qx¹¢JÄ*:ƒa¯~Q`—N:ì±{ÐuSüAÓõ[ë6Ñ„~°z^È~•lO-¯© ÷„èãUË&KJ æäyßGºêÔ6Ë—¥Wa½cÑ´ÒÚÔ²z“øì§àÑžöÀ vYe\ZcŸJÅWÙ.;|ŠzêgúñL •o½ušÕù±T¸¬4$oö¨­=NZåPKËcMRÆÀz•QŸÙævØ<ýö‘sžE5ȩ;«úÃþlóµÇм!õÀ³kÊ EçØ?—æçCêM/‹kFVjœi}'²v½Ý ™M?Zú)CÖTW¯í3 OËiÀRׇ—Te°çw®$lmÐ7ÄÙùR哇O@¢øKíø®vj§ù8±ôlän[‘|LN%uÝ-ïx´²éÜ%ëvAî-ßÚ®°{6üVÜ+')¤Hm,žâL-;/el£Â5^ÎùN†t2è¨UV,ÜšúwEÄ{ðÖ¨ßn1y%dmn»íù"âfÜlŽ]Yu«,ëeAtBJvÔðá ÿ¥i¾;ZáAå¾N."d$M«‰«,¥rc6µ¯0{Ék"Vª6Í„äÊ«ók ðqá?/'ÕQ‰Cg»’Ç ¨¤?ÆßUú: F~­|}{Îý”ªêá³¾“ÿÚÊý™Êÿ¢Á…ø¹mð â®õ1î÷(¿æc”C„‹Ð­Vw÷u ÂpaRú%ˆOóÿÁBòŸtùI•o¬»›¯péë¶Iqéï'ä]ëé¿ö_95ý7[yå<ùÞÞÞD>P­÷_à´<Ü6¹YxrKé·ÿ|úÑ6“gss/data/ozone.rda0000644000176000001440000001234512247272076013647 0ustar ripleyusers‹][lUgvÞ!T:ƒÚÊJ­ÊVu„…B᳃íãËÁ>6çÇÆ |=™d:“=ašÉ0„q&Ì4% ™!)JÓJ‘ºÕJQªŠ‡jTE}°*TU}ˆ¨”‡<Œ¢’žïÛÑúØ‹í Rf±÷þ÷¿îë_ÿ÷ïÔ Ö-;°,‚%ÁãÁcÁ’Çüué’ÿóX°4øÎú§_<}j4ÿ“_üãÏ:Ã\ðÿÂz¡  uBy¿Ñ¹_ï¼×(Ï—ËóœóžÊ³\®I›@W¿•ò^ ür÷U¿¼cŸœð¥<«iŸ‘ è“ keþÅÊÛ(´ÁÑ;/ö"mûm½ò"w^Æóþj¹ß$r-wøë|žý–‹\õÂ…‡Ÿ9ç~“øe£ãòi]'úhsÜЧÄîMâ'õ åXº4Œjt3®·‹<›dÍ“fÇþO ?­M2_‹Ø©Eæ_-v[îøIõWûoýW‹š7«äùF™Ÿòo>O9úë¼[d^}®ù¹ZâHýªuJë’ÆÛÑo•èµQøQÞPìHÿï½[„®;©½·ˆ<9yþ”ÄIÎÉë¼È±Ê©7^þÔ;ëaÈ­yÐêÔŸFÑ_ïo{¯süíÕõ•ëŽÖg]7u=Y鬟ë…³3/®·ßwì×ä¬ï«ûi}Zíôß–68zæ2ú¨z‡1OÃ7çÌ—wú±oÒWÞ)Õžß)€"?ï½"´ ô¼Œçûs Ÿ‚~zWž7;ï Ÿ'dü' ‰|7ä9å«Pxû· µ ?þ/\]ý;‘£9]®Ûÿ#rŸºEÞ–û9±Ã¸C©Ç‡ ¡Ç?ãúV;¸þÐWdÜ"G$üæÄ¾‘cB©_Iî—ÄÎ_ y/±k³•÷öjÐ÷¬_9ObŸ/,ŸÄðëíPüÏñÖ~‰ž‘Øã€Œ+‰ÝªÖ^‰½Ÿ}5ŽÇÅ.ÍÎ{Ã"óíËýÍ\&yqCø”œøS¿huô»!×W¿jÙb׫DÎOœõ䆨«*q–wüö‘ØëÆŸK].ÈxɇÄê9Ç/^lrêÚGB?»FRGçd¼>¯fÄ×5ʺšsÖ—’¬»_9}Ëf½MúʺEâ^^ŸÏ軽þ¹.£ß®súò\Æ}å“ÏØ4:ûÅ?sò×gÈ¥r49û,{7:ø[SÆxO¾åùóê}J]†²üÛàìÜqõŽßê¸ÛàÌÛèÈ×èà ø}½#gcNŸ…_牗çi?Çöð‚z'Î9ï7dÄGÞ±gƒÃ¿ÁÁê3ò1Kÿ\F©[äyLcFüç3äiÈÈ—œ£ƒõNdé_ ß7ñò³1ã~}†¼õ«[yçº1Cx¨wôÈ:ÿkpò+ŸqT·Èuªa‘vÊŠsO¾ü"ëe.Ãþu².I$÷_îÄQ}úGårç2ü›wÖÓÀYGGžºty+·ÚÍ“'2â¦n‘xlà•Ľw¢¯-‚ö…ÏçùJ÷{äÜ¡MÎ#Z‚GS¾_ÓŸo‘q} ½Î|Ûä\„÷û«¯9Ïê%ãËB9ot/ä)Evž^Ê‹ëÈö9ž=8~Æwáº×ÝåWm§ýq½[øuó¾È_ùKr^J=:åý’èÕíèG{õÃî}±}Ny7ôo›èUÿõÆöšvbÜîÚ-zö3ŽBË¿(ñ¸#²”ïÅ®ô[O`çí—ù ‘õg»ø¡KüÀ÷i7Ú±Wüß/´Œñ˜gŸÄõ¯v ¬ßyM9¨o,ù[ùB›?ûuœÄ=ó¼Wæ)É|”³GÞOæ•ù{5ÿC;oWR¿xŽÊøÚ%ùEõ‹\½aº~j§½2žq¢òpÞ²äÇ•õZêô¾ÈÆCYò±_Ÿ;ùÓ¥ú ?ÆÃÍƒÐæwäKYêD·ÄAYÞ/‡Ž¡ÔQɯ‡ÆI¼”E¿‘coœ>O¿ø§OÇ麦û#¹–<Û/véS?ˆ]úùu½)ËzÈ÷—ýAz½IâWâ¥Cä/«Å.¬«O:}ëà.9—×õ£]ô'¿nÉ_òåü›å\¿ õ½_òõgo˜nŸž`q}Ò­R§:q¡äÍ–ß“_‹ÌÃuÏãÛ-vé¿1¿ö†¶¯,ˆŸè‡²Î³®¤Ðu½(óôÿ¤ÞÇVŸ® ý=ÖË¢ô9=QzýÕõQû´Ò?µÊýÝÒg´ÏqìAÚ‘e·(]Ÿ¢ôm]âÇN±{Aäß,÷•O‡“»Eîná[»öÉz³CâRûík{ÈzÝ-ù¹GìM9vé}_‡ð/DéùÓ.vÚ!÷)O(}}1H¯ç}az¶ý)×û}Î>´Oúwö%ûâôë}AºüýÒÇ h? û‰ÈÊ¿Wü®q¡vÙ+}[Yü×+öÓã¢'JsÝÏk_W–xHô~”/±ch÷/û¥/ÛïôMÎ>p@žw:}>íÞ¥÷±¤:¾7Lß×kük>õHîqúZíãú¤OW}õ¹îûœ}O¯ìï÷8u®Gò¸Kú–’£w¯ÈÓçÔ¿YÇvIÝn¾¥ }¤uPí_’8(I¿²Cú‰6]ÇåºGìT;…AæíˆÒû„NÉ?íË:DŽŽ(¯®Úçíº™ô•×–Õî¿|´<¤WEÿ[_£—jÔáµkô{ó‹›O噃¯BÏ*ôøuùÛÍGz³ùÑÏÏÔ>Lgào|øƒÈÚõ%Øÿòk5ú Þ ~|þ¢Õû5ð}cÎÑß̉|ßß7î×è£ÅéùöwÓïG•G¿÷îÌ£Ÿ¿N»Ô<ÂîÂnu°/¾/ú×oâ;–ב7¯®tæ…~ça×s› øMKüü,gãyz ô5ðÿêäYØõô{r]þ¾wýÅ}×óøþöÌwëqõâ âá&ìýìûë÷ÿøòôz rüß9ýê?!âû­ÿ†ÈŸ÷þãÑþ¸ðïÖ~ÔûlêêÂEÄ×¥mòì{óÅûg Ïl­‹/ ~¾\;è Äú‚88‡|™gÝ‚¯1ŽQßÄý ÷m>]Âöž†~ïbÜ%Ô÷÷ñýãõû6OµßÊÒëÇNÿqó_÷>ëÓûmé|oZ³¯ŒsÅ›÷ÂïÅbœ ÅíAœ°Qðøû~¬ß5è9P›Ý/Ä+­›%Žd}¦Ý»ç‹Wò¡‚çCèÏ¢Äó# ÏFöü†ç £è‹€V°Ï<…ùŽb¾Q¼wãŽãþ¡ÈöäÏö¼ã0öÙÇE®£xÿT$|)glëK ëÜN9wÙ!õ€÷¹^Ñ>›¤NRÞ æmÝåú¼_äb]^°vظÎÛõ€q8‚q§ð|÷Ga¯áØöiŒ¥?ð|ŒöÇõÞŸÂõļ•›ò—¸š·|Ÿ†ü‡1n¼bó÷‡+ÖNÌó±ËoãFòVRÎǸê–óÚùHÞúã4øL‡9Y»œ¬Ø¸\¯è÷‘ÛG°¾ ìz1Jþདy+7óýG—œ÷öÉþ1©O Ö~äücrãŽ-X¿SoêÓ%ûµ¢ôä7ÄzW±|“ûâÖË#²ËÛu­‚qO³ l}£÷Ëú«ß—¥¿£?¥Î09O›ô•Ì×AÙ—’ò>Ç Ò)×!î“Çä½1¹ÏñÜ÷ Eéã9nHÎó/ÃÒ—D®Ù÷ ŠÔsvÁòŸ•uYé˜cÕ“òxó(: ó×Qyh'¥ƒò|LìäÉév_ëðSyh'ÕSí9%~U¿)Uù5^Uo^«»ªƒôz5(t«ømHâvЙWãZõ8(þë‚ìÖŠEç}OOµCAÞÌx_ùxz{uÅ‹ë!Y7ZEß§žyvÖyUžg\–¿ÅîÇ¥ ÿ$¿ÇräÓy Ž¿t>¥j­ÇƒAzÜ•œ÷ÆœuyÖ¥×^·:öZ+q^'ò´:òyy0=:NŠNžõeÔ]ßYöÔù‹Nè:ˆý%¼º? ϵoÐçE'§2âK× ‡¢Èï­kcŽŸÔ®u"_«Pű[ƒô¸×¾ ËZ§Tî©8ÝŽÃ’OcN“–œyt=ÔùœxôßE§=½ßýç[!8·âß«n–8_'çKëgß(ç}zN¿UΑZ_ åüCïAÜŠ8å.Áù ‚WívÎkô|‡ç`‚³èï®:e_Õ%ø¢þŽE'§¿Cè÷¨rž¦ß9÷ɹ•þŽ´,ç›ú»Aý]~çžüŽŽûìО›ê¾›ßÝïsððäû{Á{v_| ²xHRŸ¸b½'ØýÜÓ‚‹qßG<âÁÕŸ%ÎÚ}ø³‚·?‡çÏEWMÖöÁ‘=' .pHΈ[×ã~•ûã Ï /澘øÏ'’õï -Xœ•¸;qIîc‡ß$NEÜ‘ç Äù'NpxÞâ‡Ç$®Ú}>÷õÄ/ˆ¯? ¾F\—ø÷ÿÄÉs_%®@¼‰¸(q›#‹Gò\áˆàûG‰Wå-nM\Ž8ÖC¸H`ñ¡ç‘øÓ1Áƒ‰cŒ±¨®$82ñ«ÿ -nC\ò¸à5'p\p â~ĵÇ僸&ñ¦“‚K7%Jø$Þ?[<í”àýÄëˆK'çWăc‹ãžæú¯¸(Þ?Y<<Á1ë‡n¶8áDÅâÁ-.Mtâ®Åã&î7 GÌ[œy’¸3øMV,Þ8Yü~|'oÆ·$nyßâœSÄíóŸŸ -ïÝsÜÜìüLr>)"q±$&q+¸´ãÁ_LlIŽÔŠÕjKÄš,™~ ÎAAÂöçY&kd“\#×É6¹An’[ä6¹Cî’ûäyLž’gä9yI^‘×ä yKÞ‘]ò|$ŸÈgò…|%ßÈwòƒü$¿È輻BÚä(9F¦È©ˆæ½v{¥°9^®´{'Û ÛžãMÍêûgìê:Ìëzã™°9.Ökßêk>WõJÃs`_sÌc\誇|è¹rºo}]硯û›qô5O^Í!¿®Ã<âó:oò`çëÑ9xˆç¯q˜7ñȯæÛÑ<èã9©^¦ÎBÏêlæ¹þÈ£Ï×äÉDë›E]QGÊ‹ûÄýs½ÿîqÑ÷‚?æU¿Rl©ÁÇ|8h·Š~]¯­Êr™bõ•Õ4âÆÃ¸ðý~ÿ„7_,û lŽÁdÁoúéR=ˆz?áï#§Utgss/data/NO2.rda0000644000176000001440000002447512247272075013121 0ustar ripleyusers‹…\|ç÷¿d›Ü{“›yWì{Ï{›ìD$bE¶]«öÞ£vQ›"V+¨\µkS%j ¥V¢üž×{Îãó>šÿßçÓ¾ÞõŒs¾ç{¾ç¼· ‰«éçªR©JªìT%T%íØ_íK²•PÙ«\ØÑ.4¬&û·û«#ûǃÝ)un·acMà|ºèCo8 ®ã‡¸½¾2´38MMlÚž?m›šµíz–¾34j¯5†Ÿ†uϼ쳯-¸4›Z¯ý±`ç1nÓ|wðØô"E{ì"hŸfD·ß±45Ï ú. 4%~7rÛp¹ºuËʘe Ë¶ûç—-àpë߄ǡ÷Á­ðZã ¿Ñ î¾qQR÷A Nº3iqp©.÷X´ÜR¦Å?Ø]´íðY^ÔÖŠ®ûC€ç ¤¶#é¡dóðÎ]ý@3qø°ÔRýÀ£ñ¶ ­¯:‚ç=‡‰?ÎKK.Û ÜÖO÷_«/€’÷¢Êùþ šgû¦”Û<JØþ~ú¾ÅGЕ^8Ö±Ì P]nn°o>tQ7½©œš ëùó}g€ËöÓwŽŽ‹MµÍg¾<çtŒ1ö;ž¥LªÖy¸œÈÔºz} ®×þI2Os×iꆛÊǤJñ#óøü±#¥‚GÙÊ—'zã¿jÇa6p»uãï¼³À)mÙý3ƒæë¼¶÷ÃVE€6…yE»Ô×ßÿ˜÷¨)8lö1… I»ÞÿN»–óš«u“íd¿`÷̆ù“À£[Åë⛂&6ÜTvÂkðØî·OiµÀõc‡+mËÏåöÒfÜÿfîXІ%ö-]f- î3'îË>Û_(Ó®gp™õíëñëƒÆ{ðš€ö×Áeä_ËY£‚>Umóü«ÇDð|Z¿uF¥.Ü>ÎúÜç-‡æ&=X·uì6°ïÝÊu}‡êÖBÍOÕ7éëƒû‚àÆß?±~­êÂì=Ý©ÝPÃ"p›øþï#ÎyÖ¢9C[M>´ÕS«ò“\/X ?Lm—œ×w§'—xñ4/³-G–­ÿ‚óìO‹Ê Š÷QN'Úw; .‘«¬.UÚ¹IµÇœÁ×¥]5¢N¥ õùø•»VéeÁãHüþ_sBA7úmcwóIP»4aÈËõàõ4rt¤<·ÿR¾I×- s·6µË< Ë—wܤ²‚®KÐ_uæ'€s­SÌ!kAZ8}ѰN<ì×QÍ;ý¼:¿_t§æÐÖy·¼~v{puÞVTi[Eð¸9¨âŠ) —71¢a¼½èçfí:‚}Kû±ªdp¿WÉ1éx8¸ý(ïÛåö‘eëîEƒÇ‰ƒ{vþþ;¸<ºàñã2м¨mÿW»<µ[6]xS⎗êŽ3÷î;ÎãNã/™sŸ×-çòý5ã˃ãæþ%Ê.y vSÿ9U¤ßšÍ[¤Àͽãa{Ú¾]Ú/…í­ïµÝÞÄÄG¶Öç?œ½?~³ÉZ4íÿ– ?‹áò»å -‘xÿmï nðg©ó@ëy]2 hó‡Xþ™©—®“Ò[lŽimJ¼põL·Ÿžö žú[½cŽVmÿ5[ý.öíú=nžå÷ƒóŽ -ííøÎu>4 ãñ«A~×þUË ÎÔjSùÑ~®u8¸jŸ¹=¸ f(pž×0BõméÓ3ïþXœçȪ»–ãÆ¥Pæq­ÿ=•wáOàØzWäÆc¿ðÓò–§T^švU~ ÌfûÊ’ýà¼àæèu…Á1Aƹûq æ,nöÑŸÓt— ý¹´M›wù'ÉîÜÍ'^•”¥BßsEÉ}£À¥W`Íéi ÿ ÍíMw[p>vü)c~‹íÀãç³Ú³õ\“q¨ù8äÄîqà´÷ÖðÐá?ƒÎ\µÍ£ &pÙ«>\/è2¸Ø-Í­5ÙÜê?«ýÇjŽg×ç ‹FÏeþøùùÓ&W€¦Â¨àSÕ YxŽéë§…¿?*Rý–̽Ì" Ñý»F£»à¼o`•×@Ó&-ëUÏ$ðœÒÕ/zÚrpP³£$PÛûÍt ?xÚ¿wðnôœ‡5~ynáeÎËÄodÍž½^%zMàøÐ¸5ð/×lϧš½ló÷Æ%Ö¤WÝ Ú:ʧaRØUWK«ã½¶©8Ž5SŽÍ{óˆÅYÆè&†C%@3úÖZÆàeÇàÔýh—ç”þaù0pøy{/Ç€æ[×Ó‹{8¾YšqU»Ý‰ßÚ=Wï9~–Ç[¯»R¿ø=&^bžÇ¼_£ÎÜHÿ–6ëÑò¸w>ëÔ#ã"xŒÝøc¼×¿Ü¿_d'Qwhº?;þó£~Äñ·Ã߀æ÷ Y'3 9’þÑäú‡×25ä㞈¼Ëf|Ðv·µÚðlÅÎ*|¿ê#‘Ö¾×Áõ®c”È/y1ºdûZ×ÞúlÝÙέ,à=qeeÆ,àµòðî7>øuÎÓÍTùÛOß»(ù\gßiÔÂNz®[ˆ)¯ëGßp¨X{+×ižjÔ_‘×w´ê>õ ¿mO¹7êqCð‰Ž;cÙ¾†óÅ6teÿù/炽צJÕcj‚vrÍ[áÝ4”ß@sþó ж4ø7j˜ ®ƒÆœ~¨?ht+Ž—=| \ë-¬R:t¸V»ÒA<jœÝ^Öš&÷Š~a§·Œ•+ƒ&BæÊ7šn5rX(‚c#–À\xüÙÖ¥/šÎýå<½Ûé¤,§²¨êÏõéõ¢ÚUÿÜó=¸¶*º8ðò~P|'%wÏ㎡g—ƒ×Î)g3“Y ïXÎCö15G^ûb—Ž-{Þ^ùˆëÏßn–Úÿôî2D[‹®¾Õìfü z\~}=ÐvKšÂ"‹ç;âcÆ7A;TJK•A½¼EðºáÃÀËY’A׺Îè¾ÁÖW –Æv*êþ æ}ãõÈ4oÍuËï]¸DÑà9&iE÷võÁ3³K欛1àº}cÕÉOp}ážÕµSÓ-u¹~#zMʼ{¨ÒUÐ5½xÅ _ÐüQÕåã¤ñàb ©ÐñÃ=ph ç-m÷}’âuÅ;ÙSW•·þz¶UÛ9LÿïK Ï~ÉtÜw×óM–}áô#åEMáw^——ýÔÄÈJ_tÆ‘GÅü~.™ŽAxõ4éQŠ/÷!ín2÷øÇ³ñ® ­'Á©7¸¤®“«õõg:jÚÞÿq**4ƵãÎqþu:öXÛuœÿÔÏ¿y°²òfŽgdzÍÜ’\ç‚N/ kð,8–Ÿw°#Ø5ËPõûsçWí%¾yxx„uHO[ö€ãšò­6oÆè eܸn÷5Ÿš×°âqkÁèìAŒa8¾Õ.Ó«.?5Šë>Ÿêͯþº6 §F5dåzWÝvÅéF8~Í„üCÐVsØàüôxbªÑÎÆü<¦vÚ1^_¹®v>üêv=ÐÌŽøqéGß§Ö<»uuhÈó'ÕM¤[P/‚v—Ûí›§‚çŒèº{ßíÍ­–·wß1ÛY§Û×ÞñO™:É ½ó›m¼.ƒãx—ôéWÍwû¿.ççŽJ齜®J†[¹ï]\qœó;ék·òޚݴƒýŽÍ{ %ýôLaVæë£üAã¨k³òfâŸ_ôPHÖîaÍkp­=òY(óºô=ÕeÛ†£?¶ÍÙiY7“·ržÅüc}—6é‰ïß_êWŠMȳ)9C'‚ÇC/–Œ÷ƒçµºwÿ6´àøÖ¶8p©ËÄ)à*©.§ïy^ö¸{,Ùa”ØO”õ¨¶ñ=½z[Spš%ó¾fç|©0ãqŒõ&¯ÓM‡O2!é¦SÒÀÎàeýÑÈ Ï.—€&c›!ÓÀ´½ 6“Xàà9ç»ýK@·oLÛ>#z€aåÓõ‰€îýYP»Á·)“ÁòÁRï³`˪l&p?÷õê–=ï€ÿ1Ùu~‰c«ëŒÑú@À°zRÁf¯«Oœ¬ þ7?V`’Òñí=`V­|Ô¯Ö1ðÞWfj‡‘`šõïÉ#׿€ÅnIÆÆªSÀlÒ¤ÕÎTЭؽkî<ØíZaè?¡`®^"lzÜ,°HQ5Œrž4—`YºWø}+ïÓ”7õ–vÀ30µ–ínÌô{ØiÞ,0±4Ðõ;°,½»¨Aš ø^<¾wÎåõð†ÑG©à6¿Fáª9à?ߥى T0lðq‰µ]Ó<–VÂn¯Íud—#lüá¾i×Îþ–/ïÛé–f ç1E qÑÓ–» zÉ›•—ŸýR›ä0»¶fÔHð¯-¯×G/×#æ-˜ð­~ó¥‚Üj^è÷!|<¿rÞ&W.éÞv˜føÞÑó>ÙrÓºÿ*HY¬m$‡M)L\¯;‹·|7lj«–R»=û¬‹³úèõ'uËxy|ŸŽò¹ù—ÐÙÙn§Á?âÓšÎuÁ+Nr“˜KÙ§iwLÙ?Å5ŒKæî;Æ›Àd ]»ñP ˜hÕŽß[™d°Äµ—,X¾?¢]é†`^YboŸû`éqˆU±`I•ˆLß.gBî^Úþz æ—L&x®ã:&‹º½óæóM–.læ&cîã8´¤©ò³Áo©7þÁ2ÏûΗëÏ€6 Ž´>¬Ëê—º+ýÁñªgÏSÀ2ÉÙ‰eHÐß“u7­Ëö¹/ãiãàó!ðZ„ÿY~®ø ¨S¿`Y?»ÝON`8~‹U‚½ÀköÏ=ß s˜ŸŠ1ø\aâ"ixÕ‹°¿qÌ9ŸþðXÀðÐùÀ¿íŸ/_w™? F Öö`  `ØYjn‘u˜ª¯¹âÚ$ |L¥ÜÔÿ¾Yž¹>¨ ưu³³‚¶€¥ëg¦§RYÕ«ž•4ø5}Öý„;‹ßi3ô³8­)ãÒô³wΩ~m!ðÌ·þQLý~ÏìÀÒÍ7À¼ñù„ÄwÏÁö2/Ÿn Á?~rô«¡ñ`^÷ÊãÛ×À,•M¶‚9.+aa*³gêìšõ¦íýÉ!u6_ ¦-$a¦²-RBËV–™F¬¿%åúÝü<#9¤o}@]b¨¿¦ZÈÜJ`–²E>`8UJX`Ú%u³ÂÀÒ‹e߆z°´¨qoõu¸ç¢ÔÈ“Ÿ[Kf>·z±ç2ô‰sõœÏLƒ+¦vóáò};úÔ£MÆ©Åñ÷1æÁÐËùÉœßêE¬¿–ãÏ2¦hã¸þ ×m«¥[°>!ß5céáßéxqRµÎS™]“d~öEÞõ™~í^þQðßÄÐк%˜3]‚Ï¥ÜßA,í%䂹ݒêÕO¿ÄaïÝeztÉ¿Qéö¶ÎA`~"×}æ-RûÙóÏÏÚžóå –¿ÓPIƒ÷î„ͽ~-cE‰†ÁÜfšD 8ÚÈq˜ó*Ü>™w ·_³ØbÓþ3u6Æ}†+²þóJØ)?ó·kààeM˜ Á\éeÄ¡ùŒÏõÝÝBu,¾+¬¾•Ó€ó¥9óòºœž3!pS…Ã5`øu¸$|À\óŦ¢‡iàS <÷M)æ#߇°Š ¼ÏËÃI^ZÁÔ"ÿÈÑE¡`’ûx°DîGXªŒéÞ£ú#žô‚üFt³oÎí„mxþ0§l×”NÚ ÆØ.K£iÑ…aUê·Óº{QoÏæ)ÿÀ£¨F0^efØœ~W¤e,ÃõÛV»k ·-fÆ}×]ÆìlÞL˜Î*[tnà âËõI ðm'µ]ËÅÊÒøâ {ÁTJó#`ž×ÜÉmÆž÷¼öHíêjོP}¸^)0Uºp“ÅÁåäô¸5 ¯Ãå~†9­0ã¡=˜Ûvýdßi4XºTöµÿÔ,mä>·©l£Yí'Kì®ýãÏU #µN†!DÖ_&ì³ú ”uƒ%àÙÎÍwñúe)a‚¹œÇæërÿÀ÷ƒT@-Ë´qF¯ï?I…8ø>”ù‚ìm(_¡çë%`±¬Ï»ZÝÀç‹vûª`z'ó¶ÿªuå.ü扟‰ ¼l»õ¯©`ø‰Ñø™•àÝ'„¬¾»ÐÌÒÕ¦ÏáÔ|K®ÞsüÌ4ž·žr}bé%ÉÓêàÝá]7–iÁâý™øÀÒJ’U!°?«;ï“×òÏ h]¬K½2%ù¦ú{¦Üë÷ü›yAèÚMàßüéþÎ7~S€¬Ç(N÷^ìÎ*y^ÿ˜.HeC]ðɺ½—cC¦«äzÊ´KjÇù‚¾î‚VÇ^ƒÔ3Ýó‹á§C g€YúìPv"˜Š¢W.˜Ø|\VLi´&|Î@™]M²Á‡e÷¶'<Ÿ™÷JrŠéÉŒUf€á™s¦ïR¥ö}W0§Éu°©›Üö&ë KßW¬bÈ_Æ:õ—E‚~y\Ù®vñP©1ß+`QÉúθ³ ­nñT0“Êï¾`Šmw²V2ÿË}H3öû ]¦”ÛéSÆGVˆ²zA{hþ®õÓÁ4L®¯|ëtñï̓ «±è‡¶` “ëzK©iÆ¢ùÓÀgsêªÆí]Aÿ¯¬w,å$sõ‹«TPº‚©ßŸÓÌbúb0-ÛÛøå¹ïÀ´†U³îLOÄOØsý˜.Êõ‘¥“Ü?1c|²tiøL¥ÕÕûWöã[)lŸuÝ*1-ËKß½gLÂuž©gõŒ)¹Þ0’ñï³&4gõ›`ѳ0}> «'-®£Ÿ~ïvEn a|'ó£öÓÙá×îC@9éæ_+¼5<¼žÕ¼×«˜îKŸ¡’ÁìÆÔSÅ]à··SÅc^0\Êý%ŠC¯7r?ÝP9TûçoŒ“gžÙ5r)¯sÍÞ,¬¯\S羿ý5h4øÌ”Ú—MÀ4WÖ•zwù;†±¤ïÊ—ƒ7Kj½®c멉Mj°úBb§Þ¿ƒ%¼ÏsG'¿eŸ˜Öú)ð}Òû~“dÞ ÌfÄ6ô‹dûz/rú¾óËý`‰™V³ ­¯ÿ(o™Õ1¬PŸú]å|ý² ã±Äs Œ˜oç: ê7y˜ï±(ëÆêÃjÕRq]aš1É¡Ÿé Ô gHæö#»ºÿ¶eZ|>˜£Þ§=;¾Luçnˆ?¿ ¯FJ8°ô‘õ oˆûê`™<’%6¦³,a˜¾}ú- œ.àûîüú!V7â÷0SÑѸ^-Ëðý¾½—Ϙo¹Æó®SÉ„à9ãÀ„}¢Óç†8˜ýg›^ß ·ª½èg°Dyžs½¯ÓKõùüü—|^‡MGÃiéÏ™ÜùöòÑfÆûù=[Eù˜û¯;ËÏYŸ«>ÿ x¿P>Ï}‚ãáýèñû• ç/‹ã•Æëô¼;­ç%;9Ë×m•p¿op^Ü­ªã8x¬å/Íò÷®‹pMxæö£u£ß¬È;ü»5úÅú Ï”x£ë*»EàOå>y–Âçu¸ĵy”ãÓMÿ!~§õä’ÝL¸/‘wÑyxŽë±•ÆçÑ?¹Ä{ˆ×ÜÇÊëÜ_ÈŸÜïÄÏW¸/zŸâŸÛy™ð)ú׆ÏÛJ>ñ}â/|ýbÍSÚÍFyó Å%Ç å??—Žh'ñ ñòTÅy‘ïÉNPçõUâÏV…ð¯Ä‰ ã—çäDûQ^-ƒãVÄsâœãÒ[¿Ä”¯A‹Ï;+í" ß„ëò”ÏñH(ÌO|…þä~¢ýñy̳d?[Y<’}i%é ‰¿’m•ñzÁ¾~¸į•âŒìHù¾ >ç"äQÊ»”?p„'ÿÄC~ˆâ1‹’Ïɯ_åcÒa”/)Î-èwÒ¡je\oÙt¤ãTŠ?„[k¾  i?udü‘nr§Ê"p|?”§})Äg¤[l¤£ßlq}5pJÏqAúÊOYßð¼N÷i¿øœÍUX>ÇqMú õ”QÚ•ë5ÒöPEyãŸò÷{Mª?Ю¨s(^HoñúOŒ_!þl¥„¸/!èÉ B}“£Œ~N|YšpDñ†÷+ ÿHçx+uá‘ï·<Ú×ÇñiRÆ'çQÒ³Ês ]'ýDvæëáõÉ_âOùÈëtÚ/¾Gx'œ‰ëâëóò½³Ò.<¿hJÏQ¤ºÁ ä7^Gb|q]EºÉO©‹(ðõ>ø<Êú‹ò·›³RO“n¢z’ç{Ì¿\—hÿï:€Û×DxÁ}R^rUÆ ÍGú€êHò·«£`7Šs²s ²nâï?âÄQÈ_>JÅmieŸGìïð¾Ù•êOeÿ†Û…ôšZèËi^$ž ¸$»ý§ç/i»‘]i^­²ãû&Ñ8dOµ`ïÅìƒò áŒüå¤ìÛЗáñ¬ðI¼à àÕKÙ'äþ)¡Œî:~TîŸÏ#®ÃQ‰®CUߟݕu·›Nà9geÞu4_‹ç>ßÒ{îJ¿ó¼AüóD™ÉOœÏ½|k?k”ñÎ÷í ä=’§x|òÙUÈËÔ§øŠß)Þ—z¡¯Cû¢¾E™/¹]D¾tü¡òáD|NŒêóQŸÝ"ô¡í…~º§œD¾uŒ2oñ¸ÓˆûQæ-Ž÷'ʺ„Ûúu÷”ý7>¾· ‡>× uн°?eŸ–÷íï zB#è>â¢bî8x¥äË/~òå½À·~Êøãøöâ‡ÆÕ ý\oe>yŠÇC¡€CÀkÄ+ÂxîÊ>çÓ’‚ì…|/ÎOxvSòðÿ‹KÍס¿Vá»ç•ÐOpÇשúùÄzá;“²ÃãËU™xôøÆ^ˆ#â9Òy"?9 ºT£Ô}|߄ҵáû’F𣿰ŽCe>à~U y]ÀÏsÄ÷¯”üÃuç;‡…J]'ŽÃó#é3¡ó•ø–t•Ï×W_ôŠ Ãì¾qðã-èN•À?–ÿ®«øû^?«z(¿'ñ¼ü\Éÿ<¯ù ß+•yYÔûœÿ^O‘p^Ìúr…¾P®P'ŠüÊ¿?3.Ù—ÛMðáŠ_â›#ì‡öÏ¿‹v»­¼ÎçÏ+fß^øQ°?á‚÷ ÞSò ?ÿ ô—5§˜ï Âýá=‘_\‹Gž—ó”׿òG1v£~£h±?Æçünãñ¤€/ÁþÔ_ä8¸-ÄWqñöâ¿÷Ï÷yï¿y€ß/|?¯„óbìKýsþ\ž€ÑEʺœs< ë&û|µŠ'Êøu_G¾²ÿýÕún ×óÜç|/ƈvß/&ˆóÒw›JüÝýÎâäÇ—µ˜8ùôŸ_ì¿“Çi|>ïåï×Äüü•½)ϾRþ~è«y„¸ãûê¦\á{ é#•зó Ï«d/!Ž¿²{Þ籯ö—WŒß‹É“|ô^ž²^u‹Èëü;•½2/Š~ÏyüŠþóQ².ä¿#x_äÃbóÑme_å+¾ò$·£ˆëÛÊ}}eï|áws'•öåëºýß|À×ù\àKwe?æ+}RL¼ï‹|ÌÏ]Âë(_¹Bžåó:Eä~ÿ’ò{¾ø»6®k>*ñöU~êþ>Å7ÙËN™W¾â­bt×?ŽÂ÷áw¶_ñº˜…õ[‹‹çâtÑÉÿÆÿþ®R®C¬#¨^à8¾Ÿqÿ½ðQ èò†Ë?8ƒŽòV! ßëßCÿGÿ(Ópžõòó±8/ý^1+\>ÀqVÇqä_ÆAÈ.™'Ãp]Ñx½#žwÁõ¤àüÉÈ«Yçåóž«äc$>Ÿ%ÿpšï?÷ÑqŸüA^wì7òú¢ð½¸¾h²Î;È¢´[¢A~?÷¹I'ßÏÀë)hOŒ ÅïÄxž~XÞ_'¾ï÷§ñpþ¶ø\^E;õ].ÏÓ×ׯ÷C{¥à{ah‡Œç¸?ôù=ßo‡çÑ8OŸdyÝÑ©¸o¯¿M‰ ò[úù¹–è׬òûaø^*î¯â¥^ïï‡ãüýqœÁrÃâp=½hÿ¸ÞÌ9ò±+â1Ç‹ F<Ë>HEœ ÌÄõâ8ÐÔ¿‹ÁqÃçËç­p=¸Ÿþ Jœô—?ø@;|¿§E‰Çþ8ošO£ü>Bׇàºbÿvˆë@ü¦Fá~pžseû¦áóø|/мÞÏCñwçQ8+ÂçåºSW-ÝåcÇýßâã=çK§õ£_ˆßÓ“äû‘´ÛÎé9šý—…¼‰qÒ÷ÓGNìqžŽ×Öàø|ú‹ìÔÿûŠÜß“Ýúáq^ÆÏ¬ë=¯ôC†ß)cñ½Dw¥NÉ+ÏŸ9Ç£8£œ/ÃãwÚ׃ñ›r ýˆñG|Òßï‰~MÂuµ§yÜ•ñnSúi@¸2®ãi]ˆ›Î¸ŽÁÄsèpÔ­hü%ïÒº¢W)óv$ñ8Þï‡ãÆÏ“ÝËãwDž'ž¥}“½Éþ½pžø<é·¾ø^òz$Æ[ÛZJ øk?PyòQ éÄ{¼øJ·(uå‘Öø|ÿóJþ`<„“ÿH·]PòFÚô$åÁhÿÔ¿™>J;SüÆày®/çkF|ƒú£%ÆS&®7½­ü\SÌo1¤›§Ä[}‰q½Y8>åSòo?ÔŸY¤cp¼dŒÒÙ‘ˆûR8oÌs¸ÜépÊ;‘È“Q˜/S(gãü™Ê¸OÇ}§âx6ů5TJü‘n!½…<Oùã–pÚ ñ‰y$ uHgÂ3ÆÕ!„S²k â»>?˜Öƒó¤£É¨g’0%£}ã(/‘î WÖýP/¥‘N ýÏ©”ü•‚öí‰yƒð‹ó5'ý®äНþè4´ËÒwÄ‹¨k31ÿ‡Qê˲Æ[ôí“ó:æ3Ò{ô~•r=¡O&£þθâù8AσpßÕIç­E½ˆö‰´(ù°;Ù?E¾O|‡ñÓI¥Ìï1xT_!?Ó:£Iǧãzzâ¸}©>C¿Ð~£…<ÂëdPÖG]qÉÔPü¯àÒÓzdÑ|þŸÁãÿ>=£&þÕ>)qÀ@úû Þi™ô÷¡Éé½h é:½à ݨ)Ìâ2 chUšI-ýŸé¥Å~úôÑ]\NRjâ@Z]tí•8(±jŸì}vöQúçf^x3ä^gss/data/clim.rda0000644000176000001440000001267412247272076013446 0ustar ripleyusers‹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*•Ú™ªHíHí¬¸ý×];oÿ±#µ+µ·ØYðý¥R‡“9©ÔþÛÍÓvü÷‹¿?´ÕÅßY«ÙJ~vä`ñwÄîøÛâï9ÛñBñ÷ü??Zü=¶ý½ä{¥z¶øûS»üÊíßwwZÃÇ‹¿ß´Ú^Úªø_°³©äg‡Ÿ*þ>c'îö[}Åߌ5Ÿðñ E°Þ±šÎ/[-ûŸbÝ™kÅßtØãx†ÉúÁü;Åý_y1öïùwü{þ¥Öä§ñ°7Áûΰ#é/…ôO0o‚ïïè ‡z~ûsɼ}ÛÀÛ~;Y?ÞñÚ~3¡÷p¾„C¾ÿö?úüü¿&ãûí¬ó;T$ð¿ö:_Ãi§3ì].üw’yÛù¯'ûMÄyw$tw…£>/Ü›ðëC¥ó9TBOe²ï=¡2Ùç[¡*áÓ÷B pªù~:^w>ÚΤ}ÝR¾ív>‰Î8¾ËÛÈ—&üz2ÿ†óaûK7ÅOó­.¡ç§¬"™ÿ!í»ý*óê“ñÍí7~ý™Ýåü²} Ÿ´»]~vó÷¸ÜìÞÎwì8ãhw;Ÿí zô>Ç×îžè½Ëñ±}è狾~ûídýÿlÿ(™ÿsyÆóßwüz©ñpÌõ'/zŽ»|¤7v/úñ¿ô¹^ä_s{Øþf²þ™<öv8Þáp‚Ç¿…šDçBu²~>Ô%óZB]ç7Bƒó7`‡á¼ó3œcü\ÿïB=m%úpvr7vqÒù™OšW¾ñ= gÀ }¶;“ýÂn—Oþ¯’v5 ÷Pãþ ê=|'wz{;9ü:üIþ©ãwŠýÖô—E¸ã–Î÷ÚÚ~Ä.kIöµ4ëš}ÂÂËÞHöͺ’ýþÄzŠíçíj‚p°,ð{Ýþ-¿TÄû?­'ÙçW¬é‹®G½ ±óΫÆïÕƒwÛ™5Ðo¯óô/á7›¾îãE/ð2(âù²5º?l‚žöOáž´ô ŽW[µó¥ùYçGµë‰Ýî£=ÊúcøùóøYäjç’·ì[öýïaüä)ôòò«GÏ2ï>÷£á4þªÑý|¨OÖýMhBþÕÌo`¼ÅãB8ÜCø9é ü håçïGoàs@.¡ÕùZ]OÂ.ôþ<û^Æ>.a/èOH³Ëã¾o‹ó;dœß!íz2®‡!Ãwô2diÓ®?¡Ýõ7Žg¡3íòY—sèd~'ãÈ=’¿ ;‘'ñë½ø#ŽË)åÿ+™ÿ{ö·{ˆ[Ï%óÿ!€ïĵp’þ)äªøY‹Üˆ›xŽ+>%ûô„cÈIqö¸û™p†u•ø5ÅKí'wQòoÍð¿‰ýšá[>fž…Ïê÷ùüŽW\:~œ nO!ëþ!tBWrϲNórð#‹<£¼ÜŸ„Nì¼Öý³õ|ŪÉoÐ?;„Ý¥×qÆÏ¸]Y%vLÜ·#Œe]-yó•Wåÿ#ÙAû„“à{ÎýM¨"/¨Løù3yÅoâ|8?‰‡ár»@¿»ª÷ü/ò3ƒÝt µíèk;rSÛÿ$¯væg‘K‡ì û휘Ÿå{ûÇÝ®3¬ïLèy"ä°³ð¼ýÂ?‹Ü:Xß}íì—œûûÐE¿ þ~'z&ý N;ß;À»ƒñ,ó;¤wàÝ)>Ÿü…ô2Ý9ø~þfáVz(¼NâDÆéq¤¹Áã þÐî'ަ¯%Nír=U>d5Îå?ÖIœí$Nw³¾‹xÚ…~·£ø¯@^õ½³ƒÔŠgõØS#qIq÷8x׃'ñÂ.OÓÄÏfðju9Z›Û·e¨CšáK ðÒà¡<ä¼û9k#ßHÃÏ4ëà·å€¾æùBøæiCŸçàÑI^Òs‚«xƒ~²_Œ{UøÅ*·ãp?Z‹>Ô+.ÓGοó>Õ —håŸU¯¼ÏóãXG!í½þÝvȤ'Æzù¥í—ù¾Gy7ð+“ö/ú´ýcøtœú”ødäv¯ò¾«N<ˆ¤¾ËƒŸòñPíûØ}ÄÉ*ð!ߌuhã'œŸ1oWGž«:,Ú‡Ö] m¾=nÙQê!ç{àkûÌâg²ä)ŠsòƒYä#¿!»nW_þ†¼AþI~öŠüòñèSÿ¤¼F~4 ¼NÅAðÊ GWèç>Uê'sð;‡Ê?¯à?±—è§:ð»YÅUðþÏáÏrð!ú=í+¸øÓ,p›ÁSñ¨Sþ^þ> Ï6ðj‡nÅŸvø&­õÊ+ÚZKå—&NÈ~•´‚W+òÍá÷%·4ô´ƒWò;ãzãCŽùŠ;ì'¹µ*2¿Sù øŸÃ(?n ?'ND~INiÚ6øž¿ñ™ùÊ£k‰»ŠKÂ=\3ð«M~üð·¡MúÀ¾‘NÙôü²â‹Ö¡¯Yé±ìJ}å/à/{”ü;XÏùCÈ”å Òç üÕzÕ¢Gñ<#ýAoZék<}h© #TǨž:áz‘Õãò{üE_ewÊS"ËòXÙôãŠòé-ø´2¯¾P_êâp¸ÍÐw|Ku^#z‘Q>£|EøÂ§xuÑïÙýÖ©U~ÔÞ_¡ŸW>‡*êN7p»T‡m•ÊCzýxvB¯ôWúÓ"úÙ?Ã|ò ¯È§RûS©ÝaÊþÔŠ·ÓŸ¥ß'ý`1L<ïýqà=Bûo§ü@0L2>Áú üçx«…ÎQàN¢ß“‡Yÿ ïO°ßxpøãÐ3¾¸ôGÙo”y£ðyäó¾Ï°Zöfþ0ó‡ØgdÑLJ k„ù“À‹íƒ¥øŽ@Ç0x !Aø{8WÁã*x_Þ x jZð„q=íx°ÿëúág?ßû™ßϼ~àöñ½|FÔBÇ0|f|8Cðoý#?¡w(UFpÅAàªô!ÿ«èÉUöiÁcyâÓ ëG„¿äþ‰ÿ‡.Æ#áY.¿:øÎ¼ÈoæE~¿ú#=à{u« ŽZ¾ÀÇ+k‘_ŸZì­‡ï½ð¯½èAð{Á§~˜ß§–ñ_}èïe¼ø}𩸽àÝ }½È£~¨>=Ò?øûð¡GôÇ$üþ濱CüÖäÏâ䯠k>Œ'®I蘠?¡u´²{üa´è™OùÇaècýö6œè·àÓxAߘì‰õÑ_Ê.5¯Ì¿J¿åOú¥wà§vXöô|©ýÈÎ4O~c€}ú¥Òé“ä]ø-ý*°> §þÖë|#ö·JÏÅ ©Òuy¾çÙ'Ïúnö¹¢|Bù»òvÖ)Ÿ.ì+]ã<üŒç":OR¾¤8¬ø žmʳø®|»…që6«e^ëØç~ð¬¯*å¿£¥ö,»/ÈŸo U*ÿèÿÁ'Ú1üë­+³ÇÑRyöHàS`½äZŸÀ~ð(hú/ù€Ø?HþÌ“<ò‚«y|¿"9ê|‹ïÒÕaøÐÆ~MŒ«~Pÿó¨£c«ó óëœC÷£Gø~\÷¥´Ü£å_£UqWñAþX~õñR;ê—ÿ”œ%Ÿ}¥þ´Gp™ý¶ì’ù]ìÓ­ºUõ/|É2¿À>’—ÎóªáC»Î·_”gÓ^dü‚øÊº«Ï|ÙM“äÄ÷K´—Ùÿ¢à3ι\<'ŽçOôe7gå?ðk¾t0¿µlŸ ­¥vYC{¸Ü7èÞ5ÝŠ­ÎR>?ÿíÒùáptî}ñsÐw„ñ£:O^æñ½²Lu?ržïºoªcžÖI_§ˆgSO¿D>N|gýú9®<[ù}Å7űɇ;;3ð{ªÑÛYÕŸ-sCÀ‘ÿR܉ù²ât¢¯ÊË×”W–ÅQåýƒÊOµ/뇕ÿa§±.P ßb|WÂ>ÊƶJóŠYÖOÿ|à;õøò Áeý”¾Ã—C€‡â]`¾ücÀÈÞUwvé<»àWPÝZægcü–ï+ëÑý ÔÅ|PùøÉ_Å|=Šq¨,¾ÅàöÁ¯¾­²üVñ²,O`¿ð`Ÿè,¯¯bÝ¥:!”µ[¥u‰úWGËâ¾R\ž'\¯&Ö],óO²s½k¨ÕýôŸc¼Jïut_Nÿ>½ûÐùòã#úÃVú:wi¥ÕûŒSÊW€_þ~£†÷,Ћ܇D¿Q÷íò[¿¾‘wY-çöÜëqÄšø~ÖÆù8ùÝ¥û൲žóoÝþ؈CÖÈ=Àe½ó ß̾œÇÆVx¶3scã|ÛÈ/í }ò#ÿ4Ο¬ øäÁF~ßÍ‘‡ù£]Öþ¬#ï5â€]T ]âW3óZøéŒø$ºhsºgr;ˆ-~Áð¿ô<ÞCqÎn·›÷Zæë¾Œ<ÏÈû¬>åGø¨e}—øË|üa¼'Ó=!y§Q_Xžù±yÄ{-ßÉ-0¯ ¢¸ê÷¨êsÃZ¯û7Ãù»õÓçüdžÀŸó#n¿wßÈxU™\õΉ|ÌÒ²'éÃã¥ú"¾ “¼/â‰?7êCãœÉ81â¶qNd’|¨Ñ{:è©O•Ú¹ô²Eï“ £U}é…ôVï— Oúš–3ó}ËÑrNé¥.µnðêfyd¼g-ˆ?Ì'ŽusÔÙõ|ò÷qðG±Íãñ?ä£^´ü8ø;«Ç¢ßw¿s:æ·Ê›[”Óê¾Oy{‹îïõÞÿžV½ ºWyDæôv¢†-1Ï?»ÍóÞg¸'}»‡{Õ¿ŽïPü>þ1Þ?¾å÷°·áHÆoð>å¥x_z&sÆ2O•ù#øy©¬nó{Û—‚¿Çüh8önñ÷/ÄÁnêë_õ|ø¹Ý¡*ùþ]Þo>‹ØSa­æï7’y‡‚ß×>–‡áP²ï—ýþù·ò¯'íOG<Žßóö/óáÑP•Œÿ¶ù÷wã{4ÉKñ^uÏù²úµ6ÁÿkÁßW?L½õk1{Z{‘ÕxΠuªš¯s µ—iµ£ÞÁ¡Ò£V‹ÐoÑýãíÚ8i½Ðy‡òÝ_Ê.7‘û3ñ]_Ì'¤Ï´Ê[Òº_£Í©ž•žë­d¼¿É¼µoùº-ø·N>½½øñX§¨ŽÕy2óÇEuÅ,õð¼ê8Öß`ßEèºNv‹u«ß¦ýuŸ·þ+¿àpV¿Þoy:¼9LÃÝCMCÇL–û ÿwj¦ô\WuÎÑu>'yö–'I/ ÐS¾$ûÂ`Ò݆þ|3Li_Î t8¿¦u¨óöçîðoêDéýß4ú5-8Ð5C;Çyÿ4øÏh>|šÞŒÎ7Àc½ž…®iø8Í}Á ú:‹f‘ç ú7^Íð]ðnR7®œöövq‹}WŸAÎ{é£ßkÀ[¥þ[ý(}ä°ú[èÉ:ãG±öãðsUû¡7«Ð¥Vvµ"|_ÅŽÞà{=-ú¿‚¬\¡ÿW¸÷Xï+ðmÅp¸…>Ýbþ-äµûïï>æÿŽë3{Ìÿý•Q¿¿óÛuÚUêºZ·_ÛÈ2ºsºjsÈÇ7æðºÇÃŽíõ)viKn7†þÛ„ëM%íC¶â~Ãn9ÂÆ{ ›`?õ'Ý.l†<œ÷$6ã ½ ÿÉÄ;ûJãžÔˆÆy°ÍºÝØtÎÇ‚û5»Î÷Eú7³ ˆ'6ód)=óôg¡çpçÁ÷:ð ã¦Zôv™zvå||å%ø‰6ëþÆð6Kýw ¼æàÛøÌ#—êäø°à~Ó®Ó_‚oÓŒ‹_× {½¾Ó´×àyŒÍQŸ“ÏÄ}¡w|°Óeä» |ÉwZtg<æ žVü\DN×ioÀŸ%æ7l:çÐËá«–ï‹_EÀg‰õK_,Õñ<Ôæ÷Њn𑼗Ÿ‚3ô'‘W”ü—=€ßXÒßoSÔõ3ÉþŸ3Ï—2Þ+Ø$rÑ>’›ì =劭³nýÏÉÈs6°ãM¿¶N^óJâÌÆëäËï'Îÿ=yƒ_$†-òÒåÇKãÔ2qz™x{K}âÎ2ñ¸øß30o<†ßœÐû/ââ qµV÷9zÿÃ:ÝÓèÝR¾¬nT]¢|U÷"yÝã—Å‘fêE½/Ð{=ƒ¨ßTv¯_~¿,øÙ§Jî3l\çwø ÞÃï6â¹tF½âŠù{’F›BO'½ú'›Dßy—õ…wy6õiü)ðoH±Ï“|:ú]Þ•˜ßcmïOl„ñQâÐã£ØÓ$þAþŸûA—¿gÞ㼌p© Œ÷:ÆûƒžQè”?ŸTüÞÚ˜âö7…½LÂá1ÎþÚg\t ŽÖ1ôùÒvŠu1NbwSÈ…ûN›ÄLÁÿžàþ@÷F¿„Ý¢O[Øëö»U=×uüäšZ乿ù¤­‘?n~Áánb'[ØßæW¾Æ7±·ÍOÒR—lÖ€v¿EÞ¿Þëì³r“º¿²LÞz‹zpº|ü”ü$Ü$_¾U?ÿ5êˆ5êæ%ÕÔ)kžß„uòè›Ôħ°RA=B½µŠ=¯N²þ%ê%ì5ÒÅø†üå‹äùîŸËþoƒŠâmºÛÿkƒO{[2e÷úƒ«¤¿?°ùÁÊí}øƒ^Ò•¢½ûîÛã>±âݲÝïÜXýðꥭ‡o/qRïü82A¾ÇAgss/data/esc.rda0000644000176000001440000005462212247272076013273 0ustar ripleyusers‹µý\ïÿøŸsŸÝ.B6%3+«× ‰ŒeeWd“ÈÙ”YF‘½g BZHÚ›´µµç©ÓÿÜçtßýÿõóQ½¿ÿ<Ó9uîë¾®×õÚ×<½EÚ2‹d Á`1˜ ‚%~È&Äÿ0l†@L–åvsñ¿Äùbʋ̒üXúM4ûnþ<ó/?cþãgc[þ.óÿñæü&Úð3â/×ËüËgg¶âšÿõYþöÜ¿>ÑÆë&þÇx·ç÷ý¯ÏJüãÚÿ6¦D;î-ÑÊ{Ñš¹F´c¾·vüþu/ˆv¾ï¿ÌsæÿX£Ì6Ìóÿ:o‰ÿ°~‰V\ÇÿZ×­“¶Ž)ÑÊyÑšuB´a޶æ:Û+˜­œÿ󰵟ƒhçße¶a ·VFÿñ:[+cZ+¿‰ÿ8·Û"£ˆVì÷íYû­½/Ä?žû_s•øûrku¢•úAkç1ц}¾-cò­Sýk-­Ð7Û«Ãí¸§m½wD+e>ÑFãÿJ¶í¼§­«­½oDe:ñö¥­¢•ó¬5r·=ú,ñô*â?ê(mÑõ[;§[£sÿÐ ‰6Ú}ÿKþ·GGd¶cîþk¿kÝK´s?hÍ=i|üÿã.àn´Üi¹q»ø‘’äÒg™Ã©#š½žc¾qÕvêåô/Y³ÊÜf‹µø‘¨.‡¶ˆÿ½ÿ_ê Ñõ„håöÙZG[Ôf¢ â‡ÙNÕ¬-â¶µjç¿–bk¶‹¶˜Ÿ­D+ÜS­Ù"Z»mTyþ5nÿWs¹=®™Ö˜õmY ­ùì­¹wmQë™mغÛbÊ´EMi«+±­×ÑU’øÇ6L´Ò„#Ú0ÿˆ6¨LíqOíP-Zû7[³N™møÛ­ÝÿFë]Ž£ý®óÖî·­Ù§˜íTéÚ’híg þ£ZÙ–çÛr/‰6Ê@¢•k€ø?0ÛˆVŒ9ÑYJ´òw·ÖD"þÌ©¶¸òÚ"ikè†håk­ÙÙÝ¢-úm{Ü0Ì6êÙ­]#mÕ§Û:Þ­q2Û ó´Va¶A?'Ú8çZnh­¾Û–ÏÚ—a{t`‚ѶPt[ÝBÌ6ì[mу[+#‰VÚ^­Ñ«ÛºnÛàJ&]Dÿœ ¬†VûZ£k´'¤ÒžûHü‡}³-ºjkôä¶¼¿-{ÑJùÔV×~{}3my³vg[ÒFû\•­ÝŸÛ*ëˆÿð¹Úã.o«®Ò¿³×ÙÚuÝÿbkÖk[lô¶Œy[÷ÿÖÚÙm -´%,ÝyÕZ]´-¡.¢ {V[m*&£õ>¶„=˜m\ï­ñ£¶Å_Ñ}ùÿŸ©-mñ•¶W×i‹Üh«_h£žÒÚ”‰¶úñÚ–g¶S–m°U™ÿaßaþèûíM?mí¼!­÷}¶Å¾jKÌ‚h‡¬k«2ùiqsŒ)Be\…Þ»®åÐÀÜmp£ž"2æv˜áÙ{7M¾ÍÌ{à'`4ûß¡—ô5d-·UiŽ‚³U)74(BƒË°/sÏ5ñV·;!;ØPñìgöwÖ|¨¹ï~O93¨[3×$2w#…{¯N˜H†…|ù}†"|žÖ+ð“å9ìx|½µÅ­õ¨û®øçÎ33øÕ‘ø È/Z?õtO”’®}öÆ´æQ /t_·×P­ÓÓa¨¿#ü ͪÂI¿Ó+)ØÁy#øn_ø{kú'”=³Gñ½.]§yE2­Ôh˜m]×ó#; Êô€ß±^«ëë@tðîžëZ4;Î8µò[¬š3lÙ;·ZTùû'ò+S‚¾ÇÊ‚hÓ¶²Õ«C¡4i†×¼±ìæDÞ«*Z{Ý¡LCuÙŠ›ÙÆëÏvüñ&l •p%”Ý‘ý%òâI¨¼ž>uÁ¥ß͉ÌçO¾?QCÙ5—Ÿ'‡íƒ€š±gÒY#qt„‹†ý<ø¾ÂPoʧçßÞ“ûJwènÝßyEäîØÀhHB¨ÐÚs{Ùé=þ`Ãþ˜n;)"GÑýèÍÎÿ"”ËÍYÁ‡GÖ óEV†«g ¼,Äd–õÒ/„ܺ=ã1¿C¤ö{ÿMaã¡r£6“-G³:Ò3ëJMÍ´ÅÑÓNEÉ¢ÜN7uï‹C và‘GÓOGY}昕Y=@øÅé‰UX%òT¿$ÖpÆCÝð\ÙϯV cõ–•©ùVÈ6Ä5ÿl•‹ÆÏ÷Éô¡|uoIÎo>Ôïž6Üñ ‚,—k<ž:š¦¿nm¶ÓÌŠÈ ]t_õœK`¾=`ÔF® ã ì¹Ÿõ¬U‘»ÝíB¥ÛcšŠCt÷u0F¶÷ƒcþ"»»ÍŽîég)Bz½L¡ë·"=þP¼aì±¾üÉ1,_µ£-'^yG@ÍþŽcƒÖiAÅŠ—µ›Š¾ ±ËÅ37Ô‡"T^Ý(()âý sFžÝƒ‚‘åZ"ÓuݲóOhùuWFÇí½­ƒr:Ú;m"ÁuÓ쑯Çi· Ðs†ñÃuHSäÒ-¿‹òìð{¡¶j?òç„},èð––«J¹ÓsBAݧ‹¡G ‡êSêµ/dïSDÁ¸ ã­^\¡É~Yl꧃œogÎÜq›9ÇïÞ={) Y™ïni-Ÿ²K+ûÙ‚Ä ÷)»f^ É¼qSa`j1Ü NȰx Uß íäìG3å¶üÏUõ¡6õàÏ+í ºàÀÛoSNRDŽj”AæÜ›Í ³û¤Eu>ÛœÈÙ9øYr9òR×—¯¿y‚×Ãq¯¼š‚ܘHóQ‡>"óI–Ò¹­uPó4c‘æ©O4kŸ—Eߊî‡üÞw»èV†¬Ž ý^ŒvAŽÅñ7צõF–FïßšûCÅÆ}ùDìdÅ _(B¢Â‰E ;.C­ÂM[ÖF7d¤+>áì?sæ æUCî›}#²V"cÊî…¬Òä Í™‘&û†Ö£ÈJ&½[˜^f,¯ÑÙS\Á±ƒtÞ²›ø{y7'”pžñý Ê=šò²0y9‡ŠSΦ)¸h²ãN×ÙÈ\¢H4hT]:ìÃÈgp™”F;¬š“ñ—/¨þL¿âx<ˆê¬t½ö e– ¸­¥ã ‰¶-°ï]L®†ÇÒä-Óª062mºO6”ë¥þ€ ‡¯¥õ>"d8Z\ÓqpD>_ôtJ®Eˆ¬½œ¦ýzEä“éÝÑz?Eèh½ï[ò›##Ê|{YŸ˜Jêw°|ºY¤RDB–u½¸d M.×y_¯ßsQfÜÇ”ýöã(B½Ñë~㮦YfþÕê‚®½®¸¾Í7 ÷!ËyÝç—C¥h+].^î©>ίY=ó‡ÈôÓ‡o~Ëæ}Ú Ÿ}¢÷ódŸ<©ú>~-ƒ68‡F4 Ó_/W·ûUäêMÞµÕd2´bðgÓ”ï_ïô¦‚&ßÐÅõãâéPJj[òif\e[骆Úße¹~ê4+Ã{èÆÌ‚"ÿ»&¿ößGÙòÇ—;§t¥ß5cR7] ˆ¬Ï­Ê½z£¢œžÝðh3'…æiˆxÆš¿írwú~9)иöLu£í ‡­C®àEí›-})ÂRýúüeΜrx¿,2”3‡ª¬&(6é}YÚ=WNZH*ž¨_ц@f*ãØØ÷\ŠÈú”añ!x¼¼Þ)îg×ÈœwUCQʼnï :…L‡ñn%+š Ö#3 ¨T€òß·®|7Š6å_Ìr/CþéÑ}{ûê@Ä>sbHücŠ(ó@–+QVcrašš#ró­uÓÞ÷¢•u©Ô0!?ëšJHr ²f¼žöÙa3=U6[~½| êòCæïø’„Ìð>[•:@5)­Œõhú÷Ö5ÏI¾úlyKï$M£bÉþHó§ 7·Aî2veé¾t­„xñj}ëM³ÒûÇf#xÙ‚µá9OæÞ= 5¯ÅÛâÈí g¿ú\Ôß—`]6éoDbx/ŸÁZ (Èóv]ž6DÏ)žóÃ" ݦM;²ŽÆ¬˜ê­Å_/y¯•Aî*?=9õ4åý SVõã¡Ìî%î»DEPŸTS,PDlËý¢¬z̆S„†3¼[¢z£¬í»(…Ònê´óÅzSu×_/›· ¹ 1YÂÓÐej E¹ß@AHêþ%»J¡¡tøÈ»ÖšÙŽÌcÊõ‹A¤Uÿ*´?Î.Iûž…J³ßšñV,7>v]zÛEò×™Š%$*D/÷žfu/gê}ö¥zA̰§&Èý•ɺ§)Ô‡Ðü3¾lÌ÷…ŠU-™­P~%Äרäre'‡ÌR¡×ÑË"üô¶MÈŒÞA*NÈqwì¡9s(B}̸_3z™@óªŒgÚ:”ÿ¼õ=sŸ;”,öo¨ æ¼wçEéj›ä®vA)wʸæD®¾B‚LçÈ®?r®‡š*Tžÿûè[x³MmzøíõP–›¼?„‡ã–ësiæ©ZúGíâAI¯áÙ ‹Æ#/+Šûe[ˆÍ~™ ^ªQö w>c‘j ²—‹œ»ìTƒ¾FÀ¦‡{ †5píœN#[0 dü,S«dÊï>uð=¨_ØÏfþ™2”¹1Zí=ZQ„T•@ç)k ÿ)ž#×ò—jÈÆ›(—ýeÖ²P À–Y9£SPy½®Œ¥úM\;#hL4Ä®+?·r4EdöVÂôø•ý)~>ß’@Æõ j_ã {ýõÍù[ Ê¤Øs~ÏØ¨¸ñIꌵÈ+½l=f?M™ýâËì∂EìÈÞj!ÿë…ë'T3)"óY“C:Èžà|òuo>ØZÚÎïñJŸ"²äÙ¿»„ ¡)[Ìø:ÿêI¨R9°üHñEX3¸þ¬œí/ñ}6pTõ0𠢩k—%kQD9ÎF#Gíp(Æ}¹km Ed]“ÊA–Ûfï#¨’W ’{È÷¾WÞµh+M9áö3›TŸ!ã“Óƒ±Ê P3PeYÄEwäNèºiÝÙld|>scýÈ‹ËܰG—"²iözY»¦fú¶//!Oïô~Âb9¤ª£ì‰ñëºzøõ+2üì’Pã-ðÖù‰\–áÈuoá=~÷®óéÈ\d]6ñNOšò¿jË»ŠÇç@kÉó¡-™Õý†uÕf”{2ìÑøª9 <ðÍi¼æg¨ d-UüEçÆL=‘ I³^¸ï%ÖXë¦RâI6g}'ÔåÝvô¸‰Y¯ú­X’¢]¡£Ãº —·&ø×Î)4y‡_æÞ¯Hr‹Vׄ˜%RDbç¿0 Ò>Þ¼°âZEäú&Þëkž@êí‹HGrFIämsBæÊkŒ£mtµ&xP7¨ Þ›5ÿé\ŠÈTXÅ}Ò±Šo8mÜÿ|)2;zÝÁú.*lôöó¹ÈØo÷N,÷7¸ Ÿö‰{ÝœYûÌiÊÿ)°÷œ¢í«W{0.æ ÆíA–ŠÚÃéžúPãkƒS©×߈œéWGݽ—¦àVï´ªøIÈXåútßmŠð&2à©Ó•Ûâ}÷ûIÇ¡×?ν˱”Ã4™:QË“9š-¨ )Vë3P>M©cÌqä'ïq­U~DS`™6¡K’?EˆP º“qe¶­ç,\Gòï8:dôØÕûŒ‡ûæPDf\ôð Ý¡ŒqÍ€Ïy¿)B Ü~¦ë„ ·;«ö}¥<âߦˆü«y²·Ê=)ÂþçéŒñ>æ ’'ÜH¨³?ûà¡Q'šõ®ÜŠ_B“Ð'ºÉŽ4ÉW}Ä2ñ:»t_-ÉÍ™êxÞï¸EZUú© Ú¾MCÒiBmT¿~·wú o¤™ìG£ ¨©>ã4ª^²YW>Ž¢ˆœc!¬@Íõzä¦íÓ0øÖ’ÂNZn.º ÑªŽ‡ܺՂ_Ýy³ÓêwõfÏ? 绿»ªÀî EˆªujGàò¡úÔìÈÑ(ó«hù9ä÷%ï Ê~™¨¹·v6$\ø3nhO±Ý¾mÁ . Êûù¥,òs„2¡MÇ»Q/!ùÝ3?Ù~4+-ª­7±#Cù’â­e/)BI£_/þÈÞ~æ§.ƒèÏ#£=QPX¿nvÈ+šòN‡ºVES„ áДl³@øs{ᔟå«[Í:uUùçºéûöûóTñŽâ‡üD¯-Σ£ hátÏ™ &¾›Xa?MYV©_£õ¡’qÍÀøÐc8LîÊ“Qág7µ¥_(Bå°ïFÕ­B9åÃÃB¾d#akžùä÷êugäι*‘qÒäA5s(ÔUˆÍÈ„# Ÿ}G9gEDs¢L¦ÊŒøÔÈ{´„ܹyZãT6ˉ} w›»A…è!œˆZ”)•(Rít‡3@dø¯Òi†µ  Ì%wë¶C4¹—TókÏîGþ‚c·3E•Ù‡E~¼¾×þQ Ú-úz£kTn>ÌúÕ|ø±½ÇP…áz›tü¦u¤;Ô¹G^½ü Íòr,¡ˆþ3«Ã¶](BøóŽ{Ò¦?G¶VÜjÛÀe!ÔæKƒ§D¬ÐéŸ6;¼·nñŠ?!ŽþzI>õžnL*5ë¥zq=Ìy_]¾¹+l•˜q—iüføØ8¨qWs6¬{ŒeZ[ÔœçR„šŠÎwWm÷+;_Ï€¸§ƒWÞfB5»ø¢FÉù¿ÚÙuûiƒŒ3ûS£ÂÿìR( ;Ü5ªÃršuÞd:ùbñõø`aÍrµÁ§ŒØBuê?B¹8W{=ß'Ö¿Õï~÷ìò¿ŽËK^,_‹–\2tÜO3#ºÃØ|dŽÝ0Ágb27ûâé3âýørqá¤£× ëíòÑ`÷Ù}'9žMSÅ{Û×­Uo‘ï·T߸,™2ѹ½ýÖƒhجT‹ï«:[ËÓT¼¦Ü?÷Me[½-W] ¡òÛ.–þÏeâuy·ïÉËÈlôÖÔïéàoJº„/DþØcdnwEöïÊ úÛA6ž\&»= ¹w7RM“ÙñÖW× $Žo›:nü+Š0 l×u[ÃäX«Ö}:Þ“&÷HªÉ:ù4ŠÐð¬vªh©²×[õ|ë'änê©t t!›í]qo¤ͪpH™±”f¸mšOa·j(î%PÜ>Þ‰ŠÜ4“7Qfðï}¶µ(·Ra`jÑèÔø9˜=SzŠUaäÊÔ¾žd¡Hbóª¼í”C‘ž&gëÇTe"q”tDÕÑÏ'ùçíéƒDà£ÛêÛȲúñÃÈhÐòd”®X—3ʳç,܆̑Ãü-7 {_¿ëzµäxy\½J>;ëŽzõây'WMñ–¦pʬ‘IÕ)4«£]Ìu^Ù!÷ƒùê{ÙÇ Uâ=êŠáö?GBÂÑãÎÉ—+‘1'ý©v_ñ8¾Õœ<9×ê{žš~ëÀd(n}Æ)v Ôœéòø˜1TˆocäI”[݉´Œi2L]:¿Y¢Ij.)¿øÀˆÞ¿XFb©4Þ²·—uÊØf‚„±qöü•Ȫ“8@häCZ˜ëƒ:N¨Ø†ö½nóbŠ(ïukUfÕT<õ@^,B)BiÆÇê‡e‘«[ÿ½ÒÊ23v{Û± t速W§Ñü£)£ž(VjÄW5ž¢ðÚý^õ‹Ež3÷Ù½wžÙ|È÷Þ‡Ðî{&g퇟§× žÇn [¿2×0ÃD+F2~Í6†º¼Ò†ÚÊÉQÏÏ Óˆ z™Ë¢ßÖ_Þ Â×wÜ Q;Æëú eÅ.OºASh¿ßï¼Eä‡rdö.DæSŸ%sEPz;²$üÝE(5*·:3 åê/&ÏÞÙœôÝD³ì¾úÌãg‘cÏêo¸¹/ʲ­ý²}'Ò”™9ËåHð]T¼e£{iR*/~0aJ(r'–™~?_„Ü~£…>#ؼèÎ0½óàQ+õOÖ¨ö° vª}2Üxæ*2ë\ÇØßÒ¿9b¹ÝiµÅ(`ÛÅÒØ‰EÅ“õ»mB^=KÉÔÇ*¦ P\>²¨ì9ž~Ÿñ¹Yumšìźÿ¡™j]¡$Ü¥vì:u(ßûåX§a4…O%ZîëßÏÎ[j]}ròÆ#§WGŽ/rÈ ´ì-®KÆZÿ#S[l×ýyX}ôYš?œ}IruUîõÔîŠ ÖrÍk'P@FEöôFöŒþ} S(‚Kù°œþ³)"÷À¯ê{¯ ÌÒî¿ýœ)‚CɉMÕZ½PÞ}ŸWKˆrNö%ƒÞGþ‰Ék-=JS±B³î,C¹M;û÷žYCSpL©8Wö ¦g=8Ûÿ6”—)‰ /r{‘Ÿ,(ý¸ãÒQuŠÈf<z:½ÌM™`±¤ÍJù Ÿ[n×à×à⚨¦ 4Õ’Ùä%~GzþRv…¯<2`MYc·h¿÷§ÂY}yçß4'rÎÿÖ/Y ÖœóFªRx˜t`bE”u¶ë°3Ö 9áûµ9‡ñü'Tâ‹10³cöŸó-(_@nKêP7pYò œt*?Ù¿bfõY¨[;&=¿ûÔ! |_æ5íÖ7ôÓ\²qYï’?ÅÑãvÈU¨ Jy¸íÎ d§Hä ÆHô-HÍ´ |%–‡x °·æTx·ü¢÷©¨ØzÈ kG7"¸êæëÂÓQaÇÁSK¯ŒF"ýƒã§uþ(˨\oÊß Nƒ¶À¼ºàÙ÷¼î§À5ÃÙ†(À>ÿrNå[.ʬ–Äs(BzÚB¸Œ¶âO¡6*ÅFâ†U» Jμdrï¥È›¢gÎ]q‰¦Ê¡Lþ¼W‰Ðpе{„ž>|môǰŒvÝò„ëû…Zõm€Ê÷¤;zÊ(n÷ûTw¶Ù„­n?Ñ{änX}dñ%ä'xæ†zÇ ÀÁç^˜Ùdzî›v¯n?2}/+î½Î…ŠiÚw/×.£ˆ2É’ jNÈë×E~bƒ%ÇÌø¬6ôÍFý ;ÉŸØÿ‘fCçy—íNäPDÎÛ: ëŽÜ±QGÜ<çS„ÏÙš[,UAmúÐeiKˆõTƒÔéë(Bý›yQ£ò¯PD‚ç·Yí"²F#%G“Ó£ËÙ)¢C”>Œýe玖ßBb©4ûjhÝE»šñgšEvƒN¬ ÞŃÎ'¾ð¾q§óŸ•"qÑ¡nzæUа4IkIïä`¨"£“Åò.ëÐìÒd¿ð?¼…šI· ­M º4ëJM~^ ÖÜ«9G½oFº[´ä¦^åæã´_³>ÑR+:`\ j¤2¼‹Él-—o_P»îdܘktSëĬuû<ëÔ¯zf!ÈH¹ús]µXž­/™6Oí!M.)UÄúîHU£îE_ǯÝs”I™“å¤Åü‹ ô|*Ü9äe'£â3bS„Ýr´÷<€ÊÜÇ=v˜}§üB œ½»rú,šU—n{µ‹fbÍq¨ýÜWÉH4$ž¾<8>|**it{P7R·Îòß9 íªU½QcÜiyÆÂs"S¸Àgûnñºµ<“—ûGŸ¢nòÒ‹uWxÓvög‰zeHQ¬÷ÞY¶ö­:E¨>ÂÑYßþ8d1ê9YKF޵(é&¶Ï3nØj¦ˆü3©eßtÒTü~æ«Y|O–ËhØþAÞ4aõÈC™á‹¢t_¯s!§­qs¢lO±6Ýq"kîN۴ɿɿÿ{qäàg¿ I_ê·k$2Æ“f˜!ÊjÎÒ‘óúuÇä¿]¹vêÍMÙºóûBUí=ñD-³CúÏF¨Åðë:ßàé]Ô{Üœ´½ÑHdxhjtÞ‰ÄL#£=â¡Â5FÕ2™v)E±;Ô˜öxW¡€Ì5ò×lw €ÿ¢£à6Òä-‘ä‘ÑdmòvÎæ(¶Vë„„5ŸÇ8Ä@™}Wo½¸¤„L]É~ÖœT~DC3~­2ø ÷æ¬ò¼}™¿†íí6Ÿ&»Ñß. ^¤{ÔH¯Î¸ý4õý.öâúö-X(Ië@Ç…aDùæ¨i/‘µNlÞ¼ñBƓϯVtþ€ì`ð+ƒ×‚Hl•eï¦ù@ñÐFîmí³7ôb@xqô±“uȘ®½¸ËMñ¼ý²Ïó¥>x%Ètö¨|¢ Ò-£Cù+%z||«ò:Kóˆ†.v¿þáTÝI;æ2ºr3ÎÏ1ÑòÏï÷àÓ^¨¨uò)ÿ2=Ÿx•—Kjž1@›ã˼³yëòÉŒ½¬©™”x`µ74°ÆOW"¶—N”{õJïI“™bù£.7ã% ò´Ô;2u‘÷æ“uï™Í ¤–0æus¢üÅ{oVŸzÉÉ3¦uv™±f {4Dœ mg|."cÇ›{¯6QVp¿z@ážsôlÕb+Yù­ÔsÜ]äÕ>û½ÐǪ‚îÈušo2>Ÿ"%]ýÔa,EäÖÛy&rü(‘­ùýî?Üù7¢Ìa‡ýÛﬡU%»É€?E”³²×|Î3Š d(‰5#±¼ «½»sãfšµ+¥y+¤òSšân:¼]W¦oò³®í°ß5Ý?µåic²{ û¹ñ쾦 Ò+2¡ eŒi£Þïüƒ îñË{ë†ÂÛ~=­nF#ëÿûÆÅ º É?£ˆ,çÚòGiÇÙ£‹îw‚ïñŠ?ù¼Ñû×* cáòûû¬§«O^ˆ;ÑÕx–¡†¥‚­Ÿ¦W–ƒv¹AŠÈû"‰CùˆÂÎAEæ(°a-¼cÊFî"w]ýSO[ØU2ï»>ìSê õòïRU÷Rl’‹áßæöœ5 ¹?®s3÷PlÇm‰ZR)Ry¯ðãx±zn^GŠTÜRg+¯w<‹üR9È1Ûñ`¶ 2¯¦¿ºx}5|‘¸—'"ã«ú {×.T<9ËÃÈ™‹¬ÉóÄšî|šüRÝ”¥óL?JýP„}§ÊÍ™P£–·°Ï\ò¦§íˆœ´RÉmíê5øæ¹ë´ÇÂYÈ1éÕgˆ­6”ôäJs!©Î ƒúŽO5?vÒ¢Y,{®ÏÌhsŠÈý¹ë~Rˆ/4ô—Úݵ‰·êU×UйVU‡tmNä[›+(¯†¨[}kã¾ÍGb] É"ý\p[,ìÙ¥èÝ߈ìÈžGëÙw)ÍGÖ-M‰»úßh‡ól¬ÑzÎÛUUÅk9_‘(ÌÎ[qä[FW Σ̪ÎÖr§âÀÛ² C h–Jópù#âUnØP„„›ñ{ívõÚ> ­ÜnB¹?Ãõ6¬ûõZ‹÷7oNdX“by²_K튜¨\}ûÎ*(»§§®»•*Œ9@:r›*4•9iŸÄû¸ëÛnj+k¡Ö¸Ãáõ‡ÅúAÞ%Ù-7¾Ó÷+Ô¸@ ÂFìEöÐ} 6–÷BÎzý% -6 ;J3—w±rw>0³Ó½¿²æ£–ú:šiîd¢&²ä³-~‚2°˜Ì¯S!^Ö«p­-.Ê^\±k :%¿pr©=l Ø>;jv:Ȉ&÷FÐt±) þ²†Ê?B.#¿ììSùÈŽ¥–ÁP¥ÈøÇÊDÄyjüt¡ü‰1¶dûŽ)·¡¡Á0Äjó~$×ë¤ß„øSjûLE³r¦ñÒܬt(í@¦U™B49‹–Ceoغh¡M‘æÌ15þ͉œƒmε¦×ÿãYä†9¨R—†žôøƒ\ ­šÃ PUN&¢Y"§³¥BçäSßS(»øx°öþpî°—Ç3ÓEùbÕ ‘k× JåDŸÎ#û¢ Óð¾É{®Ðd Üñ{Ì ¨«;`ënÁ¥)Lõ%‚ êæñ‹‰~`_9pœfá8¯t;ún“¼O~ùñõiUTòëlâa¶ÊC¤)´ͽý„' ô ·ü Yo3`׸ï)"ópïK»ìréñHðŒ‰!f¢Y홵4eï™hŸð•"4pôÏýŒ†G½[ÅöÃiVÌì;Äx[åçªïß_Ú¹ºCÁ÷qIVm Ù`÷2kÇx€Š2l¡‰ÄüŒ¥f3AV£?8jEí„+©Ÿ`é…Ó‰£ˆÜ§ªí6ؽ›xð'ß>uã“U‹ÏAbjÀÝa=#apl›ŽÇ,a9‘žPxí³ ÇTîoäîùª)¶”9¦fçnVš,M‡‡– »(Bi§-r"U=šõrûº½:¿ J_’Žš×[¬GFÍÓÝ[‡®AÙÍÓ޽ó£ùšÃ÷”*ÜGÙà žæ¹#s»Ê‹—¢)Bõ݇ŸL¾£óyÙ[$z4•·µfd¢ýC$ ¶äÏ\³€ÊCn¢íC¹šŒcÈë!ÕïXº“ºbd£âÜSù£7ÝDÙê…šžö%%cò0ABpMΚ߉fÇ#/tд9Ùy4¹ÃG_»µùNë-Ã×zBåf‰œ¥Y>óÃú‘{6'*(/PSž!BÙœç6¥%ýP)ÿs៚2N‹çÉw uSÍbU 6ÒyO×µ÷}6Aþ{éuRd}Ù¹(5 å´’ä닎R¤âÈó9¼ª¹½Å;͆¼17Â'ùÑŒ¿±áý‡‰ÈVa*w+å]WÙÏqGüƒ=櫆¾=n/FöËC™³6;ƒè™4_…’ÀE°*+Õ¿¨…’¼~”6¦ÈÞ´Ž"¸’jNç P³äÇáá›Jôd³Žê-ô´U«œÞ¿¡ÀDC&íDêÜpñîæ%²î—Ìzû ÛHÿÈŒð}Í µ]‚¾Þ™} jÞukÌÕP”ðñ<‰f5¹mî ý‘ñ ”\ÈÙ#Í.½Z_•Ãr€¼ çKj)BCòY'÷+§uýý•²+»’žS䟷¶ŠÖ¼§‡×ozA“{gôÙ¡œï zÿxnÈwŠôu¯Úxw3¿´3–.i4å&ïÑï<‘&×SšoÚH¸P7U,rÁ†ÆÃZËÊ7~ù…µz YöYÎuÃN:ž¯¨Þåͨuqúì\g_¨ÚÈHêê¬I•zrôÏý> Cgä<€zÃkƯD{¿ëûýì•4©z$â˜Òú†þP6M.3/""¿æ]™4äEd¯³ò ÊLŽ7õ ©ú« çþ*à“£¼œZ;(:™¥u§«îf?Ù2ä4+E®ƒü¨«¹¢|<ÛosWdϺs|qÿÑ-ȵ4;éì¤FÌÅVÑÛQ&u¸?“iÖ$›Ÿ°¼@Ïäl“äaÀ“=Y»7Ô=DÎC2ÑÔ nª½ VRyß?»¯<C3Ôú;"Ô(¦NŽÑ€ü¯¦Î솬T©_5ÜRâiÁϽ¬övp»¡¯+Š="O»ÇüïÉ›)BuýªŠË®Cdˆßa•Í.4«VÙuK2îŠÜÇ]ä—Ÿ†ªÃõF}N…†ŽîsåÌ’k;­&jÚ!Ó}€Æ‰×ú©#Ù–"{¡t}E¨yU¼p]‘wgªxb¯BÆ^É~Iäh.‰E™«þ#Uã Š}ïõð°˜,dL±…}Å•¦\—Ç µAÛA¨ôþøë Ç)"«zö³…¾(Rõf(û>¡fPÍ#¨þ£ 6PÖ#ë™@šIŠ™#úz¿-¤YC¨\X8~72¾X2_û\oÔ»BŸôo0i(ýEŸuêdÙÚŠÓ7OQ,j */–NL÷Õ£ü2»Á·f¼£¢Û¤YÈCÔg÷‘ÍE¥àC5zýºCš$=Ú„fcþÇ%ìÒ»»X•Dvâ%›YZ¶P2áò»íüÑPf@ª‘KQÆî€øÊQûM)Axº¾èÈñ·tkÃ,+ñz‰ì’їϼ†Ä÷Ȭñ›YŽEb –æ•r~EszŠ·.=Š(;S@¤Ðäj*ÖXOŸ†Ì£Iëõ&ï¢ó±ÓýJu.÷žŠ¬å¤Ã~l rÎIê 70財åG*®9é|éæ$¬ü¾t{3MæØð¬cÌ1(£§ïuÍk*›Üˆ¿5±?Mþçe Ê´~"Ϩ:xî*Ÿ™dzÔ°Ï(›&µß²ûhxÞA³ÁfÍæ¯écáÎÜž³ôn•À=ÿAžf#4Ù½ÌeC˜~!ðuž$àI‘Ê×GâNÿ˜{)b{QïÄýÅóFºÖ®Ì_ë¬òv/3<ë!‡D®Üœ‚î= ðJn¿ÒP­»pþrmC,º.¢ïc¹$,¶"rÎKrY»Œ}1“G›@þÙßÌ>ûP©cÌ·ëá šÔqÙÑN¦àžógÃaN"Eä?œÜµO*©Hòô(‚°|Ý….F‹¡lR.™užkÞLt€Ê“‘[¾úÚBq©ÔoAÑvnÕvaѽ[5*l’ؾy2";Ñ•"\²f½K¿¹Èû±9Îvë0†tzs@<ÿ}é½×xš‚÷{{sGeù1—7qõ}DcD¥s߯ÌkŠÃÓL¦Bñò_Ü7Z5Ùœ"TIãt>?*P^æ±øúúÉ’•t”¾@ë •'‹ÖŸC¶K>K¬)#K©\aÉè8XeÛûËwsñç?, Ðl\úî䉨4yÉÌðZÍ ¥þžÂë->è<í†O‡ žçY@ƒ~ו1 †¢`«ÄÿÕBæ 8ÉêÛœPw€\¦ȺýäI^L%E¨Š–Æg«Æoåß¿ìNy>1õe^ú¡!”}ôæãvYž=üÅæð ?Èí­uDeFE$îNx%;*›"$.œk=´kØ^Õ³mPí‰j§­ûT×™fZo] oƒH¸\ñ@x` ÖÜ“Ö2.Ĉ-Çä7l˜‹ ™~ûS=ÜWBù^Ÿ‰¥á— .nÏÅ/ó?!a&ÍËo$”¤¬Y=êá~H²8wÇ(ÊJ\öÛqÓÜ("/ã¤5[sÉ¿Õç.÷³1â)S"VhEޤ½È xÖøõ¡®“I\·A©b“>h°:Ôiœ&Hh†ðI‡ðoš%êΖ†¢¼¶®ÙÑU1PýYZ‡Øè§,™¬‰ÛH‘EňRz!Ê"9ª¤ãO›L{X;CÝBð¾WÞ"=ï˜ÅkO1ÄŸ×àôô½/Ð :¡ü"QËžfñ®áË.&ϦólÃN¾1 ²†øÕoS'è^¡ˆ2Ç%ñšÊç–žÜ%¶Üíï8Y {{=¹TÚkÍZž_¹ñÎŽpó‹Õ›ú÷ÛyöØŒ·°aK|'_Ðë¼Bõi4÷#ïõѱéAË1î=® ïåN×Ćk U·«_x_;wê»ý5´<ޝ+œ‰¼û‰:ª]§6'TK&¸E”©‘²³û{dí¶2î;â0üúC<Ø3¸"•/ØÕ¸ EÆR;¢A/œ7Σ?ÊT€]áy+ŠÐ Uw)"cðÔ-Ÿ ÅûžA¯!þ/ Ì¡,Ó*$ˆª‹¡òÒš„û•¸<{QTÞüñl¨ñqBžJÊãöC¹•Äÿø¯8ßÞ^vzw$”ê±®|yÊ«÷DØ{ÙЬ:07.>ǹQ—¶ªm:‹r²:r^Ÿ"³G-#}¿bsþu|÷Á<jnX“³q 26¦ÁL—'Pú=`lŸØIT~8M¦T_§?gæ-¢Ï”­ý²0ÁK±ˆùÉ=MÓÑþÞÓïó)Òñ¦F"áiºIíWE¸o|V74pÝ߈ŠcüÈŽ?¡H"–VPD¾K}gØÓä’å)Ï_!»ã¸EJ« ir§mŒó/Š¡IÇÊ÷®=°>’b£(YâO?ÿaOøð¨ÇÕn{@˜P;v]ßĦ¸·Òþk"’Qà­P±Æ@™Ÿ"ŽäŒx†œOsª_,wGZ“*¿ ßηYø £"ñ_ÒdíúiÊ»HQ¼îO5ž­ŽÌWuÙúß.Q„ø½’ýÊHý4K‡pEUþz ’tîû]ÈžL殣ya¬-ÿ‘J9é)bÁ¢ nns1ù&5ünnØW’:yúúÄÆ“Íp$žït†ÁGÖxïŸ{>¾¥—ÄZUŸä›¨0sY©úõ (»,ÛîC‘žW á[É@MÙm>jP¶ð½c¶æŠÈ\pæÂjW(a¨ß}ê਱ü8äu{þwt¼Y±àÁÓƒ1ÈÖ-Êløº›®[ä£4ož¹l¿°9~¦;ö-¹A„“\ìÌþºœO&_·È·Ì 6sà 8›î5åÝdu‘ø[·kŠ÷¨×਴¾e®ÉÙOf1 öÙ”€¯B‘I¬|î`EúzÙÇf=šõA"ö•äÏRDgÓÒÚ§I¢GÞŸP?^ó&¦ÝðxÌ­)? ÕÇ‚òGÄ-<³ÔðõÖ¿eïŽxŸ3d/×%‰åÖïÝ--dÈ‘aœÎÈ™*É›„ê;e+ pƒÀ|ÒsŠÈè‰ÒO›ÊjVCíË”A×VÛh{îýê.»ý•CŽÌaŽw¦É–‘4‚ª€”²b½¥uŒ’>9MzÏüÑQ™Fȧ ~%.¾#8’ ¯f ô ÝBókcžlííþÉ û‘kâaf'‚’ÙþFÖ|3šÕÌIÞ%Ûw´`MU´LÌ–EÿÜתnÍ.˜œÜÝg~ñê&Kü4ÈŒ»Señ ŠP'ÙµÇC½™´Ž]vVÎè_)=¡AS=ËgA”+YøÄÇ^•zÞ¬è×DBÚ— Lb–˜PD9Ý÷‚´AóZ|#ÿ ôï~*È8ñáµgL òe¤ã­²º·¯Î ÈH5¼ûð“)MÁ&õ˜’åû Üðǰ5½Ôh6þú÷ dxÖnM¾O6²Ô8i_Љ·­ [ì@ágf÷|OÇé>M¹=¡Áá,Õ¿‹&•ÑH¨¼³Êu—ìc¨:ÙoCquš ·¿û)G¯E¹Ù¾§är{ ³ã”ϧ¯Ävý’­g~™Òärj˜u¯+ˆ.ܸptÙmø•~½íGAe¹ ;ßf*ï»§ì–ºžJUóxB³,nÖša)þPcàñÇ ¢32/œžnGçk'~“8Ö¨þ_ôx×?8™móç#”ŸiÛý²"Õ‡îÇ)·ýÉ×é\d|6špÐ˰9!¥cùáá¨î-šîÚ-™úgm‚ÊnÝv' JÁ4ÅÒ4hèv¨Þ¡oév#HÜkÿè—ãˆoÌ (aIê·!öÙÖߥ9~PZZL&‚€hìëçw:u¥Ù õkQ¬}G¦§t¤¹]¾æ}ðSP ÃW}¾:šfÉ[Ûž…"ŠH¸}6ßÁåŠ^GŒà,mAªß“4·&Þ†4ÿe¼)iŠ~‰Í΀jʯ ‘Ýæf_OD÷÷#N^ì÷1*™ËÉrS”›ü§ð$»Š¦¼ßÛ{‡~ä@ §'Y‰5’a·C~Ç#ÆÚÕ{Q‘g6_®ðo„?^úo©S¦ˆLÝ»–÷vNGF±2YaE‘Îïc÷Œ:¶uü’§›õ'™fó|¸F¢Ò×Uëvú‚HþúáÌþî¨LÔ­³vXEjÄ›÷–uz4ë|ȲT dd»\<}uE¨#Û$9l/†Ê·ë>Þm@¥bi|¥‘P­D¶£2Ó»Nèøˆ ?÷ý¼û¢_$E”‰Ÿ[mÿ"OX–vÿÓMäG_áî£Iå¹ð5n'é…RyûnSçY"cþ1Gæ•o_üœ(ÂEß*÷8øÒá€NÐÔȱ?6ö=Ç"½^BëâDWx¡ £asÖ’ú;kÙ£©K¾Üç™Ç3ÎxhÓJa'¿žÂc÷w; 'ïo+~¯Ó¾Jû 5̾áÕav&Üô?\4i<ÍŸ³_ÇÀ²޿áŒ_õaä6ÞG¢ø—`´vòž/`wqÞ¼4²Ü:¨È[q$$Ö>O»T÷t@¶Óôi:Eâõ“2WO¦”fù‘}7NpB9SåÅ—m(BåžyOwèn…²°mÓ×W‹õ#—5)Ru34yƒ\ú:§S¤Çµ±ÿT«Y3_,NænªKäY¾Ý\7y ·w©3šN&¥¼æAÀˆŒIwë)¢âë GcBÚQÎé_{là‹êæ†3V£Â%í ¾›_ÐäèJ q”¿;íñЉó¡2·`p¦…+ÊÔ{X'?˜"ÔÝ™ólD]Ù’x äÉ}Oœ¨ŸÐ‚¢/Œ¼4‡¨•»Ul~†|Ç]'÷»šƒè¨“’ÎR+”Uy4·˜XŠ27]Λ%ï„R'²Ý€~‹:BŠáÞ /4 š¬ëF‡Âç½AÁú+—(a‡d[uŠ|W¯³Ø$nÊ“*|içúÜ bÞ2ûþ”Ìó|Yò-½&éÓ¬à T»‘Iù–ƒ {ªQa¨ã×ïºrÈš¤ ’3^¹‰‰åsôlƒÜ¨ó# dPñzš|Y¶¯ÉŽ#GIë>ähLh‹Ñpƒé³&¢ûüfÅîBnŸ÷äÆ5Oê.}\G³±N™o¥y0%#n8õ°+²"$vá_õžÝ$ùÎMvóØ^dŸ"²¦Á¸HÏßPÔØ÷b]78óáP5ôÏE›­ùðe–$>¬gkëÁl%ˆd/ïZ¨ùû˜4™Ý=ç…±†¢BJèõGw¢Qñ´þ‡­'Ñç›ê'¥u„4éxÝà—Ýû\÷B¹¬¬2…•È2”'äÇ ×W¤©,/jv†"|I?[¢óê¶ÏåY{A¼†®Y6—î«Ò¼?Ú ±õ¾üü1(ª^<åü>r_hÝÚ¼gÔDmrìƒ2ò9æ…Š¡ò‘n÷«“ÇÓý>‰Œ‡ïÅ‚ð+²¸ÕÏú¯u¥©PhWQž9•&¿Ç²!0Êú®«öïÙ„þ/‰*­iÈ›%í?E‘1ö¹S„·/^nˆò*…ŠŽ»cF ‚tK )2å3ÚËf.‡ª²=öá×uÄóÐâž× 9¤þ>æ±¶²£Mv@Nò]GKŠô|8­çzš½" nß$ RÃ]fç™È…ÊéR?xÍH²}—ˆîOùè2<2³}'šE¤Ñý“ª>ÛžŽëT u§Ýgþ¶¤ë%šE ëÏ~B¶cÂÞ>Ûé¾ÅDYåîe¦ßh»güTÎЬ7°q€ë¡q+å 2]·<ÚÔ¿³úy¦šÚÓÝP¢M¶ A’²ÎYÈö2ÐÞV,×sºõ ÜñY¦R;š1ÑwF‰ÌŠP$V‹>£ˆ²/wœÿ¬ å…üþ“ÂúÃg2ý•„ îã3¯Ì P)#éuÀU±~ÇâCðî&r˜ –Šÿ2Ôÿ\Ôߌµ”" ºY9&]ƒÜ„×ýÃô)BÅõE¿g©wD†ý£Eó÷¦âŸP-1G šu'fn:¹aÕ¼„šˆp³îÇ Ñhrøh”]d¢²óTý ]®Îcì‹Q<ÙncMªo£NÒxšÇüPÉN‹¼ÁëŒê¬Å÷ý®x”…ŠÍœÐ/W‘½`ÿdÃý¹PÈ<˜ [i†Ž²\½ÄJ‹" –¿?×%{ÔIÂÚšP|øN_÷…Û Jç8¹Q!k'Ù^gcsBÚ—1–~( á®w^óÄ9¸×pHëCÈÓæDF®¤.£9éúHŠnZñ=…›¡üœŠÛ[¯™({ú “ï>!Æz*™éJ“§žŸ;åF-—5Tþ)þ}~}¯,×TÇå-íŸÓHäÞ'Û9l¯§_ûèߺGßdå›-uPnù¨‘òÛ¹éô%#î~ YßA,†œÅúˆöÅ¡µÅðûÕÌ^|Yï¥}tÎn RîBuÿÉ 9ÔØ²wËq…šYdzÆæ&?4±;y‚{"Dä¼|Ù{þ2º_U§"ûpÕê’5©°“ìŽ4A¨K&ÀŠõkã†mŸ¡ì«õ]äWÀ÷ÇÛ(žDeÊØŸ:´„î£@‘h¬³¯·>‘÷GÙß’’™ÚÓ/Û;²Z¶û{Ñ \ìCŒß˜A³„=#ÜîñNäÊJûŠ5’î^øíýÞwÈ3^q¢ÎÙùkîˆÝ2’&ïë¦æ·'¨Ü?÷úEšùc¨Ìçnôí”\°ïµCirj$‰“b½LoäÐä,% µnÁ÷eâç,žK¦¬ï8:R÷ y ‰Òä7/„4›åÉCU²$/®¿Å\ì2ÈuD sV¼3Þ£õCîÎ0Ð+¤ˆ¼Ebí­Sq 2?Ÿ:æxã'*/–öçi–¯@ç-ÈD©__ÿÆÙwª]{*Ñùý‡¨ø1ˆvMß2hÉtt}w‚‘—þo*oK¿ºA ê~9_+–/u.·ûÆvFÁøuc#E–p Ó‹î›z*#W‰LÏ0¤ýd¬ &éæ©HL±_$—FS‰»$Ùm`.òÊÈvJP®­È2¼û ±q6ŠIñ·,n.–Ø«My¦Ç~Y+}¤á‚Îq^K®BÁÑ… cåòíƒÃ” M}£òãåç¥)2Œ”Œôz%«'¾lÒ =oY?)â!«Ç³P÷mȽ×9{ß¼ ÍIõ—…œKÁª}ï—#!‰"1m€âòɱș»˜õÀdxIÚžê#qù‰ö ã‡4™$þÓæ¤û:]jßßLI¡É˜[µØÊ¸/¼#Û÷V}£Ùh×Ñö]£¸e¿¨d:¤=$ÌvxïLudÊnÓ‹>Šð3ÝáîH£³4K‡ø®™3¡ *£È4#kä:¬ÍÑ¿üÁƒ7—Å ãõn ä(BñPiðkìOIª§ý|©ûœÊÛ姆ÚR„ZõOd† ”<òòtïh ÂkOÒ·íöƒT­«êÉ&IÈÉR7x(B¡êñF‘O÷µ*çÿÐW²òõºùˆ÷ ~š‘ò9êÜdåi—¨¸ÒäÚiçg]úBj?ظÇN›ŒDܘ2Ï™PÞ1GÈðïË $Ç×Ð}–›3AzÿhfÜ’ôÇ@Æí Ý5#*>NÇÉ«C7̘³ó œ+^#óܪ “Ë'î[AóË)©ÿ¢9 ÔHóH¹9‘rÖ/*à8å/h²¯Ï¾!:ŠíŸ¡¾ÁA³Â‘qóÅ»ð¹-äK5ìMëó‡ÌkÜä|Ðø.ÕO ™qf½}¸©ó9¨þ½È(ñ_7±1®W;=ây¢ÛGºï:ëseù‡ÃËQæKŸRWÅá^ÚmüŸ\¨qŒì7su?Š(°äoÀ«9o>qˆGî³9Øï¥.4HÊÔz@ùJÖ“cZ-X´qD§¾G!dzîé«Lä2²zôüŠ&ŽÂÏ ±®tŸÛêc}¢KŽˆ¿dœ›ó¯ùÔ¹4\ɾÏŽßÜ#ï;Õe\zw­mâ9ï£Ù-Î3º7éÁ ½1§Á·föqÅP»¥1OQÊ–~Mƒ±d¢EZŽþßgÏNyzg5EdÙÝ%+‚i‘ã¦v~D“c~ÿjª$Ì ³Ùøf-Íø}'>ý`N¥™3_®ÐpöÊŠüak_ø1å 2%l„QR&ÇvëOŽlÒg‚â¿ 9·”¾þƾUÈ<á7c‰lU'ެUYû®½=OçÉ>—Ö¿7jIwPÖUŠÈŒÛ}}4¬¶ éS¤ë²ëÃö½W Yšu #³`LÒñ›Û¡f˜lɽA4“Éî"£vRD‚ £æ4 {—%yÈÉ«v[¾¥¹S;Ý4ݱ¯e_6ùš “‘Ï“Æg Ñ<^žw²@n¬ÒÓ먛Ýi1/‘bS~€Ùι'Mªÿ(ó›?éø§ÉéÈJþ¡"õKÉÄŠ0(]U[çÈØƒ,_‰]ÑÔ‡7áÒ™„[PQ"IdDûÑw±…‰L_K Ý•×2ï…»Ö:6Õ Åa*§ÜG¥õdš‡Eº¿0{ F‡+d7ãPri÷ÉE‰^´þÍ’•Ès¨VwJ+Úþ‰îC±ÔÕì]Î.a‹¿/{üݰ‚q4¹ýíÎÏêùÖo¯õZÙ$iì6‘¹ çÕ¾nAÖÏjçÚr HžÜ!øØªçÈÚäæªa5úë• ÎŸù+Ë\: :÷|T÷NË킽¡®¿¤;Í‚K3ûYzAéQòø.+x7VÛmÔþÓé>–2æ–z¢1QAÔ=ˆlèsGN­$Ök—ý»È,‰×}Y+y-È\E&z8Q}Ñh6öAÁMÒm`‹r‹"¦‰”UZ°±¿|ºà׉ӟ·n†wa<„²Íϯg. Óó²|ÿ€äñjŒCñüß )Ä„2²ËD™êûub)ØÃÁôoDVÿÏ›ž>¥Éõëä¸ôc92XÛ}Ï2†ÞÿtsF*U'Ð$çÆ‘âC<öN+Ù›ðj ÿ¼ÕS•"rkzˆh)òB8bƒë1rÕŒ\Öï:2‚·©•}¦ÎO H¯‡h©ÿ¡…••ñ«çqàOØ”ÎQG®!Óõñï/U¦tÜ7@l$ÎW5nYçìK6êú±j&?û>êû]³å:Œ‚ÊgÒó(V\sáäÙ•-Ø m·Ç.oøTTS §>1~»‡¦·`qïÃ.÷MœQP$9·¦(1ÎF®¡´-ÅÆ> ï®mù, ×$ý ©~ýT]fó¾¡(ÛGûõòˆvÛ¬ì7„K‘ê›Ð”÷yÚ0ê[Þ\8$iÏ¡A9dõ×gª.*ôEUþS“)"Q"QÔ¡æì¤™™ƒhþšœënvûÍŸd›#O'Hõp¿N> j$îcKš‘¶Kßù¿¡ˆ<µ°Ó—'@©Á‚~öb;Þ­öš‹|íya¬!ž4ûõÑ}û({Ä,ßc= ˆœãdè7*Ÿj–3"½;/nÑ/¹±ß²L¥}ƒÍp©äˆí G7¯#ŽùPûhŠáb͵T&šÂ÷'™=é !½“ƒÕL,‘«!­WãH!%2LŒÝnaGõSEnÈ’ÐØáMzC¹5Ùø¼ù#_öž¿ô:M†ÕWŸi f!¡då²åûŸ¤ú7\ÞÆè±tÔ‘úKëÌ2¿Û8í†#jŒŽÕ^ÈŽ’œÓ€¬ƒ2{ŒiÚGØd{…‰M}UoX˜¾Z ý¤}¥‰Œ^†zÃ_즥_jŠôû“]ɯ+4Æ­Üþ«çPŠÈz!µOä:oð0ÌiNxMFËv¨¡’¬ä6d>óuÖ„"\ömì×ÛÊt~²B%ú2•Ÿ¥¤q~ÁåaуW#·ÂP‹«Ë§ÉîwýÛÿ®PÿUÚ_€™ÕCl¨ìÑ3Å…o¨¼ãŠWÄ_Éo<7‰"U’¸ré`¥ˆ^tŒ†LwÈöz} <”÷¸hðvŠb9Oüò»e '6X„ŸFÎø¸iÝœY¨üx´ÑÔ,mš¼5&ùR)‚çðãÇg,×E¹\Iž3ÍÆø2•¥ux„O9¬“Õ~£ÜwéyD©~X¬yWŸë‡2ÅI~&Eú4óöÖÎ^•°šf˜áûèQAIÈ¿ÄØ$op¹ŠRùÕH*D›¤ò]L¦#ï¤úD¶Ð¯>Ž”ÖsųmÈÎ-úEÈ~ûݽ!2¡.éÅù_ T–ø™á²°(‚ס˜"²ÈîG½#QAª§Ð¤òõc¤çèÒé×sδ`ԯƼKy±™“˜>]‹¶œew¤Y?“<6gý?Ù MÌAFßÞcÄ#„Ǿ¼óAPº.²’¹{ «]ç͆‹Òý:ÇÙ'-è˜âˆÌJÒ°‘"ˆ¬d mä&‹íÌkGYK)‚ôü+z ˜üRÃ+"?¢È’_­“4±Eø()ƒè‰$ý¬[K$I_lø]¾<Ø„++2{ÌZOŸkÈ|CºƒMáã§°‚I—(¢J·ýs2|nCÅWÇ¡nßöAäy]gÛHùÍ&ßÈ}Dkû,c(û6«º.Î*ž¼»·¬ûšÙc–\±7XÕ]B;¢F\’¸¦¶`¾æÜbÂLÇwøt`ZAY÷×53 ÷»®“÷:2“T†=ÛøúIüÛèûìtðm<©Q~ëõ=~£§YíLKA†£_†Ã~úÄF‚?™²÷K“äFšé²Pü8Ô©ãú®¹(ñu®Ùnñõ_%à4ù¯T³„49o¶'leÐd,Xtð–©Q ý…êr>#¯òð;¨I‘Æû‰òod¸Ø‹×í]ÙWd^ "7\n€²ýj—×Pgj°]É%òû¤gMÜx9!|<?3]ÔG“f}gm²q=ø1&ø”¾ƒ¬¬×ÞÜóyÏ÷—žKÿ?q·´¿,ņ-}ë%‰=‘óL’_‡'é9¼l¹÷.væMãêþøû ÈI ÃLšUnv .žy(C¨å›ŸûŠœµsÜ6p´©sÚè~Ó!7 °á+QD{óÎNDæEI_sTžÕàpvüU¨{¨;eÉsd¬–òÉ­3Måti}F#áÉ¢´æ8ÊŒüro‡ÒÇÒ| f7IQÈ?*=‰bˆä9ØvÝ/íÈY±t£ò-Hïù™Áñª 3o¯;@3ó`—,ÝWPk}17ÍÃ"ÕÇŠîÊ’PDvgûʶ}(B-Ù†ãx —ãn”œ\i>4Mkëôs>3)BLcÿØZUɼ„XÇ?¢jåáÌE¾­ä|Æ&=CZç‹<ÏÂ]“€b‹szJô:Úû•,«üvDJÒó¦Db"o!ÛdïØÕ½É2³¹4ÍÀk°íBêÜ!¸ž}ðpMO ä+tV«ªþ†²c#w љޔ÷OvgµK¦û$Û3ƒŠÄ~1£nRçŽ!ÛpÌY¾~oŠ \.÷4ys#NÏzFû!Pñ9éÞê¯Õ‡hy޶FNOIÞ7Õ'åbµžSFJ_í®t~C#¡Vf–ÊÁuT²&æ_^ð•&Ûeé @Ö﵂ZSTr?±Óì~1DwKæ÷ÁG>ßÎP„×±ƒ;¥À%åÌæÞH …]ï¢íQyhÑ­Œ¼*”%J·Ï=TŸÉ0EGŠtÜ]¡~C~š¥ ÍÆsèë¤âLé9nÈ5ÿMv| or÷qßýȤÙXŸ)ÞçkÉÌ+Šp}©¬ëù1=‘Hêàor'ùÝ͉F…®Ò~k™s¥ñïÆó¼iR}º¨¾Ò"O½^y;@Õƒg«# ìûƒ²ð­ª‘mò¤Ç\·Þ+™‘¿ó¸!7³©ÞaÏ+ïÁÆ. ›-¼;ÈÈ‹˜tåâšr={ë¶xN“ÛUÒW¼9¡¢`€ëg߀æD¾g8i¹Òö2ÅÚ?k.8֜ȓŸ:“ù$Šî§ÀÍ9çt2)µ©<æz .«zÅ1,y2?@|Idí6ó|ÿ_$þÏý¿^û·ÿÿ¯¿AüåýÍŸoËkÛò÷Zûÿÿ×óÿkÜþ_ÿ'þ2¾Ìÿqmí7¢ cÓžû÷¯ÏÀüÇó­¿öÜëÖÜ3âs¼­ß­¹í¹WD+æíÿë5Ä?æó/ïÿ¯óŽùñþ×=$Úxþ×8í˜3í½ïD+ÇhØ1Û!¯Úz]Dåukï³k‹ø?XïD;ž'þÇúoïš#þÃØµöõDÞ÷¯5ÚÚkn‹¬c¶r.­Øÿë\ø×>ÔZYF´AÆÿ/¹J´s^­Dç ÑÎ}ÙŽ¹O´á›ÙJYþ_öWf+÷CæÐIÛ{[ûZ£§ÿaÿj‹,#Ú!«ˆV®³ÖèÈ­¢ ûR[å+ÑJ9ÁlƒŽÕ=»-ó–ÙÆ{ü/O´coÏžÜZYN´q=·Çn|lÍïj m«¬û-~L4ˆ+Ižg3äóÚÔƒ‘ÒW°¨W0À]³ÊÜf y&ƒHú ú'œÍ«6Yno|9¿ñIb÷ú‘6ýhdã#ö†kF5½}ó–µÔ¶˜ÛP?`oß²‹z«À|ãŽí6–ÖzÍþ¸Àz‹íPêÈ“Ä^üOCƒ°þ/×!c±ÊfÕÐ5Öâ·H¯…!úÿSEЦùÂgss/data/ColoCan.rda0000644000176000001440000001637712247272075014043 0ustar ripleyusers‹í[gT˶î!#JP’1 »eF@A°‰¦f`‘ " "ŠDAP ŠŠ¨Gí6 fÌ9 * £˜#¯ðô žsß]÷½?÷ÇY²Ö¦»jWíÚûÛ_UO¯ÕÛ•å9¹Ÿg? ä0iŒII£[)ôÉ`Šè*ÏðL6äÕQS É$‡ FRŒD¯w-šHd‘(#„‰DÉÀ^»ôu­ïoD ‰3U$†HzÝQ£mõÚ6¢ï§#BëLè>+$:HÑýj´Ý^[céµ&þ¹.ƒMûÓ;P›‡®ÚHzÃìm=_I$C‘HÓ1+Óãzí* ™E·{utŒ*´ï›i{évº­JÏ™F_{ñÒöÐ~+ý‚1Ý–§mõÆ^ƒDŸž«L¯©@¯1޶=€¯H¯¯M_‡ÒªÐ¸õŽMû5^«Óñ4ãèØz1™B÷‰uƒè±Êô|µ_riô§-Fï:ôøù¨]Këeh<ÆÐ1éÒkþIÃ>œÕh¿zù„Ó1(Ó±¤mÈ!YÿKîûѶTèqÒt¬ý~RÃÓ¾;ÒþËÐø¨ÐÜø ÷hžã˜Tl †­Aú(ïC¿b˜GrÛÃFÎÁ0/ ûÃÃ&£öLä§âì´p óB˜Mðð¹>ö0Ãælþ-ˆŽ […ð0¸€(:ÙØ„aÖÈ>µc1âgðu ³9açc˜O†•®Ä0{.Ú&[Q G¡´5aØ 7 3OÀ°ûH?a—µÑR “Î,@}÷¡(âk#î̉îãQœ­*%Œñn¢’ùב/Ж\‡âOFWä“Ú=Œ1f5† ß…Rf…1¬9èþ ŠÙ¶™Ò»ÃüÑúæf otEûyb†Y¢>&µù“ñáüÕnCÛcÂÅ8åÁy †ï‹l2Q^ÝBóPνۑ 4Þqè/ÂÝc"ŸM‘™+CóXߨ”Ó«¶ñ{æuŒŒrºÙB\=×€a¾‡Ý(osPNçÝ@¶MѼ@”#´¦âv:óœlÞ×М9˜ô Ïtžø¼Ç ޘܔÏzäÂeV0†‰ž ìvbXâN âÅADQä—1â͘Fä—%’ „·&ÆèÝ:æh -C¶ž3䟑&5ùl‚òB@8C[qŠÃòOLÔÖc mÄ)}´Ÿ”cÐQ‡ðÔ߆aW¶¶(vÕ©„ìš#g¡=`t“Ñùbжˆø<—ú-ÿUaü–ÿ¦üåg³”Ë Ÿ4Rt/ÃV|ãô·ñ²~¦"âl«añqÙ{»cW‚Â&¾}ßdwF]H€Wm2›œË,A·kÙΕӡ˔q•\+ˆ„c(™\{™ì©ÐtÛÓ0÷!—Ò6Pûƒ.ˆìÇîæ‡€N…‡eUžƒÈ"FÎ]¼Üþpéö—R Ò̙ȴœ 7 ͯ-.Q¾ÑÙÌe+@TMF1–‚®³»#>0ÏB×C} Öêð*#Ü?0µDë´•k³7æ|æ¢Ä©¦Ó‘sµ[ž,ƒ®n£™¡[ÓAä5¢ÊoãaxU·8çž"Ò¥)H×iB×I­.gÒ¿&í§pAdzÕèþè:cÐï@G8ˆ&8xr9¦ 0Ocÿ3w躒kÛî]Ì:UÐõ®ît“>@›Wr#Ç®^IŸé¡ÚŽ?ªMýÆÀ«S]oCûz+ÿè+ë¡+;a—­ß$UÌ•áÈ}€Î/—–¦ß? ªŸîu¬‡®Ë-.<Ú„âJS1M{ ¢ÓÒ6B×ÀÏ•Á¢} Ú°½›ÙDnõ‘§šN€(ô°cZÊKèºçû¾©]CùZòV%<ý4ˆ"ý‡ªˆiÈX0Ì:¼÷è$?ÓQV•î–1= Îk)ßô_ËÒun£<¯çê\E<Ñz|e¬Ité¦WØËoѦšüh”‡W¬}èÄ‹eç—ž×QÞ·v·=Lx•«­W–fŒøU²Ë=¡SZ7šŒTÑè‚úý·QÿAõå jOA4‘O(+‚¨ðÛ™½A2ÐQ?~qy ˆ–Ú¥ ^OA×Òzþ¦Ûí ŠU/ù¡ßù›ß¿ùýOæ·äwçv‘+/t@Ã[ñ—޽„œ¦Ù—ºÛÛ¢‘—ÁíZÕƒïjÀ{ÿqÝv‹«ÀN=ë²q<,¯¯2ò¾h­[ý€š¢ì Î2"|Èk+!¨Ãv@sxuŽ;ìY›ÂÀ“ï9¬‡˜„†íòg.xjÌ‹@ð_sûhÎGk¨TѤ³2<ôl·|3; •ÔV79ŸE­w:a*âëŽB{ïºÌ}0ϽRvâÞS`vðò‘yrçaÅH½›15× ·P»E¯ö…0ÊWỸٵ/\^ËeA¦póˆüS Z¹2§'/þ@‹¨õÊjzy~°2Ë:?Ù5'ÞUÝuÑ‚…5Ÿ6/”û KbOƨÄÏçÐ.æÒéà¿+ÕðzòKÈhr2Ø`ª %þ—fý‰à÷#»Rr¾‡çŽ›8–mn¼Àüö}náO€ËæËS-µã¡þµQ÷Ô­x:0á‚æÜ7pItÄDAK‚j4”+Ö­/{µñ_«¤ ødÒè϶zP|Àü©áÐTXáy²&à!Øg{-Hµ› †ÛëqÂïµ¼ «•ïâf ‚˜'Öim±à_ņbËØðùȳkµQ;ñõÙÓàRy[7¹’¨ÁZÖ[ŽÁʃùS²óÚ éùq*½{PÜ¿‰_Ìü;—¼0 p•?Bg4Â2á»ÜÁSÝá¨Û>½ýá«8üÕV 3"«E~°ìà`›…ò1àËOF8»;Î˼ÔÛoxÓ-¾_XŒ { ðü³u›ç€ûáay©[àûvŠEÊèÝpàClÙÙCeÀYáö0ª^Î0•-[ aÛ45<¨Gë#ŒÐûå’Z åxˆÊæç&©@å°Í=yÆ'À».]&â8 ^¢O’à°ˆ[{§²éÚo~ÿæ÷?™ß’s¼hÔÝ|¢!ìi|·Eã”G–[æ?1‡-YiïôTs`½ë%þ­µ]!³ëcN dm}£YÄL‡|Å/ËW.)„]Rû´ ƒ’äªgMÚæ>gVæ›fOØ=üyi diß0=ÓŸ yͳŽÙÚèBzÇÆ3CvdBÆédyö1äqcWôX@‘nÚÞ 3&BÁ±»ç = ÃŽè;ÅZÁê;íÝÔ'l­eüj4¤9~ò‰;oÉÁÕ›>8A vÖ±P[ùu½óŠ(¶º¶‡-]kM‚㡼]ñQ‰Wd˜§¾¸§Öì|ì÷Àòô§<½iÆDÇ®°mndÑÈVE Ù¥?²©sk«!Û"œqyÛiØPøîËæ°qHïŸ.äðï‘6/J!ßb¬Ãt89æ:Òån@EÍŒ¦íÙP³FÏóõB8°ðå‘®C`ëŠØAŒq ȶWnÃ÷+A~M­–ýpؽÐIÆ7©¶/4´šÙI'㩇çe¡ôG‘UÕùÎJ‡@ᴯ›`íüö-„o1æ·§ qS‚=õ*µ·RT!ñ¸¢ñNs°^/9ÝÇÄ29×/~´P„Œ©öTÈA²&'Šê†ÄY-·‡mæÝj_Ãê»\Ð[ ™uÇnåž…üø;*JwC6³ËõƈQÕý²CÁÌ ²žT×íÕ{ï|ðÞ­éwfïÍ+zyŽÌÍ®Iífk=Âà.èùžа6~ú4?²Š«Õ})ÄlûChÕiLÞ|øì3È”ŠO\çY©ÒŸ¶D´Bá‰ZÿŠ!°6ûÃ&Ç}FPúäåÅXî+Î,Tj:°xÎr86OQ^g±ýö¹÷Ç™3t–·)˜àÌ}Ûr»uá,c¯Ço·¯À™F [ò.?À™^Ϧ[,Ø3s'»4šŽ3w|Ý=}ÎÚWz®Ý†ÂY:÷x<œ9~ÓðÝùÝ8ë‚gÌŒ;hþUnlçýç8sÔ££Á^Óq–ÊÁˆŽýA8³N᱋ZÎZU2ôÉ]gŽÌx‰ô6Ø•?4½pfÊ¡çÓq–¢ñ4ç=í8óÅ‚UVƒ’q¦VÚRŸ¯qæ“E×ËöúãÌã"Fd§ã¬eç¨ä8+XÕ«ÃCgFϵ÷à¬dËå)Yº8kJŽêÔh]ÿµwóÌ÷âÌ)„Î|7À™O‡äF6ã¬J®0­‰3½¿.”VuÇY¾ÁüÉ­I83/ÿÈÆ¦Vœ%;#òF^7Î<ºwú’¹ÃpVLcQcð«óýþm(ÎŒU ðº‚ðg­X”òzÎÜÙQ4Ã$ g¶šÅú¨¼Á™ýýh°pæä¶þ‹öÂYÇÕeóg~À™ÒBÏþ“pVÊ™œÝAÍ8ó¿±fÙœ¥>ñ`e¸'ÎÌè—íƒòÞ,Ÿ‘óu(Îjâİę/(ƒ¢Å8ó$Ö¨ÿ g2¼‹÷É;ã¬òÁ› ÿØ€âj¨¼Ç™kÃoKáLn*ÃbIΚTÑ›Xœ5r×|} ùÓ\·¯zÊŸÔ›]_Ÿ…âÌιÕWoFù}òR‡i‚³xüÔÓž€³Æ™4Û^Á™ý BŽ‹¾àÌ9g5¥óqf—¯YEÂ4œµPw“v ²»¸Ö!ËN geAÏõÚóû7¿ÿÉüŸãaùô®â…ÉÁÒ^»"bâǕ١ˆkµ/º£WRÄüòwxµ.Elé)YýÚˆ"Ö—Ú·0·RD¹þ㫚™‘?~hcê½;EäOM^ ¦ŸŠ(ްcƒæýä5Eœº³ùØsаNãžBKô‹RâÐ<ø:¿$oExÅÏþ;ˆ"š¾$oQÄÒO÷ì³r)ÂÑnד†Ïȯ §/VSDsù„aWâ)‚‰àÿ²‘"²Ž<µ³ºAmƃËWS÷‰§ó>E½:wð€4ŠHvÿ¸°H…"Â=×[d¢õWÉn½5‘"J Ì-ÑÕ+pEÈÐ1¨?ìÊSä×â®á ÷)"‰tiµóCñÔI­zeMø†•rF(ÂçÇÅË·ÏSD™ ·üE¤ŽTÆU)âî•q{¼£ˆhuöýÜ4Îv"ç³Eܶ*:Â8KÕUòm;^%ýÏS Ý(‚?,}ü‰µ‘v½sܱí(ŽK“\î>¥ˆýèøP!‘ßšÃF×í§ˆ²å®–ȯz#ׯ’}±¹”_òúEÜ9:µÃ€"¼V.ɦˆo ÍD¨¿d˜Lä]Š8XålÊüBYîá#ß»&[6ðk)âR×Ìì¢3(« :T®SÄÇáK4 м=‡%¢u~{f{å÷ž®0-"\*ÔÆ–!<I©7 ¦ˆœ@_åçW(BP6ÐôÑXŠn]˜ƒÚTíãõ_‘ý]á:ª·Ñ|õs‡ô.‰ï¶­§ˆ™äÑ×YQ“®¶´Ê øœ’ñì㈪+*eQþšÇ´*ÈÜæ)‚Ñ&y›uà‹jb-™zlˆŸ¹#\ï¥u‹h€ÈÑ2l©i‡À4÷tþþë¯ÉH޼\b0)ÞßÖmVÓ¡¢›FÛNÁÊ}×å£ß;Àü§ÖV²ËÉôo9Ýw¥ !“Ñx­jöIH¶žWŸñŒqÕ¤Á†óÌò-c+™]pÄÍÕù×ì±}ÍZHÎX×b®¯Df÷c›eoO&îñíHÅ“£?§M†¥]ʹ%—1úôYÒåþl5™dù6w–U¸Õ|¥o~›Œ“qärt™räcéÓöý݈ÙÞ"2{ABêx Éç‹¢äß@–Úó¹KOeɃ¥ŽæÉðG{ôsY2cÑ›°kY2îŒJÖ–ï3Éõ°’¦Í&×Ë4Þi." *­>x( ¹+D³ „d2[x«°ù dj›”ÊW4Õ‘¼·J´ähqó³r ÿ£›ÖÔ嵕IŽv¸^D™<=G®þܘ}«ò÷#üJ´  2­—ŽófšÙ©«RL¾=…õ+ϽŒtšH¦?ñ°A6\¿þˆ¹édÕ(϶r8CæÞù¾DîË42gBÜöSõßÉìÉUKkD@Ä»«ÍN½%³ê}xö]êd¦åI­šG`×pÖEð 25(ŸžkÌ æn8A&¸Ô߯ú¬ Þ¢<&9ô7¿óûÍïì)¯ ®“)ïõ³–šÁº]­—5{pÈNpñ >ó†,p±³¤Ð‘Œ+ŸànI‰¡ .ZdÙ:ngž™ë8oæb>—L-°sjÝ‘K®”kõål¾±ä^ÅLXQ÷q’×Ü÷d¡{^~޶”Zè¬óM&ý¨æY÷³È"ÀêÛ†Â2ŸMîÛ&ø“1õU›ØìÈÏ…ÕD‘E®™µ÷‡iCú´aa¶§/“éeÝû~¨IAdíI««fÁ.uó˜ÃSÈÍv™ ØËÉñ7ßj{/VŽ31÷žt ¬Áv¼I‘‚œnMÝïÞ’™6ù©Më?¥)ªE°V;û(Ù_%³/½evM$Èuƒû¹k¨’‘Ïî®?:€Ì]SÝQrŠôänø¥ÅK—±ÂŒ¡˜%3¶\xJr?DV&³®‹ó;ðâ¬Wœ“ª‘ó6U_ºtÊx™ktjŸÏ`ÈÞúÃbŒM ™jzœ±÷/ LºÑ¸÷½=¥vºqÆ;Èk«J=_›oû‡Ì3O!36¥m:wÌ·w Ïú~%/é„hR'‡ß™ÂpÖýNûõï´X<œÜxÔípˊ﬎ÎdÎ K¸;z²y&/0_;k—\ÂV´ÿ´ðÄ:-Šz¼x9™ælßoIØE20MÙoØ.( XæôîÓy27'ìéTßµ¤0.-|y¿`²dgd¿÷z)Ptñž´4o”nS¯ÈZ¶€L;¾M–õ<ŠÌÖhê‘' «*ö„'yôpHÙ°!É€S!ÊJ—Éþv^È®é0?÷þZõSd <ß}/ýä*¼¼m/†}…‰ÛÏ’ÅïCñWÈ -ñ2‚3àþuƒ«bW dµåÌ•=w²gîV:½Ë 6N¨IÎÿ¢ø›ß¿ùýOæ÷ß>O”öç†Ò_¬Kõ}Íû—! hŸʉ ¿œ—¢?[üË÷ËÄ71ΖîùÛ'23#fGüåƒÇQ÷-ƒìðDéÓsÆÃIðpÕP…Ò;$ýâëÓ©7Öáîû—~ñõaC¬õð¯ÿVÿï®íÍ:R§o÷‡'·šçížg·ê=F¾´ªƒ'Ö_zn¦eö{•Vaj¤ñíµ&ÙÙÞÀÝúÚ/Ž^êÙèÏnO›"ü¸¿ÏÞÖô‡ïTúÆOèô¿‘×§÷-°ýÙÿ?¯·Bs\oŸÝ–û7÷Lm/i? éþ^¤†p9ýµåH<ÜÏÐØ6ž¬~¶lG² ´î˜ÿÍ7³õßÚoKOôK‘´_̬8³¶$õÿó߯OÈ?ò25ìÿßóÚvví{5ܨÏNñÓ¸ÝÑ“þÏóQæßNGgþ«Ý[¹*SCÓûìæ bŸ\øŸíæÏ™1¤úÙŽ÷7¿óûŸÇï_ê?ôSA𮋒¥ë«äé3Å_ê«úÓOq Ú¯õZêt•]Ó¥I×yiÑ5hÚt ž.]ë6œ®óë­k3 ë°ŒèúÁÞ¸‘HFѵjc躾qt `o=ÚºÆo’ÉHL‘˜õÒÐ5i½µkSéÚ¸Þú7Kº&lë?kÖ—ÍDbCײè?[$sØ!±G2›®ië­sB2—®]tA2‰+·?ëÝ0‰;$žH¼x#ñ¡ëý~ãý_Åûý=#)áèÕJ‰µ ÄU3ýÙ¡’ÇáÓ %¶02HÀ„r¢Å¦l8üHx€¢ í ú‹§Û|ޤ!Dó%%¶l¡PÀã‰b1{+MèqL["QðØ1’9<î/«)0…ìè_“g±—r93 ,[è+JVdqüØ‘Q¾¦ž#›çÛ7šÇŽf ÅÎʱ¢|\±-ùY¼ ¼¸iËŽáDFJ³å bÄ^(Ø ¢ø‘l®ÄK[!›“´ål£x}1ÈÙq}#$-Y;46R¢r8ðìÙ¡Ü_&ÊÛ³ù~¿>µPÈí³¤hÏáû ¹~!PQ‡P ¤œ½…*ö¸Ÿ=r˜ËüŸJcŸ19vDG œ´ƒ$!Šœ€Ž°o¤‚‡ÏG¦$¸9‚ø}jG¾@ük[ÑQáÇŠˆçÎa¢ðÅËÌa‡pútz.aä/íh!‡ï'nË;±ý‰^Ή-äö9…ZAl ×zµ‘’|È:q²•€/ˆ­öC­È@Äö>àœÂ@¶d™¹œè>Ðdç |y烸âÀäœÿ–s´dCɺ ¢KXäÂJ’qáJr?#J† "8’áÅcG„HÜw‰ŠD¯;â¸]Ù|/,H¬uå†ñ$Se\£"ÄY7?A¤„wnAž¯d·°^œ…eä/.Ë»Er¢|%áôs‹¯ç€Ü“,©àÅãq—JSr‹æFÆr„<ä™xÒ|nXÚ™| ìr¨çX ~_*•ÜÑDŽÐ7J(^¢Ÿ;Gˆv¯oŒ;7P‚½Û—-‰µ„B‰»ò½-®d õó@ÿ² d=Ø1}§—‡Ç“ì& ®„Œò½^`¾!þµ‚Nüò©úó‘Fwr–r$»\:L&¾àˆ7‡t´ä¬‘öí»ôÝòØ}·}‘râû?ÉÑ'ÓëÆß\SD‡ñx±{?ߡѿžžûóÔèçÏŽdþ4õó]øÇÿ|7E”JAgss/data/nox.rda0000644000176000001440000000212712247272076013316 0ustar ripleyusers‹VL”u…ƒò¦„ÄA/½±G°ð*fσpZ–ÚØ5ÅfM9+4û5gY3gÙ•Ú¯•¬9tÍ1×*a4#—6³ÓÕ Çñzwð¾÷fD¬ïçeí¶w0o{ßç{ïûüü|>ßïÞµÞb»×®(J’’¬ÌP’’ÙÒ–Än3›2“ÙäF_+»ßÍ—ìJc—WìßÜܱó ÒjlYÐ\_Öæ~ Ýꩺx®eØþíó¯á£uc~çÅ \üìŠ}Ù¶Ïa쓺vgøð¾‡.'+áÂÞò÷ßHÍêãá=ŽÎµ )âÃ%°+º3ijŸ~ñûo@eÕu„é™;+Žeâ¼w7<þ³ÞŽŽ¥žŸ¬ùà'~/E(æ ÍǬ3mîU=_¡ûŽû“fUŸêŸýBÀѹ&¼çhéÆç…f/¸ô§§óo݇•ÇYµèþð‹þu£í-™¯»vÁ×wÝ‹¾]͆8{;Úw3׈9°b¶Ì3§å$kð è©¹× ³`nF#o—Ç{¾ùø¦ð)›;pá›â=DÄx/Ãù¾«sY)ÌûMÖIå(®_Žž^±ÀLÖ´7}âŽxhËÞ ts›ŽòøÀË‹«¯±ð%*®~FÎsטŒO¡ü•92o^­ÄÙOsÌáSÖ•`U£ÀGz B\ùž .5°Ê/èé’|”õ â`Tæ_¹÷«ÿ`Q'ð;P—¨­—ÇÿÄY4wy“Ôƒsø)ˆpYx>E[4~>æ‡?Šxà.>hã `õ8c»¡z9ú»†A Y=¸4*ãÛˆùáážããn5¦Ž!*y!É'è”O+úƒÞk69·!h:å×Dú`pt–5Aôì>ô9ˆ‰r¥#÷— œ`PÈ5‚éBâz!z/Dló@•|ƒÎMYh¼Ã§!Fñ† ¹bøïG¸AºáÛ)÷: É}šÜ‡‘ÙÆ‚$…+¤ˆ‚ŽŠŠ.T|ƒŽ@•ŠŽ* J嬯dÏíÞîÎì­ßŽkQMD)KIœ²=Vû+IEªo>æYö>ý´Ç;û=©É&·­ ˆz•妺룵“2{Æoá'÷’› ψvð›ôt#7Õ;Àoý ßëõÏ1êü&ûò>(ðyƒ:|Í>>õuØÇeï ¾õÆ¿ˆw™WÌUô×3äëo ÉßÀóÂ9ÆÔQÌ7$_‹|m¾‡ažÇ÷¨×ežY 6à'}ä§Sà„õ)yRꌩ;&¯¡nïÂwæ^¢/Ä]ò¹?Íú1÷)àh)´¿¢¤òÅ.gss/data/eyetrack.rda0000644000176000001440000001323112247272076014317 0ustar ripleyusers‹íÉ“GÆkº{ËX 0‹ÙÍn6£u$ÝŠp3D˜ ãa,[ ^X 0˜Å+Á‘#GŽ8øÈG8ràà@È´ÔÙ…=¨§+3ßË|™ùsÄçjI]]U™ßûÞ—Y¹|îžûNÞzß­]×Mºi·ÑM¦ó³Éüݬ;2?Þ²÷øÞþ•Ý»nzûüÏ›s¼®ë¶/¼ôôÝõÿ^úù3îxËâø³'ǧþíŽ__úOwüòâø“¿¹ã½‹ãÿìŽýâøäÝñøâø£ß»ã‹ãëŽÇÇ<åŽÝâøÄc‹ã÷ÿ±8~﯋ãw_Z¿ó‡ÅñÛ¿[¿åžãqwÿ¹û~ÔÝï#î>¿éîoßÝ×Uw?WÜ}|Ã]ÿ²»îCîzºë<à~ÿ«îw÷ÜïíºßÙqçÉ÷E÷ý/¸ï}ÖýûgÜßÊýùD÷ªÿz÷çÞý{ï¾ß»ó{÷{½ûýÞ]¯w×ïÝýôîþzw¿½»ÿÞ=OwÏÛ»çï]yô®|zW^½+¿Þ•gïÊ·wåÝ»òï]}ô®~zW_½«¿ÞÕgïê·wõÝ»úïzÇÞñ¥wüéŸzǯÞñ­wüë{ÇÏÞñµwüíŸ{ÇïÞñ½wüï]<ô.>z/ýÓîy~q—;ºçúå9wtÏ÷«O»£{Î_ßçŽîyŸ9íŽî¹ŸùÓâø¬{þgïqGWÏþeq|ΕÇsŸwGW.Ïý}q|Þ•Ïó÷»£+§çÿµ8¾àÊë…}wtåöÂÇ]ù½ø¤;ºrüÍmîxoÖ8Çx\*Z×ͱ¼1¢SÙÊ94.ë_„/Âá‹‚óZiñŸáóa|Εw Ë ¥äÛ¡*å-þ ÿ†#ß…æ;õz«…¥×ó*þ¦Ö¥Fô‚¼L^&/“—“¿o å»á×MùeVÏR딿9p¿RùC]wµù¨cøü þÿì_´y Oá©OkÕ]©ú°ÂÃ对óy0Oñcø1òy.T?àk_áO–¸%ß‘ïÈwä»à|Ûäolž“z~åøÎ+ÍðÛ˜Žâsð9ä |N°Ï!.ËÚã¨4¾¶¢ß±¼Ö5õøm̧Ԓ?ñŸøOü'þ“~6ø[µù¨Å߸“Ž‹UãaÆæ)|>Å'„¾W)•/cŸÏZüÁsYž¯¨ò"y‘¼ˆ^çExQ/Bõa$Ÿ’ë]éñż ò7ùÖêÿ&nøëÇ_­y=Öòr(KÓáFÚø(|> 죌Æ<äq)¼Ë¥§KþT÷fóõŠúõŽgWÞѼð̯Áz›¿Gê~?ˆÄ·csóúÏëË"ó„ɦ׫øž{ß |¾_@^õðI†O¥Öh=¯‹ŸJy@¾%ߢäÛàvXmñ#ÍßJù°NW£u¡´¸·ÒOû<+ê/[ÞÆŸàOð'ø“PBÜ•wµÆ›T9.u©’ø­5/|8OVòϺ|°¬ïƒúêë»ðsäü~.ÔÏÕÊwx£û^ȺnäÖ»e~"?“ŸÉÏèlh~†ßðÛ¿©çÃëÙ7nØŸ_©}ñL<·ÏZý"ÂõYJ^æk* ‹Üyfù|K~®‰#|!y„<‚/̶ž•õçKgfô‚x­³§”×ÖÅ{)ù ?„¡¯¥ÍÇú?~û¶x§­Ÿ«î׺þ®à‘õ<¼¶¬Åëªú ŒW|> F>4³ï1õW¯¥ÅñÁ~@ô ì~êÐùpø|>Ý)mýúZy _uùš[§Sû‚RtzM\æö±ñˆÏÂgá³È[Áy«Tþà ]^¬ÈÍèŽp½kçÏÔåTKžÃ?áŸðOäÉàv0¼+›w¡åk­œBëßj\­÷Uº±Ìcäwò;:K~g\é~‚ëtL­ÝeL'¬èbr½’Žã\qÚˆãgð3øüL°NÆ–wàýG+â¨6þ²®yŒy?8ïׯgøÅt+n‘·ÉÛämt:8oÃWøZ_ÉKAyI<áoúŠV}Ÿ¸Ž;~âËñåøòDðxi¾IñË:o#}6ªÏ•ë~¿€_À/ðþ >ÊçP?)]«Ê;–W¹x°®¥ù®ÍËÐóÑ×›ë+þ F>ß±ß8ñUB|7âyþ™Ôwëþc´¾ÕÞ?¹¦Ü´ùÿÆ£ÏøoéusKчæã Þ‡ñ^[÷—º§]ÖÖË¥<€Âá‡È ÁºØ:_´òmbý!Þ‰÷QñnäùŠ÷ø.|¾ ¶2®ßj/ÏuñM¼­‰7!^¦Ÿäqò8yœ<Üη7¹yÜ‹×=âÞÏoŽåoèú±ø| ¾_êK*‹;±xK½î¥5=ûûRïÑ)ñ<²¬WôÙ¤>ãÏðgø3üY1ïà[|k]ï«/ ¯´tÉ¿Áßoð7Áº‰Ô¡ã¶²õ0’é_n½Î¥Ï¹ôÐZ^H¥ó¡yhM~ÀâñƒøÁà<ŸJ'ˆ'¿xŠåóž®wi}­w¥¸ Í;Õéh㺈¿É¬Ç¥¾7’z~ÖÍ%¾h?Ð~(¥ý@øÅü}Íç…\üLÅ_ßßYêx.ÝÎ'øüþÿìˆâƒø¨v]_­ü©§¥Äƒ=°Þ.N”_¬ê;>ŸŽÁ‡0î¨J¤yžŠwcר¥^ÑÓ´q/üü+×ç6–·ñ¹ä7|.>78ÿguÆYí¼ägp})ë\0ÏsñVz\dªxÍ ¾~ŸFþÀ§áӬϻªT'Äã5–ç©x£¥µè•ÖýeÎø ü~¿‘}~Z*^Â[ü±Ê—Äõ.–'é0ùÚ/_wÝôh×m_˜بOh^Có¾KEÎr°Ä»’ž-uyÕ®= ŠÜѺVS¶mh5± àOÙ®±ÒæÓ,+t¢ î -öûdZÕe|Pýz‰G¤A¼h)®Z.;¸RG™£—öyVËó[|_OžoOoñ]yùÐz³ôž@êyi ¢[‡q˜ŽÄ ÀÿÔ£5iB»”~ˆÂs¨µg@É‘äȺ¼/u¦wO©çqÑvèà} m­VÊÆJXjs~å–.FK_?!–_ðŸ±Mx‹WN?¥æ¸b=;D_y°–¶ eØF´Ïø$Ù±£”}Ûc³[Ïýäò2Úp›;-ó¼¦üRë{6Ë:TsŸ~ëíÅ\cᩇ´å¥õûøžüåA\Õï[É‹´—@í¹™>ƒ|儞խOôѵ=‡)æzµ·Y[·Îq°ÖùA.ÉÇóÚÇKÒ£œÈúõ‰ŸFÓÐ [mÖ¹I^K·G˜Õµ—Ø£Š|ò­åJŒ€†ú2r­'×úú£h¨¥¦µñ|­Æ/Ú“f¯™ZæÙäÚ£Ýòü}üšWJNÇŸ•±GIªu@kZo‰=†igJ”?:ríyØã¨”õÞko_’_Ñê¾NNáßÒ”!1ÊzÈ­Ïu‚Ûh&õ¤öZ` Ð ¸Þæû +{Oà (<~jÖÖRÇjk‘³´:†_j)?R&Ä|ë}0pî´ú>°ŽqK|n9Éä¶V8XãüûZÆ9£]èLÉXãúî´/ÚZã «»¼jÞï¸Ä6$šYλB|ýw%¯½2Ás™­—Vã36{ f‹ßœuGæÇ­K{ì]º:ÿtìÆÕ»q|ùáÄïoî^Ú¹ºüúð#wv÷/_™ºÖuÓ£]·}z0uÞHÙaãXÖmÖc€e|m¤‹ø®¯ÌѤv}²Å÷õhZ Èùµ/óC¢[9u­JÇ bàða´KËßÔ¥™­è=œA[JXò¤•-hC¶-9æèäæ[N*ÉSð¿Z{½³ËA²4¶¥qRäb b¿=²MåÆš/hï1©ÿ s–í:ÆÇõ½  Ä:¹¿l=¡Ï3öxl™çÄlÙü§\qQÏ6UŒ‹x.xDù4¤< añzÖ¢$î™cKÝRw¬; Je=&Ñ@>,‡Ã­ÅW cvÑ84­ ¢ž‰kòZïÞR¿!í b½ÆØ§ý Úêõr­ôSÑgŒÎ×ì3EL·[Ï5¬éʸí|}¾9ÊÍBóZl»Ð†#Æk_ÊÔ¨ƒvÇ÷’ï¨;¼$ü$NàF+:EÀc€NXëÚXÛ™¸¥×úš®hè~†µÇ´®E½ W¥èM©ÏhÙ+¢ hç}M÷(±¾Ÿµù*Œ/”;ù©Æµ‡jàmé{°®”n4› x€˜@%¸@‘x=dÆ› @¼P5>øT‚» 6 q¼¸ Ž@&¼@5x€dø T„€'> å`6éºÉËîÈñnvcÿ­É‰ç“çSç3çíå§“Ã'‡3Ngœ<=|Î=9œ{j8÷Ôpî©áÜSç†3Ngœ¾wz¸ÆéáŒÓÃg†3Î ×83œ{f8÷Ìpî™áÜíáÜíáÜíáÜíáܳÃ÷Îß;;|ïìÿ¾7\ãìpsÃç†3Î gœÎ87œq~¸ÚùáÜóÃç‡3Î/Ϙž8~zQáÓe…o¸Úº¸³»ùÊüÓµ9ŽvÝö…ëk«†™-—úš‚‰Ãt$6á³|ÙT“C°‘“‘ˆy¾18¬üc‡@ú>«4¦JˆáO(SjÉaЪ«™‚6L B’3Ëçœ)r} r.q)yOcxd-?äÎcRت!9sðýY Ocó»´W“ð¤Ëû‘ÖØ(5Æ-Å`¨Æúæ»±¹'ÔŸlxž£™o6#=äaçv>egÁ›øøŠzÍåQSù^Ëú›/}Ëå —Rµ‹}ïÓ‚g]û±q˜«Ý$Ùæ Õ÷åÈF#¨¥c¹ŒCãY3îÇê£åéíšm¿±:Ú?hÉHÅ›v_£V<ø^'ö=Ѻ¶ZL»ÆJ¿õØßñmcùú¯±ÏºQp ‰öê÷kVÞ׎•ÃâQ£]é›ÏbãW»œWÝ‹¤§ö­“Ø|>¦\­Äˆ…>š›•?m%»}C©ËË×c[lWÌ„õCÓwM…¼“u/ãó¾nª¬g-¿/Öz¿àó®ÇnÆŸ”ï„jÏ¿µÇâ¦B{~Ò¬ KÑG#å/,¼O-%¾72ûè‰ Ç¥bǧ/c 'CcCËû‡öëJi°ôX1ŸžÂó·îA$9+Áq.£;þ@Ê£§2Sœ×¤Ýg-ÕgãQ+;oè3¿#¶¿B£®ÇÔÝ4±¦ÕA÷Ï©û<$}ºD_Xî¾»TýœZóbs­ö\‰6¤¶Þ´<¯ÆWW´ßíKõ­jyÔÜcbß…çß3®%[‰Û3±¹54?‡öÏùzBŸ~?«sŒ¥s~L® yG;Ì­Òk$Äΰî%¥×¸Y߀ô|Éq[ëÖ0ã RÏ¿ -£ib¿š{Ž»¤N†Ì¿ÞÈ™“.ïxT -š&èëXw¯5Ï™‘x[ÓÚ©òMè;ãZß÷m…èÊÁë0NNÿSö‡§ìÖöŽRë}i¬•jü\ŠõOr½ÿÍ=G@#‡æÈ=’}p¡k#탘*ù‡œu:%×ø8æ²È¶åJyïã“‹5ú¦Ç®kµý¡1ÿxf¤j¯§È1%åÂÖç¤òµ±¾ì0- Ñ*ËóÅ4ãOc­WÍ5|½¡¦ÖçШkU2÷!MŸ”–.çXO<Å<&ß¹9ç'çô0)âÖz9hz­všEŸ}³ºÛ¾‰Ýs`Öé­M5—1VgJ:%¥‰©ö²É‘—rû±ªš¾&Fû58«1—\ß* -eiAì{Ÿþß5È%ò½¥µw$´»5¸­ª'Ƭó0&vBµ ¤}ºþ„Ô˜^KëÍóRÚSÓÎ^ñÔ³L¤ò]‰ûÏ„¬§¡ÝGdÑ'jîû8›]þ1|Ú±`qO>úÛK!1ŽJª#ÉõTã8^y=M]ʹ¦ äºe÷§5§”1Êcy•jo­õ†$óñÌXj"ܦJ5Ï<µ±¸¦³¿jß°YD_YεÑS°<7Iko"É}¹¥×v¥-c£9wKÌ·ÔZ£:Å>cò³T›#Õz;ÖµtÚÙ_o,Çú¾¿ê{¬úßö…¯¥|Íùc=HKã±Çjæ|ŸU͹O¼ϧ}ëÞ­Ûÿ3t]¸˜Üžº<µû²bçKÅ–ÿº>gß2’ð;>kŠÄÖýª÷ñ“¾Mj]“1×k¹]ÉÞå©°4Îaì:H›Ú!óˆcë%¤ïRò}žÄþäškhuó™+ÞJ¿ f¿WJÏé³¶šÄÞØ¥µs&Ýøu.×é†EïÓ,Ý&)­cì<”T}>1|Û\ƒ§LùŽTã9æ·HiÀ¬Óß/³FH¿¯Ñö‹cæKø¶-|¸,1ž.$/¦Ðj‰q…¥/ŽÕ`­õ ÆÖ“O݆ÎåH½ßè:=ŠÍ¥©çWƼGH­Ç>÷SR?jê÷¦%¯2Æ Õš¥±ým³NmÚÒÆM¦ÐLë㔦™=¦JÝï(ÓÆrk³K3GpÚ¥ß/ø°½è¥ßáθ/¹GOÿ£¤>XÚǰÿš-îmÖ¹“ï<´wuþáØ]üålÿ‡ö–_ؽ|éò÷‡­Ë_ùÚÞî¾ûÓäûݧéîÃû‹ž¾ì~ky[ïßÙß¹ûâ•ùe\úÈ•ËÞ½¼üÑë¿÷Dwý¿í óÿ]»ŽÿíKDgss/data/Sachs.rda0000644000176000001440000056632712247272076013574 0ustar ripleyusers‹ì½g”Uåòõ»»{w$AT‚# ŠE÷R@QTÀ( ÁfA% "*¨ ˆ‡` "IAQŒœƒšœázΞ¿¹®O¿Ž{ï÷#gŒ÷õtï½ÖóT˜U5«êº:M«4-H$™‰¬DF"3ë¯ÿ3™ù×ÿ—‘H&òÿúoöõ·ÝÑú‘D"먿þPü¯ÿW2‘8ñÌÔÎI+§ÞÒ¸uj÷òƶ¹¥QjÿmmVŸ÷Ì-©3+¿ùæèÇS»ªR¢à”;RÛoßÖ¤^»Á©½¼¾p÷¸ŒÔÞû·]sk·(qÒŠ–ÇÍ]“Úqöe?M·7µíÁD¹Fßß–:°ùå]wö¼.upÙY]oÎOí)1桚ôLízøßWnyè¾Ô¾³öUž_©{jç'·|²¼CçÔž>§ÿ:½Íí©]“?9û‚ZÝRûJ~Ø®ý5©=Í‹±úšb©]Ç._~ù-©=?ï|8³øý©½‡Ý”Ú‡ÿ»£Ñú^×+µ§Óq= [ý˜:Ð¥m¯Ê7¤v¼glÖ›¥ö|µæˆ NÙ”ÚÛ;yÕ±­¤ö¦îy¼ÿ„©ƒÎYU§FµÔþ’ŸPüâ*©ý š¿~K§i©}ŸÔ›ÒêËßRû£ª¾“e¼•?¬ÁÄb©½[ÎÉÿêùÔ¾_~ü©]Ûù¼_”¸ú½ÚÏÖ­œÚÙûؼUG÷Kí‹F<öý¥g§µó„‰k³÷~eŒK”8}Õ'©ýg/¼dÒ5¼kØ9C’>÷}-Ë-.¶­Vjç²ÚSKš¥öüóéÉËWúÜ9/ÞSÏ%*ßU¿ï%}SûGu™Õä÷ý~íÛ/ùºÚÙ'¤ö.Ùü}*gXjÿƒM޵ÂêÔÞO>o{Ã{Y©}]ýì¬^©Ý¥ºÏúòŒR‡úäÿøãÛRûn¯ÿò˜–QÆ“©.޾6µ­Oꔎ_å§Œ:oÁ‡'¾¿÷ä‹ݸ¼·W§›¦7ôª(k^‰å×ΙžÚ3ò†¦G?YÃr¸wð3‹^Üó}j_§}C;¬:1µ/Q¾ùÝþº×Í}nþá¬ÔÁÒßΫ—œ„ð¾QâΟî«ZX­è°pØQµì?vÞº³É¨ÚÅ|þÈåÁSŽÊªØÿËsúù£Ì¦×{Ç´ÔžÛL)LZ:ªþÐN-ã?KO±+œ×¾Þë^{漕¾Oô»œòýòwÖÿYvþ[ßö÷ýï.lך)ÛÓ·Ÿ<ðè_òb{*§÷Oí*±sDçòë(ãåsçÖ>ãç(1ùú%7Ù)µç²ãÏ®Vxþ/Êø´÷½U¢Ñ–pöã`ï/ʽ1pKêÐÈíƒî^}’ß“ûƯØÏèýµÌ/É7úûö-Ù×õýç»Åv½HãÎ+µcóª3UK­9°+Ú3½yjk߃j?{ƒq÷¿í®òsš>Ý:þ<ùcìç¸ç¿þþ˶Ëèé®MÇN8uOªðûs›-+ãɹ?½^xºådËð³ÊTn²*µ¯â'wîZ¾ÅçTøÜÚ›Š êl{ Î*|ýêÏ7ñûr?<7¸ƒóÏ:mn½Ö_Ÿà¶Õ9ªá'Ö§¤^ßøÐuñóÉNâoU|ûƒéý&§¶,k²xü ù©C›ÿØøÞ¤;°{QFÙĶÕÉYœS” 8¹Ùý|ÖÃ^ïæ>tðmŸ'ò½»bÕ'»\R.µ§â–·..÷ ñ vkï–‡{m¸ñhüzj÷¥ÉMO¼¿Èr„¾Kÿ¢DaåM‹~Ùëï£{Ãrn»¢¾¸nñ­¶'þwÙîcëÓÖžyp¥ñž>7J wk·- ì¿ñ—Ü3þA8#>îIx<«Ï±½ØÝè‚Ó_8pÀþtëöΉGZ¿aܱûìÞ¸ÿÆ‹í'Gì'ú‚žm=fþ¢¾™¥mg…?ŒÏ}è§ð!~c÷mµ÷¼;¸›qÓå§¼öᙯù¾÷T«yÏ 7gÛ.¢‡èú(û%Þ:ãÛ-¿Ÿg=Ǿà,ÂIà!>¼^Øêý O5j<Ãs‚³¹OüßÇŸ·ì«¿pÜiµ£Ä£Ï÷XøC×(ãœ×¸¼i)ãÿCk7í°· 8Éq ~cÛ7ãŸ,¶q¯~{çæ;xJ”ÙèÀ}þÈzÄóù<ü$ÏÉçl¬µó…ëû,µsöö›ö×´}1”|bßöV+±éÓs5ÞÂŽ€ „Û£ìͧ\?íRŸ_`¿,§ÆzîÂá½Z6œÖ4ʘ·c໓¾Ní›ôx~µn»RÛ+<òòäcGE™Ùóf4Îifœmܧ8ùAþ±ãØ9î;A<‡}ð{¥Î<áü/‹ÛNò>«•^S¢r÷ÔÖ—¾S|Þ˜8^\€w~x¢nõ©ÖSð ߃Gß ©tÚœgYÏøž]×\Þþ¼1gûœÀ-œÏ®>÷QüÝ־߸8—EÙù¹kZ‘Û{¥Ï™sÃÏ!?¶ ÒgâNãYÙ ÇÉ’GûsáGâÿ0N í ç¹ýþ;Îoy/Ë%çÄ{l_1®|Ùƒÿòs`×.)6fÁ «‡@î¸ß»âkô\Èïáwn|èß¹ïv4ŽÇó¼Äk¶?òßà'ìÏãž|ЇÑ'ÎmÉ¥ïÔ©ÞÿÃÇáøçaÒþÂqñ y çSd׈›ÐCìߦÄ)ÏŽ>yªåÀöDö9 Àss¶Cú~äQÿnÿK\³õã¶Ÿ2ÓqÄŽ’çÿùõªçRÛŠ½ݳ¥¿= ý¢ÏSþ{¡x7µóé³/Û÷#û_ÇGzp:öNöeûïß—Üv̺ùÇ7+îõóly£ü)Å«½ì÷´Ý~ÿ;Ÿ!?€CßÊŽ!àjü#ùŒ­ÚÒû©',ä É+‚Ãß~Á~ozÛ©M¶üä÷ÄÎì¼´nå‰ËšÅöTvû‚ýŸ€3tïQFë·žS¬c‘xL<È}ø•¡%/»kÃ˶Oë;ö|tòqIã¬EÉr›¿ÚÈÏc9W@¼¯÷Žå®juR­áè1öݸ»ƒ¿b·¶üóßõ;v·?B¾½õüIó«n·]پˠU§9ÏBþ„çã܈w½uåêWw<ÇáÂØQì&¸À~H~e{ƒ ¿]sg烈ÓòÁsƒ[v–øcG™Ó«ÆøŽ<´ž‡¸Þ8”xFßgyÒ¹s/Æç²Û䋜7Ñû“Aþ·ÌSûË#›Û!/Â-àé(qôQ§ßþ‘í övbT¡„q2çç|í-³ëתœÇe’cüºó%Â佸?ìïÖ³3Öþÿ¶ŸÛq›òšœ'záøMçèû•´]ã°Çºoô»D\¿ýí}7ž~FÓ8.й:O¨ü8ö‘óóùHx^â ì!ŸG^;®s³}En8?äËyDòî²Gö÷éuv”ѶW»‹V÷rÞÅñ:u+y°¬.Ýnݽ½Ïe¼ß÷ú*ÕfF™Š‡°Ò‡(c猦í+ŒuÞGø=ÊZ÷âg=ZË?¾ÇŸò>Žûd×ÿÓöØñ;ø\Å}H£¬ ûG·èÀ{E™©—î/Ö ¥ý¸¿®ówü¿ãÒ‚ÝýYì¼—äÀuüœå‘ûLß3x¼e\õÔµoNý –×ÇO4¼ãäVþÃùûkêcüW~+ûà¼4y;ÿ½ä¹Hü%ùÁ~‚3‡%?)œîxN÷E~Nçe ½ëÖámGú|À?Ü'ÏÏ'vnnW®æ.ã ßCÁ†¶WeäÅuÌYå^ºeÝ“ÖGp¼õUr'?æ÷åìå/·XŽå7¢Ä¨Å÷×îxqŒŸôÞàâ }Žë0´¨õ¯’~u\‡ýÃoºî ¼A¼æG3‹Îòðó–{åÏÈÿú¼±ØMäÿççŽAî„Ó¢Ìsžøðš3¢ÌòMéùC©®#¼ê÷s<`ËÄMcnèn»µåÔ6“[Ïèê¿_ŸÏý‘±VœJÞÜÆ9‡nh^é§rMN´<ñs®K¥ñ¸ëBœ?y|üºq§ü3σ^’!˜öoÈ—ÏÏçV¾ýÆÊk¾‹ë6’ã?åþÈK€Ëð“æ‡è}± Û/þdÐQýJÆøHñ?o¿F\¡ü€óŠßù}ì©ó>º_Ù§(óÉ ·õP25oß²ýö3<Ú[ì½ódzŽÐ^/Éë¢Ìe[î_5n*¿%¼»qÑQo¦v,5°Êw=Í—!Vg»ª÷¢^‘yþ9o\|r]ê$¶ûÈ¡ó.àC½ŸôÍvËy×àžÀßÜ/ú@œåsàü…ï,瀞ñ½ÄwÈ'vÔ¼ÎgNÿbý>Üj\C~Äü#ü²ìøŽƒ»+œÒi‘Ïç¢~ä:xÚ_ÿ9ÿ"½q=’¼£ÞÇy(äJú°«êšdÝã,Ù+ðjæ°ß:ýpFÝ(Ñ¡Á©•pýÚ8û>Æ‚k%QÆÄÖ5–´MÅþBß.垜ߗý%þÅÿawÍϢ΢è~Œ_À=ÂóÒ3ÇáÊ‹;~XÞü×¶¹—­Œël’äØq™âz×¥çY¯¥Ï®S?(/k‘ì—ó¹Äa|>öž¼•òB¶ÇaœøÖxLõ_âeòŸè‡ì·õÚ¼Nì±ìží²ä”¸{n"ç<€òŽØ[åQc~œìùpËMÚÁgŒ2Žè0ù /ÇyTé§ý'¼3ý×ç/;‡Ä_8¯ ?EÅuEÙ)p$8TqçI<eêPê•Ém§ÉGY%›oëzàf®ó¦’_ɹý·ñ!þRæ}…³ÇÉgó>A~ÕzŒß w9Î&ÏÍ÷WwógÎQöÀycìžù9ðE„cœ¯ÂΑÖ9ËÙïqÏæQ(‚Ü9>E$ŸÈ9øk[ƒÓßkÚbhlÒÒz†˜F=T¸‚:€óÄ“i;OÝ8¿l»nÞ£—Î+Êï™7«úöÞ„ãâ`Õå¹_ç›ô¼ÂÍÄ×!;ŽGÈ{aÿô|Â_q>NyMòKØë°žíºq¤îÉy÷tÞ8J|Û~Ê7ÕëÅ8[ÿNiy=qÞJrîúüáEú&wñÈ«ÿ„ý6ƛԅÄGsÞ\rW˜øßÿ|¯æ‘g‡¯Cü_–º® Ï‹øHÿN~Õù.Õ¿ñc²×¶c¯ýÞ}Ñg[ì切ÿäÏÀCþwârpŽÏ¥¾Wù?ãW×½Áº'ã;êÞÎóéóÁqîÎÃqÂ]qz(ü ?׫äàŸ8“]5Ž„O®ÄçÇ¿K-—ȯⶌµÏŒ­[Ìñß¿ãáÇzü{øŸñ}É`ß\·‚¢8‰<„ìX”ñsÛm+÷õôç‚û¨óS7t_ý=Øç™àÏH‚º¯ë#î/^þkóä–ý£ýSÌc ûÜÐp¥û“à1ë½áGYÏ„s o=ý¬5uþ,àå¦$§”[r]Ó8_#{ELÝ|Ã=À(<ùÂ͹Þô{¡÷äÏ6·XÑÏ?Ô1Žßž1®U×ÕG[o‰]/¯Ë΀K/ÒŸBý9è'ñ=’oìüä-e®*¹òÀå©-/léöÜ/»~̹ —ú¹„þçøÐudéÁÚ ³ªæÝ3Ïñ<ñ°ùˆ²[Û?>ú³é=úþ¨ó‘v=IþÊþ ^p }®ÛÈÎ /® q~ÎïRGS^Çy¯õG~Õ<Åsȯúâó‡',\î®»mLÇŽŸÝb{Ìyð½ä‹¤Wæ¿;ÿFÞKøˆzƒã §yµÂ½Ä7îûPþÇüÞ3-®{¡÷àq|åmxoç+¤§œ~‡ø’9 ÒÝ·ÝÒ1æu§åÊñ5òì>QÉòB? òOm}¥ûó&]°4ÊèR°¸Ü³ ?—y!ºOêEæWÃ÷>ÂpN|/猉—¿&nt^Kö!Ìïlùç;í©I?[ëx~‡ä>¬ë8¿€'„s–­hZî諾t+ý*ä;ÁaØ‘?Re*½ºþWÇûÈãvêRð èÿ”ßÆß OðË—î]ÚãÙã&ØŸÀ×wœ?¾ ù3Ù%óîù3v?æz³pAf½Ùu/zubÌÿ=W_ý ynÎ> ù%÷?Hÿ]Ÿ~’<‘C.üUò)ÂSàä¿nãyÍû§ÏPòµ³ÁG}ff=n½D>àË?ÛOñ¼æAÂóSܰõÊïW–ßU!æ7ÿCߤùHÇ[q@ö$´æ—ɯ€ÛÖß–ñÖÈÏv»^Íû€yðç¬~ ˱íEÀã±æåÑÇ«÷57m‡œ×6ï[õup)ÏéúGÀÿ²Ðïñß0N¦ßŒ~nòKèŸó‹Êˆlþòã|£ðˆûtOîÛ â:â÷ñ<é|ˆó"|žû!èËOû¿8?¢?»Ÿ,Óc¼K|-yw=Kçj¾‡ü çl;G¿¦ð½í#<úN駦nŸNu:ú;]§…¿®¼õòö÷ðƒü™ùuÂ%[»é±‰ûôåWñ“ë–¸àÔԜԦK¯¸ñåÊkéŸÄß¹G}‘â5ð.Ÿg{Cß/|'⮿ç?ð/Î÷º?Aõ*ô?äwó½à]â|þžþxôšx¼ٰÏRö‘ø†û&Ê÷šWû÷þxÛgËùêÜz>òCè­ŸC÷ž¦ŸaëI{>ùú¸“çÑ÷€>»о,êü—úbØ—%œâ|âêTÈu1pŠí6sôsœ‹ë¨š—à~âDÕAã*Vþ1Qèó¢¾N%¾óùr^ð[ôüâSǼáñý¼Î'GP‡ êØ‰Âºß|uîÇ?Çóпt|êü¼ø‹ÆiðaT/‡w.^ƒyuÎ)~ux 'ŽËÁýòwÆKâ;.“0¦þC]H?_%®#ŽsŸ äм:}æäÉùyðèòƒ× Üö᎛‹pîxmytÂ3?þžcœŠ?Æã_Ñcó„ÓÀ;_øvÕÐRâ>Aáç¯ôùÎI¯á_àï¥æ?Š—â<u#úià;ñ¼Äyäœ7§ïExÄùkÕY¶ \¼ö»]GpOÄÏŽ÷ȇZžñCºWÎM¼è8¿F¾Jçç8<ù%Å'à^p-ÏïúTÀ‡á÷è¯Û²qɦóÚmr¾rË¿ü"wåg¾/ò•œ;õ(ì5»rK…œ7p_¤äÞŸû‰™Ç#ÿè¾ xÂqšû×­¥ïôI»ïŠ9Â%à/Ç5oˆŸ·œ¼ ìvWy“˜ßB=Sòî¦®Š½!¯¹©â¢~«—û%Ï©.gœ}•}ŠãùOóžÀEà[êéÌ‹Q_qŒyDØ æàȃ×Ý'\‰½ðœ6ì—ü³ûð”O³Ò¿¥ç^wâÍ5ʶ¯óg™g¥ø{ìy’'â%òlæ=(_J¾ˆû´¼ë\ñ{›—þ¶ðš¯ÇõÉÿªÌÞ—þV­DÜ¥sÀßGé¼VÙ³fà„Eì–òÖ_¿‡ð çòœÔê£î×´½7?>¹æß™'$<†ýBèS?Þ~Çóô>öïâAâç°gΣ‘çÁ.¨.Ì{’s¾Lu çe”7´)ˆ]€' Ο€ƒ±¯öózÎ ½ñÛÑ[R¶¼çóÆ5kû±Ÿäó=‘x—s#?­ûä{ñkœ 8Üëü¡ì*}pÎ×Âww1ÇN}Jȃó²·¼gØÿ …oOþ|gž+ýÊÄ‹:?ð9xÝyòŸº/âRú%Á1ø‘UÍ_|çÝ__`Ÿàk9¯¤øOyŽX‰C„7ÜÇCs‡èÏ‘§q_èп@Žë‘Ùeºïºé¸ î#•S¶Í÷ÿe-?àøÿΓY÷ñ]3ûtŒò /¨}Á[ Ën?¾îÎ3Ÿ²Ô_‘5¹ÊŠ O!%;¿z÷—¬‹òJ-9âŒüQN‹Ûo­öí¥Ö¿Ü¡ š–®I”\³ïÂŒœóáøy’ý~©jqý}ÔÌK&¿”;à¦ï?îvy5Ä9Éî k ÿ ¸2ÊûªØ}8e]ûàñî¸:Ê.U÷›™w÷3/›¼9}8YÓÏ{®ûu[ÈODɯå<{ä'ôF¹kßÝfDŸ(yö›ûgϸ <%7ZºcùÓÌ1Šr¾º n¿É;ýç¤ê#â7EÉzõê |ý,ÏYú£d‹FS_(¹=*H󰘃e÷¸ñ‹/lw“Dz7°ÛìI¾×ìï¶×¿¬ÜC1¿G}2Yã˽³{ÜäØñ`rXé¹.ä¿ÏÚä¢UCDù­ FN¼±G”•³ãÉ^}ËXN¸ïdî×­—ýuĨXÿ5Wfßl}ÄâÁÛ‹ëð´%¯ôd·|t^‡[oŒr§'W¯ž5‰|Z”µsé¶ãç%£ì £¿¨¿¸ŽÏ7÷ŠÅ/^óóñÏ¥ûߢ¬ãZÌmrÿQòî%Ú ]nùÐÎøüÔ/Çóªþå—®:¥Êc£ÌCÊÉmüRNùcÍÎ7|øúŒiQ±ÿÙ½ÿÀStÜ’ÕgÀæ¯ÎhÏœ´(§iÔúà c¾Œúøs š2öˆÏ¢œq={]¾º;ùë?Ÿ]ô˜ ÿº¯>íg•/Q#ÊÚR¥Ùâ£:F™ã/úzàœQÖkÛÿ”1:ÖSCÎÈN=gÓ×}²â‘˜ÿʽg=XiçÍUé%?j=à5/–+=GþéÇ>ûÑE5£üa•F¯ß·:Êì=l᩵χ_f;”óÝœ*CV’þÖl̈Óñ{~Ì/šyÅ£ôgùy”§‰r¬;{kÖZôØ÷€üXÇ]йÂÂöÖ'ì¿—l2záÓ3Ç»îÃÏù¿e_3æÌÁQñ´~DYï½}q¹femGT§òç©Îå·Þ§ûlGù=ä² ô/Üsäy¾oë÷y¨YaáÛgù}°S¹óö^ûÙÃ/Gyþç·«§`G±ÏäÝ}îÜòŸ¿kÖ–góO¦ìûÒùÇr…]Ôsg'ÞžùXý ÎËXoç¿Óò³%÷Y¯‘—œÞӦ߹÷±Xu.y]ÎÜ÷å›Qü\’?Í%ˆ’ s+UßYÏvÿ”SøÊ7ö«Ž’Ó¾gÕùŸØ%wW®{QõçãókñÐò³*Ÿå¶tú…ßE¹Q•×ÊW¹ þD”SñØßfW˜i9Î$¯垸èºÛn²¯èzJ±óÚøÏø%ø¯9ýg\™5b¬ûl/ôܼVÅ·ú-)<+Ê>mÆ} ›½åûòœV=öÀò.€=IžþFßË;²_Â>â×sË¿uBäú’ý£ìfv«ƒO¼7bªíV^ÓDåV£;ÙbGò¾[õ]íÏ;EYMG4-œEÙkïZSsìý¾ßܯZšpù[Qö®®Çô«i¿Ÿ|³Ä€2»ËDy-³›üðÌ_ï}E¯äÃõ§“o.¨ðãäç®r–v[sõî£ã<¥ì¨å1Í{·\¨ïÓ¼SÅö‡ž3G|¥óËiÿúi7”¼*ö:7pçþçìš¾ïÓ:ÃãçRÝ/é´%݇o±‚·°›ÙÕæµx½oé(÷ÁNë¦TMº£`óΗžÿº¯qŽê–Äæ©¡æ¿{ë·»£ì ~Ú¸ÿ– Ÿ£ñSúœÝ/ÅýªO$ÊoYÿ®oÏ]ã~äŸþõ¹[>¹/é385ÊîÓôÓ§ wÛ¯å·ûóÁv­ºD¹M+^•?sRŒ³ä¿ó†lþõÁü¿äJÃ/»}·5–«oJOWôßã?uŸô(O@Ï»fÿ©÷§ÎŠßÌžÜqæ%—òý¢àä;ŽBüž:ì~ŠOŽÌÉÛú^wÛOüñšìZÎŒ–=Ÿîsžíþ69¹ø×»Ï]Û=áêœuÇÌœ¹ f”Õ}_“ÔÜdü>²ø‘<ñÖrjT~ñûÞÛÌËäüýûÒ[ã–4NŒë›UZ’_-*Ñ0w}ó¯Û.ƒ›Ì¡Ïv¨ÿü¦(ûv«†t»Áö?»K©jÇOÙÀÛ}~žûñ¿ë¼™»àù®Ê&+vmwñ¯›ì×°›¾7ì ïÁ¿Ë/ã?•ÿŒ’Qûäø çó5o–¼ªüsl?dïðÇÜCAîœRù›—Fù ö×èÕôr߃ý²ì`Îû6)Ûýì§ë.ø_î1»Ç~Jí{'áÇ|zߟò²æ`oô|Ù£J´}vÏà(w׎ÇmQ=óºøÃtüâ¾PãB/ò ®GKÏÏÁã7ñsŠ«°ãY³þµõû½¢ÜvÓÏZuãúÇËïH<—¹±î?\ ¯Øsp{n™çÉé÷5y°8–_9^ÿëç[ÉŸŸûܧ´øéið”ãSÎ1/ww™Žó¿´r¿¾ü“ý«Î…¸/‹8ƒ¿opYÛË÷¯vÿþ‘¸‚ÏgZ¾„Ó4OÙþµ uéžß½{%u(¿'þ2ç´‘WHÝn»Ÿ?dÆèŸ7ÌõWñ}ñ%|Ó«Vœg—¾x. sðÛ<§å\öû Þå{ðÃØæä€ò÷{»-GÅ}Jê_GNyä˜÷ÈûÍü›7œd~&¿g9hµ¤Yò•®qK¸ÿ“Sú³æ¿]UÎ÷Ûºì•ýö?å?W¦}µknŽãN=oö¡Ç¾ZZè8ܸ˜x½Ñ=¸.ª<‚ñªð†çÉgÏl|óÒR sÄ+Øä\J¼B\„ÿ⹕ïpž›ì¦ó,Ê?øÜûóÎ1_Eù¦Ž¸æÎx¯u§uƒ'Vw ‹ë„ðùè/[4và˜–%âyöžß¡ú;u4÷åªB_õ?÷)QÐ÷™‡§¼»ë–Ì æ¹ÿŸ½SªCzó)Ù×A]‘9šï×ýqª÷ºŸ[s‰<×L?/…ç¥/ œWë>9æZ1‡}Ô{¨#Šì÷¿‡~ló˜ÄÛ¡®¿±Âãÿ¾àß3ã=Ì3ƒÿA„xÔÙèצ¾ò ¨™ÈÜBñƒ¼/‰½1ꡯÇu¦ îÅŸ}ôCóï¨ÏÁ£~í¹kàeækÀÿdoû¨G)æƒÁ§D®ÌS¤_U|6>þóRÔ÷ιu>\õ ï'H×Oã~È¿óÕÍ«õ Õ[ù^ö)¸/]<6xnþ|ñà“y¾¼î:ëo—¸³Ñ•³\Ïç{á_ð^æWŠç‡|cô\qŸs­Äu|5úÓÅïBž½ßK<úçà­zN<&ñG݇¤yåèù¦ô °7ž®Î½vŸƒêÀð1­ïðø¤—æ­0Orß(|ø€®ûªÿ^2?Çþ#êÄÔËÀãžÃN¿¼Uøð¥à—¡¿zó^™K% ó ÀÃÖ;ì1{àÄG4š9¾ð?àQqª›ÇK¿î»g;(>vûÏ÷Àð~‡y~ú=ú…<Jçà96̱“>ý™X|lãCËc¾‰äÍóIÄ»¤þï=6ô*o„þyžxu®OÓŒßCžè¿–Þ|Ée † nï+ö¹„¾ ñ®…sâ¾;=ÇÊe½îûýî—q£ü”x$ñ¼&ž—y9²OEæéû7 ¾xÜÙ/´7ß»]u+¸EóÐ÷·0¯Lýê.=yÓ÷G¶7/;®<[¼Nv’þopr7Nç'^„û­ì‡ÄÂÏš'ËÜuÙƒMO×jyiÕâ{Õ¹mùfÏØ†§>ó Å#§Î ÿî¹?Ôç™G…\1ß3}^1.Í«²Ü…}àðÃláeÀw¦/ Þ ~BvÕöˆþ!ø”’ÿáç–û±CÖãªÂÆ?ô?½ãé1>_’9 ŠÌG²]‡ÇG?ý¢ú}ɳç`ø^uïî{–}ÝrÛ„ùÝ÷¶‹ûçt<þÞ;÷l»‚ݿȾѷÎ]w?bÚøüÿ¬ÕõÔœèx®ªÎ›s‡{Œ˜gå÷¥OFø þ.¸}ÏÞu6ó3…Sáš'ÄÜdøZÒóòØ¿ “¾_üHë1üL÷½ò{zoä¢pü;¯=Ù¸X|Î:ïYÕ½‚3°ï>wéãÆN¾õá×gû}­÷àBì?¼ZùÎÝs×à—Óï«÷ãçÃ9žÞ?Æýý}¯JìW™GLûæØGª|ydxÆæ9ëùÑ;â"ìƒòÚq?«p½û™ô|ðq=•¹ÈðÎà«i¾0y^úÕÂ=hžwÏ—tü÷õ0‹}³ðט3$ý/Ð/M_µûrè«®±þ ?xdÐß½Sº/üû¡d/¼×¸¾>ž“>Nö½ÐG©¸ ÞxÛû+‘ áQÏ]gn+q¨äý÷fæèü}îuÌG§ßEq¯å„þFüGâ'?÷ßq²ëWÆ›ìEd^}7ôÏ`¾3}{ð@Ù[§{0þ×fÏ! ú¨˜KÍ8ú¥¼ÇF~Ÿ9Oî[>$®÷| Å¥Óò»¸ºÿñŽc8Wð7ñó3ñãÌ醇Í>W¿?óÈè÷TÂ}ÍàúØ-;é9ŠWÜç#¿ç9”òCÞ Å"övÊx}²î·Eî%gÌ]ñ溪?É8–ùÂsîSòçÐ&µk·þ¾ÏÛûsé¯oGa®ó[á¿ÿéùÙïĽ“§€ßê=™äAä˜ãâ=èØ éݪɷvº»aÃxo–äÁóYôœø-ÇÄÃìRÿ´÷U"—’ÿM_yq‡—>çð"Š#½¿Ix ¿ê½7ä[”¿ƒßë½ì æRÁ§õ|Káx°øï Õçx®Ÿ½P>=æ|¡ßDx ¿ì}C²óŽ¿*4ü´óîù1Ž!.f/)<êÇâßÀ­á¼!ïÐ{o-ëš¿h[ƒ1§ç‘áž<'ûÇ÷7éù¼·—> ì¿üŒí>ó:ØW ½£ÿ4”¿åË üù›ã}x’çÇ4Î}¤Øpò¨>"Ï;—<¡§à8ÏíS~OzèþDâcäÔûfÀuôq€ë˜Ã >„ ‰.O>÷à!óÕ½?Fq0÷á=Õ²gøeã ækÿ½Ï8Ž×ÄGàçIæÛ¤6—·tü„7¦¬7n#OÂy牗ªº/}ÔoÍ7ŸfÞ§î‡~óðT7¦®m>£æ”°7Èþ“ù±ª³rOÄ}œgæq·ïyn|Ìß2oþ1ã¯X˜e~|-ññ¬ïê'‰û[tð\O/þ<úL¨7›ði©{¿(Öyq¹½ &ºo…yIÌU“¼Çù:æVˆGf9?À|DΉøBô£0Y| ûòKî•ì]áäÜ—̵4_>^±öyfÞù¤çäÀÃ3o¾6<®´ÄûÅ´+Ÿ}>ìÕ\ò‚v…ƒ{¼=!ÊNº7¹¬.uâxŸŽ>>ƒù|Ÿþ Ÿ ïù»Ë•¸>Î#w”߃¯ÑüHÕÇá=2_Óø.=?Îü+Ûøíú÷œÎOž2}áÙŽ©§ë{È3Çñ¥ìü!Ù]Ÿ< ϳ…w+¾uzôFúa¹‚ˆý¥ݼkñ+Ä7ô¾3x¸Ø!Çÿâ#ÀûÁžÁqÿ‡úN°£â‚üÜðýIsQÌNË«çÿ0מú÷‰ÿã÷T=‚¾]æ›#~›û0$ðy.ÎÉ÷Å~?éƒå'Íë‚÷…u</U¸9Êk7¬ôeûͪ ÞM›È<ïG”_âsá‰aái©ßÉyoø‡ôa™ŸÁýÈÐ/̹qÿ ù|ô½©Ÿ^ö!ÞŸ«ùY¼Ÿù§Âæ9é¹Ìo–aßÁæ“:éó]ã[ßÅw#Þ°ßß„9)ðŽÈ³Y¿Ä3òïcÇì×ÔçÆœ3ð@ÁôJ=»¾8Í<1xòè=ú­º”y‘ðáòÄ#?ßu*Î)˜sHÁ¸Ì·Ÿ]XÇü]ìï‡üˆï ® F§åŽ~xƒøí‚eg>Ùøô5Æ[ÌEôž4øÏï#ð=Á¥¿"·Æ½ŸtBóŠÍ•]Îé1ü™éKG:ωŸ‚Æy€—˜gB¾77ïŽûÞÉlóÓýöŸì³Çy¿¯ðPöæŽS®Ÿvi”»¬ÁÂSßéó¯¤ÇØGð6}’÷•ë=¼‘÷ŸåøA}£²OÞ‚¾yþKPÂq¿Ì ñ|$áE÷шï‡×~±?€§±ïøKÙôÌý5i¾.ócû*þ,vÿK߃ù“ð†e'ÌÃEžèÿÜæ~ð“æ‰r/ÄQê3~é_Ìs"¨·€›Áqùý÷¼œ^Ï«¢?øš~õ0ß>žå&ý¹ñ<ús…oÙ/﹃·kþ/ý²+>ì)ýÊ⵺Ÿ ^'}zúÝG)ÜŽ§Îæ¸SýÂÆçÒWìfG×ùÄO„竾U÷›ðÜü<òçþVñ¸Ù›@^<êýlàyúéç¡Dr~1þ?Q?^lßégLÇÑÎßïÕ¼»¸?Z|gÞ#ä{›/L?¢âEâxŽØ1Ë?}Ìê2o?ͧq›ü&}Kôs׉Ë“ì8ºíŸxÿMÖ¼^vÓãâVóÔÅ·ò¾É-}wAŸ*|óz‘?âü¦ûÁëib¹¡œ8Õý’é~YûWò æá3ÿH<_ð6ý£äyÌ·–ôüPÅš¯í~â{pCAËä®ïsž5n€LÜä½¼äÎùÝ+¼cü|lÙæ¾Çý>²GðÊågâý` –sú?Ú_\}Û“C¼†½´à̬{:}ٮӉί8¯tÅĶ~r¡ãxÇ)éyñžpé§û“eoȯ9^P}’ùÄÌ= ˆ¾L¿§üùåmGÈÇÐHÌ4ã}”GA.‰ŸÜ×Åœ â/õ)X?ÁÙg—Ì¿¥ö|ÛwòlÄGà'ã^Í‘Cïá£[Áê‚/Èyx>¿ìhÁkΙôãæsÂg—?ðœ"â?ü(þ“þvðš÷`)nb½yªŸûù¥Wô["är+ô+y|óÛ3ò…àDÎÍù)ÙñÜaÕç”Ñþƒï•8Lßë<”pu5ö¯9O¦sŠûïÓñ†çpb×e7Àaà#ö_пî0Ž¿‘/”½ÈÝ<ÿ”™©³ã¾â8ü¿üfÎÙc¶¼ì,óÐ ôHvÅq:8Ÿx{EÈù&õáÿPG">bŸ°ñüñþ0;?wM‹'«8ßç~=õ§0_ÜùõŸ gÎ73—DþÌÏ©øÄuoÅmØ9ÎÓú¢¸9'3Ï{g¼ô›¯{¾‹ì/çCŒòUñž íCßè'rÿ'¸EÏÿÖÏ;¿Gÿó8ìðá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªÞ«rx¯Êá½*‡÷ªüÿ¹W¿Lžžú óÌÀ£ž ¹…çõý¥ÎS×;þÄþq^䫨£â9 ì%žäù¿X‘gü þ{sÆ[S×—{Ûy0p8q<þ¿Âœ5òZž¯&ûN²á²k?½Ï¸„:ù7û¯ÛZ:¦ÄµŽ_±[ôŸ:î–Ÿp]OxwËõÇ~õæó‹}®àòkàhú2Ý/*{HßšKoÿ~ó×߯sá„Cø9ÞÓ}ˆäEðŠÓâ8\s0ÈóòûÞü#õÕág‘î‡:x=¤Ïzø“çbþ?Gý󯣗†xûìý9Ô8oÙË?Ê¿wÔÉæ:žÄ>ð|¼÷/ý‹ŸŸù ê“_Ïsþ[Œš¼–±œz†ñ•稑ç.0ž”<Ÿ8_$ÿÀù`÷8÷?;•zýÜeM·Û®Éžú¾õ_ž9Ažm…#C;æûÝ·«säüø/8Ç󊘓„>Óõ~è¥åRsQÖyâþ#¯\èº5s„›ŒóÉ#a'è'÷£ÜOM]“¾YÅÒ{牰G+–-Þß¹Í/®¯r>:ÝP£MûšqžQuðrn}".ÑyPŸ5NÐóºœ:›âkîŸ÷ã¼<¿Qñ8ÏÇ<'Ï©¤n¬~k~x;Îç"ÿΧ(žv_¼ôœ¸Ós2¤¿äíÐ+ì9öÍøAò çAQ¯ êæq<Ÿö»¶3®oé÷‰ïv|Z¯òu?•ð{†sz\·”~rOÈ#ú¢÷s~Ž: ç‹ô<áEôûļ!p·ëòž³%»ê¹w²7ØäÚþUþÄ~MòÀ¹cÈ/ó{ØUîËóê˜ÇœA?ïùòç–ÝçæsCo‘[ÎÇyFúº%wØ=ü¼â/ë‡î}]I»œE—j;ò@©ûPgÃß¡Σ w:ã2³÷Åéy™;Jž»Èù£÷Ô­5/Å÷ï:5ò£÷'E>š÷ÆN wð œÓ=¸þ ¹Àš× ûÀó‚3œ_’ýæ\\dž/%}õ<Õ[ø>ÞþŽë&º7ôœÊ¹R?s^Gqè+N­zükIÇ àÅCñœ#ÙâSð~øóÊW¡¯áäŸy;–?ý½í ìÞ–Nï9ì_ûc\£{÷œá5Ëä þ°ý¡ì.÷ ñss_Êgãw±Ø¾Çñ“äšø¼Úß"ö½—p¾€ŸãtŽ<þ•ç¿Ù áÇ _qÎ[3WHçÅ\AäÊóé+éϼÜ^­N™¶Þq€q©psðˆ ×Sjl¿dŒ¿á(?Í{3ßïÙcjyds¿?q.uÂׯîQð|Ë)犽Å?qÌ÷4~“='N ý#zœMÛmÙ/Íɲœh.žý׺ƒ—VíUúTÛ â)ìÒÆ–OŸ~Úe{l×%Ëmþnh#Ë7z£Îgýþt|¡ûXV¡ÄÛí¯e½ÀžnúcÃ;.9™~ÅÔÆ¥¿x¹Éãq>G~#Ä㜠q1ÏþÀgB~±×Ø×ë%æ#Áa^žê\Ž?ˆÿdß±·ÜþPxÓ|Aî{Šþ3¿Š<+ŸC¼g?)^r‚ü1¯ÕöQvG÷ŽÁŸ‚;Èÿ“ÏAŸ±cü?A>EñZ\™9+¡¼P‡%.çs\_V¼Œ|`ÏC¾÷í9NÊ‚óÀ•¶ Âûæï¨^ïø€¹ê²“èòì8Fó‡‘'× Á Êçñü…»_ýh¹Ýñâ7ågÁsØ3ç•È÷/ëû°;®ãê÷‘_ê¾Ü·ý½üŠãtí1£ŽE{žQOÅ? Wü=çLœã:4ç£þ\äÞµ?Wv=¢nÁ=™‡*;.¹*â'>ßäùͳ•>#7‹§ÿvÚ´i=c{ƒ¿Ð í ²_Áþ8~Ð÷¢w«j•9êÒíã8]òÊ¿ƒwUo°¿·_“]!.à^ä ?ƒE¯ñáyz>+u êà}pü"½!Ëœ.ð+ñ.8‹Ÿ—}5Åç£8»àý ð<%?ØKp8>ßÿçÔúUßøoŸ3¸?óÞžKš–Çx6u!=7v܉ýà¿ìmpÞF8Ð|Eâ‚t<ÀÜ¢˜?@¼Á}ËÞKNí/<_\õAìãA£Ï9<ñ=ä[}ÞÊïòü|þCÿ- ~>Åùnçoá 'ð¹Ìébž ñ ù3½/ú_Å?R7´Bá£0?OÏ~ñ\dáÏe“|a'ÇjÎïÁ{¯¬Øèý> æÆ÷&;€µ’}fž%r꼸Sñ q¾óUAœì8Mv ?ý¢Ÿ6mÿI›¸nÌ|PîQ~ |Š]Aþñ§ÄëÔO°[ø_xŒÎËë¼Á©øEóZd§‘[ì‹ë²Ÿ!Îòï 8¾ƒç£xAöÄüêRÄIœ;¸¼m9T~y”àþËy¸¾§{ç÷™3nGyÛêJÒSä~ñ&yΟz 8øyq“Î…ú÷K^äÁßrûqKàü/…±Û!_-äUR7eyxp(yCÏ]U^ˆs\ré;uª÷ÿ0–/p•Î ýO‚ó™ãÌ÷¸.%|Œ?ä<Éÿ¸N!ühܧÏ·ƒƒ¨[ð}à'óê*U:éÞ;§:ŽòŠ´,¢×Ü·çЦýJ<ï^÷æx|€>ßzÿFçÀ¹c]?—Â~ºîÉVù)ô…ú@ÈÃÁþ¡—àMù%¿§ë¨â·ñœà;ç}~ ÷œº¿G| ø±ÄëáüZâDþësÓ{¹®•>wÏ Ã¾ðÜ+ÿçŸöYÌS_š÷r(¿l¹S\àyžÂøW÷_*Oìsÿ!IËüÀ'´üöÇt{Ïß ÿ ~Æ·ÏŸÞ«åØm>‡E,päû;ÎÛ÷EŠ:“äØ{˜ß«çà\‰œ÷W ù Ÿ‚\aŸyÏuƒ§¬úÏcþiP?ûÁÂÁæW»Ï‘þ:ýYùó4Ðï•Ît?¯xXÞïôO³¨?[õyžË¯}¦Ô°Kè™õPßoÞzCÝVø8œ³Äû¹GòôÛ)~dNÜ'¥ý¸æsKÉp¯æ™±O¹¥ê‡…OÃü)î™Ï#ŽõJ'úá:/| áVÎçôyÓÉ#ù™ßšõé¾qŽÝ/Æ‘âþÝw(=˜zmƒ²»Æ]ç‹eè÷²Þ€sñ/Ì-£o•|}gºîÅç‡Å/¦åÊy7ð*þÛøV¸ =tÞOqw¸oÀuhúIŇ£^ÁÞ`7ø|Ïç×{€¯ðãè…å\rh}WžÉ}8º?ø·¶ßZ„—d¾Î¿æ=†ªÓß|x ö]øœ.¼bœ~a‹ûÃ˜× ^÷ H®À—ºßØß€éãaß{Lt~ä•8â#ð!OœŒ¿u \ðÌ¢_;ˆÛœ÷Óùó_òôÜ“÷¶²ï–û×9“7ƒŒrý(ØÛ‚ßÄ>yƒì8ËqšäÙr î`ï±Þ¿Ä}x.<\ì7u=ßC>Óù'³ã}ïÓÿ¥_ÿxbŒ¿Ðú]ñÃì9ao™Î>'â"ü:ñÜšAmÿsýc\Wpß.û£éO—\š_ÄÜÕ+9oêX³{o¼aè»5ÍÛµ<¥åÅýuàWäÕò)»g¾7yré¡÷?a'™D}JçÈób»‡©ïs?ódÀ5äoà§bÏà™ô˜oþýûžïG{¹]Wb·Îƒ<¿ÿ^÷î½'ôåJßÁëæo“oÀ.w¥ÿö£ô]èÏèyhœ£Þ÷³&ÅFuªÙ:ž+Ö—Ø>ÿI½çŠ=]̯!¾$ïI€s·{® ód9gþŒÇoû&b=–_ ÿ†?¶= ¾.{Âï“_!ßÂyÃO5Ï“¾p‡p¼eó‡ÉG"/Šà°ïÆùc=gÈ#Æ>¸ß< â>Aé9þÚñ.üÄ4Žûë*K&'ži|E=çdï¿¢ùã³kŒÎˆó ÒïO‚Çô—p®ŽtæÃá¯$|ÏC]Àu[ÙûýôýÇycáNÏ1“BÎÑÿp>ùvªÏ‘W0ŽÕ9Gº*œŠ‡| ójÉ«ãω%¿~^Õˆÿÿ òDæ{ósA>¼ ñ øŽºƒóM’_סôþî#RÝûæü¥äß}®ò[ÞÏ„Ü2NŸãylØsâåù\WEÓòì:;y{âIïa•TìzŠ‘¿Ã_bÌ}‡wlž¨x Ž»ô½økäÉõâ\ú'õ<àcÛx•ÔëáûÀß—ÝY{éM÷u¨uu¬¿zþõSÊÔŸ^j„åÁ|ê¿×ð_ž‡ë9>Ì­.C.Í_”ža?‰'©_gÍÓU> ñVÂþFò™ä{¹'çñú¼p^ r ~%ïÂó».Òy9/!y2O¾¿ð ÷ƒ|X/¤gྐྵ·f?ºð'û!Á^Á#0Hö<’õ–z½îÅŸ/;b?¨pþö·ÂÇîû×Ó¿/Üm¼¦ü$}ø[ì©ë¢ÂEôš‡+ý7ï~6}óê+g>>úîþný¼ç§ê=ðçÌ—gNšëÓðsèoÐ98dN }áœ+}pĵÂëøóƘ—«¼6yÎoÉÁo¾Z´cjÜï¡ÿ:®Ôó€¿ÑOæPcgÜŸ,}qÿ®üq ~?ãøüEœ‚]!Æ^cùqì’ùªää׬WÁ¹r~è¿ûoÚ7«ðu‰=æãš‡ \ÏE>ÆuSæ4ÈȯëÃÄã:ç1˜'OÞ ü*i>7¼]Ù òÃàRìýÐàjðówoïÎz£Îç±½â!pµë¨ê¯&žq~L÷Eþ {ˆÿå<©Cš—Mÿ„ì•ùÈ¿îÏ<]æ? WòÇü>~\ÎÆOЇhÿàü‘ã[x€ÄIÊ;Ïþ"Þ¥ÏFrdÿDý^8É'É÷yÞŒôù&5>ú{ÿ˜ûoÁ_žA^Z¿Ï}p~̯ ç%ðïáœ*óæõ¾ž3ÀÅ=ÌiྰCž#{ö“€+ðgØCäB}ÓÏ+ûa>=qq)ññ8~$àgyN üTì?|Fê­Ì_ò¼Æ7ƒìu~˜üùÅQŽà’o¤_‘üŒä;çûa®ƒæðò¼Ë—þøó7Çñ&ñ¢öíÁÏA¾‰[ìoñÏÌ·ÒŸ=wAxÅýxª òsø}üý»ä…ç4Ó÷Rç¢>ï9:ðX‘¾UÍ?£Àñ¦~ÎóôØ¥ù2è£ì“ëÝæýÀk NÏ\bâ|òúôáÒ'LžUøùò> Õsÿ<ߘ¾TÅÿއÀà|üƒðó˜ÿÀ§ÓÏ›ÇÆwíMñÞé |UïÙ`žŽxòžÏ¨9°žJŽþù÷JÙg÷1èù˜ƒB¼a#ù0ïDsòŒÿÒz潎—¨ÃhîyíÔ´§Óü*xª/8®ð>ÎiÞ¥öïéç0_€ú—ìúŠßöÙs©…;ÝïOMvšù´™…M¯9öŽi¶ƒž¯|«y¬²{Ôٱמ“#9/‚k…§Ý')ü ?gɸ ¯‘ÿì¼'|æM¦çFø>‰sÌÇ ODß¹ì6úë|šÞ‹y]<¿ãqé—ù´ØæÙ×Jû_??™:¨ãgð/sX”OB=‹>7æå1ŸUrâþrÅÅž¡ú¯çjKoÍ»T_¾ó•䱨èý‰gíÇÈ—0/ÎFææQ×”¢·Ôɰ‹î/Ä^Íó6_SúN?²ùÐÂïÆ_ºÇ™ôÉêç¼'‚½GòÞO¢yÅÆ«z/ï-’¿b¾£ùì€ÇÔݱCæÏ“OT<Þ6Ÿú)z#ÜIœMžØß#9ÄîZ~é7MÛ;óÄ™Cîw^“~ùp6ñ„ç7Ê>àgÝïÎ\KÍ™c.-y ÷±’בçx.²üX˜ßòùÁ‹Ç¿ÁKÕ½§cWÀ3ôõëçܗʉ÷á·Ð·ƒ<£ßÔÅÉW³‡Œ}cìi¾s_¸ì»ÎÇ8¹Uý›=£qX~8ì{FþÀŽÛà ?"ÇÔ×¹ìýaŽ—˜'yÄÏñ~æ]§íC”‘Þ—óOõïá>òôEb9W×…á ̧ 懹Où„ŸM޹hăâÛk~x”ñ~ßë«T›ÇwÌ×ú2È—ÀENÀ+æ3ѯDÞ%˜OI½¿í~'ÅY«†ÔúøÒ¶]âøZ]õßÓÿ˜>,ìs,d÷8_ïßd*¼.éY¸ç‰óöü>ÍQÒïÅñ7ü¶`j8oüJ>ÐýWØ-õ›˜ŸÍüÕ+˰óÔiÁoú|üx߸¾óÖ•gô\æ¾2WN¸Ÿx yv\GÜß‚ºœôÓóru?Ø9óÔ„ëés=By[ÏÛ"JIqûìÏjžýúzOö°±_®H߇óÙ’sË«òPÞ3 zÀÛOãpëù!óqÑWÉ…óÿÌ} Î¢8×õ+}>sÃ<Lç _û ïÏó»©JxnüDhw=§šzuð:ŸC½.-§QÆ+¶õëüP܇Ä\fø«éÏuœ‡5.…ß&ŸºzË99ŽÑyÁ3R~Éñ¯ç7J>Î/ûŒÇmÙ3À<ÅÞÏ1˜cbªŸó<ö«nî¼ ýòk—³à†ÕžÓA=ˆz2rNÞ|â>ÉúéþEæÊ¤å×vþ¥çÀQg€Gȼ?ÅaþÇý¾Â·Ô{À§ðïÍa¯žžžó¡ÍOdž¦þëú±âJêèΧƒ™³‹ýÖ¹ÐWn©{óœRâgæ)§®Éó›­ïó¾ò6’ÇEÌu•ýpÝžó¢…Cñ3às߯ޗ9ÓÎïÿußøÿøkì9uYøž¬z v–ù®Ì÷d*yì ç'ùuÜŽœ£§ÎƒëÑÉ“ûËñÓÔíˆë™kAŸb°Üû"8OøPA?¢yÄ9ì##ïE=ºyp,ù>æ™}ûäñàƒ±•|=ø;gž!üxbÊK‡ufò3<u Ÿy òhò¿Ôeüïð­ˆ/éÓ>ãÌ/šyE»¾¨÷4ÿù¿Ñ—¯›½ÍÌK NúêÈ‹;¼ôi\_g^#~Šû¦ïƒ{§L5ˆ›¼ç*ØLüï86˜ í>wú²tîØ}Çiì3†×K~Lrž'ßä¾;ý»ûÇÉpþּ̛`ïßäýtÞ?OŽ:âeÛ æÉ3?è·ð^2½7¸Ñy@êžä°çÌc!_Eý¹5Ì“b¾7ýݲ›ØµUÿªðzÇuïÆý3ô[ÉÎzî5¼ xn’÷{k…ë:ìCSœàùìs' úàà[ÙûzŒÿ‰àÛ霈g±“šWå9ž÷#ž%~ñ|}ê/²‹ŽÏðcØ êBÄ ì›'/?ê~þ ^€ß6'ÔÓ‚º™y0ʘoø+÷åÀƒ#ÞR½/ìãáÌ[/É_®I\üå¹sb>§ž‡~ Ë'x“½Âà3öG{ï’úG¬<—äš>/p™ç.€ƒ½?Þì»+boˆßÀ‘Òì†ß ¾®ìçnÉ~Eø'’CÏï‡/§{7σ<¼È OØûàKÑ'®¸Î}ûÌ ãþ˜WÍ|jÙ7â!ôÐq­ø0Þç¦ü>8Ú{Ô©GýÈIØ'hœ&} ~â¾ü{àè£Öï{¯F°_Æsiéã¦~M]Wsɘ)Þ­ç ±/ -Ÿñ.ð~B~”}˜<ý”žn’¥Ÿ½äž­Wª‡yž¤ôÕóö™{ª÷4¯:È›z{»è/€/AÝ ~±ä3Ü£a»«¼8õIâ9÷ŸÁ >ÌEwAq­÷bƒ½Åà0ó©á2¿{î7Ä{#ïÌåbߎòÍ!¾`î~f½Ùu/zubŒ_ô¹ðx<ˆ>ú‘ÿ áù»/¿è÷‡gÂ^ Å•|®çH`ß¾³ùdÊŸzŸ6õð ñ<ÅGÞ³Jý^ û@ÙGÎн:n†WD?&þ|DÌY]>¯o•Y£ãù\äu˜ƒ¤sç<á_9žW>×s6à èùŒ…Lj»ŒŸömPÿao'ý z^÷×Â/aïyGò…àézí>;æP+/åyWÁ¾XxyaýžÓ¸ekt¯W<Êý…âÍM»÷ýçî.Qó©ƒ=aNØß€wO¾Às’„¿¨Ó‚¿í?éëA^àgË_R×¢|º™úŽü÷WQ'$N ú*Ìb˜Þ›9òÄÝì;w¿"¼OÙñ`p‘>Ô°¯Åýq’ úRœdN7ñ)û ©³J_ÀI|ÏOœÆƒU§ ;êéSgyÞýì‡'žKÇ—æÉš_ùwž»q“÷‘‡Ó/'ãùÜðFÙOÁè ÿŒþvïïælÙÏ’÷“¿¢_<Üçþ ê–ÊxÏyúv”·Òï™×+?a^YØhœ̵÷|4æŠÒŸKÿ+òaÜo‡çczO}‡ôOÀßg~¨>ÏóQ‚úÐ̽ÿSÝÏâ}äìGQ2ào—)Ÿé¼?õbÏ%Ô{¯ðyŽë‚½íì¡ß÷Ï¸Ï ¼äÜOMž‰9Ìg·£ø–øüZDÿÈp~Ì3“=†Ïîý^Ò«Ð> žãJ[Wº¾”ß‚‡€_7¿™=ÄÁ¾læñ"çÄyÞ+¬úq÷xÃG‚÷J?7û.è—÷H.Ã9Åè¸{ŸÐ~’úxž/{hà}Á¿ öù™ÿúS=ÿ_üVäBŸç~×IÀ•ÌŸþxÞ¨âWÏ]ÒsÓ—êü¸ì—y ÈÑß÷ÎÄ}€Â]ä+Øß‚ŸÞò4©—ëÜm‚þ\îŸ}¢á¿5'6Þ´%5¡È>\ã_áêÇÎ_—•t_­ä†¸Ôusp=rîº2ùuúWÉ'²o‡9;²7AßI”5¹ÊŠ O‰2Ÿ¬p[ÿ%£œ-{>Ýç¼(ë´¹õZg|e]Ñ+ùpAý(¯bÃÿüvõ”(»ýøº;Ï|>J®ÙwaFÎùQÁ¼».yB”Õ}_“ÔÜd”3¿\›_šeçç®iñd•(»Áem/ß¿šúJ”SñØßfW˜åüuå[5o‹rì´nJÕd”Õâ¡ågU>/Êo]0râ=¢ÜÒ¯FçV]em©ÒlñQáAG9ýg\™5b,ùˆ(Ù}aAã¿FY9;žìÕ· õû(¿Ú虿µüËœóú—7-EËÏ‘µsé¶ãç%£‚Ü9¥ò7/õ{å ùö–;g#<§(ÙþâêÛže*ÑöÙ=ƒ£¬YÿÚúýÞ QöÒšÉþSö³GÄï‘ýÝöú—•{ˆ¼Z”[æ¹Grú}%§}Ϫó?‰ò®˜ØöÃO.Œ’õêÕøúYQN‹Ûo­öí¥QÖôóžë~Ý~¾f”ÕtDÓÂI‘÷ ñÅŸ+}ۥïå^±øÅk~~"ÊL,:wÊÃÝWÃÜJÕwÖ‹’“‹½ûÜÕQÖÿäö?Qn—üÛÚäíbÿ‡ÿ›]aôõ×Á¾úss š2öˆÏÜO“»¬ÁÂSßéÌ<¦nÏÑ¿DÉ7K (³»Œ?'·ñK9å²'wœyÉÃ¥¢¬¥ó?xJT|×öú;œ÷7îóÎz×­ÃÛŽ´ü%‡•ž[á’AþûdÅ®í.þuS”{ZﳊŸ|r”¯ßGn³KÕýfæÝý¢Ü¨Êkå«Ü%Wä'}VfÐö(sÙ–ûW›e_Ñõ”bçµ±èý¢œzÍ2«½x0Ê>mÆ} ›½%k¼–ó쑟ø=àÑf>tK©âŒ zìºéÅsÊE™*Ý}Û-ã{>ý¾—w:å¸éû»]•8» gæUµ-7’×(»Ç_|Ù`[”\öHÞ¯ìŠòÊ|zÉ{?¯Œ²J6ßÖõÀÍìùˆrwíxü×Õ£¼YG^ðÆ'Q攆_vûnk|^ǵ˜Ûäþ'¬_Ù3ß¼´Tƒ({Üðáë3¦Eɦ¾Pr{”]¦û®›Ž›à÷ãÏyÃŽüüñÏ.‹ïcwåºU>Êúl‡úÏo²þd·:øÄ{#þ:¿÷›½L¹QQVÅ·ú-)<Ëß—õ`¥C6Weoýã–ç‚a¯]±ô½¨`×Ö6­Û–‰’MF/|zæxß_ÎWÔí7yg”ŸWïÛÉm×D9M£Ön8h;‘¼{I…6C—GYë^¼â¬Gk¹O(»å£ó:Üzc”Ù{ØÂSkŸåµÌnòÃ3ODÉ>íg•/QÃòš,}ìĨB‰(µOŽñ—=׳×å«»ûþÑsþ›sö˜­/;‹ï‹²=öÕÒ­QNÊ/~ß{[”½ö®55ÇÞ•¬°ùÛ–6‰²û4ýô©ÂÝQÎÒnk®Þ}´Ï'ëžN_¶ët¢ï]ö,ÊÞÜqÊõÓ.µþåæÝqß;™-,ÿœk±ÖgÜZ¾æÇÖëÛíV évC”=´ÉE«†ˆrFvê9똾¶SØ£üÔÁÄÈâC£œö¯ŸvCÉ«ü{ɳßÜ?{ÆeQN«%Í’¯tõç —Å.˜3sæ'ÍlÐÍ#sò¶¾×=Ê®6¯Åë}KÇþ@÷¨þãøZ—½²ßþ|ïè}îæù§ÌLžô-¿ÿž—óÏëâsH>ø[³1#NrʶÒâþßc{®sÅÞå:éó]ãÇ?§ûÅïù}å¯l——ŽŸðÆ”õQ^ŸsÆL=khlWÇ~3ÿæ 'Y¾WþœßîÏÛµêâÏEy.ñý\Ø!Ë¥Î'™ûuë%GŸWƒŽo½ãÛ+Í5cÏW”ûUëQ.+>?ùEì ú“ßdYñiR¾×<ésÞÚý½ýð—¼öÁãÝqu|.‰·g>VB”SøÊ7ö«ïsã=Õ¿æó.¨ðãäç®5NÈ•ì]áäl?‘¿ÜéÉÕ«gM²}ó=«4zý¾ÕöS™²­ßznL±ŽQ±Þ;ÞÿåíG¢¼ïV}WûóNQæi;[œ¸/Ê<®óö=Ï·>#Ÿè)þ;¨~Ø(9ïƒ*µN`oží:ö%/ww™Žó¿ŒÏ#gŒGø/Ÿ›×j÷™Û–Uó½dL¯ðʤeÙQ1ü’ì_f§ö¿l­3<Ê/¼ öo-´¿ÄÿØ/JðSâEÉίÞýåëbû§{à¼À…à‘ÌÇ?¶|kØoéüùðŸƒßßåVkwꎺµcû+û^T¿M”×4Q¹ÕèN>_ì9~Ô~Wö2çÁº³·f­õ=âO²S£îM.«ËüÔ(oÈæ_Ì?ÖúÅ{ð||_^©%Gœ‘¿Ñþ<ÙÐè—ªfYñOØô™ßÓ|fë?v1·iÅ«ògN‚_ëƒpGÉ™‰9ÍOŸo|Àyg½¶­ñO£mïs×¾?ºÍˆ>ƽœíÖ®®Çô«iÜgÜ ® ð¹êãÆÉèrÜÊm1èô ¿ƒk\‡½cÎ猼 ·Øyû{ùwálxÕ>/ôûÈ,ßô—ž?ôˆÏ\Sºê”*ò}cïoñˆëà_ø<ÐWãñ.Ýnݽ½”ã/ô ?ƒ?°^H¯ð‹Ž«ð{ÂUÖWìŠü5q xTýZþ|ôž!ö5ëP³Â·Ïòç çÄ}>é7xÊs‰å>wÁ)-~zÚ8Wrgœ†çþŠ-;ùâÇ22A‰gù¼‚C‹N¼áõ3œ'àçÈ”è½ñè뎀Çeõ°ù«3Úc·˜ á÷Eþñ—ÄKòkQn¢bù·Nˆ¢üz9 [®m¿wö¼sš7r>àÆ‚‘sÊèún”y¨C©W&·µÞƒ')Ž7 Š¿â÷¸°ôx‹ŽÓÀ/–ÙpíöücÆ_±0Ëþ’ç±ýå>ôûù’_p&~9¯Ý°Ò—]8œzAÉ+ÏC¿œïK| ë+r¥½íq<¬< qÏI÷AÜB>8ðîÆEG½i¼™×ü˜wŽùÊøxVÏÇõA¼Á=XÏdO8'ì^bNÿbý>Ü+Ìmؽú+–oü3¸?VÐç˜oœü™ß‡¼O¿8öÜH\jÿ-?®ÐÞœø9õßüC‹jôøålãgíÛµžd÷ïØoCé¯7r‡UŸSvÆ_8±Áº† ÞÛiòiʇ`°W|>öŒ\8(;ËýäÎÛ{íg¿ìsÀÞð\<v¸àŠ5çLúñÛäÿJèŸÏƒ|‚ìBAÙ‚ÛN[ÐÓ¸W}7Öw¾/£ñí»·\gâ¼”>}çßÉ!Çèþ  Êxç½ úùyëgÞîzÕÛ¯ÿ4Æéúxìäwˆ¸7Îs¿Öyüœí¡âdô¡x…]ý>[}ýF^ßVf>ÚÃv oüJÞCÏIÜGÞ{¾å޸ς³KæßR{~¼G‰½̯¦/Luç̓ùžÃ¬ß£^ÎéõÜ~ÕÛ\ŸdŸûïÄ;pýTü{÷íQ7†Gßê™ÔͯP ž©ëjÌïPžŸú…ûøTßuýºõêÌUžyrô…ñóªC˜_EŸšúÎÌÿ„ço€¾Wææ2'‚ýôCßkþ†êÎá)ïçŸÀõ xÙÌ'©{ùÞÇÌ= ç ˜È<Õ‹‘êÈÈ÷ï‹úõ÷Â?Æ{#è–<Á#vZÏc¾<|0ú„ØóÿŸ:˜êzÞgoœ|„æá»>/›¹‰ìµæÔ[ž™ÄÐ3ïEW?¡ûé$¿á>ïÛ hócªc\dÿ ß˼B½—ê²q_»ôÍ{2à—3ŸÿЇ‚^ÀËCoàaQWöøÙìûÔÜ䇾Dï-ŸÄ{µô÷|ž÷›³—Eï‰}ö^qÍ9õ¾!ø-ðèŸaŸ¡ø"ðÝ'¯¾4æYÂb!ûã½— ù¡_—þ-êÿºïÃeÏ»~«÷¬ÑðcÑïÙŸ„ú:z OØ{Ô?Êy8߆óà¼Ì„ÿ©ú2þ¼-xªÈ‹ôÆ{he±#è£ç„SÿÖ﹯Gv0œ¯ƒ>y¿*óÜàm©îïùÌ ¿Öüæ™‰× ÿØ{(Õ÷Öõ½gHýøÂ}1ß@ò‚?ø³V×Ss¢wŠøóûƒ¹ÖºŸ¸ïZ~;È/ÏGƒÏ ÿ+Üoì!ö^€ 3Ü»å~]úf5’>ú›±ÿÜ›ùëìý„7 T~Úó©à)ûÁà5„<[οíýpÌ=§~H¸/ïïûFâ~1öžÓ‡Æ^ôHòÑ{Xø^xô?°O…ýâôûÓ‡É|wx¡Ì`/sHÙß?&ØËç~yæ§Ño”>Û1óöd·½_E8Ÿ&˜7ï}ðáÀcàá Ï`ÿ«Þ—óâ\˜[âyFÌ_„߯ÞkÉ÷æþ!xXô÷ósÌ«†ç¦ù&Æü¾ÞÓ~B}µôaW-·²ïî·ÕûÓG€½÷lÂo¶?€$»k¾/{‚5¿ÐûИÈ>[æK_Â} ôᘷȾÅ |n‘~]ÎCøÔ}üôk±1Í/ô|§Ï›·ÄþúFÅçòÜú`ŽòáýâÓ1WÇ}Ìà â(æœkÎöÁ|#æ²Ê—Šÿè¾gü¿øWà7ïñÒ\kÅÙñ\=æËJ®Ø‹‚ß‚íùfðš™+¥xRró‰èã¦*ýšçb¼ôý¸—~³å~/ýHøkæuð{̧Ä?ü}n^‘}àôUx–p ýª~ÏsŒ$¯Ü?ó+=GZxÉÏË>aäŠø‹¾ã`§çØ|sÏen2o—¾-úÄ´?Õïy®¼:æ§…üwî¾Fü øŸêC¶>{o¼yö`ò_ÅùÜûà…JŽø|÷7‚t¾ÞÃ/UçæþéshÿÝ/ 8ÂsÀe/V ­Ý´ÃÞ6±~²¾jn óËØïä9dâëö¼Ù}湑?Á^Û~‘ßnrÞƒ=”ô…°·!è#·? ú¥˜`þ)-Í! ¿Èý¼øwö“àçË`ÿ(ß·¾Òýy“.XûqæªÐWÂ|Jp ž=öÞõ„óy?äüU攲¯Š¹@Ì­.rÿ·žoÃe×$~{ŸíŽçsq=7Oq™ß/öϱ'RýUÎÏà'•¯ çù¹™ÏÊÜ /î‡ñ*8Ò{+ÈãùU÷ûwýtÆ Ä•È¿äÙýײ+Ì[ñ½ao`0Îùæ)Ðo,¼ΫeÞŒíºô’¹ öÃìãå\é#cn|`ßÁKîû¢Ÿ‹~ûà|ÀaÈ«ç>awu®Æq:æ’¹Ï|žçÀÌÊo¾9úqîÑüðŒÿâ‰Å¢Ü}^ýã´þ1êïÔe2Ï?ç‹O®k^u¿b—ÛÛ`¢ëKæÍ¨ÎD}^õÚ‚¡åzÿ¦œyðÇà SW6¯JŸŸßçˆl×»ô<þ>Õ¡¨·»ÿ@ü*âIÏ)VÌõOñ«ÄÃ`®O”qÕS×¾9õ×ááÁ«‚÷/÷¤.¯Þ|®Ü÷>|Ò e¢üuyõ J5òª ÞM›ˆ9Ô®瀯HÝÔýªWÂ#õy‹ŸÃsˆ÷Ýò¹P—§>Éyó^Ôåá'ÃÏ3^|÷ 4]0öÌë3çÐÜø|…ã3ÏyâÃwjÎpÝ~-õóÌF>è{ôGñûÁ…—¦ú°æ.Â÷p¼©øÝülê·Ô“áõ˜/*>|Xä‰:ªëúyx¥Å'o?péqç¸ÏDõdìŒû¸?úš•·3ï½ãá/šO¯Wü}îMçïyϪßš?A%˜Ï`ž8zT|ìþíƒK¯r™:-|Nú7ÌcOÿÙxŸ}â¸^¡¾~ówá­‰Ÿãý¼7¼§ðà£`‡à…‹å<ú›_aêˆkî¬åmдtýK|~ð?ò÷{»-GÁ ô>'xšæ¿‰W¯{EŸ†ùiðdÓü óöÔ¿ÝŽù¬i=ôþ©üçÊ´¯vÍÍæ¥š_®þ󹤧¥/xáž#σ…ÿ„/Å<óŠs+ô+y|ó¿—âióHà#Áó“Ý´½ÀÀgD>ÌG—žË;ê„â³obnívþ®Y[žÍ?™óÅO™w,ÞIÌ«LÛqã(ÍÝ7¿Hr~õžB扡·ðfèssŠxðpòO?öÙ.ªË“ôF{ÌÓƒ‡Å}Ã{Ïh8à¢Uß·çóÁçæw¿¯#^½û¹2> òÆçÃïÞúÿÄü%ñPÌÏ…ÿ2G œ ýî'1oIüuü|ÎEý÷æñºŸ~:<0x%ð¦Òzeþþ¯c†ßã÷…gd>cúÞȧ™Ÿ­Ï#^‰ Z—îùÝ»WúyyñÁ—q_¡øyâ1ŸÂSùðÒ‘cúšÄ—’þ¢—æÊ[^ðKÈ]nŸF¿ÝyÕÒ˜ß'¢ù½ÂÂÅ~^ü‰ø±ŸŸˆ{‘ße®„qåHø¢x½ì•ÛþS ~µûÁcØkxgÂ3Ì70Ïû†§(þ£yYÆÂÓðÐÍ;—§ïмæôs¸o„~÷?lR¶û#ž/Xçb»ÉóÃÏo°¿F¯¦—¯Á7£o ¼ ŸSzKCù1x¾ômÐOŽ?æç±Gæ¿{뷻ͧ/]s)ã>š´|Æø‚þ\úWt¿Øeúó§èçÁÄ…îgLË«ó•ä‘á8~×s»ß¾ºì)zçþáuó¶á•"ÿîó£9m7É_‡aÀíÒ{òÏîoa®| ÕëïÀëw¿â0÷ÉnHŽlwàYÃ{…¯÷'¿SdN¸˜þâ'ûYɉæ×rnî‡ë1ü™éKGG’7âð_Ä)ô¹Ó/H|L|G¿–âgó«Š £_ø±b=¶~öRóãÙÓâ|÷«>ãn÷¦yåñ|‚´=‰û Ƀ¤ûÖR…ë)5¶_ÒrF?–ûH¤'‰[fׯU9ÛþÄvXý°îKã4òbQæø‹¾8g÷Àß}Ö’[÷åÈNчaù#¦|q9ú.T|Ë¥ý¾ÞCvžFŒ›5ƒŸS>Âñýp:?‘ZU«ÌQ—lóõé3UþÁó"gG7ÝóÞµ´ÿ5¯Â}àâ¿ÛŽ g»ÏCùR÷©Ò‡F¯ð#ñ!ý?î»Rá9ò“âÿ3'ö›ò‡¾'úV7‰GkÜOó³WÔ8òÀÁcç—Ð'bÿ#=%ÏJŸ&òFß8σ½s¾EqìsœØÃb|ƒI‘]ga×™sá8„þ·´3nSÜ㼑û”ôœ¾Èô{šgp¨Ë¬Û}±Žå‰øÞó^è÷¡¿DòL>?/ºþè1nó´Âkô3çâoܧ§<¸›>Ox2ÊÇ}ªêcvŸMúüçÙ§Þqv½Á©?çð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UïU9¼Wåð^•Ã{UþÝ«‚]wîgã”}o'G'ŠÌA¡ïÖ~œü.ùÅÓÄAa?‰žØÿ²çEqù+¾‡<õúwjxáÅ®x^v\~<_¤ßVv…ï·ãWÔolÿìq!nA®6·XÑÏ?Ô±}A^T׌í£ðyLç»Ðù{òÎîÓVä9"²s[Þ(Jñj/ÛW2/{œ3é+{eø{òÛàoîy]߱磓KÆóÚäïé“fžúdœ'{Dÿ$v {„?ïðyÄ1œƒí¡p þÈþCßG¼úÅ?+4ü´óîùñ9Óg'Ü¡ú%}:EúÓù=êœèù2ðýš»¢=Ó›û=Áñä9œÖ>ÎÇy4½§ã:É=s,ç:gñ{­W|v;ÎMp³ü ñ+öûÞ¦þäù9’{ß3sõô\¼¯xS¶‹Ämà$Î|ý‚ÔGÿ˜¸÷´:cϽa7‘G¾÷Ï¡Mj×ný½ûÜ‘oâ=ô–sÇ>ã_ˆCÿlyÏçkÖg›ÿ‹ü¹n@±ò€ëO¬>î@—x¾Œ~<&?%ò~gwïßl—þìTêõs—5ÏSrâ9pê'EÎøwÏ}¡[öŠxsÄþà—ÑopŽq¹ôxŸú6÷D¾œF¼K^ ?Lþ¹†Ÿfù ü£çHJƒútœQ|‹^Póô@ÏQŸÏ¯m~A‘¹hŠgñ›œŸóÄòçäéÐGÎÎÏ#eŽ‚p ëAÁÃÄEoüvtl‡ù/rKž€Ÿ³”?"OJœçüùxÉ÷³¼R¥“î½sj,—²ËØ;ꨮ_êsç?¼ë?eþø Ž—˜ƒÞ#/¬sà<‰l/ÀÕøUòY:×Ó•ÿ qò ~ù3±øØÆ‡–»N²æé[þ|¥ë=Eæ™x^ŠpŽï{ðàYc&4Šqxüú`~ôóó|Yü³ðï‹Þƒ<§¡y¥ŸÊ59Ñçˆ<¸oϱ“üb/(¾çýÏ÷Q|ŽÂ¾àG˜sȹºÞ">¬ýÞËy]½?õz~^û:bœ_`ž ¸^ù2Ïib~5ù^ùgóB©ßŠìÛšÿåÃ2-'ÄMȿ絪ÞJÜíx\rÊÁÅžc®çÙ˜ø´iûOÚ9_æNQ@_Ñ;ì–çï2§Nñ~–÷ÚÎ (Ž4¯Ý|´@Ÿ‘+ô;ÍyûaÅËöÄUìa–?·9OÆÜYô@~ƒ÷Ç>ñùŽŸ„ǰÏÖ{ægù`âQêzó/øpÎ-C_öÏ“OGxžœâ#ϱWžŸºñ"yTÎ×rA^œ¾ì¡ü:¼;ׄÏlߤÎG?$.Òón\Zñ‹—›<×såïÀ‘!_Åu@êß.§­xæü–-–=`†Þ2?ÍûJÀËç~¨kû½ƒû¶ÿþ3¯\q zÁóR"/€¿Y9©]çyÏî3Á{D˜[ÌÜlÉ ygð¬ýŠì2þï_rð›¯í˜êü‹ó¹Ò;Ÿ¿î•:/þxÑ Æó ñ/äSìužØÞ‹çZ;qWvƒ£÷û~°3¾Gð—ÎÓu Éçæ½ìI]]Y±Ñû}ÌùkÒWð¬ó¤:/ðîú)eêO/5ÂóÿðÈ+8É÷¨<ø\…~;ŸNþ‚¼œúœð#ÄóÄñð±÷Øsô C¼ŠŸvÜN=Au êæG²¿>ý{ô¡Ù¿ú|¤'Ž3}OØ?SG¡n­:qU˜§ç^£/ä©muŽÈ uOÎþòr¡¿zþ§îƒþð2ò…¼ÓO¬>ÞXþ$wkµýÏ ÷މû2T$¯ä=AÄA·œ«çë¾°“àoì-ïOœÉùz>´ä{ý%ír]þ©ýþ;Çïñ~zNÛ;úf¾nÆIÿÚËŸÁÿüsë¬ëòýcS«W¬.3ÿƒš‰ø_êósî/(ûñ¯©ß’•WÜÒ¤ŸÿNxeùßwl[äï×uiÖ¤^ç;¿ÿÇç þ½ÈçÁäÏV=.û›çûçß?ï•WMÞî?ó¼ƒý®ðëŽ{ý÷cŽÿø¹ÞÛê?ݩڅMvv/ò}ü÷ùÿ¾÷ûø{öĨ85iñ¦•WtZ⟟÷à=š»ù’Ô¸~NßÿÓóý?=·ÿ~ÊÚ—fOºoé?þÜË]üÏG†§^_ÿÝ’¹g/Ký㩺^{kjN…#K½¼ïÿ³Ü÷úäÑ¡›Rs~ÿÇsâ\W,[¼¿s›_Šü»ä½¨Þíï}°kÍOþñyþé<ÒeA¯r]ýg½·_rnùûjÄ·«†–ÚàןÿIŽ‹È9ç:ÿ‡ƒŸ~qÇè"Ï3÷ûŠ×?ûžÔ»ÿû¾©áç–û±CÖ’ÔOÔ­>õÀÿἺ”º¤áÕ…çúöùÓ{µ»Í?¯|p‘{æ÷–Ö¹÷ÂGުoY‡~ûÆ¥fnýöÑk¯ß’úæýÑœP¹q‘÷â|àK¾üï³>yá÷ååIÍÌY>¸XßþÿŸí¸+ü÷‰•ï¬9å”d‘Ÿÿ=û軞¾9õö}–7ºzKêéÿ®WøñÄ”Oý{êçÎ7}Ðlש¹W }rGÙÆþyê.è§ï)}¾©Ù½7Þ0ôÝšEî»Ì=ŽÿdEé{Vó_¾~ß^ÞñŠ‚³k.ïÅyJòü;r9§ãå¿W?n‘óý¬I±Qj¶ín‘Ÿ[0íáïžÝòNê—öõ*|à?Z~·W÷?Þ&®þðïÃÛûñôo}S°ßßûëÿðÍ>ì_üÞÿg}õ¿cÏáÉñý‹§ÿvÚ´i=]Ÿ[¼§Õѳ»ÄrþýQµî¬>¨Eè—ÐŽâ'ÿœäÛ^:æÐ€%cc{]¶ßHŸwyÀžè<ýy¿œòãÌ|ßóí;Žéöžå”sZ,9D®>]jô¡'®°|·J?ýy<Ï?ܳŸ“yßór{µ:eÚúÔs»½¸fåÝEÎý§V=þµdjÑØcZ–x½Hý~ɧµ£/§&ew\øú’¡©U™½/ý­Z‰ÔJ=ÿ² %ÞnݨԬ^?ßZiI»Ôºe#.855‡{qžÏ‘_IõûôÝ*\ñ‹ýÞ‚‹›žÜ纑©UCj}|iÛ.©o×}dDÓîEì <ü販=¶Õ¯U¹È{/Ý»´Ç³ÇMÀnø¾d/üóäeÖÝ6¦cÇÏnIÍJ}V£áæÞ~Ÿûzç?tÓgÆ•œSˆ·¸/ìÆô[~Èx¦þIEìÏòe…?þüÇÍ號㇊ŸÙ7ãPê÷v¿7ŸR<Ÿ8´È{-»í¦óçðä+5¯î}g=óÌÙøYß'rDó¢¾L°øßÇ-›=§¿ç§§÷TÞ”ø¼~ÂÎ}}ÜÞ¹«ËŸ©Ù—¿rÆœÁÕí¿~þÍœòý>t^\¸9öGâgñø#É£ÿÞ¸¾çIýŸgþzÂï!¿áùo€oñ{¡¿¡OO~Ìr‹>ýÞ¯|cêdÙØOË/úógÜ¿£ÇÓû¶½W„83¼ožëŸüçÌŽ¿\¾ÿæ÷ü÷äøwôýÅßc÷y®É)å–\×45oò«÷Õ~ðä"µäÒwêTïÿ¡û°à9à—VÿŠÇ×rþô·ç^j}}Šþ{äÿÃ}"ÿ̧àóíçšõéÿÝþé>øïñ¿à®ß¾Ÿ{ÂÜ÷{øß—uÍ_´­ÁˆÔÜ‚gW•O ñçËý#nø£ü{GÜinjùÁknûðGÿ=üô{\ž±ìÈ5ãªúósì£ä¿ˆ~`¾lðÆc™­®ýG‰}BÈÛ¢¼ÿ¯Û¾m×zì-©ïÞÞõFÏ‹àPé?òû¯4.(ÿˆ¯ë¿_2î‚ÇßkT$¾ÂþbwÁ5Ø'þ?øõŠÃöyà󩷣ס?äï$?vIÌ~éª)¾Ÿ•OÿtRÛú‹ý¼+¾,{ò+ZÎC½"Çs“OÁÞñgìv(üÎÇÓÏ=ðœªGú9þÞƒäÄ?ýõùeíïØ½À~—|žð‚ï‰|ùIÏ5‘×ù„r‘ZþõmŒ{=µâÒ•uÚŸ÷‹í€ôÍïÇç½yŸ•9¬ÈùrØìùp&Ÿ+üç'¿Ï÷€ø3ñ,r@üB½Dø!µúŽ{ ¿:×x;Iþ ûEÜNí-vKv.~Ýöœóæ=dÿR+—}|ôºï÷ÿòsS¯mPv׸Kã¸O~E~¹ˆ½ãsðƒð È÷†þ ü Þ¦®¡÷ç’OâÜy/òºaÜ…Ÿµÿ‘–7?ù“ÿ}ÆñKþ¼«Þä·HœD}ý”\yOí‹q¡âp§w/ÜùÂζ‹àPô‡G?À9:ïXNåψ#ð‡øä]uœô‹àcì/ö@þ&Ž3t/œŸq’ì¤xÍEâ8Ÿ¯ž »Ežóá9Â<›üé?Æßœ[˜·Â¾“__]+üñÛº¤V-=wì–Ë{n¬§%‰Ï4/ž¼¹ûá©O¬xïýwr³\GÁîòsØü;uø!ÄÁ®[Ëï{ošxKÔ³ù=êóæç¥?×ï뺭ž ¾’óòÔEéÏ îM]LÏIüF={”:+çG=Œºø_<7?Ÿ÷*‰W@—ú}Dîó¢þ';O½Ê|štÞߟo^•êÂÄ­ž‡?Aþž•ßC¿OI}‚:qŠëOôõ(ÎÃû*ÙW.ýü~nêiæûÀ’ܧ¤®Iý”úüâjê;à ß³xGæÓ"¿ð%Ä¿à}àWê==Ëýäð€™¯ þ1ð}ÌÄ!Ô»ˆ+Âzù]Á¾)Ï_Çûyõy¼ÏŸSëWm|ã¿ãú,û¶éo”ÜR'r/]çó}øyÄdž§„]0?K| Ë™î›<ýè•ûaè? xîCe~’x•þ{É/uWâp¡ç^‰÷°jò­înØ0öKÂÉÔï¸g䎾âôÓ}(Ô1ÅÓò~pæfè9ÍÇÿÄz'9Ã~y!s.t®«'.}¥S‰Ëc¾ó’dáI{o"ývÒp5¼.êý>Oø¸êó=Ü/n=‘>Ðçëý”ì!÷Á«OÑŸ$C~ >gx ªGy‚ìóoÌëÕ}Òÿà=âí‡Ì÷’„§lþù[½ÿîyô½p^z>ô¿lþ¾î<Š]“*’ßÐ^ªxî¥ÞWze|ÚûÞ*Ñhã4÷ÃkBÿñ×ÒSî§ù¸àæåH½Áôc=§%Øïi$sÄ;_ƒÀð±ïȳçJþŒÃéßg®¦ä1œ§êyôŸ0F8Ë<\é§ûˆeˆ'ƒð9à31ç#ä•yîóRäïü÷š».6Ÿ >«~=5/_þù nE>ÁàÞ5_ý{B™57Æó\tèùQô§Ò)¿Œ½÷Ü@á4Ï•]€?Æó‘ñüfùæôpÞî7ðÒÍC§¿Tv×|kñ=ïPçÀ=š‡Íœ ü;ýrzn÷« ÷‹³ÎÜXÿ±FÖìçBƒ£„CÀoÌ÷`§xâóÍd•G´]€? /Òýƒž‹ŸVüpÏkwÊþá§Ã=öî+cÏ´ÎËïyo®ì v½ ÏëxBçò0á¡‘¯Ãžà_éÓç?R?À?ãÍÛïÜ|Ó‡îç~±_ÔAÿ‚{å7ñg¶sØé3ñ£í»î×¼{ôŸ>Åq¶{Š—Ü'J?¼VÝ‹ûùèûÖ¹x®(óH„O9g~ޏ²ÈœtåUܧÀ¾sú¤à¥s0ÇÑ·®û3~…ßÍ|Œ€Gíù²Ä™Èk0÷ÑûŸ•p_$¼eù3ä» î°ýÓ98^`.'}Ÿä[à‡2¿Ÿ9¡Ì›Ó÷ò=žc,;å~'á xTñ#¼`ïÇÏ€KÁŠgÈþÒGI^}ç÷Ð7I~{ïyœä-dÏðãä•°'žŸL¿0s¡˜ÏL_ 8‘~!Ùì´û9ö `Çõ|ÔÝ· ¿‡ÒoÈóz®¦ÞÞ¬ý.sà$wž‡¨ûƒŽŸ@®‰›Í‹Öyðsðä±'ž»§øš{àþe·â<¼æ$¸Kòå¼—Þƒú7þØöEqCˆ÷ñ{èŸõG»Æè ã$ÏSfÎ q\0—Æsä$ÇÈ#òîAîð#œ“çMÐwŸ?è?GÚÿÊ㿜 $â¾CÞ‹>æÆ3ÿÀ\Èy€gÝ×Íûëù‰K¼FùCôžøœ}èúFŸˆçü1'RïǼ3ìy.íµç £ŸòKà!ÏWÖßó=ä;í/È«ë|™·â|]¯?Òéy!Ì›bž™âS~Žçõ<¥`òçç•|Ñ·ÊÏÓgÈ{Òÿí<õöî`·GÉq/ÏKÜæ~}é!}Íî¯#Ÿ¢9µ–_æÐ`_ƒù—èsèŸò\· ¯‡xØý[’—ƒ£¢¾G½ÙÑ~ÄóDe'‘cϋֽ¢§Ì‡³üIy~ðöÖû ‚¹ àPìKˆû\?d>KÚŽ±ÿ­Hÿö }ás=_{–öÏ®“…ó¢Øoá|1óEô|Þ› y¤ßÑñsîOðè%}èì@ÿ,×Ì¥”¿ã{ÜÔµræM„y"îŸøÀçô{~4}¦’‹Ðž‡sº¹ûoù÷á’G”=až•q3ó¿è$ÿƒ?•½u‹=ì#aßyü„Îþ8ô9]¡ßv<Æ#ì~œà:«ÞÓóÒúû]檲gFù%ò|®cO’ï—žÑnœAU÷N|çx­xÖ{ Òv,J¬è°pØQµœóbÙ)ï‰PÞ;@Â8•ýkôRo“c7\ÿ æÖ1oÓó‚˜W.ÿ€}ò>+öå`G$/ØÇûÌ¿ ö?¹\~-œËè¹ë̽îs™9úϳAÎÈÇ€s$ÇœƒãTÍ¿$Ž`^¨ó´Äò;®› ?x¯’òèèÁÚŽl‘û«ãäÑó£µGÔ{øØ7 ÷¥ý ç\ãÏ=_‡:¦ÎÁû’˜#'\îø˜}IÌ †/AWþŽûóù2N÷GØ8yÍÌÑ–œ±÷’ý¼ö7²_Æ÷èó>¨7àG˜!ÿ Þsxô_ϧ'ÏÅ| ô9d>sÿÎωñ¹ì*z€œ:¯C½-¨óyŽQ0»Îç çj{ŸsG˜‡À\xòÌ1ÅÏP‡×}“—v|Ã> áïpÿóRä·ØWÅhæ÷#÷a½‘Ÿç¾˜ìUôü\æfkØÏ¥óÇÞ¸®Ë\%Í%³ü°_RvŽ÷cþ’çl2?Eç@ß5Ï‹Üáˆó<¯} oÌÓñÌ5?AÂx{€÷^Dâyé½çzß³ÏNv"¬Ã3¯Ÿ·Ö9š7Ô]ïùºoì›p†ý®í-sT•×2ß)Ø¿é¹~ÂßÌŸðï«Þ ¿±ˆßßá…3Áç£Pwd~µî™8Þ çä|y³`ß}ûø•pÞ/öÙ8Rσ‘g÷ÜÉõ‡xÍ<}êqÒ+ã>Ÿ¹µÁ|zÇÑŠw½Q†Gì9ªÄàÝ0âóÙÿÄÞ%â|x;ò£œr€Ÿ&Äü7Ïñ×9Y_¥WÆQÁ¾ë=zËAösï–= Îaßçy‘f 8ƒz.{täç<ÇVzÎÏ‘EOÑOÇ±ŠƒÙwɽ[ž$÷øÛcxÌÇ_°‡C8i^EЗá9#øQâ;öü’–=b^ ùbòªÞÇÂsw“×'ß%ù6Oyð쯓|„óAÌ7#¿Š=fï„ò ®KI_×w‘{ÅgÄožÏ¡<‚íü‚ó"ðá°ƒÌ %ŸAýKvŸyAÌ3Ÿ~'üüsU”‡5¾fÿ£ö…xn¾ô“>Ïѣίxœʹó,ì}RžÉóÀ™ÿ-½‡ßŽp¼ ~•¿ â9ÔÁñ7i¿%îü龪…Åã=ªÓb'áCçGÓö¼óJU÷[$ÿ(yå|­/ì»a_óÿ‚ýñàó”‡ ÷ Ñ·à}¤²Cè¥ç›‘_Oxo3ó|‰ï$§ÄOæEÈY>Þ²÷‘Rÿ•¼9ŸÀ}¥ñ™óFæ/ÊÀÇ”=‰ç¾PGIÛÿ¾ë!ì'×=`'á{_<{¼…£‰‹÷€Óþa…ï“ýÎð<ƒ¹©ô[„ù Ç;Ô«ô9ô¥:¡¼ çË®8îâù¥Ïôk37`^ש­?+¤ç‰ÇŸ§ä‹øžüúþ™wž€ßNÓ¼ ò`ò÷ðQÐoæ$‚wéCtþ¾¸Î+ƒ¸Þ)œåú¬ü"|LúHé›å}Ô¿ûÙßpN/ÏO?+|7øñð÷ðkäÑWì?·Ô²O¹_¹0ŸþúÈŸÉ.‡?ñ·à)øNÔsúyÝ'F=!؃=eÞçK~•ùñÄì'â{à«Ñgî} ̇/Òówe÷=Ä>VöàÉÎ ·ðçÉwЦúx‘¾cλ ï˜úulð‘û ußô›Á\CÅßôÁ‚‹Ñ?ïi–ý¦ü‡¾ ¯ô}À`¾€óxðIéÃ`¿‰æ2\Á½£öKìi¢L<ö# Þ#!¿æýª+0…¸þ~ üH<=Åã·<¯Yv‡|~š>iâSô޹ÆO’WpóH¨“óýÌÃpŸùÕe‘Gî¹æ}ùøøoæ³FþÈð>è=zL*ö–üc‘½ÇiÜ÷+êù4ÇÀÏßž¾xäž0|lïÙ¾ÆÎØO*ž2ŸNøürC?úâ}TÂÇøMÞÇ÷¨çä<v¹©ÊÅM?µ'_Ë÷ÑOþ:”ó’âüó:Gæ]çr¼Ö½õyÈxÐüú±á‰)%OƒŸ¤ïœ÷Â?07ÅuiÉx6œ{ºî²ŸŸºñô{·âóo–^x޵pÿî=ª?³ˆ= ô1ˆo‹Ý!OŠŸás¨â_àõbGøì;q ~Ž¾Ë‡žù$ŽÀﻞAªÎ‰~óEäwè#q¿¾âzÏ—×ça‡¸_ÇS’p><|ð ÷Jýœç5ŸŸø»-é~Õuܯ•Æsqž’<‰~Ÿïq= ¾0EÙîy*®ÉþgïàÏ(oà9òÒGôÐçƒüË2‡)ìô%ák÷Sé{Á?È9ñšçž8}¢_ ¼„G>¸úª÷PG ê+ÈùPó¯áñ3GCòȽ“Ÿ"NgŽó&™ æ9 ª×;O¦û'a~ ~Ëûæà'«~‹|’‡5¾ê¼ÌÍ#·Ì³÷ñýÔãñ3Üö”{š/ö÷zMßk®òà¾^ø²äÈ7x¿¼ð¥çC¯x­îÍyýƒ¾‡s¹4—0Þó£{ö\#ŧÄEàgì0x›û#Cœê~;ò\—œ7ñ7ñ…ñ¤äÄ{Ú¨ûÐù}÷{}ÜŸøIö³áü οEþ?E¾Êûg¹wÙ™°¯‹|çï:˜âp,q’åV8†>¡_gî+þåW·xn<âçØ;Î>WáQ÷uè|¨›`ÐæPy”ü$xù÷€[½gSöмUöáJžˆ¸_üþš{„÷¹·sË9ù_=_Ä/c¿tq(?Š7ÏŠ=ÄÂ[Ô Èûú\Ø÷Àžrù{ôÖû7˜¿ =÷œSÍáCO¨yùO=òã{—½Õ¶Ñqû¶¯‚Ø+ĽpþÔÛíOéÃÒçsø5Þ»Žÿ"_Aœ‡¿r\"{(½/2w‹9}Ì/5ïz){ätÞÌwóoü!óGdO¼?Fø¿†½ÅŸóûÄ™ØÛ?òÅïo¢¼'¸„óçïÉKaÁ%ð+äßc»Â÷ ‡†sUÉ¿c¿¹Gò8œ—û€toìcnŸñ™ÞÇs®ä‡è÷"¿œÀ÷?ðgóEõ½äµ°ûÞ; ÿ6è‹EoݧË<ñNÇ ¯…u>ì òÀ=€ƒðØUâíp:?ïxVö¿?g>ªûÄWpœ§ûÚƒü'öûͼ)ï×Îã<™ Þ°å|…¯<—Dq!qóŒy_þÝu/á@Ï™“}Á€ûñîŸ×ßûƒ~üõÏ© öv¿ÙþÁwd q/{ù}úåñŸØ#æ‡ëß±çÞ‡Ã^Uñ5˜£é=OÂ'ä…=?!ȃ¢ÿÄõÈq=÷ÅÜFÎ}/²§“}ÐÒ_ôžŸGÿ©ÿbOÌÇžñ¼DáòÞ»'y£~>#^ƒçCƒ|v|†Ÿà>¨ßð½ÔÓÐ+ö#a'sÍÙëJòä]¨+›'(‰2 ›^sìÓ¢dû‹«o{rýQVÅ·ú-)<+ʯ—Ó°åÚFQVÎŽ'{õ-“:´ùïMº#Êj:¢iá¤(Ê+µäˆ3ò7F[&nsC÷(qĂ̊²J6ßÖõÀÍQöÐ&­: JÜ0mÔé·e½¶­ñO£á¡E95*¿ø}ïmQÆÏm·­Ü×>Y”]ªî73ïîåŒìÔsÖ1}£äƒ¿53âô(kçÒmÇÏKFÉίÞýå뢜÷?lR¶û#Qró ¥;–?MßX”,Ûøš1g޲ú ØüÕí£d÷…5ÿ&J¾Yb@™Ýeâç.ß~cå5ß±/;ʽbñ‹×üüD”Ý¥Tµã§lˆ’w/©Ðfèò(Yú؉Q…Qî°êsÊÎèeïêºqL¿šøož“¾¢(1®bå…Qæø‹¾8gG”Yjüô¥½®Žrúϸ2kÄØ(cÞŽïNú:Êx2ÕåÂÑ×FyÃŽüüñÏ.‹2ÏyâÃwjΈß¶ŸòMõzQÖ¼˯3ÝÎ(›Ø¶:9+Êkš¨Üjt§(cí3c+ä‹ÿóKm£¬-?«òyQæºïšÙ§cÜï“ÎÇøï“#sò¶¾×ÝÏ¥÷‰ NÛÙªàÄ}þܬ+í²¹j”ì?hôKU³|¯™ŸñsA«d” 8¹Ù£ä¸ :WXØ>J¬oViI~µ(;5êÞ䲺QnÞ÷½“ÙÂ÷–=³ñÍKK5ˆ²¶Ti¶ø¨ŽQήéû>­3<Ê_îÝãÆD™|Ð÷èR‡Fnt÷ê“¢¼ë6xo¸å$³Þ캽:<e¦ñ>¿çsÏ®Lûj×ü%ã†_Ÿ1-ÊIõ©û7ÙQFíúþ/yÈýºõ’£?ˆòužêËŽr _ùñÆ~õ™7ß¿ä¹L<ú|…?t2wmmÓºmïkËn?¾îÎ3Ÿ²ºïk’š›Œr¾º n¿É;£¬ÿé÷#ò2Qvâí™ÕŸe.ÛrÿªqS£Œ«žºöÍ©D™­»Þ{ÔæZ>çÜß>zÇ#Q~ÿ=/çŸ×…|¡ŸƒïË›ñQïëÆEè/¸,Êz|ÜÀn³'E™Ã~ëôÃu­O–?s²^½z_?+Ê,ßô—ž?ôˆòu.‰¼ßßÙÝû7ˉä þŽŸ?qÒŠ–ÇÍ]ã{‘œÃóÃŽÄÿ•\ä]1±í‡Ÿ\%‡•ž[á’A–ŸœÓF^="u»ï;㿼Á‰Å¢ÌNíÙxìÊ(£ñí»·\å.k°ðÔwºX2nùT»Wï‰2ë¼}Ïsã±;QN½f™Õ^<%×ì»0#ç|ÿ;öÉ/yÊhýÖscŠuô÷d—é¾ë¦ã&ø9¬§Òƒ¬ÓæÖkñE”ŒÚ'ÇHXÏ8ÿ~úùâs¹öÁãÝq5}çÖû¬YÿÚúýÞ –¯Ì•î¾í–¿ôfÈ··|Øù¯ûš\üëÝ箎r[—½²ßþ¢Œ3š¶¯0Öö }ÍÉmüRNùcááø~üœ²§™Ùóf4Îiæï·}æ}Ž»µÛ–QÉ&»J²i…ŸýÉ|²Âmý”„‡å™1úç sÁ;Qö]O)v^ÛÁÌïo(Õüí|òþ¾ÜQÉÞNþ ʺ§Ó—í:H^-JL¾~É GvŠ’ËÉ{ã•]Q~»?lת‹ï{–u\‹¹MîÂòÎ{e6~þ¦Uu†EÚ^•‘g»›³î˜™3ÔÄNÐ?Û«CÍ ß>ËvsD~ù<ìúžÑ¶W»‹V÷Š2u(õÊä¶±õ¸ñ‹/l³^#oY“«¬Øð”X?†Þuëð¶#í§%ÖwøsèïÝ×<›(cbëKÚ¦¬–Ë4/Åv?kéüÇžb»“×j÷™Û–U³Ènuð‰÷FLõÏñ¼ÎÒnk®Þ}´ẏÞ5ìœ!Iû#üKû÷ܱßÌ¿yÃIQöæŽS®Ÿv©ï-{rÇ™—<\Êv<9ýè{Vÿ‰íd¢CƒS/*ÑÁ÷‡ÝäÜŒtnÖ?ôDóAræ—ksãK³¢Ü¦¯ÊŸ9‰÷‚—Hï$QfbѹS~žþØ(QXyÓ¢_6Äß+}Êxö§¡eëŒßPǵ¼Êow%+vmwñ¯›âï‘Æ^g¯½kMͱ÷ûÞ°·yÕ₩MåÖ¸÷á“N(c¿š<ý¾—w:å´ý´J^e¼ƒðsÈ%Ï•}豯–nõç¡÷à«‚y;w=\òð{”qÁŠmý:?d?‰½ÿHo,ϲOÜG~ƒý5z5½<Êx¿ïõUªÍ´ýÅOæŒëÙëòÕÝmwó–ŽŸðÆ”õöSÙù¹kZ{ɹf­{ñг­åsÍnº`ì™×gFɦ¾Pr{”}ÁO÷ß’aÜÆyNÎÝ8Jö'§ûÎ>mÆ} ›½%›Œ^øôÌñÖ;ô9â9Ñ¿üÆýÞnËQÆ5ü>÷‡}ÿWpèøsÏm1èô ¿óùÈÏÛo Ëx튥ïÙ^9~à½/øü[¼|hæFÙÕæµx½oi¿O~^½o'·]eÑaþò^ŽrË¿uBeö¶ðÔÚçG9Ÿ¿å’ûÊ-ýjtnÕ…¶+9 M{Äg~>ìFîÐMK׿ÄzÁ=Kí×õþÄkŽK„ ñ_è¥ß#gÀWŒ2‡>Û¡þó›lg?‘—2žC?-'ßm¯Y¹‡üœù¦Ž¸æÎZ±>§í™ûû‰g„[ügü¢õK¸Æú.fù—ß%ÎÎy°îì­Yk›m7Óñ¸ýo±ÖgÜZ¾æÇ–KûÎY÷‡ßr¼ s´ü€?$¿è‹?Gq€ìp”Õ¥Û­»·—Š2Ï?ç‹O®kû˜]aôõ×q~{Büb{ Γ]Žqÿ†êG1nþǾ"_Ú£DÙï¼7a9ççcoõ<ú¹ø¾¦Ÿ÷\÷ë¶ —©C-óË_rÅ–;ç fôyõÓú3ß)ÊîÓôÓ§ wûÞ2ÿ×1ÃïÎq<*ÜdÜ(mïü‡â ôиWøyQk½è÷ã¹úéþÿœÞùΫ$wW®{Qõçm/ð¿5Ž/‡ý1ðAà7ÿ€ï£>Úxß•øEð®¨Ï°ç 8óFÙç¹ âãPwaŸa8ïÙsªU·aüžƒº8ÏOˆ}­ž›¯÷t¾xX3Ïšôä¨s ØOïÙLןã½Ìº/x\ðè_a:uDêœÜs‡™Ó ¯™ß[s`W´gz<×Ò}+ªyïqºžïC™º{Ϩç«^Td_-Ïíùíºöùy¨xeæÓ©.G}‡¾ê_È%|抰‡=¤Ô…¨?!ïÜrÅs©.ï³’<‰§à¿§®G Þ…êlÿ¸O½àžàsÀû£^L‹½ÈÔqáÍPGµ/Î}@ðà¡òïÜü9xœ ÿ ýBÞØ Kß;ó™W¯X]fþ5½>Îé‰{O«Ó¸ªëº®‹o„ž!/Ø/öpð=ªkÇr––gó ¸OïgüûÞØ"÷Bž“~/Ü/ïeמGôD<¼x7û¬$7ܼGxGÔçÙ#ê9«âGp?ìgôœÙCöœSg?-û;Ù»è>/ú\ƒ=ÈØìÌ¢d¹Íß mD__Ì ï]{¸b»$9ƒ×h¾«xôsP÷·¢ÏðÙËÈ~EíG÷¾mê´Ü3õ`Þƒ¿‡‡o¾§yãÌÛVûÃϱ–çF¥¯q?žúÙ‰„χ_â=¨Û»/Dz­ï‹í‹ÎmIÏÓ^kðÛë¼&êÔì…·ˆŸÅŸÇ½Ø®ŠÏoå[íE†oòÅáÿ¢÷¼—çØKŸyNxÓÈ v¦0Ð?ó«ÅsÐ^ظODüxQØuöÃòÞàì÷޾ÁoBàÿ`gŒ_Ô߉<{°Kð;y_>þÿåþñðxnìz Ï=¶þÈ®²w;àýñ’_ï›è}À…-– ù/ôsæÏÌ“ /?Á{Ó þÀnÑ/‡þSðþ‡ÜHü|ækê¾ð—?Ï}¨ðÕOñ/ã÷•?¤¿<Ã~YâzøÎêðï³_xÉÁo¾Z´#Ö/ømìæóÙŸŽœŠ·WdÏ:zG7÷Ÿóa¾·Þ/ž×&¾|r伎ŸÀÞÀëçñËìçýú¸ÿ¼sW—?}¯œ~•ýÍà0p3s‹°àhüòÃþb÷çÊ€Sgx¬Úû#õ½˜*öì‘sô•yùè9|n÷¿{^ñãèvÿn žÁ>r¾|pTÌÅ~â?GäÜÎæ¼°gà俼è™ï:eÔ#ö·²ðnÁððûÜïŸ9gÃCõ|ü)úºðÇØUâ-â"äŒ÷v|†Þ¦ùeqœÔü×¶¹—yn¿å{ 9¢_|ƒÝà¿øQÏ?àóxoÎC{É‹È÷ M.b'¼—HüJú£ø}úRù~ü6|<úÀæ—JŸÁ øòÜ/ø|½á<è‹ò~-ñðˆãÀàW~;…<º_Eq {ÂÁCðÆý|iœïyïQqu‘~3ì z†Ÿà<…#c¼¡ù!à;á’"úι³G=gÐÏD¼†ŸÂÿÒî=ݺü£çHÁÕÄáÌ=pßbÐçK\À=ZO9Ù#ìñrƒzïŸä}ùiîæKRãvúóñãįܯ>·HüîtŒüx€óÀa'ð#ì]ðH—½Êuõór>ì‹'?€ý+<Ëïé¹ýœÄ¹àRpxÇöAv =CÎÈÏ`7áÏï¢7¡Ý÷`ç¸Wî;þÛýºwä’xEþ!¶‹²ƒÞK®|ñxÿn<$yÅþxîƒpσ½wü"Þ/þ^ÏYDO½'Fx|Þ%_Gþ‹9Ä‹÷´:zv—m¶?àföÄ|sÙgßzŠ|#'îK‘}Bÿà óžÄäѰ_Üî#W_ ¸ ?Àç37Ô}¹ú}ôÝûxÔ_MŸ1ßßñ¼oö3 ¯y/¥ä„y\ä±§î»d{hÁ«ªÏ«îì{äÞÕŸ%z½›ûÐÁ·=ÿÑó $Ÿô5{¯¸p÷ὪìsdŽl0ǘ¾eϯ êØ=òåÞcƼIæ8óW<—•¹ Â9ø{ú3É QwãûÑgÎÏû*´‡Iü»x+s(ÒöùᇸWì™æjØÎa/éÃó\TöM2™ùþš[Ãý{® òÌ\˜p.¸ì&ûjóý*_îÓÀŸao˜Ëâ¹Ä²?ž/Ë~õÙ{ž{™ãÀÜ;~‘þèÙ£¯›qÒ¿ö—ÁØ;pçÖJ^¼UþœÂ¾æ¤xžˆìöÖsèw¤¯”="ì=`ΩærÛ½GMrl;£{ó#ÙYïo“½Àîâ­O’Û Ù괜圽®²wî륿XïC¿²û[Ù_A~JòG\ì¹9ì'ÆîzJ®÷¢÷ì3g/8Est=¯(ØOn»ˆæý˜Ÿ®ù_œ›÷ŠðþÌá—¼·éÇe>œçí±‡=rú{Îߟ‹‘^ð>žc,¿ þõþì—òàä=6¾anþPó&ÁÍás¯`Wˆc=Ÿ5سÉ> ô5œç9ÔÌÕ‚õ9•ßB>ñ3žƒ"¹ð=K…ï­GÌ)ÐßÓóŽ‹™ûÃÜgæLJî¼ßWúçygúôû>þ“ §îYï!öxg€+ø^Γss?9óËuïª yŸ‚óeÄEª“ƒGÈWp/Þ“Äžö¯°×€º8Ÿ}‡zæIø<9é/ózwΑüóÑð;Ä®·°¯QÿîùúàY'8çdÞŽù:䛟ó>4ôVó°§ÆOznïý’Ü€?È“£_Ì%À>«(¶c²›Ì5¥îiû¯@yWêÞ—ØUÏ-’D/=Gßë¹ZòoàRË£ô¼Ç¼ òja\Lœƒen0çL<æ½cÂçà'òÁÈúŽÿ#Ï€Ÿö>AÉ­ç!Àë`^„êµè“ç|+ˆ˜Ã$üˆÿâ¼ÀYॕÁ¼oö}„ù üsÃùšÞ(y§žA¾Âuæ]êï™oÁ¼¹y“_½¯öƒxþ~Ý~IvÏóËdï=žý3ø Ù3޿ȼ,ÍÏ?1W˜=µä#ÁÔ!ÈâO8Wð‘ï½²zêMžc*|N|l| »ã<øGóT±ðbŒ«t®èµ÷ÊÎQ×C¾ŒÓdWÇ1çMvaÿ–ê×;¡_<P÷î«ô~vÙGÏç•ÿ"ˆÞxŽžùµè¯÷'³w@þŸ¹-̽!îr~GßOžÜçI>‰Ïc®4¿'½çy=OMù$ûW½'ùfâæ¿Ú¿é¾ðGä©È[y?·æßWrOè©ç9/RwaO ø˜zìŒçÖ2WQò†¾ñóì/Ïï+ùa»öCÖÄzBÝ^öžŸ—¸Ýû Äo·G>ƒ¼µ÷+êœÈ¯˜g »7»÷Ɔ¾×9‘ïm"Ÿ*yå¹±«ûûŒI¶8þ€yxð@‹à é8‘óG‡¸‘÷Ã×`·Od_±Þ—:'zß>(ø»G y÷8Ùò)Ø ÞÃø~H°_…{p:uæÛ*h=×½YÞÒqXŒCàӲמŒò%Ô'ÁÑÜ7ÏýðùäÈw{>;ûP•·Å?Ⱦ„ûØç@€þ~ž|-¼8üµú3,Ož‡.œà{Ðy‚§‰'àŸy^¿Þƒ¹àÞKÀþCì½Þ‡~zç#ñ÷ð›ÉãHÁWØ ÎÙ{«ˆÓÁ Ì1&¯¯{ :3gùàb}û»ŽÎr½ÜIÿ Þ“xÕó¿ÏÑè¹ÀÔÃ…Ë<Ï^y_úÀØóËÈê¿Ä:êØ,Ç5²7È7}Äž£ s ÷¬9ÿŒý Hš=^ÔÛ^„ùGŠ×Ð{òð*Ík“?Â;>PžÎóâe'øâ[?ç"ùDî½Xõò’Þÿ ÷æû¼×^ùYx ØIò¤ä­Ég‘¯q¼ÔåáÕã±ËàTòÌMÐóÙÇÅ÷ƒs°;ü—:çä}ÂÁ®êùÜï¿CoØkð;©ã¡çÄù|xý4¯[|aã8érŠÝq þE:¾÷9°'“ç'‡û]Á)Üyìþ—¸ünAฟFx›ÏCþ¨÷{¿¬ü«ßO¸û³§ZÍ{N¸9;Î2'þ"ñ{•dßÉ‹ñïÔ'ÑkòŸÜ“û“”Ÿæ~97ô¿`ùwøtª€—5çÉ|j仄ž`Ÿy¯p¯…÷¨©^ÞGâ'Þ‡| u)ø`î'”¾Ø.IÏÝï›–æŸÆ¼hxÐz䈺%vÌû1Ø"{À}…<{ì3òåùìcaÏûCÒzãöOÀS–%ÿÉù¸Ž(}Â^pÿÎWÀ«’>‚Ãþå]“?9û‚ZÝâxSïa=ûìuòóƒK¸pœùŠßé/æó±'è-~>ŠëyÔÑÁS²‹è3õ,ó¿áÉá·ÈïOþ~Ë—ü*rKœÇÜוØ/ÿ îp_›þìxFq§ù]òƒÞ'O89CNá?£·È'øûOþÆù]å»ð—ûþùôäå+'#np=NúÎ>C^Ƹ¹U®û‰åCŸç¼¶p÷HŸçLœÿ˜<v»DüŠØÞKŸá› ¿ü>?ÇüôËvHúJÉ|$òËô9È¿9…}–œÂC ÷°"çÞïÂ>P=ýª×ÇýΊ¨xO‰p_ØŸïÎvCÏOþ÷p>Oø üNEÞ¨gÂÿ%ïÍ}¡OðÐø?È{žûA577æié>.;0«ëÍùq„ð-õdì.Ï«yí©3+¿ùæèÇ}ŸÄÁÚOë<ü.Îõ½s„ýýð×T·wŠô;ÉßÛ_…ûÍ7Óß{hÐWÁ¹Ùª¿¾¡y0âé€Éc%n¹.„×k>Šž›zoÈ·CáÁÁÿ‚‡ä}°/Ô{Ø·ãþåUÙSo^»òð{´7ÁzNÞ•<þ×ûÀØó+»OÌ|ø¥úw÷“(þ²7ÌýkÒgÎÝüNñ2À­šÃëûÝß ùë·tšæç3?8؉ÝáÜá!ào9OžWùæ+ú\É·€“$§î»Á‘Çà¼ØÏ}ºOy¡»¤z³å^ònyaïšä…÷r”âeêJ]Ÿÿòäæ>GóN¤ÌWæûÃü2ö>6rh»&?å¾}®ïŸ½t²Ãá>.žßq;{º$ð?Ìg“½ä9É‹ºïBòÆ^Lx€àž{†~x©ü¾åKò†þR÷õ>oÅ=ážlx°Ü | ò€œ¯û|È£ ?úþ9O~>è¯À_ ØAòS¼þ]yJÛeä½óÞMx»‰¨V]˜Gî¼"v¹wŸTú<¢Ä¨Å÷×îx±ý ϯïñ¿»Î(¼Œvß“ä=ñ¾8úãôÜ|>õ3ü)rß”s5¯H¸ŽûñÜEø"à§tœo»@Žs}’àxÉq„ë[ʇjÏKêÛucÑ´»õ›|ó1Š,?z?âB÷3éœèçÄ~H½0¾ñ¡ëâyŸú~ô9 ¯Á¹‚o}~’ òÀð¬S߯êÞöÓìÑ•œh?”ÏÍ;ÉóšÏ);aÜ¥óD¾‰À'ðñ´%®é}yæ<:_޳‹Ä1äý‰ÏÀ_Ürh¼(9µÀ^ëü¼Wüª{2¿^öÚ|(éö¹ó>{åqÜ_'?HÜãýðúx׎·õ½Èí¾Þë^{漕>Wü7zÂïß G¹P÷†ÜPCnBž­ù‘ø#xâz^prÀùº_~{§Áaì'Ö¹!ß–Gð™¾Wûvâ~Aæ Hî˜;æ¼×•ú÷+ÿˆ½'þsžQõ8òÞ“oEχßÄ/ºŸ< H÷‰Â…_ƒ1>D¯/ÿ…Ïå8ZvüÂ÷qÌ­€7À½€ßÈÏÃs‘·çûÐ_ìòN^‚ø;nþ3u+å-ñKÈ“öÖÅö>­ŸqWvÔqp‚qy8½¿ãúîè3ƒ/ãŸíÄ«²^ËY®àééß-Uh§–Ö¯0žç½àEc—ÜÏ(½Až‰sˆç°ç¼¯ûÓ~°h?1ü^Ù÷Á*ÿ¼0½ÒÞÛCôùÇþ8*»Bþ¼Ÿ½çó¸G÷-ÈîÀ³pœ_îUœàyð|À÷àbø9{FÞÐôè'kÄs£ðOéócOåØýr’sóxñKÒwꪎëU×s¼¦Ÿ÷Þ_½_h×È«27Á}pŠcø/~¼C>Úq8~‚ä ùp_»â4÷è¼ùóxé×—¨ìuî0?…]€oNÞübû§x¸˜Ï!~æ¹Ü??VzG¿yÇýò ®Wê>ˆÑgó•Ç3$˜÷äù6Š;ø9ÏÙÐy€CÑsìu!æ¢bÿˆƒxì¸û’…?Ü?IVxÇüN}usâ(ìõ5pŸý¿ü;χ_Û÷Ðõ×ÏÎêÇ5²àpŸ›ô–zyfìu ç#©O³o^þѼn=÷Œ\¸ïŠ<’ü¶y%ðrôﮋÒG«º uâäßþüÏß —À7¤ßqõPé|Yç/%¿ä °‡æåéüèCµßŸ#ÏÂ_Ôí|žŠÃ9OÏÇÐó ®R?ÀËÎb'°Säÿˆ¹âò‚Ž™“À\#âMáyòâæÇÊŽ:Þ‘¿öæW)6_•9_ú=ôŒ<„ßGu"Ÿ§p6vž"Ï…ßÁna?œ÷U\ÂÏ€ÛC^šyz.Ï1aÎŽîþòÅܯë^Êë¢Ní>aú(t~ðÀQÄ;ÔûÁ)È7ñ0¼d×Ë•o’\±G×u,p#yH÷ê~ÉžÓWayFþ˜7C|ªûƹ¿YüâÏcì5þÕyŠ´Þ»„¾‘·/¹Oç‰<‡srÁ#ðб7à í3·À×ÐÿM?S?t^Š9w²ößàlÙï!‚ׯϣŸõàà}—ŸñÇZ߃÷ûïƒSù|â6ì¤ó$’ ì¬çHñëø#x;Î×Qï‘_q¹îÝ8Kõ|âìšëÂ[΋HNˆÿà™óÞ®êûy^ë3~€9jà;ô€ø˜>rñáù}úH‘p!yK~ÿ^â¿ýžäÑ…÷ÃïE[xÖâ½'swð“{·<ÜkÃGÇsfÀ;ðɘ?¦óbž-÷êº7s+d_ÁÑŽ÷dç8'ü7ù ÏÍÔû·€3ù<ÏñbΟäçÁ=ÈQ|$»çzúCþAçƒ]vÞ¾gò Ò[üªã#ä ýÕŸÉË"WÄmÜ·ó§ð’‚ù‰ŽSäo\/#O£{`¯‡_ Ñïyn x’¸M¿OØñ=~; s湩‡Ã†èyzð¥þ(ßK¾Òú#ûÂç#¿<ñòŸÞ˜ï™÷§¾¤çvüðœoç©ãÁs‘|ñ÷ž Ì×r1}Ä-ø5ô?¨S†s&ˆS<—€y$Ôcôyîs/ ïGºÈûÉϘ¿”Þçó·¨—«®ŒœÀ0ïEòá|>s/t~ä‡g¾w:£þxÞsΔ¿G.ŒôgãGø(ÑàQ_ëÏÃoÊÞ9>áü…WÂ<–ç (^á¹yÎý£ºÌjòûþ8¾T¼~vôá›_F>5àyn}âôÙ‘Ÿ£¯ž‰ì¤ã}ɉçürÿ»ìsXÏï’?âóוÝ'ŸâúƒüãBø$’Ï'cÎ+ñ|qÅÏî—I¿/ûVý}®#0§—ùGú=âòŽdí÷娇Ù?0Nù*×A°¿ØùgâaäɸFø>O×éáoÒßÔGáÿ¢?øCò,œ«yáä9àÕ“ŸQ~ˆ¹çä—°«È7õÛKé1yçÍÀäO„/<z¦ôÎ|€pÎF0¯Ûs6„Û‰çÑò¿ìuõ–óœŸü-yAøMÎõöý¹NKœ¤|vÊuòÒwçÑ{äœA=Jv^ s=¸'óÎÐwì¨äíü¢ÞÓ¼QcØ·IÜäó"S·e^¦ü´ã=xFº/ÏGÔû¸Ÿ‚¿ÇoK?éåü8ŸÂ`þïŸ?‹?0.Ýùuü>óÉ„ë=÷]r.À“¹øÄ'á{ /¶›Ò;ÏMÅ^Qÿ37½E>†sí]#o#»íùé𩘳Hþ–yu’ û9½~Ø8Xrf¼¥8<¹õ[þãÛ3w}â‚ q¿4ñú!»Àσ—á%x^-Ÿ«{ç>GóÁ„O]—Ö{37˜9X²‡äo\”=Eï¼ÇCum÷=<ðýŽ#™+ªþ0ì¿ëwº/îÕy-ågB~q¸ï"ܧD^Þ°çvK®À‡î““ÜxŽs˜k ï^AÐçæy˜ÒóÉ 3§šú¡âTìü:äƒ| ÿŽ]6¿ˆú*ü;æP‹§ê9¡ä3…‹Á{à+óÞäï=—ƒ>pÉ)|]òhœüÛ]æÑ1J ÷ÁÚ^ïÉ>ò^¾oæ 1·‘øNÏGÞJqDÜ÷»ò¼¿ûŒÁ;¼·äÇ<|äƒ:yæ8 ºßRïA?ˆúãÿz¤’‰Ä‰gÆþ}Ìy‘œXÒ¸ÀøÒõ¦t>?ÊìÔþ—Ç®Œç?ËßÐ_Â}šŸÂ(áÑCôõùüÚQâÀ»õf”qÎë?\Þ´Têàæ>·Nÿpø-Ê(›Ø¶:9+®Ã¥å/Ê,5~úÒ^W¿ 7ôÝîŸôÍ„/tëÜéüE”Ù{ØÂSkŸ_¤žŠ E‰ N½¨D×éSS}"JÖ«WoàëgE‰·ÎøvËïç9Î#î1ž‚¯•ŽËÌF®xþƒ•Nírw³Ïã¸B}(Yã˽³{Üë)v¹ÇÏJ?¢Œ.‹Ë=›ðþä‡óÀ.Pw:4£Aë…·Vˆû”‡ y{ÞcO(}ÎQV÷}MRs“qü¡üƒìóâäi¤·Qâê÷j?[·²ë òSQFùö+¯ùÎ~Þwæ®­mZ·-ã<qÿ®÷Žß¶ŸòMõzî‡ÈÚä¢UCĸ=-GQƳ? -[g”å,Y¶ñ5cÎì¼°ùô)Ÿ"ùµ\R—¢þ­>Ú(qÿè;ËYÅ|bòºô-Ø~ˆ'‡_PÃòç8’:ºúœÈç?Ð_,IÜ%;nþ·÷»0.»à<õµ`Ž*ógñÏÔÏà‡€·°ÿä™÷©Ù­íÉwÇ|®´¿ˆ2nùT»WﱩŽe<™êráèk‹Ô©*Á½EY[ª4[|TGç¥Ï–?ònÊÛÞïé¿QâÜ_{Oüè6pi”8îÖn[8¿ynµêmŠèOˆ²oÏ|¬þÛmï)>" |F”qÕS×¾9õ÷É!ü\Æï™o*€Üd&;åáç­_àcì3õõGŸƒÈ#ÊaŸÝw…½'oæþáõ“[¿çFÓ+¼2iY6?%æô/ÖïÿôðåsçÖ>ãç(cí3c+ä‹>ßcá]ÝWý=Tñí¦÷›ó§©~êï“ß䌟ƒþ(9¬ôÜ — ²¿Á®P¿Å>œ|Q£—÷6¿\†D_àûyžG0/‚ºúÂ< óè»’@_œ/”Ý’¿‰wþt_ÕÂâñ\}ök¤y¶QÖº¯8ëÑZ΋q~Üû¡Íl|oÒEæéƒŸ ð'÷@¿*y8ú5EY¯mküSÆhê‰QâñSÛÔå§¼öᙯY~B=øÓ¾¿wG™å›þÒó‡ÎGIž]¿ô|¦ô=Ù¾ð{ø;xÐà)Ý{”¬ñZγG~5ÊL½t±ñþ%ò:‡(ùf‰ev—‰ç¼¤ãû!òGÊSE™CŸíPÿùMè{”W±ò‰BðW”1±u%mS¶¯äk…ƒ£Œq‰§¯ú$ÆM²“æ(~Aï2?Óª:Ãð³ÆÆÊ'ù<õ}øôû–œ~ô=«Îÿþr”±sFÓöÆÆz‘¾/ûGùý(qôQ§ßþQ<˜üŠì9úßåžt?¶è#|ÇÅÊ¿ªe]Ñ+ùpA}ã.pŸ÷Ï)NÁ?!ßà*ñ¢ìµw­©9ö~öœG‰õÍ*-ɯe ½ëÖámGú=ÏY„£¬ãZÌmrÿ_røsÛm+÷õŒ÷uÈŸ¢ö‹Â¯è%vöÐÈíƒî^}ù°(+pr³û¾É›…ù Ûϯ†Œ¹æÊDŒ©¿é|±+Ù£J´}vÏàxþQº®e÷ïØoC鯣$y#åmÄ{ïï*ˆ2>í}o•htÜÇ$¼ë|:|7òUŠƒè“r]+íÁÃö³Ø áª(£ñí»·\çþ?py5âtç …‡ñÆãšî¹UÂUÆ- \´êûöQöæŽS®Ÿvi”l2záÓ3ÇÛÞGDY‡š¾}Ÿ%;¿z÷—¬‹óôÕI°»¼·ñb:ß%+vmwñ¯›¢Då»ê÷½¤o”ñ~ßë«T›éûËØ2qÓ˜ºÇyæ9KÎ%OQâçÞGv/3=ÊÌž7£qN³(sÙ–ûW›J>9Êö[§Ψ îWí½¼ûóZœ¿d>xTõÃwRCã=\²ï è?úP¤ŸÍùÏ´<€œo"ž!ÿ!¼e_Ñõ”bçµAÿ£¬ ûG·è`Üo?η>(¯>í(óÉ ·õP\Ÿ'û´·0·uÙ+ûíüe¶îzïQ›k¹ß”ó ŽòåÕÌ—U?Gœáú2ýº·ìjóZ¼Þ·´ý&s„íÿŸJ.âÏIçiˆ?—pŽÂ‹Ø7ÿ|rÜ+,lo\¬>?÷i€“°ëà˰̼Zý¿§x3ÊPéîÛnéóãåo°œ<ñʰƒñó§õÂ÷‡ßqÝ\ñö$cÅ-³wp¿y[ù¡(£õ[Ï)Ö1ìÿ3þ¢þ"ûeëú”äCöÁñ$ý’æ2?$èVžÈŸKÜC\ƒ]ÿ÷Ä^û¨ ߺ.½ÃQGs=Jx½“ÿ2ÏyâÃwjÎ ^²7°ÛìIäuˆ£Œy;¾;ékëöAŸ%Žø/Á}–ý»ãæÒkn ÏI~œïù+éxÓ{È£`Ç5O ÎWÀ•ß çg˜F<Æù+.â¼Øwš5ë_[¿ß;ßãÏQæC·”*ÞùÈøóØÞM¾~É Gv‚gç÷B.ñÿæ±×L¼÷qˆgC¾HxÕ8¾£âtû)λ¤<`”Ÿ»¦Å“UðSöÙ}š~úTánÿ\²ô±£ %ìçl/Òøƒ~,Þ3Êø×ª-½ŸzÂvQ|Î(9¹ø×»Ï]í<"õøƒä/<ÇBù4êîo£>©xŒïáüñ÷ÞÛ›ŽÇ|îªg€ï¢ìRu¿™yw¿8¯!^ˆ÷ (_K^“x/\鼃÷]«Æø[³1#N/RFo³*¾ÕoÉ_ï‰=$/¨¼½ãï-VÞ>¨ó)Â…ÄæhÞq>ò ¾PýÙöœº)x?‰dŽ‘ì®çD 7Ô=© äˆ¿‰GÇ‹Šs‰ßÍ#KÛoçëø<áJÿ=?oÿ/|œYovÝ‹^èx5ñêùKG·šb¼ÃsPw½ð ïÏ=R/g^qj¢ÜU­Nª5ÜþþÁ#·ªï9oƒ=µ=QÜç=»²;ð‰…ƒÉÇsÉS7‡O^IybüñžóŠGtNQòô7ú^Þéí~[þ ÿe6:ðAߣ?²G¯ü=äýÓ¸Øþ%»Ç_|Ù`›q?÷C}Ìùþt\g¼@] 9Ï>mÆ} ›½eòLžƒGÿ¤ì>yüŸügå—ÌëD¿™CM}¹ ŽÈnpYÛË÷¯¶ã¿Îg¤ëíŽ×ÑcíýpüA=,KyPp¼çÿ{ÎH:_e·½þe岟7/K~Vq¬óïæÐç >“ü¹ýd‘|vš¯%×ì»0#ç|Ÿø ½¢#b¹—^Ä~Hujɉ?N¼™Ý¥Tµã§l°¿ÕýÆþ*}žÎïdQŸWüIœ@Ý÷¯üöÞ~;!\í¹WŠ‹Áö³²äAÈ»€“È'éû×aþ´ç¾Ð§"½gЇe®ûø®™}:Æöòì7÷Ïžq™qžêýQæi;[œ¸Ïuì £¿¨¿¸Žý®ðp\gW*NòfŽ‘ò7ÆÿìÅAm/ÉÓB>…zF‹‡–ŸUù<âü(§Åí·VûöÒ(Ù0·Rõõb¹T^ÉubÕy©ïá×á]X¿¤wøâ÷})žQ}<žßÃ>mÉ 8…ï!¯¼{I…6C—û>áÕ0÷Ûyá;òð6ˆ÷ˆ™ßðY“b£:Õlmû`ÿ¯<v”ºprwåºUÞùôˆçÇžá/²þwÿ‰çÉ©®Ë9p.™ÇuÞ¾ç¹ñ®ORÏðœ'Õàƒ‚KÈ’ß"ïBýMs#ˆ7Æ|øµäÁ³ºt»u÷öRð׫~Ä¿Ûÿº[¿O½!¬OÓ€OÃ$N—Ÿp|D|Ô-Í'UÝÎö¼ä8YþŒ<$~–÷Õuòøiê‚ð3ðcäãà³à—ì§K6ßÖõÀÍñ¼ü¿÷Ÿ#?~?óИþïŸZñ y.ߣð/ù3âÇ’cä%¬;Ÿ&¾7¼ óM_J_]gp^^¼òäMÌ óês ßBzâ{t‹¹1ʯ;>nQëú\Pg°ý$?æ¾Uæ‹¿}Ô÷³h·jH·\q_ŠÎ_õI×/Èo çÆ=êã'¿£ø0ÞË%œ,{û?ú_Ä òq½•¹ÊK“o%n炟Ég—Rÿ•¼ñyÄQØú)Ý/­8Bòê{AÎÂùîÌ•“}Ƹ<9qñŸô-Î?Ñ@¾4wós‚³Í£hÑhê %·wó{æ=ÀO—ß”¼D9ßÍ©2ä`uÛ êÒÌŸP]–Ý7Êü[å;]ü›ÿžø[ù]î%5ò¨ï_êÖb…ymøÕÿc=H÷½8/¿Ã÷wßø®ø[ê/â‰ú>˜ÛAŸ ¼*âBŸ³äŸó×©ï ŽóT/%OÅ\wòeâÇ;nõ½ê½rÚ¿~Ú %¯rž|nÈ9mäÕ#R·GY;—n;~^Òõhô™<÷C‡¸Ås(T/ >þ¿»ó°oçj}üÏ<´›Lj7j°Õ.÷§Ú©ÐDQ4ìR¡AEm„&4K“FI¡ ’±Ì3Ç1ÛPįýýœ¯ó:\÷ÑñóÏsxžûþ|®ë=¬u®s­u.õ-]÷ä åÕùe߃c]øûáü'Þ;Ô›‡òÁác¿‡÷˜Ö üTú“èv÷«su®c·kßó<ø0~ ~tÈ‹&×ÄoÕ^w¾Mê¹ðÍ;é¼w]oñˆ{à¹Äaú>_Oqž~ˆÿå5?•—I~¯8(öJ¾nñ /ùÌKÿðÁ^æ}Ý~â?{Á“…[¿÷¼_÷*¼Sã×ê&/¡žKܜҿ—Ϥß½ÌÖ…‡jžG½rù ô³ê_o}šo~œ=*ŽM^þÜï÷Á[W}uýÊüß<þò}7yä0ÇŽ~‹ùÁt;òyÎ3¼†Ï¡ –Ϩ_?Lã‚âùôM?È¿À)üpô|ÿ´ÿF~-vdÑMŸ?åU_Ú¨y&ùÀöG¥Ÿ?‡wñ<å‡ä åÍIQ—{—¼Rë⊂zN| úöIŸ"»[¿Ç³Áíò¯ž{ÑâWvÑÃ\{HGI~U}½xW){†Ïk]MxuüâÓÆ…9Gî}æ1Êã5¿ªƒÌ¾Ôo—¤NÄçŠOàiö5¼âX/e¸×9ÎOçÀ†·/þÄOÊ×Öž'ï4š‹×¾ÚÔ ï§þY\4­?é{ÙÇÖáÒIXqœãžª#‡ç9“÷›wÆNà3FñÒpoÞ¶ë¯wÜõ¡ÃyÍýaדç,o9êOêÔà{so“µþÌçÀ­Wu®s?Úï«?8v±ºéã…ã ö#})¹×µGôþf—ÓŸóž•›oÓÿÔ|}ìaú'‹w<ñ‰W¾êšæu2¿yÈCǨ¬°_¹Çž{œ_ä÷:?,8-ýXå ñvü—¼¡}ßtRÏ‘{=øÏàýM­SJüVÏÅ>ÅîµÞ"ºl‹›útß³ði§^×–sË+°Ëümú·ZÿÙþ¤Äkòx–à£OJ_:ý¦æõS¾hãosÄ¿:ÄaêÎRï–:0¸¿÷–_ÅÓè¨NUê·èHá£ä»Sqxû ƒ/[o®þžÎ>«ûp/š7I~Vœ´dÄ+ÃûðêGïø¡ó>zgïgu òsø‡æññäù¾ÚƒÔM¨ó¬n3ÝÌôsáyÅs©+ð^øSúùÍ÷$o_©ÔÔo¦þŒPùƒð*â¥æ[Oéëh½ºþDq˜ÏQOŸxË9õ\ø¬®¿ —OëÊø‡òÆð&¼ÅoñOí[ùsþ_«Ï¬þ6}x&÷®øF˜~ŠÄ!­ŸIŸz÷~R7”üIëž’?ÎAõ.7ªCI]/®O-y òpû¨Þ{à•c×Ô$¿<ôSæÞ7?å~å9õ\ùìUðÜ}wêß×ßÇï.zë²-|~¡ž7ë\½…i<9äaò¾íÓK¿Kë;Ÿˋ\ü‘v»Ñ×:·¤vØ}€Y´ÖƒÏ9sÍÓ¿–¸'©ëQ]Ägê¹åGõÍôyÓ‡#ïwÃs6¿7?Þ{èK©=9ò€®™{|ý^yúäÿêgäõét¦oŒ_f«¿Ç¾Äÿv?§qjësù\y=ùÜêOÓà ~l~ø”̳øÅ{×7¿ÛxšAúð„ú(ü{ô@‡<;}­“¼A~O=+|iùüœÇE{â›ÿþ¾~þâ5¿tß5^¿h²Âç~ù…—þ ùûš¸t²Âýžöé·Ýÿ)Åmî§øoñ! öZó?xìàs÷pÉ ÚþÀŸ>}øýàÞÅ»-}ÃvKnŸ,³é¡«|ãé5¿¶hfïÞø»…“%o½ãq·,ÒdñúoÏòJùX÷£ï·ÿ›­ú±úþKÙ?ùÒ<÷Ò'vú9[¿k²d•Ÿ=çø§}þÐyâEëöþ/ýÊß>·ô)»ù÷òKK~»â;Þ¿ÏÝžO?&’îß’­nvòG>иÝ]á…WýÇѧü[ëaÔ5.Ü‹ý´ú!½WîÑ kžò›õŸüçÆûø>8ªy›àdy ¿èà]?qƃ¾XÞaÉæsÖyëa»NVüíƒÖ¸â?ßÕçuO­[??u`Öwñ’7½ã{ó¶*Ÿaß—Üñ¢õvºæg“Eë¯ó™“öºe²xŸ×œô“¿t²è]œù×ùž,ùáýþþCŸ7ä“ÄÑ9‡+¬ºÂ}á'ºòpaòHåÇù§Ÿvöé§ÿt‹Éâå_ô¨ïíÿ4®Yxé3|嘻&+lvÕWW½á—õ×KÎÐ/^xÑüÖoðÏx_ÿß>[õ+‰¯¢³Ó¼Ã’Ó~¼×ËœÈ7Õž¦z²xóµ^¼ôô£ËÛ;¿ÎýYáÏW?þ­·¬:YqæOÿsìKðvîKìád…mî÷‰¾ÿ_­C€Òï6Ëà=–ƯµÞ)çoÅ5¯yó«7|Gù¥ÅGüîü×^÷ðò€ð¾}€[¬‹¸®üD~ŽÝ\ô¢-æ=é3wOVÈïy®Å·ßúþ³¶Z¯÷ÀÿÈoá_–ê߈®•{‚¥{µ$q¾ÓϱO‹®~Ðé§_øÌž³ÖŸ'^ü¤uëϯ¿õ{½çyoëØº€äUûûé³ÕñwàgÜ þع¨Ý›³ÖþóÉdéÌÝs¾Ï~åEœuíîOïÍò–|íó·—ðœî}ÏoìUø‹>÷Ê?œ³×šo¹l²ä+¿8ü{úmïß§“³â‡.YýïU«žcÉn»ó×ßž´~®qÊä<üé,Ýñ/ïÚñ­»U‡@„Wï—¾­ò_Î9þ×s5–û»ÂŽ7}óãßýçùžô¾ìÓâ=ŸöÈ­NÝ}²ðôW¿öÒ•7ðyò¬~ŽgW¬«øÐzõ‹¸ÞÙ«žöOrÏÅëüë÷"ûÖ|Êôý‡ýr.¦õXß‘ºþæçã/å!ùwçxÑWNû¯ùQ»°büHûHrÏÜKûÏÎóõá/—¦Âúð«ÎwêÀzž—œpå Ïÿù®“¥{ÿÛ>kÝëÉ’Åw¬²Ëù¿¾ï·ÛòË ¿S{Ð{ž ŽZºäE¿ÿÍöWõXŸ…;ýbƒÛ×|ë?ø÷ÝýYºÙòû¿ÏLï©8ã>›Ý¶ÊZO~I?—]°#øç¤Úç°ö«v9ö«:Z±çÅC©û\ºç*;=饯í=-n îv_¯²ç‹¾t\ý „'f—üù®½.>y»âµæ“7ÂÓòsì¶÷¶?‹÷Ûxóûmôœú±7yôÌ9÷ß³÷ÐsE§¥¼ð’¯ÞdãÐüIpÊdñÆ»|÷·îÐ÷]´ùd›¯»{²ô~O8æñï;¤¼×’õçßÿi_ûédѺ‡ÿußç=qrŸ5oÿÒ¡z[ûÄåÅø3ûâç“·î9KV8ýA|â°?¶¯cé·N;ì×[?P\™ûhÂãÖÞùùâøìcùÞÔMò›ì€>x箸:¼ï çÝvû{îûÚwøÛþðð—óGgDüÄO¹÷ÎCÏgö…sïá¯îkð“|¼ÏŽ´ß*8›¬_å‰ù“®—{‡åsK~ ú­ì_žÓçyþ†Ý*nÎùµ®½?SüÝx©uRò/ôÜR‡aýsçqñŸ÷?l»ƒönÝ¢s6+ŽÁ˿…pØ’Ÿsż÷~|²x«o<æG70Yü轞xŸG<¢õEp?îZçÄ+o={Ê?¬”óÖ8$ŸO€½S¯gýF}¥Å7üøâwízõ1OXPÜn=ÅAƒoì·{µâ*×>ï£GÿW÷s…ßþšÏüÇêõOý¹Ø9÷Š^ƒþ¤Åçýýe‡¾çsÅ =ÿpXøÉÆ·Y÷NtïÙ×úùðÖM<Ûú¹<¿óÀÎÀ÷‹÷Þôœ7¿øÒÁÏŠS¹õ;ìQΙ÷hœ˜ýãZëײ—Öþlõêð^ÁöÕù´þú¸}ë÷[ø¡ŠcáÆÆáYGÏ»ôà³®øÎ3ßP Ö^þ€¯¿ûïòyõ`Åü œu¶É«þ=q?ûÀ—öþ„'à@þï!^À;u=cßùåÔï5®¯ŸZA^-uÚêÔE,yçùw¬¾Ò+&K·Þè¿ÿä«úyðzëÐà˼/|Vü߃—ð4Åûñëêÿ|>kßÛºÇÅ7žÿÈÓgÖðZx vÉþÁ!tä?|Ï '®ý‰=>süd=íKã×|Ž8Ä{¹'ÅmêÃkÂK¾uãYïZúà¿ þàïÜçÞµôû¯ûýÃ÷ÆÿÔ~ã£Ôyâ Ø=¼JüTï&ŒŽ%ýNç³ùõÜo¼?{%ά¿´_ñÇxZ÷½¸/7í)Þ,;ãܸ7~~É“¾y×K·› þ.ÜëÖýÿøÝOÈŸÂðÖ “…û¾ùís’û,^Xaë·Ÿ´è£37\ú€7¼ã]g~·ÿa×>dWÏœsÒ¹9wÿÏüáC¯ùÑ×ýºóŒÒÏÖ>zÞ—íòÂÖ}æ…3çìùÙm^±þZ­ã?àÉ«Ÿ²óüeêîû§¹kç¿çö¯¯ríf.>bß÷^é»ýÜ«.ÿÁþß[<¿ó6éF½p—‹¾ºl¿þ\æ"·îÔso|ÎÌ‘·Í\¾ßó7ßùïÛ5ï¦o;uëý}y×kvùÄ{³Ú‚™ >ð ÛwíÌq—¯´Ö[Žºµ¿÷ÕkNXvîºË;‡yùw¶ßtµ;ož9ó°—ŸöðÿûÌ•¿yÝ®oÙd“ιxÁê7ž°ß¦3Ë>ñè/o|έ3Ë'¯½uÎÎÏ™¹bùOxõIwÉçõ9.É:ë_¤c¬/Z½éÙ»lxÁz«Ý5sô%7\ñÂ]—u©uþÓQ—~~ו6œùäÿÉñ´íÌE»¯|Ø=xáÌe“‡|ä” u]¯xýyÌÿ¾uÎè¿ê­üeÎ%~õ=—Í|÷±{_¶éKnn½pö¯?á‚cV_öòÍ;ŸìÌ»öº{gþt梟ÿîì‡}éÀ®ë5ßúÀ¶÷ÿ¯‹šG÷{—ÿzÕGœ¼ïZS|Ýó^:çÔ#ÞÑÏ?s¯ë_¹ß÷Ÿ9súþà!O^a抯]wå‚UÜs4Ì+Ë:þçjËÏ<ÿ¶ê™êCòó¾ÏÿgÁ¬u8j7?ó˜G.h½ÿq»>éé›Ý6|Α§­ºþÇ^tŸÎQõ÷Ñ¡S6ës Ò3¹ò[ÏþÉs·ß­ŸcŸéÀèÿÏçvü¼ó²ìÈw®ðþl:sÙò›Nùõ¯mÝùÕËzÚ£fÎîsÐÓ<û˜Ÿ¼Â•kÎ\6wùý¯:ò 3×?û¶O¿âœCgíó‰[ž<÷#=¼ßç¼gýú÷œúËù?»óÈ®×é»üqû^ûƒ~ÎÕw?÷ Ÿºß£fŽX°ð[?ô}3ß~È_ÖÞáàÎÚ—œßþžù]©Ûëßïþ4Ã)9âÚÿ9y—½næ·ýþÊýV¾ŽèÏýåÙ{ìþÃùúÄ—]ýµƒ‡{5íg¨_õ{>kóGìýòƒ«óh.ïøóù…å—o¾ú_üë™K¿gŸeGü½Ÿý~oxÔf7Ÿ:³üØß²Ñ³×ùWûÖ¿?ÿiž½å~Ÿë=;ãSxÝÚËvœùÓ³—þb[v«_‰½êï9—öý¬[~¿ã6Gl9üûGžºõVËß ¿ þ*÷×ýþÿ;g'm·Ïv§ÌìÒ¿·oþ>ržÆë5þ3ö_]M?þpù·ØSþ™½«?÷¹æ<ûsQÙoÿ‡dŠ;ü{˜ºÌ™kŽYe£W>¨Ï5Þ¿¬Gÿßï³WðÁ%'žóèãÿDï'»æ=S_Tû]û“}4ﵸ.ŸËŸÁMmt뿺©÷¹}°Ç¬ò‡Ï®zâñŽߣ{_§±vÞºßt¿g#ûê¼ùþ?}ëoWíûË ‡Ÿ›Ú«þ¿sŸóÝzÜØÿþÜiÛÞúñÝï|ÏÌéýý{_öŠ›Ùãáß×Xö—ÿ~ÑÍÅÍâ…Ÿ°ÚÂß}ò’öÙóßü‘:+vÍya7b—†xàÛý•o?¼u¯ÿ®~:~'¿7ë߯Yeí/\sVŸ;ý/톛/ùÛ[xænÃz/õÿsŽ\•~8÷²»_ºï-žR»Ãÿrî‡?sÕoéŸ'=àÙo^ï[õï5;}ÞâO½õ‘Ç_3àÝ{?ß,ûò—c7z«_õŸÕIÅ?ÃúæóáÙSv›sæg_| 3{}§÷høý)þìxp*\çÞå=g}ž8É<vÅùâçã/û=ű Öñ×í}óÞú2~mˆ£Ó:^ßcþüÙ3~Ç¥µûîÑa¬¿ì™¾¶ŸïçGñSãNÿ:œ“œƒÃ×øÉžïüÁ_ùÍÚ™Ä1ÿÒ_ØýôÎÛàOüÈGÖ­ŸcO®Y{Û%G?íRv°ŸsìË6^õö#ŸK_¾q»}g'Å%~ãçö8íß®½ð÷ðΟv?ëu7¿o2k=Ï ÷mêO†{’xåäl°Þ±ÿž‹çw=—óíßgá`ÏwÍsv\tñ†?›…Wà6ñ|ç|zŽè54>ò^™ë×ÏûùÿãgÕ:·Á«Ï|+îc÷|.;ÎþŒqÅè< ç*û×ø6¼‡ó:>—=¿üoÖ!ñÅ̲»÷Û‹o=væ¬O.ßéMw\Øû»5à°èHoôïÏ»sùÎ_ú§¿üýãn?âO[ó_âj|ÇØßù¢³×¿èà•?wgûÀ­þ¾pîÝ#ñ;”9ËÝþf|~ãWÄu}.z™ìuìyÿ=|ÇpÞ£À>ý‹{ÝŸÏRÛ{¿‰O‰_ëïÑ ò=öuÇ—·JœÔøÈ¿Ã{ê éߺWüä‰s~rÆ7Ù®¿—ŸðoâÞžÇànþ QŸ{û¯pOýõøç¼×õs~¶ùN?ÝnNt~Ù[vÅy‡ùÜï>¿stå¥O>âæw=là#b‡ðñÃÕ±¸ö¨¿?ú¯~B÷#|âìxjz_fþÇ}8cæÐõ7¹q¯öŒøxcÖ}Óg=ÂKú ûÿß|ð 7·Ëßgù+ŸŸOÌN»‡‰kfŽûþ{¾e¥›fŽÙmåçlò’——ƒñ'Å Ç¿ç„Þü½òšÁ±³žc_ž¼Ö¾¹ó´{zÎÒÇ ÿ•7´Ýgñ•ø<8—îŒ9c>Â÷ŽðݬsOáyù/ñìUsžõëw.>»ß/ζìsxtýû½§Þ8¶ÏõWáwì»u·ÿü'žÒ÷ô^%.Œù¯¿Ûÿ_äÞ~=q›ûÆNºûßÖ¹aÎÏËC‹cÍÉÃ'ð“ÖÞ<ý”{ö?uƒCgÙ3ñ›ïµžÇ/ýðA/ùÊÕÙ2¿P¿ ])úuúÚožü°¹¾t¤õ[™/ˆgš5ç,óØäçÿü¯ìsÃ%¿æ$ÒYÒÇÝwuôô1éè7«þDæZÓí2_ƒÖ·K˜.¥>Òö›¤¿.}l×­®óG’WõÁÐ3jÿ¯~ãi?Uuõ¿é¥‡¦/Ð<ß±>"½býóòYúáõ=ꫳŸÕiÏ÷›³P]Øèê÷­î]ôxWô=n^åÅ÷½âóøÒ÷M÷^Ö‡ Ðgcÿ;¿1ó¨Ý›ÔÙ s¸¢ci.’ùÌéÇ­NHçÂæ¹ÌŸïœÒ¼'ЛÏ<üù¿¾ÿë{~ô'²KÖ1z¢í;ÍãôߢWhÝžê«è[Í\ŠêĤ߾zÉÑië|‚Ôù¸½—Y'çŸ_˜ÕÏ»ÖùEô Ò‡Ç?ò—ì­ùÇtï«Wšþù›wÝÿ×?ü÷ÎÙæfGÑ::æÒ›ßùY'xàæwM6ûòÜË:GN?3ÿÛ¾èÜ?siܯÎÏç²#æ‚Òk5'„u¯è-˜·Ò9±ôÚãWé¸?ì“~[õOôßèÖ¸7Õ÷‹¾;ê¹­£õÒï7˜+FgB¹x¼ó-Ì…NxÎGã%þ…~2?ªîÅ>X_ç‚ß·uŽƒy¥™»¢ŸšN>ŽoÎ[ŸÇ¼êKÓÉH_¹~ûΊÎ|ä~ÒÁ½iƒßýöÉ?ùCí”x½óªóþðYêxŠ‹Ìƒø'¸Ç|…ÚÇØýèLó.òût^Ü_÷ÛúÒŦ“@½8$ëL·U\áÞ³+ÕµÏ+<}1ë͈cÌ»é|ÕèŒvÎZêóÍ]`<Ýý ©«½b7:‹î)s<Í?ˆÎSu3è¢g¾ƒ}7çËyï|ŸôQÓÍî<0s£/âÁuü$ÿ­Oœ>7üOÙ<ú±ž{é\§¼83ºwoÍ.d®,|â9Äçôâ;'$úƒ‘÷`¿é¾¨Ç¢ËÄÐ_»Ù™Äƒgp;á¼»§é‡š5‡—ÞÅ^ÑÛ3Ÿ úÛ™#Ùû{Bïµú;ô82G†®º ºaé»®^‰:¼â­Ìp¾;74qœƒ€w;çÜ9˜öE6>£›/.æ¯ÝïÆ©t‚Ì þW¸Ÿæãu{.ƒ#ÍUèü³ôc²¿ÅCÑ‘3ô+NûÊg˜×“sY½²à­Î]îóOÙW¸oâ>šo]Ýzù=vn£{ÞýÊ÷³+‡‘8“®0å9膸w¿2šsnN–ø‡>tç©Oq[yºÑê£ÿö®íïž9ü¦ÎEà¿Ýü<Óý >à?ù§ÎËÝÅпÏܵꤪöÃ}¶®Î‘ø˜?·^õ_ædÎJñqêù龉W;O<Ÿß9À‰—««|D/…]ïèèÌx>óF«=Kv±ºö™ße> Ýurt›ôU{~sh¬3?O°óZÌÉçÁ•x+q£÷foé):¿î?Nç¡@ï*ùˆažpì^ô·º¯õ3Ñ!7×+û[~Ÿ=wÕkÝtÒ>çn±|•Á¾å¹éµÐQƣ՟ùðtçU™–ù\ârö‘ݤÓVÝÕèêWP·Œoôs¾§q}æÁÁ›t«³|9ÎÝ?ë‰oä‡ÄÁ‰÷ÔÑ:·æ5™_•¹7mþŠ98tHc¯àvÈü ë>µ8»s^£÷æç«#<ÖÁIØù~ѯ¡s—>‡>Ÿ~ qou£Oš¾’ò)øéòÑ{ægè£ÂYð¹úâÎå¦3J§*zÂæL9Ÿp†|ZùÈœûâŽØø_¿‰~;üsÞ«Ói.Mü9:ü>ý6/ЇLŸTùb÷‹ß¬?Á׌î±óX¿˜}Œ^{ã!çY<Àï‹«Ä-7ìwÊ&ozÎ#ª‹bþ,ÒγuÎÜO¼ùô=·²cõðPø9ñ»X?›ù»Åű»ôéá(zHcŸÇ•‡É<]÷<ö^vnztxÅïx¦ô{Ö.:õWá¼?=îêœÉ‹˜‡jþWÏWö‘ßvî"ݱèŒã¹äIä½Å5‰ç‡üHtØÍ9‘©Þ&ý®ðt±Í¥á_ð2ì…úç Sž¯þñ¡ú8®pË$Ž4'B^}‡‹§ÅA¹wt×ùY<¨yâ^8ؼÂê(&Ž£—ËÞÒ«³.p/:¸L_þ¯ó(á¹¼wçSÒõ ÏÒ9™±ox'öƒÀϰ‹ìù€—;F¿^2¯Åÿ»—òg£¹KÓñ¦ÑŸ¹ùk{ä}žT©}ÒxxzñÃýÎ/^´žÙg8"÷­}Ž=åQ{¿Í¡,ÿœãüËKáŠÏÅáÁ›ôÌ;wCŸ\æˆG—µç-8gÐ3Š^eíEöÕ=¡ï)ŸÊžÒë»éO¿qñ¦ß.OÎ_ˆïӿݸ¿ó®‚ƒÄÖ®¨®^æÙGŸ/.Åóoö܉ÃÅúñòÈîÏq¯è‹ Ô‘²gÅgÉCÈ;âäéð^ð¿ù%Í¿†?àÿ¯ßõ½ß9ð¸uñõ—£}Ðê”'¯%…»äMñQtUáHñ›þæu³ÿôÿðèìž¹²éSòØ™OÂ.›¿íüçû‹OÝ{s}Íó“/—ØïÎñ ïXí)¿U\Ô|¼|öt?ЇÊ%—§kþ<÷SÞÃûÂéì>Îzô!›G…3Æy~ºü½y5±[æîÁ£9o»¢³9äm£;ܹ(ú'Í¿Š}ï½K¾?fŽ¢¼³u0g©uÉóòq7ý?|´yã%ºHpSç OûÂk—á‡æ'—ÑQ…£à½Îsdwâ‡Ì‘‡5nμ sÀ2¯§ç¶ø8ú²üLý]ú)Ící<£èãYÙñ¿{‚§Uк˜)(n‘ßo¾0¼KçYçü°ÿÕQÇSE/®1_NÜK!zcpø ÷›ü¾úZq5ÞC~/u“zLóW3Ìùêmó€ƒkzϧàØczÉpMëAÔ_ß”OI¾³óuãÊ«ÿ‹ÿðêÒÏP}Y|§óÒ'ç¤÷Iþ&÷¢ë ¿/NhÜž ·˜—è¹èòˆWàvüBórÁmâÚúyóVò\ò êåØ­àž ü)¾¾éÜbñéTŸyà¹ã?Ó7ÔMe^®xëóMíaýˆçÒ‡ÑyÈâöÄI­ÛK]\„Ÿ‚¬¿«ÿLÝNy›ð x»žÏà÷_ü‡º/î)]fqPçQÆ¿ñ'ü(¾Â¼y9øš¾ }wq[t*†º°ðVé3è\;:‘òjê õK‰ôqÂ=Σ:z‘Í#‡7“SÏ ?Š3ð.úäOØUúî³|DçÆÅ>ñÞCÿJëx¦xfˆ»ás!ù‡)¾ô2âGÍ)­¾}öKÜÏ¿òûÍ—ªï¿ÃÏvÎOî¿zø’½…£äÅ™êñ”tÅ¢/X~ ÿ$Ÿ€/çús~ù|§ùSòì_”¼û,Ž£Ûî~ãGb_;O´89õTâ q9>C~ŽÆ+ºñÍâµÍÈêÖ?4û`ýð"ãxßzà ö»~Ö¼Ô%׎çJ»§ö›nž П .hcê‹37 ~æko’çPˆÃ7éÃPG¨^ÿ2wH|©Î.õm³æD°|kç·MùºÆ;ô Zw{kÞ¿·ßü–|º<œ|\ݸR¾;v;yŽæ}ŸEg·z¨æ"É×$dßùÕΉ̾ãÇGó‡y‚™s`~Mæ³×˜wÔzëé=îIÎ%œÔ¼wð }’Î׋=“O7Ýû8§ì¹û×¼Wø#qIñ^öUÜÌÉg°sð<ü¡~Õs˜#ÜÏNh]QöǼi~X,;&_¿¹×øƒòþ™‡¯sþá8øÁ9mÿDüIó0á/:o=ç/q\óNøfø/]»f.yêPË7„·€W¼§ý×gƒ'j¾(qúxîÁÿåœ6O3ªCÎ~ŽÄ¹Ù—!Ïèyí[ìVçÔÆïÔÏG–—ÎT} ê¨Ëo'ošº¦A>óWÔ/D³q4|Ý:žØG~Î}ăªÇisÎsê>ZŸ¢¸Àó6‘û¤ÌûÅo·¥u‹á¹¼üoíOÏIì­y>¯›>°!O‹g /C¯ÅæZçŸúayyMq =ö¹üùÔoÓ—¬•Wi~?ÏCGÜýJiçŠà™òžÁgpœËï²?á)ZO›ø°ù5ø×ûª—ÆoÔï4o•z|vž¾ÞN½§¸Ž]±~ê­Ìy©]Jßgy{sxÃó¤¹sák:šê <€ýÁ‹š—ÙýcSëOyÞÆ#êÄ×î—>Ä|OëÂ3ǰs¸sßøk¼˜|oûâZO~^^žuNÔý/04ûod=jw[g¾ñ‘uPÇÄ®ñëÁ¡Ã\ðiýô¬úìÖq›NßD¸vB>ËœüÝùÚñçk>X½ä´Ngè/˜Æ­£o?EøHýFã¾ÑäS»òœÕïŽ_ÀËÀËì²¼œz«ôC—¿£Ç^½ÔÄYêÊùq÷ >¥S*ç³Ãò¼Õ‡M= Þ¬ó%ƒ§ùÃöㇶÞ)þTþ’†Ã[‡Ÿ¼Zû‚àºÌÏeÏÅ1Ωõ+OÜÞ¾›ðdêÏñüHtÐZ·ªžQ^œ^œýNŸsóúïäyä3øKv`Tç×ýè¼ÑøsÕè©{Ö÷-þ6ÔºÊwËßðGîOûÍëˆöóüüÈžá»Û¿‘~i¸EÝýts Ùm<£: øµ¼,~&8IžAÜ‘>rº¾õ òÌòYp¶õhÝGò p´ø /Ê/‡ÆïŠ×k÷“ï¨.pæ–Àí+Ì>_ý†ÃwÙåÐ-{þð7ü3»þµu8ö7xªuÂΟs…ßóÜc>Iþ¦|Xî‹x §NÞÓ3Ñ%ÞíseÏÏEw_½uïIòÈ{Ø>ôÄïâ¾è«ó/Åx yxë gÒgŸðå™ô¿Oíjí¼xbd‡{kóóæ êãk}ب®¼ç.¸ÏœnvS?’{ _N¾HÝšõj¾S=Œ:õôƒˆ‹éÁ9›>çÙyÒr¾ÄCìUë”å1R ÞE|6®7Õw"ÿ•xº:êÞßê¼¶¾<ó1ñ1©w©¿ Ï>ÌÙÉܹúYõìê»s® }dêuĽâ¸&øª}Dåab'Ûç>]ÞWÞ7ö·þ}ªË^;Úy¿±GþWÿ¨ŽñÞõY­Çƒ+ÄÅC©WíðüþH×€^{÷¿ý‹±£xgøZ=Ô_ÖÜägºcÀË·Â[–Ÿ¿w>·÷š>HãVy1q¥¹¯þÝs©§TïF—þÇ·.<}‚á—ˆL½PpRãÿÞÿäg­wûkÂ#ÊkÛ¸¢snƒÙ1ëÿÐ~kõ_å˳êÜÊû‡'È}úŸ‚¿Ô÷ȇÐc,þÒ?¼Ô~¹äÿjâwØþ¥~/~¹|^ê2äÕ[÷~éo ®îmyÏÜ£â¦Ä;ú­ûs‰ÇúÃÄAâ^¼tîkãšæùÒ¯Ù9{™‹åœªg¥[ƒß“ïgDøö§}Ô©ûi¿Oð§ýºÁMü)œ×þàÔ;Å4Ðü »g裗ßV¯Îߊ/ÄÕúyZ?ï:_ý&í;ƒß3_cˆWå¦ù‡¡Ÿ?<‡upÎÇùGv¿ueéCÄõ?:v¿çDŸ…yã9â~¶qEüš8Áû˜¤ÎC}øÐ¾ãð(‰3znøý胇ë/hÝ_ú•õ9D¾ûÛ¼@ìûÖRÏÐ8>} òëæ·eþÇÐ'‘þ:Wp–:“öË¿ºìµ÷‚ŸÊ_&ϧ?Â|}2ü§gÄ6_~ÈÎIÏûá«è2°—ì5?,ÏêóåsÅ#åÿÙ³Ôaà-è"¨³•W±ïÕ7 žuï˧¿8þdÀíÁ­³ŠÞMý[øùzqŒú~8¸´|ÿ[}‚ôuËÏɨo5ïͼ©ÄS=Ÿì…xÊù°x:õ’Õ'Ð?Þ||x2vÊ>ÀøSºücãñôû˜'Özaú5ù÷æçí'¼˜s@G2ç¦þNÇÃoì ¿æÜ–Ÿ>ÐoT^0ç Ï[Öì7¿Õ|Û´îZ>¢ü¾>0s©äõÄ;ÎaúÆZ¯Ò[惵¯—ÝÂ#‰·Øý®cü»þ¢sÄ:§-sóÔTç/ùÉè —“ïi\‘xDþ®u±©×£/®O |"¼©ßCœmdÞ?s ‡~ŠôaÁ­Œ?Â_´‡ŽEðAõ\‚3ùÙæ7b7̯î¼xºCêzÂ뉟ÔÂe™3Ûü¹þÈê¤/•þžø0:'­‹`_éÛ¥¿¬<$û*ÎNÞ°uLú¦ŠÛ§õ —Ú:°œ¯öáçŠÃ}¯¼cûh‚#ëwä£rocÇÛw=«^G]Ž~çôSÈëá9ÙÙØ«æoÕݧnsˆ£rŸÚ7–{*NpÿÛ&ûOßë†ßÞÿY;ög7ÍÏÔ€/È»âQçKß“õf÷«·˜óÓ¼ÚÔ_Õž¨/ÀËÃÁðPu@òÞ~.xe¨£K¾´¼…º¯ä=ZŸ6űÛiþlò ƒ^fúª'–{Ì>–Ç ¯@÷0û%NëýOüã~•ïÍ=l={x uÊö·u©ú¾¦y”ây~‹}h¿eð†¼‹¼Šç‡·_¦Þ§ºf©o*> ïJ÷O5îwßT÷$ýý¾äÑø/þµ:ôýÂ'±GíïJÿÞOgE~¨ÏJ}úÚ­O ¾jÙô\vÿñAôWäëôÃÊ+È3´ß÷Þ}øíËR·—àWô±ÊƒÉ÷´ž$q|ýpòÞôÊjO2?·}Césê= ή¾iâúâ¨Ô×ËOÁ 9åávÍûà#bÌ}(žS'î7lÝaîKæþ¶nJJ¥ûÿ†×ÁÊcð‹ì¾¸ßúÎØëÌÓ(Om~;Ñþ‡iwOVýÜsyH÷X~Õy×ñíw£c”õk¹úäOèIW¿3ùv¼Uû°ÂÈ?É4Ÿ¼ÍNÔÞÒEQ·—ù×ø-ëÞþÕÔG5®IˆWð{xC}VÕq×u?’ßá›§‰ýgžŽþCtzž‚3àUulã|wû«ÂñÇê`wgÿnxî _õ¹uvô¢‡¦n®º¼‰«ÔSÀõúeð|íkK݃zDïÃþé³R/ûÐø>Óݸ ñ.üªÞOÔzL}~ÑmS‡V~˜3^6q;öJÞÇÏ5NÏù¢‡ÇÞUïcú9ƒ®þ)öÉühöLt¤gÐ:,v'yƒúý%êmØ1ñœ?оo~ÿjý†|Küuô‡º>­KL?vu—‚+ÊçÄnëG/Ï N9¸0s©†x%ç\\Üûžßzã?à¼òútÔ1EA?Qûñ¹Ïú쾕ùWí߆{ª{œüûÊ/U/:øJ\ãÞTÇ#x O’¾äá=R7¨~©ó·ó¼êåoxÃ[uøJ/k=mëB¯áàÙæU’«Îú“ÔŠï«c˜>Të(€cªwžsT½ÄèéÈ5ŸM·® þ_kŸiô<ÕsçÒ‹>“¸­õt÷SOYýPö-øB¼Ìnã1ô§ÉŸÓ%açZõn~Z}Dð~øÛê|ÔþŒô©׆¿ËÀá~fñ-Õ¢k¡ž:8™þDõ5ìwø|BëÏàìøqñmurÒ7¨ïªñuÞÛ¹ÁS«‡c·ôíX?~Å:ÂÛâ<”s‚'”‡3×|ÁV›ûéûþoõçñοz¸P]ˆ¼^ñ€:êy¦ß|uý‚ò#øóê4éO]=û¨þJþOß‚þÆÆs÷Öå(_'ÃK¨c‡ã«»š{ß<—øÎ[âo}ÍøÁ×ê¡Ù÷ö·Š×gÕM%þh?šù9ð²s ÿ²w3!/®Ïf“Åk¯wÛ‹jOS×:3ûYû> oÒúe:³É£Òq4 ?®/¯øÏJ'y q/#Ïgþ]èê%/Y¾4ûÏ/ŠÓ›?õïôTè"§îF¾¦u ð½lù®Îc½ïœ9}\ùqs‡èˆš[V"¼ž¯ýÓut 廓(’¼-^ €·®Ž컼¸ùÞp,¼%¯×ï7·>úÔì°¼åusvûàžïº§ù$ñ {o.“|Bû“Á­g¾/VïH=ïOÿUuâ¿[ÏÞÊ<§±½}U—kþœydúÕGÂIævˆÔ·î‚žDÖA]lë­sŸÍ'Rפ¯´x'q¡x¿ŸýêGÂ÷ðKö‘ÿŃš#eèU75|¾~EŸcžº—qݤ:Çê]/¸ÿò_t8ñ­ßÈ9Â'´Ž[}!½²{óúC½Hî£<*ÿŠ_¤gdŸ=þ@½ u´þ½§¹WåÅôe$Í\’®“9óî›úm¿§Å|uçØ~ñgt¹ø9çÖçË›´7öÁ\2÷ ¾ð¹£y@­rï­Oý\ìqy½Ø-s÷Ô±«ö½íƒÎyÃ[¹ð¤8µúÊéÛ¬Ž~î)>³ümü¾¬ç"û&ŽWïŠÏ¬H\‹—`¯;Ÿ+ñ=öëåOvûòç^ñ‚žòÇ!ï«®[~$ëa¾ý<%ü!Înºg¿;ÝüøbyjûÐç /\>ŽW‡–uõ<»óýòÕæfÊß;o>W^…?ª^sôXì£zCÏÕ:šðRãb¯Öʃe=wçÕ|åê"Eo›£×Òz’œûÐz`}©úJGˆ+2/²v‹·p½s¤ÏŒÝóæH¶ÿÁœœ×êàFÐ\:yìÆíòôêÒóùÎMøñÞGýž‡¿òÞݧœ¿ë^¿ö©«oöЙË^Öö‹ŸwÅ 3ïÇ“Ã=âêkÓ}R×C"ëÕõS|À~â«ÄEtŠñòå‰Fsõª—Àç|ʪkQGªß†Pß|DìFë`sþĽÕ+Íþx?vÇ9ãçù[ŸÏO窵Ÿ.Ï_½øäi=·øÓsÑ»¡¯"?Öç‹ÿm¿lì®yÔügÏå˜ÇßL\ÝûÄŽ™‹ŠÇa·ª÷š>ÀàÛÉâû}aòä'\T;VœG”ÎsìUõ £#·TW$ö·óiÂwâ»{ù|}Üþž~Ó¨ÞlèÓ×>Dÿ|î}3ù ºpºÎMKßjí[ò$ðNç»%Èß›âÜU÷-ó^£ÿÖþ¶ÖCoêM†ý’Oý{¯ŸÏ¯º—å3ô»«¯Q¯ø‚Ÿíy“ÿÊïÑÑvÎÇý§p¿s߈£Øcç)ü^ícã|ú3æ¸ê5ÛŸ“çÍô¾ï¸Þ³}б/ž×þ‹ÏÛ¼Ü|mâ¾ÎO‰?ßõ|%>¡‹eŽ«Ï«Ž–yx”Ü/÷>Å#xŸqŸ;ÂVŸ…ŽPþ38Öy*΀÷ñ|±ßø¶s_¼ßo]õÕ=pTu^²Õ=J_=> ÷{˜«mnfì<[]Íð$üû5¶»îA×7ç½ýÂæªÆnç’ÂSO½©Îí ÿÓùê,R/2G·8<çèŠå?yàÕ'ÝÕzyçÒçö=bWôã:§È¼0÷:¼7=8À9áüž{׺yõÏtô÷ÅßÀŸî3ݬÎ+ •ߣgØ:~óéF8.ÑOlýËÿˆs?Ì!‡»/ñ+î‡ø¡óšô5'>…÷è'Ã-ü;þN ŸÈ߉¯Ý;óù³~Žz|úËYÏâ•œ×øÃÞ‹Æ}á5¬»^ž*÷Ìù¶Oð1{ÝúKö ?¥X¼†ÒŸ‘u°®âsÁávßùñÿÕ5ʽ³OožÍy„ƒ¸ÎuÊî±ùãÖƒÝ6ŸÛ½®Ê÷ÙGñ÷Që¼ù™Çü7Áò•ÅwÑ?t?;Tž6q;‹ïGtNkæXGùOö˜¿²îöO¼Wýÿ¼~.<†¾ q¨u¾`Ç ^Ì}–ÖnÛï+Ÿ½Êž»ïNÝGÏ/à;Ü/8Sœ¨¿u£zòöU÷ãkèRÁÇÛ:OóÍÅMå•F<ÝŸº}áÆ¼kˆŸÌ÷H+Þ¿Òú”Ä5ü/;ÊO¸Oð¨õÇ—z¸^¼ó—KqÃI÷ß©<9~›NŽŸsñÄììõ[ïþ˜G?ïo³t‹Û‚;=·u­ÎLüwõ霫çËùn]až¯ø-÷ÈzxßwÕå?Øÿ{‹çÏüé¨K?¿ëJö~Ã‹îƒø•n‰ø^+ʿӻtoœ¯ú‡ø­ê~ªÓŠ…«÷{ ÷àáºotÝÕ‡˜³ nàç/ÿÈS·Þjù;ËGÑa ž½r×3¯ÒûÖ.ÿ`ý{¿âÆù |~ßꋚ#–ø¦õßòW±SåÁ·tÎ ýßœ_ú¢ìÿé“辚‡Ì¯›ÓZÜÉ÷|éJüÂîòëÏò~ígQw\ïÜ:7×uñ×ÎyàÍÃ=4×&<ö5ÏÙqÑÅþ¬ûgŸñZí¯OfŸªã+?’xŽ¿¬´®æã¡ñÕðjã˜Øüu,’_«Ä“ìµþÓú-zЉ‹àqÕéO<úƒ‡6|0šëRýHuqî¥üZt_º^âBû]þ<ï6~éîºÇâ,¼ Ý>Ÿó»ý»ö!뼺øµzö>×\ÆÜ{:…üjõƒs¾áÞê©úÃÝë3{ùiÿ÷¿7 gðÃðAy­Ü[Ÿsú_ÿÞ—½âæçLï[qoßËÜsæ‚'[?¿tÙÚk?üío>vfùw¶ßtµ;oæß…·‰Îrùô?î´Ñ»ozç=Ã<ÂðHÑin^OÝzû‡sŸàÐѼ¢æuÆùšŸ¾w¿fξ`˜Oÿ(O¡^ñ¼ß|áÏ×­„Cá¶òýúg?°Û#ÂoÚo÷F~Ù÷ÂSì…x s”årž=¿êܲCð]ó~zﺿì²{ÏntPî½ïóÜž£zd‰wÍðýxb÷Á\ZydïïœõD'õò»ž¼òòÓþ§ÏÃNàsÝ|«¼`ùäàõÔ ö\5îÈùð'üS¾8uJê’ÙYû|á³6ÄÞ/?¸ñDâü®ïŸ—­xø…¯üÓpŸ¾ù“-߸ڥƒÝ‹ []÷Ü+ï{Õ7¶ÿú+ß~x¿_¾s)Îìü®¼¿õW©ÎêÏkžñ„%o;oæÏoüܧ}àÛÅa—üçjËÏ<ÿ¶ÚýùòØâ@¼ük=ÙE÷­:p24ç¡÷#ù~x'ë6ðÈáUœ+ëÔ{œýøùl»Âª?9«÷vùÛ^þþ«î)žg‡Æs,ÔÀgøDùq Ý çKŸ;¿Ô9$ñ‡øæú‡Ä;â'óŸèIðW$Žo~n4…ÿuàx5z¨ê6:¤zHÁß}ìÞ—mú’AýŒOýáuk/Û±ùþ»~ ø‘=蜥ð£Î­ýçoä©ÚGò¼ð+澘‡]=èü;^ž¹òõk\òæ·üjàÒÿ)ïu΂u.ßr³‡ù"ü¿yMáÄEöë’ù»~£÷ uþzî'ó©­¸¥siØÎŸ…+Ý#¸BœPü·ÌûÁ ×nõì¿ï/ÏêçŠÇÙÏoªû"¾uïä?Åì \Ï¿á;ßd„Ëô¨·ƒwá ÷õŒ™C×ß䯽fN=÷ÆçÌy[ñ¦÷l~$ñÿïŸðÝ;æíCÞÕ\"çøø¥>è%_YCŸ@÷Óó»çã~zøÌ>W'põòƒžö¨™³ûxððõWò ð¦ø¼:é±Çö…¿Æsg®I×Ã:Àtá“Ëæ.¿ÿUG}?î±ó¿¯ùƒ?ã+ûÜpÉ/zÝ—ÎÉ4×|Ê“ô=ÝoûËŽzŸeÏýÞ ÖûÊÅÛpRëÈè’ÇoœuËïwÜæˆ-k·+¼º÷a¿Ž^¸ËE_]¶_ý ÜÅO«WO|ÈO°ò”åqî=·£ïË^è{U‡uá{-}÷k†~‚Öo•ŸO^ÎÏ©ƒp®Z_£.+ñžïeàÙƒ«Ý_~]¼Ì?ÙŸâ±àxø¯ú‚#9®ÿkß/½«{^Š*®Æ²›òp<]ý½àþEý©ïu>Õù9|?àœ»Ç‹rïÏÙðÀÛ6ý¯3ŠñMöì{ØA¼püà Ë,ÿœ:ï‹wrnZ$ÎI\pþ{nÿú*×þ¨<¦ó¯…ÓäÁà(öž?¸þ˜;¿»à°an ?iΉyK^xÔöþôé£ñ$ê@ø¿ïþð¯øWñ†x¡ú±_ì‡uƒƒÔaÀWî¿ÏÁÓó'g}rùNoºãÂÁÿóãáUÔÇ9ì"=ý1~äWÚ/.ÿ+¯2êK€ûÜë_~þ²÷ü|—íë‡ÄgígµßürÎÿ^~O~.övù^óÔóôõ!OŸs)¯dýk_âgàÆÖ›Ï@_D½Ex^q²ü¬ÏƒÇÝ·è¶×~à©Z/›s¨Î¤ø 烿Åøû£.}Gº?pÛø˜ Nm?‘¹$yžêÍä=­3½®âžð—Μ&ŽY7öÁ~ºÇî©>üªu­îZê+äóù%~±õyö"ç£÷‰ßQWlÆ8·¸'÷Ï=õýâ–±«ì-{‡wäÙûÆ9yŽÎ÷R/œóWÈâ‹oãÏ/ýû¥ÿèj¿,®÷‰¨¯;åÅíÎiõâÃ#]±Ö¦ûï}á¹=×]vÀ‰{¾ë-­k½¡z6yˆœ78žsnñsòò»ðwæË ø[?A칸Ù>ùýâæÄSüœ÷å_ÎÜëúWî÷ýÙù[üHûá‚ØýÆ7ÁðØW¯9aÙ¹ë.‡:_§yøÔ׿¾urî {-¿‡ Nêz´~nzþû÷âwŸ'ÀoÂqìµ{Èá/øóYóLåWâ¿Øm|nýjæˆâ}Ä ð:\>¦Ïï9á ñ¹ü¼x©þb¤Ïî>_µû–ùüo>7ö_}Á²»÷Û‹o=vÈOñg¹×­ç¼w?A׳º™êŽÕuè·ËúÁµ³Ã“´*Ÿ—92=p¦ýqNñî\„×ÂÓãOàûÊ~9g­GÍ:âçíÞ‡üþÿã/ì†þpuýæ+% oGO¾8“½ó}øouò˜ðŽ|ºTyÿà™êTÂâEç ¿ß<²úÕÄ3ô›§Šßë9Í|c¼¼}§/Õ9ðñÿå‹òû­—Éœx}üøõâýÜy¸úauâá—ª3’ùUÕEÎ{²Oðnu™ôÇæ|³¿ì‘¸‰¾!Ý ºDúi¢÷Y½Öyá¹GóàÍ7“×´N$úBô¤Å“ÁÕ÷ê\†œg:,ê àˆYyí|úØÎÓK]rõ S¯•y_-o׺828¹s첟âKõòÖ탠­Ÿ.yçò4y|yç]dÿù÷ÔU§§óÄcW2׸y ¸ÓüjükñJì~~=H8Ìþü€“>ûá­.xÿØýêm«;¤C™uV¯³ìþòÆçÜ:Ôe¤ožþÞwÒs×ÕÇÞ>á茉S¬/üÏÐÑoâcª7‘>ÁêFÆnv®^tܺœ—8 ¿Ûz'ç$¼;ÝzCõ'yîæU§ØWïžÀê‰Æx̹ÕWwã÷Ô…ˆ«ÕÕôüdŸñ񾄩pßçÖùŒêМÃÎ]—Lj½ÔŸÚúGëý§§ÜºtõŸÑ3Ïçcñpø‡êBÝ{nVýûä<8¿úSk×¢÷£žoÆ?ð{êYª?šóo}Øoëª.Ýóù¹|ï0'Öüi÷-÷¢:!Ñ¡)ÞŒ`§ømºÖüRù¢Ô=ãØ;~ºsKõGåù–¬¼ìß»ôúÆò±øQúêÕó‹]`·æ|«3w¯;:ü¶}–ÿ­qî¿jÿ[¬>ï w8μáþÀ í ŽìÜ(} ñãÞ«ó»õsæOÃýž×yê\}•Ùq¿õxn³ó@?ÑþâSù_÷Ÿ‚¯åoøò¨ÙŸÖ›ƒýo_¿ýÃ?<£|\ß ÎˆŸ¯À—p^û™á¦ü=?X^T|ƒß‰ý<àÉ«Ÿ²óüeÝÏö³¨Ͼ²£òˆð¢¾T|"8¤ó‡óÜÃ<Ÿx¡õºáYŠCã7ì#.­®³~Çøü@çK‡grÿñÜÖ ®h?==ƒØ{÷Ó½Ð_»»é¹ðGã>Rû……·ÔYà¥ZtoòÖUÃûöÓ>tN_p—ú¸²÷ŽÞ‚y²æÊd_ÅUp¤{g·ú¹é=©.}Is é TO=þlÌñËp¾8¤ùŠØÑú©øOqLù™è<ÒÉoÿcÖ¯‰wÁ³Ô¸Wú s^õŠâø>7»“sÔýïåç:ï!ö½s rÿéµðãx°Ö%›OéÞÓ¤KÞ¯}VS{2ðÖ1ñ›:2çU^ŽÞ¦{é¼êO3Ÿnè’óô‹^4¿8Òy«ÎiÎSç Ç.už…>·øMþ‹}ŸŽyâöéäs~ñÓË79öoª=ì÷æ^µo?s/Ä7íÓ Þg:ÏÓ|æÔO7žÊ>ˆsݧÆÉæ×«SpÎÄ·ãëGcŠ'b×Üo8®õ¦ê»Ãçò«íë n¯Î$?{Íßâ»Ø9¬wë©ò½í‡5/2ýHðûÚõɽ,~‡êÏŠ×,ÿ3ê_kü“Çß´T|âý>oÖ?'Þ´Ïò§Õí£/—ûè=“_¨žyõýÌ%Ž1\ ޝ]|+Þñ^ìJç–Ò·‰–ª¢#GW[¿¾>ºÙל‹Æ©î·óæ{Õ‹é_¶ïð¬{’¸¬8#ç«úfSž?Ë¿9Á­ö±¸3Ÿv¿ÇyAxÐ=òðḯ£ºQ‰+/8õ—óvç‘KåáØ¿Ÿ´"~ÝÏ©÷ÆçwþétËc8åÅóîQÎcç™û©¾0ü¦÷m%ø¨õáoœ/~¤¸"vß½*Ï`®‡º85çˆ]Ày>¼sóÄæÐЭÉzãñ;/ù7W%vÀ{æ<àkÊßÑ Æ+å}ì§8Ngü~õ¼ƒkÄÅÏÔC†·é'6Žêùßi_fð¿ýq¾ÛO¡ÏÕ¼üDêyý^õwô)æœt݃ì_õ3èÀµ>ŸNSêµø Ý9…çcè–Ò»uO‹£3—Vź:Ïã¹"åwáÇøÑq¾ÃýèçeýÜq²úÖÑëGŒQ·á—ôwÁuò"æ=¨OQ_=5y@z4ÁaãûÌÿ—Æ~×_å<³3ð;\«Nš?‡ä9Õ :æ1Àýðººú(§<æ¶ïün…»ª“ÒþœØõò’—¿þýg®ØÜÆ[êÂè£ÉÓÊË©wTW ŸŠSo+ë}Ô·¨nÝfÖçØ—m¼êíG>·Ï'ïZ\ü©Œ8oc·9ôa÷/ÏÔúFuï©;qn¬»}ósêòħpŠ>õ…ú€¼ŸÏsŽðçêŠà ñNu߃{ªCÏ }wò³òþ£~º¡/)}QtnÚ?¬ÞL_QêžZ«õvÓ÷>7u«»ÿ-zÊCk·ÇuŠ­OÝ€çL¿Ií5Ü ^—-Ÿ¼öÖ9;?§v£ó]‚ÇÔõý“oWg¾ñP>‘¿KBó êºÚç \½LúLNÝýoëÜ0ççC}¬~µäOØ몿¦ý £:%v½ué#rÎÚÏœmÿè–Ó·ðžÖC¼‡Ç¨ÎÀwõ$¹ï§œûáÏ\uÅ[ú÷êÓåGõ7ÈŠkZw£¿/vC=FûòSçãýÔ3©WuŸª»¨~Ú½iߌº ø{öˆýó}ò‰ÎƒûççäëÎ[ü©·>òøkªÃ®¨ó`OÆõ¢êçÜguœü•sÖ:¯è¡ÉG²[êXÛÏ©(vjŸjÎaúQªëÝú¢Ô¨··Þü/ û#‰7ª£¼ ¯¯ðû«Øá Í?Öó²ŸÖÝýüÉÿ}Û_¿}cyõ…xQø/XÛ/ö ¾b/凨1ý¤ø„ÜÛî_ãýàAñ?ÀÓumßsÎ ÃN©oÆß²›Î½¸ ö¨·ÌzŒç¡ÀË­gŽ¿P÷ޝ±sÇíú¤§ovÛÇf.ùÐk~´Åu¿.Þ žè<xÍ} ®îs%ß2ÔÛ»Kß}4ǶóÆùì;|Òóžu:âÚÿ9y— ñ»0žWÏ‹÷ìK×>¶:îà—Ú›Øýbì=Ü*þcÿÅÝìÞØÁSÇì¶òs6yÉ{^‚ZçÂìùß¾è²o®øÅ¯T/ÚÜ8üSûRâ—á08@ý«|CûêRçÍÚ/ŸS] ýšÓ}¬ž³ú`yíÖ'.U÷,ëÒyò™ó^\˜÷õÿì ¶ö>ÿÏÏU?2ç.m¿cì+ü¯¯WÞ ^ôïÅôü㯫ÃO÷Ó\ï•÷g¯Ûwš8Ÿáýø³wÙð‚õV»kèÃÌýÓÏÿõ,é•áw䱪C—u²Žâ¤ø‡~Žøž„[«Ó»_"y~öù~ßùfð0Î|êý£‹ß9fãzñöÅ$O ŸÊ~YwõÓp£çkýcìVõ‹c‡ñ*}Þägoü8ÈÏé·2Î\QyUvÀ¼5õžK?˜ï‰?í|vߺëw¿ð pXã©äìƒ~cþ¾}‹ñoíþRo_wN{øçZŸZíbp ;%n“Ç´nì!<‡7ð>ÅýtÓÍåÈs;øïÚw:¬æÄNàÛ–Ïw^ñ˹ßCœŸïÍzÎê3¾ìk;írø‡P™õšÕÍï5¾§_…5"yç¦zú‚“áÌqŸ]y;x"8„½«®{ò[Õ‘Š}ã'ð}â2üâ9'ûs÷ÿxyß«oÊy±nð)Þâ<åô­Þy`q ƒ‡·¸¯pVûBrª_¯ÿ"Ÿ_»3å»:‡S‰½ñÜp9ÞD<Õ¼Hx ýrø÷¥zÙgñ.?c½û|øÀÔÕ¨£’€ûÕßÁòRþtþœ÷®:•àjøÎsˆ7ë'r?ý>ÜÔ¸8û_wßóótÚwC‡0ñDñApÎÜónÝ÷ûG×:döŠ¿W:?í£6_!÷¿%Þÿ/°W£;Úû‘}`‡Åñð"\o¥Û휷þ>÷—Ÿõ{åG´/}Ö>Ô^&®éÜñÜGçŽvnð`ÍëÄw±çô:ôcæ9ËϪó¤ï˜ü™ßÇó·¿$ù~K_EuâOôC‰Ã«ß»mŸfé°å|W—¿¡MÞ¾zžÞ“¿ÇoT%ëÒ¹ZêS”<÷E¸þSý‘~¾}wáÍNÚnŸíN™Ù¥uí§ÍÏu¾ª<;¿*~Õ'® ~Ä÷u®—~z Ó÷és»â-~FÞÏs±gÎ{wßóËÕƒÎùiÞ.~Öþò«ð@píÀ³fŸª£Ÿ|5?ã~áOà„Î×é¯ÂËí?÷žùwøÄ½Ò/X<{Éß™c}¡òáxï3ý¾¾!u)å¹òÜWŸç¬n}±Ø±ŽûužYåŸ]õÄãgùãê?˜_‘óå|°‡~ž.¼oŸÅáì=?*ï ?ÐÏÀ§‡éTo‘û›yáÍKñ­¿H½—çÂ3àåC:WNÝ«ù/±‡­§ÉÏÛGç¡s†¬¿|³¹í©_Mÿiñ7|ë{ný´Î?»ˆé½ÌºÕ¾Š?²îÎø»Ï}´oƒN¯ õ\·|åÅGì{øÖ+}·Ÿ'/æßñøJöªup¹_Î7\ÉÞ‹ƒ—ûñ[6zö:ÃsÒξùþ®z«ñSø³êæç\ð?î‘çÎ=îýÃõ¾*ë2æ;œþÓþ\ò··>ðÌÝn©=,k®BÞN—¿Ç ¨o輒ќꓧ¾b̧vÞáÔÞz–±;ÍÓ&~­>zÞ·ºm9Ïø3zbígÞ­ÞhêªØ?úc>Òù·¯âîÎ1ˆ*ÿ›uwîÛß7™û’ueÇðöÎ+¾Ãç9ÿžÎO°tàØáêÿš7—z*çÕï‰ù«ê⋳o|ϯ±?±ƒÿ ÎZ¾ÇÒ‹oÙø âű?¾Y<æž4_—ó#~åG<÷X—? Îg·Ï;y~÷À¹ ›YýTúÞ¹Ïê+à~ù"öÏ~ußñu¹ïÕ¿¯ÀNñì£< Ðyxt ôÅï¸Gã¸Ç9óÞâŸúËœkç£ùÖœëç=ìžÖúóãÖ½óØèè{È=„ÇÆóîØIu¬³jnëhî…ýNhÏ>þ™Njû½Âkun ¼©OÌüúdt÷rŸðÚë“¿¯N¿y`ñOÖM¼!ÆÞ^ü‘v»Ñ׆:Ü‘>GóÏñí«‰ÿ¥ãÄNðwôíWë%øú‚Ù'çÝ~°µ_9Gý÷ÄÉãú 8Çû–o>Iy¬ç@'Ðz'¸'ŸOuÔ#8Ÿìgõ¤s>øùêÓÏú‹·œú޾ösð¤s ‡‰cÙg÷ºø(øIÞ sãï:/õîá%¿8ò££97ÃüÖü?<ì|TY©yÔñ›s‚[à›êoЉ ®àG:ÿ0ç„ÝÇëóÔâŸç¼Ê'És³sc=”æmOÚÏž“Ü?ï]¿Ò9=â,õ3ôêéæýè¬w½ƒ‡ªãÒ~ø‘R/áø÷ê\×4NÁSÊ˨_Kœ!Nå§ð”ükómâŒn•ççwkŸÅOy¿Æ¯É[úyßk=Ù¸¨º,ìîÑ xÐí»¿¶uUü•ój=øãÄYÝ÷â}è‰Ëð‘΋óQû«.)<]ó±#ýq0ݼœóhÝlÅCv}æ6ýyºŸìqë¿àH:„±o§ŸrÏþ§nphíhç¨ÆÐiõý]—<7Mgºz×±/ø‰Î…—ú{ýdòì®?ËWÀìwu9Íí5¯#ß×y¢¹.8fõe/ß|¨‹_¯]¥ßŽÏr^Šßòýøê0Ï´'ïѼ>¿¿Þ¹Ë9÷Ç¿}ÿ=ß²ÒMƒÎc:¢ð`,úGÅeprâœþ}Öݽ„[á“~nÎ߬8 NÕµ¨UÓ¾Ú‘îÅ8_«îÏîþ™_­Ž4ë O°Ûü‡óÚ¹y^v¬zê±/ü§ù‡Ÿ{÷º÷ùË v/vCž¤uWÖ•>nÖ©ë•çÄ—VoL^î^¾‡}ÃtŽ™ùNøóïðEûùSì÷Åð%¯³ºPy_óvüþ¸_ nÏg‰¿òê¼òœÍ;á]äñØ¡œÆ%÷ÎG5~dŸZï×N?ý4߬ºZ‰÷øG8 ÿìóøE÷³:æñ£òNì^^l_¨¾âØéêà䜫g?TOÒ\ ¼Oï ÿ+ž çJ/A?Pì™ó oHÝRûÂw´®Ý<Î|>»¸Îçêƒsà?q­8¦ó‡ƒkõË?ãX|iy…Øumâæ=ò'>œŸîܧ¼'²}:úÇr¯ñÚ­cÕ¹3ñ'÷ÏuNZß¿Ò:¦¼—ÏØ÷ :3£¾¸?ÔOÔýʾTW.þݽSo$n½í#ÿI_‚]켸ܻæ]äOÌ3ŠS‡ƒOÓç+Þàïëß«óû¼×>0þÕ>4Ï ÿÍ\ÙÄùœö%³gê±àvsl¯²ç‹¾t\ó¦íKÍ9îœÙ©Ýn»PôUɳ¹Þ»óÂsÈ{»wø(ëU½ð¢ê‰RW] ¼òÏCݨ9,üoⓞ˜c÷²y´¬£ýÛ3<§{Z¥ÜŸ#,üÀÖ}_ý³¾ôαM=«¾\¸°}Ãé·ªNCνø Ïa}ÜïòÝøs~ƒkô÷£ž·sŽÃÛX¸Ì{³sÞǽ—gÑßXý¯è¤ÁeÍÃèq.ªëž{~×<’qÞÓ¾àwÙñÖmçÔÎò·ìgì#ÿÛy“ôR¯·bïè%±?ê¾Ä1Þ§~K}Vpï…7èù4fþCî=¿fݬ³8N]ÙüÛ.½eó¿Tï7þ«ýó¹ßÿž>zó÷š;ß­››‚OèmTGI<à~³'ÎûÅ~Èã„ÿ¨IuïµsÁZ·Îó ΪžPø3ýxgöªº £ùâO8klÄõΑu¦×Í¿ª'ñóìpõaÕ«Òƒ¿èÞV·;þV½ž ¾L}äçÓ£ï^}ª©ÿø0óVcwª3Ÿ{ÝýÊùgø;yŽÖ{¤ÿ¿õ.Á)ÍÈßÄùÉÓ¨³êüø¬GóíÙŸö߆§çµ®<önmuòü³¸Â9†OØ5¼[ã¡Ø ?O_¢óa§uš“9¿|ëÕνªöIÝ Ï-n·žü¦{^þO Ž"ç]óì[õ¼âgØ¥Ö­ÿEÇp²äãç\1ï½ïý­®^â?ï©X};ç^¾EÜ/ž†S:¿5<>'ù”ê»ÇOÀ#î5;†‡?OãÏ©}«qïá/vîÓÏoâ=áQöb<¯¹uJæ•ÅîùºÕI¨¾FüàH?fÐ4'/^@šÞ—}ë-‰ªgH#öþª§£?Ç^4®2Ÿ9|@u2èPÆn–ç¥K2ÂYìmûûé<‡Ç)~ÀkÅ>‰àCëßù—‰_;7$~_ßwë“é~›“ëÍZ§ê嚃;ÆïósÕyŒDùÃØ5~oËŽö<Ä^©¶?ö^Xqhú=:Ç6úÕã¯ó<ü{ÔüQðŸßï}Õ“Š£zoÍÍy×Ã)úâ½_ó®êÖð[Ùöµúýá9Ø‘ÎßSO DïhîŸ?rÄš‹Wl]s"(¿XÝñI~®uã£úÖæ>¶ïĹ¥œv«sìc:ß’]ˆýçãiÚßjÞjÎIç—ÆïëgnŸú|õä 7_¹|оHëÙùæé³ë<¤Äâ%ëîàC«KJ÷:ûïü†Ÿúó¦_¿‡ÇgÿÆ}ƒÎaëè ÒCW·™|Ñ?Þý€æ”ݳê´Ï0Ÿ¯¯ªú ú òÿ抴N ß{Ç^Õîf»Nxzõ1ê ãÍÝã«/¿cÅ)â“έ >Á;ÉâÁíCóòÈêBðôƒGzTp«ó(6ž×¦>Ýoáßà<ËXOѺQ¼pì±{Ѿîà+þ€ßV÷,Š;Õë4žSW˜õ®n©|.¾-ûç~˜s²`«Mýô}ÿwС¤Æ?ÆÏV'#u8í3Ìý.O¾Ô{Óh_Aî½ø§sšÂo¨Ï—gSFvîÍGÝpø+‡z¿æÓ§qvõ[cß:W½ÑÏ/©¿¾¬ØÛâ¢àÍö7…Ÿ€{ÅgpRçMëßags¿+uê­Ç¦SŸøyÑMŸ?åU_Ú¨}ð2ÜfN÷Å÷¶ß#~Wü)Ž5ç«úƒê Õå\œ·Á;žø‘¬ÛûÌ_é'to­—<ƒÏ…GäyõûÁµøÁÆñ9Çö})sؾzù®ðWךóÏò—ü©õ­®Yì œì¼VÏ+úñâ™ÖÏ™/xͰÃ/§oVQì®8ÎtñCì—õ×éËHž©ü±¹®xMÏ«ˆ_‡oÍn>Ûó'¿†Ãî:íׇ/}ä‚òdÎaëKè éƒß¡®Ýú²ÏÕåËzÊÏòwÞS3voT=|tüwuÙ‚o仜›Úô-ýã²G~ùÀÇ}¹þ^|Ø|qâ8ç§þ Onwÿú>ù¼ò‰æ›z®ôí6o¦Î¡zmt~7;oñ_Õ‘s^¬¯|¶¾æ±þtìru¬ëo‚×;·ÝÜ™ì7¿­'Ï9™ûçñ¨çò³í×L|ÍŸU·bT׎×i_@öþ`Gð/~ïúÕê©òßcÈòñÃêBñTìuÅéf_ôÂ]x4öNl]=—ÜÇâÔØõ ð¿"®ï\¢ð›­gHŸýWµÏ“Î_p¹sÏU?*ùçÖyu/Ù‰æÕécÊËÛY_õ‰C˜Ç¼bßáôæ·sÞÕíñø4ë&¿@ŸU~Öùò÷—n^¤¼`êÄC­WÎ÷;·Ö­v*ýòÆð5ý#v¯qeÞ#öu¨‡Kߢ<ã¸þ¬ý!‰gä{ÅßíOK„ù ô.^°ú'ì·é  ˜óÂnêC…ËäWéôÐ1lý}ê̪OjÎFþ_>ŠŸsÄü·¼¡õì|ŽØ'| ~¼u¦êÿåÛƒËä]Ä%ú[Çü´Ïw¯Õt~Fî1ឌóéâVø§s%ÔcwÞɾG¾îÃ7_8ä‡bñ0ÕM¼-αoÅ­ú±ƒ/ZŸ`¾úhž{㬬ÓOXmáïþ¯ÿ$|–ø¤ùçèt~Øòœ±Çk—Gî_õiÊŽöE>Wž£s@¢¿d}ôÓŠã¬Oõåã­sãØœWü’¸¢sÁr~;‡É\‚äݬÞÉóˆ¿è,ÐMÆáe;ÝœxþÕ<ˆð®Î•烋ÛW8Î)o´Éût®mòn棶>SŸî(Ÿm[¿»5®s.Fç8øD€õ³ì¾¬ó¸ƒ#ì#½%ç O Žûk§ÃG9OíãÎ>T7—޹>žÜ'<;(‚i{IW-<Îdîm§m¾ÓšG4OÁ¾ê¿c/Õ+t=çQNÀ©¯…—Õ]â=Ù3üŠu·9‡åÅ{¿ÖILíõdÎÎ?ê+í<ð†Áê Û/ü€ßW§Îÿ‰‹õ wXìJç–åœá%ªßÜQ}†œ~£¼…þþœOx§|œCÿ4|dõCÕ%ꯠŸ<ˆ¤ïήÑKv¾í¼ OñÏìlëðÃCÃøëT}ÁáÆóeÄ¿ì;…' _Ýú)Ÿk]ðTÕÎýUW²pÿ-öÐê‡t$üIO±ý’¹?êܪ~R~¤x0vƽ‚ñ¥òöâ8ºç>ëfÝá@é¼­¾úÅ!ÿ?îe/ì§û©ŽÄ}wãØ x³:’t£ðY¯ Ÿµù#ö~ùÁ­ËèÜŠØÍêOç84No=¬9oáeÚ÷‘8ÑùåÿÄãÎaûòÿÍ£gÀ³ö‡ýQWÔþµð%‡;[}³ÔµðS­È\'zH­»‰¿j½MÖ¹s¯sO;ÏÏ\âÜO¼Pû¡À%ìqç×$¾ã?[7­ïNÿ$½ü ”'Œ¿–ƒóùËqÞ§ýÊy¯æ÷s_¼'~e\ŸÝþGs0RG$_ÒyÞæI%¾â'ÕµZ_~µu;©†Ûš‡ ŸŠ?ƒ«Å‡SÿT紧κ÷AŸ¥zuŠÁ-â}~Œß®^xpbóuyîê¿ÅÞ³×Ö]]_ëùל}ÌŠO^áÊ5¯àûÛßc®NÖ½}©ê7Íß”2/Ñœ"º4òCyîøóa~Rp6ž«º±ƒxª n¿gò,cÞî8|ŸìùÎüµÏ+c/êçÔÃ?°ûíïp?åôq†h{Ì®·þ.÷ o—âQÄ©‰_zñwî‰|Jëûbg¿$O óû‹³úWì?û›>ÛÖ‰àYØUçÌ=ñ筳J¬ºˆ±+>vâ–'ÏýÈFæ?†wu='ý1l_<^€ßà'Û‡)Þ hÞ•ïcÅãâ¼æŸäÕ¦qÜ`gá¿Øø&çj˜;jvp\Mר9uÎ鯴ß®½·Èk°ÉÏu^ÁSôãûy/÷Þmõý‚ûðÎKûrãïä [?ç~„ltòƒò —ÿzÕGœ¼ïZƒ.gü&>´qYìò…;ìvá§VߣvO ÿ¹‡t-Ý·úóðQü ü¿5ÔÕ$/ŠÇð]ðȸ¯Òs9¯øë‡/¶þÎ/½†êÓ«/7î§UŸiûBߨ¹â¿Åÿî…úïÎÁȿÞ£q(}’i>¨ë¤ÎÕýcÇZÏ=ŠÔøžÎ' Ÿ$î¿äÄs}üñŸh¼Õ‚x+þ.4ÏÆ½(ßÜ 7Ožfœí“Øñ®:t}•ÕÍÏçô¸¯p¸ø¤÷]_Eâ4ï…§s;Ô8µyÈÜëžÏœ7ö zdYŸÖéC̹ûçæùèª_˜Æ+C_Mþ^] çÿ¶N2ýp{ùessÂÇÀOÿ™ç¥£aØ‘ÎMÉúßÁɉƒÙáòGáÅòêÀš—Õ/wdôWÙûÎuÒç;¤~©ö?<^ëƒ;·,õî³{ì¼UŸ7yrû*.u^ø=}Z~Ͻ­n›þ=õ á#Ò_Óú8Æs´NŸ¾žƒžCûγ_gܵÃÖ¯ýà©å?WäýÕiµo*|}AëA× : 9_Ék úÁÁQðhãry‚ðü¶û þÅ<æqb¿á5}NžOÙù ômbÏùþRüc=ÅUtYá9ë:ÖCï¼;º«ùy¼Œù6Ö¿}%Ù/~^}Ru@é²?Á—ì”:q÷˜¿€»ØÿÎ% n†£Z‡8Ò?Áïu¾FâMûÞøWÞ9øYZ%u‘áÅùò_ì´þ·±.žÿ—GeŸÔâk'ú$­×H~ë÷ÁÉc<ŽÏY°Îå[n¶qíVç¡ç^¨Ÿ’ç·tŸò9ð^˹Ô',þ—k¾1¿oÝÅ­S¾*™ÏçÏ;·1~£zAéÛkÿ³ŸðÞã«×œ°ìÜu—÷þT'8?ç|û¸Ü;y(v„ý¯n{îÝe¯?kûÅÏ»¢yyqŠ÷ƒWOþ¦÷>Àß%®QŸÉ®zoúw|•z-s,ñ$/™x?å¿Ì•Gµž0¼œÔú0ý©æÅßÜ}ãÞ¯;ñÀ3†úܱÎxî[ûЂái÷ÈçãaäÉÔ¯Ú—æô„ô­—Û'vp¬—¥îd<'€Ÿ‘g†Óù9¼Œx¨ñCxþÎmñX£¹}ƒ®+ž=û.…ÆzHì)Neß­;ýZ÷i½ïùÖÚ>{ã'â!=JW=\ëǾV/!öFÿ,|êüÀmìJó üœ{üÒô’¯¬QÿÀÎv þïä嬋8ƒ}•ÿÇ_óKÕŸÍp¯ùSuHâ;~¬uÌ9ç­—ô\Î¥üaò%ÖWÏ…—`׫+F/+þ(v¢ç¿u;ÁgÕ &Ï“~öΫgßÔoäܶ_;yuu­Í}‡÷Ôò¯Î?ÿ wÀa³æ×%þÿ˜'Ñ>e¼%¼H§"øC¤^•ߊ]Vo1àÿàªòeñox v±ºÝê÷GzEî5?Á>61_b4WŠXÏYêåä‡Õ%·³¸BŸJp4|Ô¹ŠéG¨Þ,ûŸû Ÿ¾Ôg°cÕíÍ=ÔÇ·Ï+žÍ?÷½ü ~ vÆyP矺?û-þõòéâÝÎk̹×?!oáûÕ+È×u~Kìõ˜ç×õ7°Ãâ`yü“}u/ÔÑ´¾:öƽµ>ÖÏ9Ä{©›ï|—ì¼Ã¾±·åk‚Ú@_'öG_¾Ï\ñ¦zœÎK {ž{`ßìÞEþÓzáEñγ<}S_n_ñCü¤ó¯Ž¥óËFøhgü¼ÙÏ~æžÌÒoÆ#§·¤Vß÷dîÓ.¿åKz÷ c?#ni?ÓH+õg“9—ï|Ñðlë8™{䜕såO'sÿ°ý-WÜù‰ÆOì;2Y|â‚?ý錣‡º‘Ä_Á{Cþ.ñôHϰÿŽWlŒúQõÌSüß<_Öo2²Ï#¶8ùÕõo­—¦gh~VÖ‡Ÿ¿µOFßKx¡ÎÁšÚÃɼwo¹ò}>tÿÖZçöm›»!/O^?}ìSöa2oÓüè‹üñÌyw.ßùKw9ÔAWó×Á=“y{ýð¢G=ÿ©“¹=u¿U_pÈ ©¾¤ ËωÜvAÝ…|˸î·s0³¾Î{üîdÎ!—lûü]žÕ}s^¬'þ¸|­¼ÝœìWõ¼ãïšßN¼ÙùôKòþêSøŸê äþ{^ø”àÆyúÎiÞwnà:缸(õŸ~Îû„G›ÌýÜ“Ï}þcÿPÜí|USÝgpiùÍÄ‹Y—A÷"vƽ’ß«[ø*ë'±ãê£ôeôœOG ürüø*öºy*Ï[ý¨Ä¿åýñ±ÁìRy’œ7÷PÎùé{÷»aæì »øwuo츼ý,ÁYòÕ½Ó÷“¸Ÿ,o·Ä¿¨ÃsžàÐæ•Fq{\}•ð³ìyõ²>ÕoJÝœ]0ºÓÉûwÎFòøfç¥}¥ù¼1Ní=O<Ð>Ó©½,øáýÎ]ó9ߘ­_1âßõÃu*úɳò#§A–N†7ü?;~ámå ª³§}¸ÉÊŸÂõÕõ GŠùñ$^Ù¹d'ÜßÖI9gñ«êà©êä÷ÇúÎ-†/¬Îfž‡ý×›×îÆŽ¶>y*ü\›¸¬~\¼Õ¼Aò+Öóžuý‹¾:̱î†Gœ'÷ß¹cgàeþ¯uDtXô]àMsÿÚ÷œØºI÷úçdî6ßÙóðwøÞà¿Ö…˜÷H7'¼¤}/.ÉóÖ®â9¦Þz__À¹ì§üfö©û§n‡ý²ÿêwœ3ùcþôžÓ6Þæ¢×­9Ì-QO${Á_³7‡Fý­sÑלß//M‚ÞböÓy®®¾­œÛžûœ7u&ÙßÉœûúíþáåËZgž&Ï$ÂoVO8çÿÕº/õ)ò¿òC#ËòD¹Ÿp»‡/«fÎ=×ܯÔMæ|á©—öÖ¡.Áógì³u)™úòÞ¯Ø3v½v%øÞªÞ!Ëܼuu{׊×äžTç_]òw³ôàõãšœu€Sé©8Ÿòîö‹}kDî+{-.:éÏ~ózߨj°gS¼Z«qßœs«jÌóˆ×Äùüº)ù9<»:Eùyïáþ»ŸÎ)}ûìÜðÓ͇Œæ7&~Pg¼éÞ‰ÿè$´Ù¼ämú9ì}Èô+T¯oe>3¾.wâ”ök'ß.¯ÖyÓóýÏ%¿ïœ9}\íVë»ò{ÝÑü.ëÑyÌò¿9wÕóŒ?”_¨.~&uäÉu^8]ãÄOÍ3å=¬‡óܺþÉ\à²êžVz¤c'XÝs²ƒo›·ˆýá·ø‡Öï§^NþO] ¼ìù¬¾ÜºàᚇŸÀã:Ÿò4Ý'ý‡ù\u ð缕q⥟zIóJøºÎS£[|Ð9»‰;¿*ç¼ëÈž³_×bŽEâAßÛù¥òòêÔ—òß·©@bìHy¿ÜC:?òbâïêÜçR¨ʽƒ?Êw™çšúñhûüã/Ú7˜ûwÞ¦ø'þ>â·Øëæ§ÍIÄC›‹¬/ˆ^~êÏjÌ%Õ‡h^Tþ¾:Ëæ º÷ê™éÁÓN]´s ‡¶ï(¸³zÚ±3x¾Q]í`§²ŽÍo¨ËÈ=a_«Ï8¾}à©+«ž¤|Qø×úq8]Þ€]Ži¾/ç¾ãÓ;DÜœ{Ê_ø9õí‹pŸéúŽæÂ×£|HÏwëÑÃu‡¸'yDyTç±u§æÉå^¹ê‚Ä‘ì·~‡ê«†?h^ôb;Ϝ͜+ö𪇾ú†›g~9äAbOø·êåßË·Ó]77:õÍ;å8÷íÏ7W=çºõ‰‰—ñYÖk=EΞ…€Çápû&ßì\دê@f]GÁ•±øL÷ .—ŸpÅ›­#K|ï|u~ |&~n4W™¿÷©Ã!‡ó¾o>øœîlçXå>ʯ·Ž{Šêoð¤Ÿ1û<ÖA⽸ i> ú-øÔGOæüãû×_ü€oùëÄEì\_›ê ¯§îµuåÁÿÍÿçïÕ1µ_9ñ°ºPx¹}Á¡x.qhñH58Y¼_ÒÜïWhýRÎMó—Á'øñêe]éγkÖËß»Ë>ñè/o|έͫ²ü¼ç¸.³ç?|*»©þ·:Ö±Û«*oW6×0<£þö? ·Á_îYë§ÿò÷p&; çú|y <•—§ô¹cDïá¾ÇŽ4¿×ç n«Aþßsýq§Þ}Ó;ïiÔXWa¬¯Ëϲ÷ìÜl>ôùO;ðì-÷û\y9çTUýÙ§´þU¾žk_Qöa<µ~#çŽýÄ¿U/käGñNõÛò÷ô:/õ/Χ>Vx²út7ÅÙ‰‹ãŸ=cõ¹—Þ¿Žu*;‡3¸¡s Ô5æçŠ»è§$ÿž}´þÓüÝàÅö·™ï@?E|aiÖ»õÁgîUç6±ÇòP¹?íÉýç?»þù}ü”ýÃkãë«_+ªÏ6þ@’:¦êÖFþh~ngöG< Î >ÀÓè³qoà‹ÎƒÎ9¬Îrü^çiåœwÞmì©{TP:Ö΃óëžçyÕ ðSìǹ+|ôʇÍ|«ú=æÿÒÑ îÁÏÈ vNxÐ\ÙàŽ®oðçUZ¾Þüõ”áSNßåÞõÚ4.cïùí·éÍôˆõ¯ògéÃ#z8©ó èøç^à#Åið»õvâª+zÆO?}Áe«ï0àýð~ì2ÜÒ8Ð|Gü…| >ÒÜW:¶ùwþÕóð7ãß·®êˆÔçÿªËâ/åÌs ‰7§è“÷{^}@ìé,]õ§tüÆóçb[ïÖy ô°ÍÑÞ—Ô„_QeŸ‹ïÍcÈ÷³[ò±ïá[¯4Ìçöê’àŽöcèó£g¦?6q¸ºüö%ownvêAáºÆõìhòQ·‘º(¼]û²ávõHxü™þàÄIâ£Ö_ç\Šûñiãþöö¿à+·”‡ˆÿ¯þ[ìû'nvêW‚'ZŸ|lß«ó–8oÄï»oì€up_Šò~ødþܽ§{S]Éàž›Ä¡ì3¾¿ó'ò9±ÿ“ù÷lqÓMß}â {©^‘îºx#ïÏ?8ox}xR ú¯Yçö?«ÓÇÃðÓu˜ÌýàÌnO?ìeÃ~gãØÓÎÑ2W38[ýoyYúÖÉ7®T?”ø°õ䣺æö}§©úbñÖQÜvÎIç>äÜý?>è|ŽæÝ8'¾OüGvΤ÷£Ï»Åî¶W=ùx¼Ø¨þÑçzögç°#îKë-Øëøñ?X°i|:Yñ…Wìó·om0Kß°:±/îËXO÷Ä9?9㇛ õÅÎÛX7Yª}ê£ò4ìž{OT7ߨð3žï9×ò/øo|Fùÿøqšó,ïкuEÁmö‰ýÒ¯dõ‘Œó#Õ‹¡Ë£3ÿ.ïb?3yyùñRïëû»~t<ÌÎ}i^R_eö£sÎÍ ®÷]v>HöÁ~»gìLy7óaÄ—êRb‡è$èÓkzÎwõ"é½ëO¡ÓfTâLü#½r<¨{ݹ`áyÊã¹/ÁÛc<¾p2o¿î¼Ñ'oèóWWB<\Åî³åáßü~yrz ñÛørçË¿;Ρçìèà—cVùÃgW=ñøÞ}†t㜓¬wy&ú4ÕÉ 1îãP7÷À·â˜Öñy_ý yþêUÓ§Õ+vþ=vyñìWënó>ž _ '4< ·°+îAóÆ©CóŸÕéÝä¿øßZ0Ìqˆ¿r®ªÓÔº£àÄÎ1§JžÊ¼ð)øÏžõsêÑÒŸ¥>‘.…ç  ×Á~•·ÊçãNçG>¿ £Ô¸P}Š~‡ìCù‹ð7òº­›ÖÉ®˜ožumÝB΃xÓ9§sá{;w;ûÎnŠËùÅÖ7©]Ç£TG'xßÜ~£ì÷;gÃoÛô¿ÎÎmü•>öžósÿ­oubÓï”{ÚyÎgõz£ß›{:™{ù–G-¼íÍÇŸêcÎú7¿Ôz_~5qJîÙàc‡ªÏ›ó#Øy¥ñ—>Çϵ¾-÷ž»—Åý±ûÍW´_S¥º8ø0ö¢zHpbìÞÞN¿jëÏë¯ËÜ?ëZ½y¸?¸¨óÚ¢Ö¸.q÷¸Ž¶õ¢¹wübõ²¢—aŸËCÇî”—ÿ6ßÊùÌùªúˆüœó ¿à?ä¹ñ³C™ýïù‚ã“i½bÞ¯sá‚?ø?v£:‰ðcC;?ÛsØ9.S\×þýÖIäsŠ{è©„ßÇ4/¦,ûƒS§Ïð'Õ—þï/{ÑzÄãí› ?Ñ:¸é½îYü$žÇ}m†:»Ø™ê_çuîVø/þ¡¼DöK^Óùßè[æ·«÷¼ïþÀí{…‡Ä͉gðï~ÞfŸ÷ÎCÈþê«s¿ÄúÚ?“u†«§eUæ×7Kße¤çTûN¯3÷Æó´O(¸…ÿöžðiÞ§õ]¯Ø‹êµÜ[·ëQ=$sØ3º¹ÿÕdbÏÌùpàyéêeßàÄÖG$>ª>Uð4»kÝ‹Ûâÿšɺú¼ê«š³•õmH½Uì€uèœÂéþ´o²}ô9ŸG\û?'ïñ²Áž6n®ÿ·ÞÕƒ ^¢W_ÂKtäØuqPëÌýé%µO†gö^“§lŸŽ¸4÷‹N9ÿ÷‹Ÿ^¾É±ûSïç8®»æ[ØöþÿuÑdþj[»Ù¶ƒ^÷®:ÓŸúá“à êpÄâ[ýüøÜ7¸ÄúÂiìBë„ó^öW\Òþtõf9·éw¨.Gç‹ÄŸˆûÔ—éKhüˆ÷Èy-Ÿ–ûÞùªñ‹ð©úâBç0vÞ`?Ä%õ‡æ5徎ù±øÁÚ ÏÿØoø©º÷Á¯=wøªü^ëÍÙ3<ºú´àÀÖCæ¾;c‚¿ôýüظÿ ÏÒúgs²ïî;èÿí;&u®uøIÏuΞŸÝæë¯U¼a?ª‹˜üžx­º±ãùÕú´Ú•:›â´ÜOùÔòv#]óÆëY—òøúÈrßé|´/¼@õ9èREר|Oâ"ç¬ùeuYY×ÖÏå{Ù³öOg]äç›òfƒÿ¢#‘óRýYýI±‡úšÊ—å^ÂOêŠÇ:šÿ ßTÇYÿjæÙU÷6<6$ø¡~+uñÕ…SW‘üVqטÏ7®ŸÊ>àØ }(³“ýЗV]Á©ÿœÌùÍ+–½òþ»‡;ïü[õÙ_ç<<žsêcm[=söM]~¿óóx”êßè{H=|õgü<’¸¤üPuècîÞøa[®ºáÿª³“¸c<‡¶y8ylõBêä¦q\õnàBøž>Dç¸sꂃä/«w—û×~1}õñ‡7>âͪ¯š>tüˆó®îRüå\_f;ß ¿ïßñ³ÿbïÃßÊËÜ=gò쬿[×o¤—Õ¼Øx~nó•ÁϾ·õ›±wâ%ùHç¶ó·r«oœûÒù¥±Ãγ÷wÞZGþm~>ëß¼L잎ýî\wºœæ£©§ŽýTç`úxrû/õG·@ªx™·/$öa¬WÖúì|®:LÏ OT/¼áœ· ï™8H½¹:ÍUoÂ\­ø_|¿Í~Žë$àŠÖý郦ÇÂþã;gYž:¼ou˜ñqñ“즺¾ò‡Y§òõô”ãZï’Oš÷Âß©_‡§+÷w<ç_@׸yݬKþ2÷Åÿó²oû£ò3íËŽtœ/òãpbâµòâvùwûV?•8™^eë äá²¾ø]ïÕž¿ÀgÊ»x^þIÿ{G¡saßÇ:_ÕUÒç“þ„ö٩É=‡ÿœ x¿º¦êiÔ±ä|W×3ñSçT'¯j_[O^ sXâ:O1qª:‘æÛÕÓŽôSûá\´þO]IüŒ>±êŽ§Þ£u§úâôÝé£Ë½Uo/?_…ä :?9<>¦Ï¯NŽÞSî'œÐþÄð$á''s^yü!yã‡9œ±Ûµ—ñç±ËýùöQÅŽÃ'£€¯éGÇÎôsÄ#õ×ê~Ü_uzyßêÈeÛ6ªoÏïÖwGŒë—Ø}~žl|¥O(qZÏAðeuWé¤$OÇß9W½§ÁcþÞz²§ÕóŽÿi?vê©Ó¿<äMÙ¹¬“ý¨žWìBùåàïáïËó'~ó<âfv ÿ6Ö™¯Ž¸9iæ«Û‹Ç·ÞHÝJìå‰+ªßüŠoÒg`]«W<šóÞºùùðgÖ o_}œðrÕ!fWb_­¯x¾s…㯚7ß5ï%N‘¯cÕß³£ÍcÊo'߿܍¯Â'­ÏwÄŸ:úrÅQxX¸ºyÝü{çÄOò#3rnØu¸Îççš¿¥".ïÓ9Ù9Gô›ý¿¼Uí„:?z‹‰7ªküOŽ]  ë÷ËÁ!úÃ;•ßÊs°Kúé¡´>7öØý—_•oÔÏÔº zô‰g›ÿ¥+ûÚ8‘^WÞW| g”'6ÿ€Gø“ÚÉØëž·Ñ|ïqÁ6çÏñP±Ãc~[Á¯ÃíÓÓ7§N.Jœhü¿ú1uøê´à#¸Btõ#ó|øzügûºê‹€Ãù‰êLäÞŒõ2õwÖ&>Á×W¿w¤ŸP½m}h±7ì¿‹7è~%>b¿Åeê’Z——çW:Gö…Ýç÷ñ|ìuîÜ.:ôæoeýº¯tvó¹úñîí‡ÝçÛ­'þÈŽ·$ñÌh{Ÿ×>¶žhÔS;2Š#Ø ö´ó«ôë'înÞV¿/ý˜Ø)qç8Oã~دÎÑN>­óHÂ3²Ãî-G/Þ¼5þPþ»ùŠÜüªu¨ex4qXç©ëïÏýÁcãAª?¢9vT¾4Ï7îôœ­cÄ{æùì[ׅݡØx½y:óåäéoªG5G/ç¼uôE³îí»Jü]|%_ã|áõÓä^“îŸóRõØÖ«ç÷ùOç^(/\fßèá«;qŠ;ϰ'ê‚à©ö„§ðïâvÉ}«_˜¾÷dÎK~ðün°ÎpÞ’¿äÇðü­?¯&€sÙE÷¾º¹xë|~çkÓ«å¹ÌEïÜm·ÿS=Ž)Nê^èiç¼á7Ýó䉗zxÝú²óöÍý…—Ç}äp“õ6G¹v^}câÇöK$o /%Nó&ôÒì»Nï£ú»æ*«ûÍs†÷i5ÿ¿ºïö ß$ï¾8ü}m¶~êÔˆ[ÄIüUë¾o»qÇÕŸyûdÁoîsÜOþÓÌÏÿcÛVýÉY}?ý}î[í|>oNǰ:¤ÁEO¿ ž¯éßK^a<_ ?R|¯üBuò·^ü‘v»Ñ×Ê'V:ùi¸£}~#ÝâðØwøÃz÷|øûà¥ò÷±wx&ï'O'n©}¿æ{Ë“âÏc_[œ¼„ü»ºtøÈþX¯öá»_9_­Tÿ|^EüW>!ëÏ9_c? ˜—g^bûLô•Áø^|HâYëÃsïÙIüÿªN¡s؃OØ/gô¸§õ±¿Õ95§&~·z øŠèDÛoñ«û«Ÿ¬úgÁp£þMv¤úD9÷Üxíõ?8úM=øxþR^–fgÅëöI}FçJd]«ï¼AoݼGõì»ùó^tæÏøÂQƒžpìª8‡ý0¿A^¢q1þì{+ß«ŽÖ§ŒßÎùŸÌyÁ?þèÓuiZx]x7øu2ïÕŸ|Í•/øaójõË©iŸQp“ûžhÝqâsçÄ>ä\4§Þ2ñódÎïw:æw뽨ïœØó㼩+3·ËùsÄãzÔÖƒ¦ïÙ{±gΗzUñ‰yiìXëßå9bº¿9¾‡]Õ×ÿ¸_ü¯uo=îTgšÎMÏ›ÏÅã°W]Ÿì¿÷ˆ½è9®ýÈ÷٧𨓹ÿgZ±ý@Öß…wdœ_qPðsóª½Ñ͆ª#4gZÿÈ_¶B|ô¡ú¼ñOòÅt¡³O}ßΙ›òýxYœÁîæ<ô|Åïw~™û‰¿ôÿêŠèŽÌYç¿7úâs¾ØçÊyk]Tû8ŸÈ£w¾í'4¿ÒzàßôyŸê!Æ_Mæmõ¹{Ná{k·›ocûø·ØŸ>·ßc¿ªC—ýô¼©™Ì9û++~éÀ¿6ng8‡âvªº¬™ûõï|ý ½—‰'¢ÏØx!y´æ%í:î« ÞœÌÝÿ‹¯xü“NoEž«ïÏžÝ3ùæ!k}yèGëü”à ÷D}™s\Ðú,ø’½fïý¾sÌ/¸wî{çó$ŽªýûuìŒûÇß©ÓkYð#?Oq/:*|;W° òÜâmq¯sÓúõØQëÛþûøQxÝü8ËßóCîó˜>…ÚŸê²ë'qÂKD's2çȵÖ9eÎMÜ›àÒúëôïò'Å=Óõôó\•y0tEÙ#þ\ŸzKøÃúT4ûã÷ØÿæSÃ/Ûßà„ú ÷"üÖdî&û<ãÊ“vpMÞÏ9/^ôç7MæÍ|vÛ7ÞºñbüNíjìEß»ë~J½(» þ‚{ïsîÜÏŸç(¯ò£Î/ûæû:—A+q õËÏucq[ö%ÏU|Y>wZ/5™÷‹g·ïÙ·Ö~ãƒZ‡”:÷r“÷€ÛOùœµÎ\ôދЇÅOð» ':á“û­~A¼S¿œàœæîëi~ÿ>½ýwþÞ9ª‹aw:"vUSçÞ†wè½uî|~ø É¼Õ>ô¿ÛóÅMã~ëÝ8.çÑ~ÙçÝ¿;âÒÚ¡ø|lïëªsnùÓ‚3z.óÖ[© ã9Ù9ñuãzë™8E^nlŸà~zÂî}í{ò Åý¹‡É£t}ÇÆÃ9×­cŠýbgÌáo­#¾ˆ?s¾ÔõÒiV/V3ëå=‚›«# —Zê^乨“àøò´Ö‡áê‡cÿð>Ö¡yÖ䛼è\ùбÎnqCt3ªƒ‡¯‹]¡ÿ˾ä9ÚW ·µ4ç ®i}yôÎÂs’àìKý­ßÏ:±/©?€o's_ý£>¶õÕå%õwMæ™0½wæB÷^ˆ{ZÏ”ü¸¸­ø'v¡óX’g‚·ÄQÎgïYøøÖoÂá9ÅS?ÛëíŸÖsê<ÏÇž±3µßÁÏðIø3qqÏiýiìþ»Ÿ—sÊ^»_w³þp°xÄzuž~hЇŠùk¼ û.l>]«Ý‰½¨]05~§þ"v/Ð9[ù}x«÷2zÛõ?±ëòÛνsgÝ;¯1xI\w¨/ŽÇ+ÈÄÿ:/têgÔŽÈç×N׿¿Ÿ¸wˆ÷Ó/ ÿwÿé\¸Wñ«xj爟3n…·‹Ÿo³7ÅÛùÐû¢ŸÚ}Wg/ç}?û¨Ÿ€ß².Y¿ÉÜ/_𱋽¹?Ÿx¦çV\éܪc¯«<ǨßïçÞMlµé±Ÿ¾ïÿö^V¯[x«êÝŒt 䳨z–æªÃƒÏhŽ‹ú5s¸èËÑ?“ï/Ü9Pñãpfë]sŸÔóüWy_u?ê·ÔuÆžËvž"]âÜÓÖsè+I|¤¿W<Нç'õ ˆûؽq~ϽRçíùñ¯Þ¿ó̊ߺ`Ç ^Ì}–º³ô(¼Wø­ê ¤H‹|ï—í\¹¼?¾Á>t®fÎç“§¬î@òdî>ŸÃ©÷j½YÖ¹q`øñ›>“‘žKqiufâ§û\ú s‰ðyõ ð÷Àsò·ÎIuR蘇÷õžÕ#ÉþŠÕ»àŬ/v¯­Î¡~ÉœéQ}EóìñÿísÍ~u‹~óFsÜÙ÷U’zœâ–Ѽ±ömX·Ä•ü¼¬>Bü#Ÿ„olhöŸýSG ¿³wü!Þ¡~4g§ýÈì)=²à^º¾îaõ9sØ[þ߯?ò΃xŽ8»Y}ã|OëU̩ͯ^Dú@œÃðzå3sþ¾ùsõº‰wªb>i~Þs²kέ¾ë®Ÿ?Áë©ÿ±õ'ôsߨaç¼õ4ú¼‚›k×sÞà‰ÖÅÑùsþé;fŸÚ2š 'Š÷áyëÕÏч ^ÞPêÕ[ãÙ½_y0õæ¦gØ9ëj?;Gt4G^¾C6~ÆýtÞà)÷’ß©®ä¨Ÿ”rš7Hœ7€Ä]í3ä7ósø vÀçˆà øžp/[W”8·uÞx™ØiÏѹÕá¿Úo™ý·¾ì«}c­{å^¶Ÿ(<`í§úŠøÏâ€Ô“«ÏáÁÙ-<¿ÍVw*ø>mœ8Ò1¯¾ðŠóÏÿÒaÑŸãžáGå;Ú¿Eï%|iq‘>Ks·äë˰ûêÃ[ÿM?G?V=rx…ÎÃLÿ0œ\=cúZ±#ì½~B~¬:Ï©ŸS76Öý;e·9g~öÅÇ q]³|/ÿÝ9×ÉG—Ïã¯ù™àæêø'·ïÆþÑI §–õëüЫà_دÎÙ3ç,ñ>?Ç¿é…÷<çy¼ã‰ùȺÃÜ‹ø¿ê‘›&¢·H'ÉÔóOÕÿ‰ßpÞÇq!ûÔõ‰Ýëâ©£lß|Ö©þp¤Û>‘Ñ$ö¤uÚé3ñž­§£¯9ŠóÚ‹ÏQOOG[ý²ÏÅ®vÞKÖÛúˆÌ­®®iÎ'^Äþ§‡oÀC5Ïšû׸9þÀ¾ŽçèŽø±A'8ç¾Ó¯´|òÚ[çìüœÞø>“'bgÕ!ЙŒh=‘ï…cè`:WêðK=ágôTÏš}Ð÷¿Ùy©'ÏwŸµÏK¼ŸsÓù.úUsZOe_â_Í iß¡¹SÁ1ÎwãØø¡êê—5×f”Wª®=¶ð`ÅÿÁAüœ÷§[Å^òCÕõ¥ƒ¯ÿ<ï_ˆ7ÈùãO:Ç2<[ûÙõ]Å_Àåçã/ñ'Öƒßã+õçô^šÏÍy`w­CuÂøéÄíìnpIëc¼Gã;ú5æTâÍQË=ñóì|ÔþÀ¬£>}«Ó?]ßÖ™éw/î¦çÁ~™Ï@7W¦ù›æÐ+†èΆ‡i^\¾<|*•óÓ:vþ£KÓù¯ð¸¾ZúÄ#\‹gbwͬ?¢ßê^fníÜm¾³çá+î2à—ìûlìcu"sNø}ù ¸Ä½À³ô\'ï²3¾¿}Jñ{ιs·_q„wÙëÞçü|õjsÎ;pÊ/ùýž¿ùÎß®qû xÐí»¿¶öXÿ÷O^ý”ç/›9y­}?rçi÷ÌyÚªëìE÷™9ý”{ö?uƒCûyÞÃÜ/öɾ›Ãs×ß;ú’®xá®Ëª‡‡£)Î<ÿ=·}•kÔßK}DÿŸ]/9_Ç­öõïý÷néÏ}÷±{_¶éKn.‘¾µþ;ûã¹ã¯úïêÎÊüØèBõß3·²ÿ¯¿Õûã•ÏY°Îå[n¶ñÀůÑÇÍ|Ða}ƒ“ÛW=wûïæm}òÿ®ÛAÛΜñ©?¼níe;ÊÛÂ'ýùŸ<üÛ·ýõÛ7Îüì-ÝöéÛ.ì½;ïÎå;éÎ#áçþ¼çºðø÷œðÑ›¿W?Ð~èÄ ú²ÌÛ7žq×[¿öƒ§6.çAÏ<ìå§=ü߇ïÓ×uêî[ç†9?/Þ‹ÎôœÑÕW–×d7Nøîó¿ö‚ŸÏü!ºæ›Ã'`ƒõŽýǺµµÖ~Sðj¿Ïþ¹æåt¾`ü]ÑyõüæwÑ0ŸE þ¨Nóôô÷უîrÑW—í×þ¾ãß¾ÿžoY馾Oæô÷ØOz/xùæƒpÒg?¼ÕåÕÛƒó²ÿòܳtþ2·i¸¯ùçÉù:éÏ~ózߨªç0ý½Ã½OŸ/^Ïþ˜_dÝ®üÍëv}Ë&› }´‰?ßÇϦÏÿ_î{òýÿ·®Âá³~®óûZ·Ì éÏýæ°£~µÇ+7>³¿¿=è÷Wî·òuãuæNŽæ2«+ÐO¦¿ïû­“~¿o?ä/kïpðûsY¿aÓw‰ÿ3oK¼aÿŽÙmåçlò’Ïœ½Ë†¬·Ú]íoûã#O9}«wX{ËÞ|îÝëÞç/;P»±ü ¯yêù?úú0/ q›ù´§ÿõ÷ï}Ù+nÎkî7?JŸN:îò•ÖzËQ·²/þÄ/Ùwú5}¯Ä±æ‚³‹ÖJßàØïÌùÿù¯scøýî{ôÕØqdçgNqÆ¿ü\zèôo.ÿÈS·Þjù;‡x-|’øÏ}Ú‹ó¿öaÖº:üû‚þ™9å1·}çw+ÜÕswîIkýd£ußÖç÷^gÞµ×Ý{<ó§C~ ùJó0³Ã÷çæóû÷ò*ù¾þ=üÛ>üøWö=¸{øüôÛËw臅GôÁë'e÷ðü _âÇäyùöÂù O0Ü#y¾)2k?Ž_úáƒ^ò•5fù½à†ú÷õ›>á¦ãvù{÷%û0ػحà•Ù÷uzŽúÿáûÿg}rùNoºãÂæMòþ³ì”ó|Ô×—ŽÇ…§ì;*γþþÞ=¿_´Ñ­Wüê¦a.>+OOsÀWÓ{ßÿÿé{÷»aæì †y1Óx~ˆÂ/À¿yïøÞ)?9Ë>9GÎÕ²»÷Û‹o=¶|^ûúéµå^Ç_ 87~ŸÝ7¹üä¹Á½xk<Þ”ž+¼l]ÅæUã«â—ñdz΋x0ç~ðgSÞg8WÓ9pýx3ujÞ^°ð[?ô}½×ü»õ©ð4NŸ'ƒŸœõ%ÉÏÏúùœ£þÿE»¯|Ø=xá,üÇ_$þéÏÃÑΑy0ò:Î5»_<>R¼•{>ëùðÞúûáUq>ÿež'>Óþ‰+;×0ù™ð.ÿÒÏZwö>ó‡8/x®Éyšåà ûïý+Ne_Ì)ËzÍŠ÷¯ŽãˆáóÃò3òüŸ¸Ï}€?F¸`–ÝÂÇàuí¿9’ôð W¬µéþ{_x.ÞlÖú^pê/çÿìŸç%¯ƒg³ßp^ðó,{Þ¹;y.8TÜ]œÜ/opî‹÷ûà­«¾zˆ_¦ñã`ÇâWñ¯{¾AØ©çÞøœ™#o«=Ϻ÷s¬Kðåp>¦Ï7œ÷©=œU¯ü2|^ö½8ð «-üÝ'/é¿ë Æ»–'I<“}ëÏó—ê|ðÎÃ8Žoeîð¬}uΪ+Qžï¬Óï¼Ï¯»¥xzÖyà/¾zÍ ËÎ]wyýûžøq°Oò—#?wšõ¼xGvFìþÓ„ÏǸ?R?wʹþÌUW¼¥|‘}pñ^øZ¼ÛØ~Àøäè¡ó0’—ãçðY§Yï)ÞýÿÚŽOyhõÕÅãòéøZ|pð÷ÀƒÄ>97î¹sÇÞã'ÄAc<Â'O>+n’÷ÊzõßõÁÙ—ÿzÕGœ¼ïZ­C‹=íÏ'îâúé|‡!ÞÎçŒy,öV¿Äî™W+ÿ'Þö‘^Yâ¸Hx^¾N’«ª›—Œy’ãv}ÒÓ7»ícåØQ~¸ücؼÞÖ¯OãÕ1žÎ]î^~”÷¦ãÎîéÃöÿòÐp~Âóó'îžÚyµ/ö휓Î}ȹû¼<; Ÿ0ËN:¿ž§à¢ï5ë>—v9<#;çûéçÙÈOŠoýÉN°³â qwò¬³ž‡„ÿãßjϬ«û%ΰ^ÎË8Ž2ßÌó?÷{}ÙÆ«Þ~äs»?¹?ýwûßÐr¿Åñc¿éùƒ÷þeœ·Â5ê‡ê¿2‡ÙßËgÁÉâ[ñEó·Éëâ¯;¯=q¼|:< A>¿ó¯éؘ;»èž»7“ºùu8SÜkÝð‚âªÖѨK.ò^Õ=ƒ[Ôãõù-¼vðÎ/ zRù9ßçÜ‹“ð4ãx°ó‹èÊ…ÇP­.†=`oåmåÙ/säWÙoº•Ëÿé\´?5Ÿ£îZ=>«õ=tGyRë¯n†cÇuû×F—>iî‡ýoÞ=üž8²ùòœ3u*Ößè\ÀQß >²óðÌÅÁËÆ¿«è|óàsñ–ŸÍíí=Àã:Ç&¸I\×yîáKåä-Íg²깜cëTý³ôßàÑZo©.˹S/ž¶> õ!ί:PýÁâÌêØç[?y"ï ?°#ðæçñ0p |Õù\æÄÈgª‡kýºúªÔG´n!ïß}Ï|¹ß^iŸUîX¥u=ê§Åòê@Ý;õm»•x°ú¶ôÓ²ì*¾¢ç…žqòã­‹²9oΓ{†ÈÏ zIùܬgu¢š_½/Æsîàuô{ïs/í'ü®NÆ=dgZ·so½°¡þ"÷>g÷øñÖA§Î½©î`ølü¿øŽ}æ§ü¾¼{ëåmGóq/÷ žÐ?§EsçY©oh¼ŸÏÓ‡‚¿è\ñämùú‘ü=Ü,áTŸO8Oý-áªÇÞªs“às²¿ì{®~§<‰ü\ì3ÞÝùV‡Ò¹Q¹§üMñBê"ø1õ“ì„züþ´úš©ÿé¼%sJèÇ¿óøÏÓyK¹WìþξuŽqöÇó¹7ã9Õì;Ñ9}9/ü:!¸þ¡ ï=ÚÏ{©‰ýkÛ·£ï.ö…ýrØßÎ  ßTß5¼ütç¾Çÿñßí«Íëh?@Ößsµ¿5çT¼T–èà—Œtôáëí;¿ÖOß~ÏQ8þÙs[×öïOxOë"¯êŽçM¨OòÞSsŸ8Ÿü<üÈß¶Î|znÚ?ê^òçö?Ä—W§n®kΡû÷Àeâiö»uíæÒŽægØ'ùk%ïA‡®tŽðÝâm<ÜxŠõ ?Ü|\ûgõ¿çœØ¯¾bùOxõIwÕyžÎYKüdÿù_õšÕ±ÏýÅxoþ§ºó‰#ÛÜ[}éìCçÄ?ŠKÄêcñ‘íߦÏMÿ[¿¾Á:æþÂ7îmÏ:o‰ ؉úñØóö‰ÆOÔoÐm7×Vøý=ê)Æü®ûØyùç ^.>€/ͯ7O)~ÏÕ¼ìÔŸOæoõîËž¸ÎSº¾ìŠúIq\ãý¬{û<ƒ;Ï3ûÁOã}ª«‘çaGÏ/ÞêÜî芎ù%|CçNf_Ø‹óO¾ûg¿zÓaÃsèMŽWUŸÑ¹TY'ü-ÜäÿñöîoñOü1\Ù9³ê½ÍÇÕÏ>.qOÅÓÕc§ÈçòKâëÖmæ9ðŸŽÇ¡[»Ü{–óGÏ´ý±±¯ÕcÑWèß?ˆÇøSï­ÊúµKŸ~üUíR§ÚKöÞ÷eÿð+âbq†÷myÎ¥¼Dû¡c‡àS¸¿¸*~ˆ½â%g~¿Y>=ÏãÚçê'¤¨¸w4OÎß»âÖ⥬n¦/0®s¦·À¯áÄöÍûËûÙwø·þÈtø'q.œæžõIʆWU§Âþ´ï&çLÞC?‡ï“Gã§à8­º)‰ËàžÖ7ÅŽ9'ú%ıðûÍ—gá!~7uµCH>‡]Áðâ­ÎÍþ\¶Ë WX÷™/ã­Ý8£ü^î¿éÔ/ã:O,ïÑ>ç<7üÁ>ð?ðRu?ôÃÅÁñ’WâgÇýcxsû¨cvÛè+ˆŸÚw›s+/â<Ø÷êxè÷ ObÅî;+Þ- Oè{=GùÉà\¸W§;Öß_Ó_´>t#ç5vk2wûOíøŒ?}jЕ‘¾ÝÎwÖÑ/¥]=Xß“>¦êG« OCïm2罟üøE'ïQá£ðŒ±K“¹·¶ùNkQÝk8•®~ð4¾tCã§Ø[uÔpý§q?Ÿç®~¾>ñ\÷˜â‡êáÓÏõóÖgî‰k~þèå «÷WÜŸx@Ÿ0Äö;ÂùôNFó¯ôýòížê‰–?Iàpn¢oÈYßê¨F·ždu~óýòûÕe ŽÂ·†ï£B/­ý»Ñ뜓Ø÷t<ߦýô±_Õ!~À3W—Œ®Câ_ü¾|­<?"ï /.®êÞ©¿mþ~VÎKuÙM÷Öûá!èdznqCuÂñ7ò^øaHÖU\ï<«'¬þ¿’ÿÏûÔ¿°[ÁU³ê«ç%û þ`Ÿ_åyä‘éѹ4Çjγž°×eûGí«¾6:TòwÕ+¡/C'=úDãÄœ/ûɞ˚gAßAß_ëȲ¯ðqú˜k'àB~¹ùuÇêyÂð ì½s—s3™ûÑS÷[õ‡ :üæ&§/¯ ®ðüõã¹ÕÍ}©~Mžw¬7èsz£Ï¡n¯aÝä娙ò`ôï­ûT]ðêáÓŽþ¼>a÷ÿS=uó5ä#_ã3:WÁüèè±§xú Õ»‰?À£uNhð0|Ðù6ѹ0?aî ×mÿâ¹Kº~±sÜéÜŸ‰wæ¿m×_ï¸ë°®ÎIÏiü4¿X½¶Ä›³eNIÖSþ¾zˆêNôç¤ÞF}\çÄfÿ;—+¼ˆx\žB^Ñ:Ö_š/œçvŸèæòg±{£Öùž;ûoΈ¿ïbz£ñgt`ªÃœÈOˆcøYý„øiLç Oà©«ç{£ÞQÝú%q<û Ï\½íœ<°u®àob¯Ôáã«O%?Ÿ|·zHöÑÏu®û2µGÝ'úÈÑI¬]’Áv>‘|òWú"ÔÑÁ#ìž¿ï|²ð¶pªx¯ºoìåÔîwnKõÃoš£ÿvŸã¯¬{ç„å߃ ê—áT¼xþ¬¾râ?÷šèý¡?ÿ‡°­O0OË\gþ8ñcøÉ¼ý>ºóFŸ¼a˜gþEpSðaùRõuòÍÕqb?ÔT<ëiŸÌ–—…φÏñ{pjãfzy£ïWÔ÷ݪ¾~òÕUÌy6OQ†/ö|­k§{8ݯa>Lîw¾g2çò/úážÝüTûcÂ_ÐÄ‹È{µ4øžm^/ñ ¾¼s´c×øë†ÿ«n¼ø†_¡·žù“s?8³ÛÓ{ÙéÂñëê…¬}ÇÓƒã/ÍÇ¡»Ã®v^høç®zÑpJì»ü?»ÅÑaõþúoåÞ‰óøAq´øÍ¥Î¹0Ÿ .Ž]âgåŸù§æ3¦y¯Ú#8“?®ÎRüþxŽWu^ƒ «ÏK'˜¾eø¼^ Oc»ïtÿÜ õüxÞÛ½À¿ðCÅ5ì©9Yá7¼ÇX_Þ\þ~4·±óÄãgÚxÛÜ ø[úƒü¿d¿ZWœü‹z`yþòjS{P¿e}ùùæ'ÿ9ÁËÕ‹ N.å}ðç­»Ìçª3¬Fpþpë®ÏA]dûÿòyðyõ›c?Õ‘´Ïfš'ª}R_دÎG ~–WãÅ+ò÷úô¬sy#ýKSÞ¨så[G)ûj=øOq üU<›u÷yÉŸ´ï*yýþ=Ÿú=ÂÿwžwΣ¼¶x\<æýÛo(–¸Å½’×hßdÞÏ=À‹VçÜü«±îcø{ö®þð½ýRõ]Ô#È3êgð>êk[ÿ»áyÛoûª¶üzå麗¯TÏÈÏË·°ÿp1ûT\‘ïW_£¯HüEw¯ Þn]vÎ)¼èþÃmη÷pþäõØ¥ÎC ^€ÏÚw‘}÷§º/ò9ðŠxÙyÓ?^žZÝoðJüÀ›S‡;[>šWãÄåâ3}¥ž§uæ‰{Å»â(øÚyösúBoq…ø.nkž#þ¢ó€ð4xP÷B¼¢þ¬}}‰²Ëõëñ»­wÍ>ÊV§<ç°ùá)>(/¿6/Nox4g€e¯š¢‹ln€ù0ñÕ…ÉçòËâFu"x4sÀí?ÃÞÈsà}ðêê¨áöLžÍ¹nxÞ—_°®å5ÌÌ{²ìà˜Ÿ·Nþž]‚sä§ñ0ö£}ñ3pwëÍ—¨‚ïñò¦ã:÷¿T»—z7ö½ýG±#­ßl;<­8[Þ•~mýH·}a§áv¶uäyïØÝÚý®ƒúôä:‡%<¸|??$N…¿­¯z8©ø)ö›]€w;÷]¹~Ïû—o?vøÖÎÇU/‘ç‚ÇàwçÁó«+a=Ç1þì™G¿ãÒâtyJŸ#ïÅžŠkícubÆüCëŠétg;oxûÙ~èœ öÞúø\çÎçâe­?»G÷ÂùôœÖÍ:7ŒûFýTÍϘœûä¾ÃKåÑõIÓ9Ͻ…×ZO®N\fÞ†»Ôߩ㡿ҹdÙÖA¦>î?j½‚~Œ¬#>‡ŽIõ ‚OÙCóQèzW‡>ß_ýù¼ø´¼¾ùYêë䂟à2ÏS|¼äù[¾èÌ ?ÿس¿9èÕöÜÒ…ÝÕg„/”/ÆSt¾YúšG ž×tŽ:ž~¾Î[‰?¥Už4û霪‡/n ÞiAúÆvD=sõþ¢Wä¹Å“ò>î ÞV^˽`OË3ÅÏêßp_ijÖW¾_'„/,^t¿ËįëCå#Üv´sƃKűå_ô{¯ù÷ÎÍQo\ÙùœáYÕ¹â­ñ¼)öD>ž_´íóŽŸ«½7Xž?ó—ÅmòÔÞ³ý ±â q?Yû;è!Äߣø÷K^¹ù¢œ_vÀýq{.²ìüÿe—:Ç8ø—à7¼§õcùqu³ìÝ"ü ¾Ú½€ÛÌ·ß{ÏêÄ¿W§ ñqùàü»ó­Ž£<½¾ðAžŽdœ}QîólÝðåíw‹}+H—(ö]_vûbôaej¿èëä\Žæs v$þ©õª9?÷¬õÝø¥ß ç0u2ž×¹lþ1õp8| GŠK}ŽsÐø*÷Áùôûê?ÆýfòTð¦ø±|Dâ¼°÷°þx~«úÁp"¼2Öip¯à²ò.âÆÔoˆSýI/׺ð[ò.ìFçO„'W·Éò;kþS"ü û ‹/Õ«þó*ÜwΜ‡>®ñ}óEðuü©zS~g\Ÿ–{Ózœæ©’'¬}´áIØãæ‰éŒæç°'ì<”ß¿çÒC6Úo×­‹Úœ¼»zCç±|µüCì‰u…ë<—ut.ZûÛºÜQýš8¦uÒùÿ>'ž>Š×ð¬•ç«ýÁÓ‡÷Ç#Ê7áIÊç…Yð–ekn·ßeêøß[FŸßH×ÀsÃux£ÖM°ãYoø§ûk¾‘uNüïß“—ŸÌÛf·?àÆgמ:~žhŸpÎxq¤Vþµó¿ƒÔ¿Ï—÷åø©êiåÜÁ¡Î[ëhFç¾ð÷ìhç9…wh>-~.mý`ø?ïïáÙÖ“Äî7o^løBqºuäwÝoyÁÖšg˜¸RžT|ÏîáÛZ_Ag0ß[½”ÜËöcÉW»‡x:y]õÆ©›×mØq<žºu:æ·ú{õ‘êà:ï:ïÝyxyÚ;}*y/øc¬cdÝÛÇ•÷±O㕼">Sþ´ù/çøÈ9+=æÊŸvÝðíK¤‡®ÿN½¸ï˹i}®ºu|¨¹Ä¹Îº°9_xꥇ½õ˜Aï1yhøÁ}wŠgáÞÆâÙäµÙ¿à‘ÉœO}ñ»ïô!ì[Ÿ'ïóß,>õ«7=¦ùX|1{Ð÷EÛÌýU?Þå‡Ýw|¢zéÎÅUŸ»Â®±;­ß¦75Åדù'>eϽü澯ó#ÿ¥nF¾¿ý Gm³þ²í‡¼9?ìýåSZ‡2=ÿ“y·ÿu»m¶_¥8ÐzËëÊ+ó»­ ³–øO<ϱ³ê5zâ‹#ð–ñ×ÖÕ~¶n!ýšã9óåO×ô¹èÕÀ‰ÍÛ8?ñ‡Õ—]iSp{й‰ÓÏúS/Äþ°ígø™ö¯ä{z’ÿ)?š{Ôþc÷6÷~óÿÅCYW~AŸ`õkÌqÎsz®ò øñà,û^v2o¯^ô¨ç?uÐ+ÈûŒí¶ýë<ððxðBûxÕǪg‰ß«>"{~¡ó’á€ÔqãóšÐ6Å#훟W/+<—sô¹äQ³Nílj=tíCû=õõ†ƒßð!¾·z¡±·á1&s^yü!yã‡û™üRq_>·ö öOߘ7RwU˜üy):¹x‰öÓÄ?ù^üzç9??™wÓæ/}ð›Žêüã?«“OÇNÀ¯½ÿñÏÕÅÒo¨^_tÎAÖa2ç쯬ø¥ÿ:à_:ž±C­L¼Š×v^ÝûÎ?žâ’Þ÷âË‘žOíXìÕüݹÙ̹ †º}üÍtÛça}ä½—}lý«9ðÎaê2«nζ|FâúÆCñ[øÕÖšCÌšGžsâ^³ â'ÏW=z£ôbs®ý\ýgü@ë|rϽOãÂäð€ÝG<\î{yçI\ßï<åø!öŒ^Cë[ó9Ö©úÂâ³øøE}£ºGxÊ>Á»žoÂ~«ÿ˜ûç±æâ›ÇÅ+‹ÃØö¹sÄcwÛg®uÖ¹þ8~A^ªs‹Gç.UP’8pŒ+ñɽ¯±ÖÞm|ì.…ª ÎëÜw¸^‹x'ç»ù윧öSºS;Þû ?ÐÁ€›ðì(;7Ö9‚ßZÿó$.¶_9ø>¨ßŒ°î¾¿z+é#³p$ ñYùÌÄ©µ[î]ìYûãÃ/&®ªŸÁ ÃMãsÁÞǨÏzµn#ö™¿ðî^.Âk•ÇN|à|—ßÍ>ÓðÕÛÈù‡º¿íŒýR_)>w›GÒÇ3ÂiÍ‹¯ísâ£1_Ñü>Þ^½±¼iâ4÷Uü¦Ni¼™xvÑæ“m¼îîA§uê7&sþ°×ý?¶Ê‰C¾Ís%~·¹Ÿì{^=1ºÁÁ[½‡yv°|CìZú½&óÝúÁO}q•A? _õ¨nCx‡>gü…~:ç(ø¢õqú(ÊÐwÍþV’dì^¬vŽn$ÜÜ6î‚¯Ø þ…ÿƒüûT¾KßÖè|4®%®pîñKâ0÷e}c­[çV›ï>Òñ­SÔ×6}ïÉ}¶yØ>/:ù/µcâàòzú²c_Ø)ç­ûç¯1™³å™={…C]6>;vÙ{ðƒµÇê¡’¿‡û­§þh8Žë?àØ#ûS‹.‡¼`üXíZøàòá ô=¹_ü¿sÞ¹ænGt=³NÞÃ~¨›*âsâ?Êsä}g­GüA÷oz&ãºvç¢:ÃÁŸ¾ÿâÏÕyÁ‹ìhû Ôí±Ãt.RßÖúýPî{îwëj‚ïÆïϞğ?ù^ç½q<@üœu‡GÚo¿%à|ë'i¿…|ü…¼`û&c?Õ¥ÑÕ)NýÇ¿ì»[<¿&O ‡á]äç䟬;¿,Ñ:޸׿Ìu ?4çß¿þâ|»ñûÚ¾žQ¿PùßCŸ(ëTž/÷M\á½²þ“yWÿä¿Oß{—žoqOñVpLu’Õ¥‰c'Ø[õVübûŸñìñÇü3\Ñþ÷,vPšÑ}eWèïú^ë`ü|y–øv•*—{Q½§¼—¸?Ö{“÷oÿkúd«Ã('¿?åŸrOÊ£ÈKWÐA,ï˜ûÓüvιu¬Îîgïqò•xþ¼~Ü×:ÔÞõÌyâ'ü~õ´Ä‡y¿úË‘½v¯Û¿œõ6ï¯&!n·¾þl$N¥‡4Ò_+O”÷iÒHÇ…½uZAg(¸Ü¹(®ƒ÷ôãÓU ß\Ý)ú§Ùwzâís >âoÄwî‘çÏz·ß_]Ü¿ÊËÃsåàý²Õ•ÂËÃÛêzóyõ‡æ½ÑA ]u,/ïÒŒ¿(ßšó ¯W·ÙÜõ=©³³¾Î¯²Ïøãúð½ÛԽƟ•Ÿe·².ö§÷;ûWÍóMæn²Ï3®–ïLÿyÏ ÿ8”ݤçQ/çߤÞQ=‹}IÜP^ÃùÇËò‘Í£óCÕQ lãH‹^Ð¸Ž‚ÿ£0÷¼[÷ýþÑÇõþ·¿5ñ¡óÞ{,žWOë\‡þ ù¶õÕµ#žß¹nß~®Ï=í:Oïau’›W?r.ÅSxOëÖ<Ÿ{%’ç…›õûŠ7ªK’Ïã¯Ú×ü]¾RÞW=YâÏæbwà/uŠp?=Ã9;oü¨g¬´ópŽâé„·/âÞz:“yüûƒxË¢úù±â®ÜSùÜöqÇðâ™öOÆÞ[¿žËü\ãq:<¸=ëæToAœ,/’ý£¯ÀŸ·¾5÷µqý6ú-#}áæå‡óçX§õÓsQ?*¯Ø¸[UøvŒôüp?ûY}iñcúÌGÓw”ON|–÷.uîªKý~þ¸}£þðæOóy ßz÷~pбþþÛÎç_ö顯ƒ½Ò7oÕ•ñKcžÉß»ãzZ÷•ÑG»P>«zõâ]u@‰ßÕµŠ}~úv&ó'ûœcxËy«Þiâ$~æžÉ7YëË;õä꧸­xLÜ©¾Â:Ãc}5ç¿õÏS?8™·ò/N¼ôS/ôFà“œ‡êåœuþ%²ø8®õyÿq=Ñ8®€ƒæ\³ÅÚË–>©öEß»þŠÎ)wÈ£gœWõ¦©î2x›?ìûå¾ãÃÕßYGþ…_“¿ðCµ§ÓsP¿8®w¨=K¼»Uüg½Ä×0µGC} óÔ‘ÀKÍ3ãñ‰¹WÕÑÑžóå}­ƒ¸²|›º ñ&½RùùÄoÍÿê[ «Î¼|Dì°sY)qõ¼®ù†¯ì3ä=ªÛeMÎqêºÕû½+®R÷®ž;üzõÊbŸÊ_×g}†ù윖ü_û²ßôåZ·5â]éMô>‰Sùy´ûãûË?Èç$o/«ol>5ç¥õf釈}iývóÉòlôòÕªw33v­yœêÁà™àö¥:`êØb¯Çu­ÿ?l½®÷ÒÏ>žòòòx˜à68@¼+¿àžZçê–$îŸí'ýåÁøaö)qbõÊ›wSÏ<Í{TG®ú‹ùý9cÛ¯äçƒçG†gPÖ:ðœûR> ç«÷A=¦ú"|'Ÿ#þfçÏ×ÿ6/‚§žâlº©­3h^Uý„<½5yÒQ¿€üœ~ãò æFMã§ê´V7ßüü|ëSñVñŸ£¹Õ_nhì¹}j_Õ?UÒùõ#OærɶÏßåYÃ}Ó/þyÁW¾qØgŸ0¿ëáù«£˜sʲ¿­“¿ˆž³üyë*ä]ò9ò{¶ù?qòÇÝöÜÿê×çäùË>gì¾qÌ—À âàêóâϧv©ø@¾±õ9Á)þt®ñ„ü¡sÖ~ÙØ“ÞóÔ,xÌ×¾¸á®÷Ôo5îWåþµŸ3ç¿C_}ì6¼ÒzŠð#p=\^¾Ó\$ñeâ»òò9x ù8ó·ßµ©{nBì¼mŸ­[ç_æ·Mÿlœê{Ú_—óÛ|†>¬/>½ùÕô=ˆ7Õ™ð+åõÕÙ§_aÁZ{ìø¬³nx³øö›xxùr¼¬ó<ÿž-nºé»O¬¨ÞjüåžtžWîay¸O}Ÿ:Ûð+á;±uH9/9§µ£üCõòù¿Ôã•Ø™Ôç{‡øoìÜ«ÊsvLp‚çë|#ùãÔ9á÷ðÚó~úoXá­ ^>uîaçråsk7è§OÏMýByåðPxRñTã]ýf¹­ºw{ŸÃzòâøö“Êgêãç˜o{"oÄßÒWÑÏ2k>-Þ.…»á ólRR}ìÜËö'ª¯Ï÷ôþÓÁŽßl_¸üݨß9©Žºz%vl4ÿµyàà•êB'¾Oª¼¨?®º“Ε~ yô‘|Óº¯øcv©õµ¹×ptqÇÈî5ž§ëþþÃ÷¶?kT·î ½òa3ßêZåW¿ðMx²òYovñÝÿ×¶ýócLj¯;Ë< =ôœƒú±œoýÍ£eÿűü-¿YmúBæiÁ_øéðÕQÈþVGÁsæ¹gõ7‰£ØÅ<ûwÔâK}ž|–ú;¸éâ |_ó+ôäéõ'_Ð<ùô¼µ?/Ú:’Øu˜âZŸ×ºõ8©{n?ßtÿ—´Ï6x½|žüeö‹¾MùNñFì;|Wýu¹Y÷?æïZŸÜů‹›;׿Þõ©å[¯7ªè<äÄÑåÑÇ}åê"ñOΉ~ õ÷™çÖ8iêG:W²ù±Ä•ÕMJœ]ûœ{ØúƒØóây:Ü©ëÍ_ë;_Zöϸ‡éçË;›ssÑ:‚äY;×1üeï?Á¯9o;è·ªßS/™óØyÁ#­ιh¿Sì³8ŸáÇëS÷¤Ü:Âý¹õeêìÕkÇ^ªãk¢|JòVÓ”ý­>Œz#z(ò.Î{ì¿ú£q'ÜY]!ý9/³ðoÖ·ó)ôµÂ£ê-Æ:x&z‡t9ùÃðpÅïáZ¿—x£öqÌG„gn_‹Ÿ3çÚüíœ'ç]<@[ÿ3¿ß«ýh£y"­ˆ}åÏÙïåßÙ~ÓÕî¼¹ö¨û“z¨ò ™ÃaØ÷âàöåÁ/K ÏÅî9ÏóNzåʯÿîÒ¡>#þ0÷¡|,Üœz—Yõ§ìMçÜ™?ÆŸOídý ~ÆsÕž¤o)甯wÙµÖÉçfîX/U\âœ×.˜·¤¾K´úÛäñÕÎûøï»ì¯/˜,üó_õÌ#¶-~g'~³þQ\übΔ÷wŸÙ‹öIª«¤¡ÿ]_¦y´ÓsÓzáúëܨþ~©.:¾1<ü¼9?ù˜÷|²õ7øTþ¶}¬ñiÎox–žSu¬î+{6š»”ûÒº†æmÍýÒw“{UÞ<V~ι2Ǫ:ëÓx²ý°x£Æ}ú=Õëò úòó>W|ÉNñŸÕ‹ >t/«“0µ£ÅÍ·åžW‡b4§ž­ÞÞHoZœÔzï|_ëbZo—:)x¥sYè&^j?ž{zZ¿Óóšs-þhÞ0õêÇõÏ97Ý¿±®f秛ǃïõ)³‡Ö§u&± ­ÃÙ¸"õCð.«^t<§)ñoóÍüËâ­¾ñ˜ÝtýÁÉÂý6{Æ•ûí3Yð›ûwÇ“ÿ4Y°ø¸m–=ðGô£&ó§öb²`ïÎxØJë×î-¼ô™ ¾rÌ]“ù»}øuwüïÊôÑäÁÙáÉ‚ó~ôøžýÉÂ{Þ÷ÛKoúëdáÒÅWmõÁÇOܱÎÏXï“æ>N–ÎÜ=çàûìGWe²`²Ó‚_4g2ÿ¶KoYã¼øü>ïü~jÁ{VØh²`«Mýô}ÿw2óƒ6¿éèÉð÷yŸ¾ßïwîšÏùÆdÁÇ.Zÿ¿øÝdáÆÏÛ~ûþùï[¿÷¼_÷*º`“EW?èôÓ/|ædá;w¼ò[~¥{ˆÿtœ¦ço²ô~O8æñï;D_üdáWvùÒu÷;n2ÿêϼð‰ï}¶8;âs'‹.ýðU/¹ã“…Õ¯~½ñ-ê'sÿ°ý-WÜù‰É‚#Ÿö¡5/ÚI>ß<Ùî_æCÓEû¸ÙªÛAžh²èã|äÄKž,:õí^õÙ3ú¹‰'áX:œò“…«|ìö׬öK}Ï“E«n÷­­¶½€ýíºù^ûEw,qûdþ}_Ëÿx­ú€É¢õ×ùÌI{ÝÒó´`ùK¾öùÛù¥É¼GßöÖzgãz?ïÜE‡³û¹ð7»œþœ÷¬<™ÿƒï>kõ-V,¼q—c^qüs'ó÷ÞçÆß>öŸë6ÍïLæÿ?<ýuu=ß ç|÷ô÷môËž³…kö«.ù§Ý‹ý´ú!“%+/û·Ç.½^OýêdñúoÏò ¿Ûü⢷.ÛbÁç÷˜,øÐÞòëk¯îy[²øŽUv9ÿ×}ïyÿñ¿÷ÌÓðWâùÉ‚ƒ-ùë>F/®Ï±hÝÃÿºïóžØÏ›·üæm¯<òØá}¦y¾YÏß}Éù ™,x×9[~Ðc&ó6ýǾøÀOyÀ×Ì=^ýÝdÑâWvÑÃ<™·Ú‡þ÷o{þ¢û¾`§g­wË¿Õsξ¸Ÿ‹NÛú»ïý”É¢oý~Ë?tÀð9öa«w_öÄužÒ÷ë>æ¼ùüE/ÚbÞ“>s÷dþûÜ÷Ãg=|®Ï›ÖéMï½é9o~ñ¥µ[½§Ózšaò¼Îϼ­>wÏé/|ïðù{â›ÿþ¾É¼_<ã¸}ϾU}«yܽ§É_Nžð¿=oõw÷\ÎÿÅêß»ãÈÃå›'‹7Þ廼u‡ÉÂ'·ÕW¿x¿¾ÿÂ~±ÁmûçýÙüÂ#÷ŠyêD'‹Özð9g®yzßþË޵ƦozÉdÑÆß8æˆ;.žo:·¥Ï±xòø/?ìñ¯™,8ño»ò©?,9äá?¿ý—ÀÑú>;yÆ¿ÿõ¤¿ÿ²ç°v"ë’ú‹ùOÿÊäý[í¬.±ûÍŽ»‡ì{â|—N²ÒöýÛ7'‹×üÒ}×xý¢ÞË¥K^ôûßlÿO±ê«_zøã¾Ùý\üÂK>óÒ?| Ÿïýî½ùÏþç¦;jœŸùç­tÙËÎ>×{θÞwÁú_^ôÑûÿtXÿ‘½µOás' ®ºóés=µë·ø{­ùˆMíôÕG¿ò¾/®Ý­Ÿ{Ñ‹^´ïWŸX]—àéÉâO|╯º¦~!þ¦u¨Áµ‹o¿õýgmµÞdÑVo|Ý“~ÿÜáݾÇõ‡©úÄ]'~µþ(~Ñý[°Ùaí~ú/úÞö£ç|Z?Y4³÷FoüÝÂÚ÷Æú/<ýÕ¯½tå‡ï_ÈÏã›êÙiuá‹æï÷߯;`ûƒ{ïàyïÞråû|èþ“%Oúæ]/ÝnR{—õ©þ©ó“:3uvÞYyƒßþ–/‰[{ÏùCïÍ.¤^°öß¹á¿ÙÓù7?~‹K0à)ûRã¾í³ö[Þ°å.Ö¿¸“v~<·{>óâ®Å«ì¹Ã¢/×çvœSû®ß%~]ôÛ§mð¥ßÜV¿ÇÞ:Ïó^tæÏøÂQ]ßÔ‰Ô^Ù/þÃ~²3‰‹ËS,X÷ÛwyÚóü1ßûÜì#?WØÇ>œ“ç¯_Ê:Õ¯ä|ÇŠ÷ê?ßï “'?á¢Éü/ßòêSç6Y¼ÛÒ7l·äöžà’®Ÿ{”z¾=ú´wl²ÅwŠë=úà—4óÆò±'æNžÿ½­]öŽÚÇâÒo¯´Ï*w¬2œ›œcù­äz?Ü[xµ¸9ûëyÙo86y¤ÉÒmV8ø¨W}œ=GÔ®û<þ .tNR\?į$~*޽ªŽr×uŠÓÚÿš:‰ú ¸Ô9\²Ö&_?ç%ÇTG7yæÚ!ÏÇžúϹxϧ=r«Swï=¶>pš÷„›àqöž]àg3?x²ð…{T ë¿Züó'îâ7pöã¿u÷zCÜï}øƒžóدÅKÞôŽïÍÛªv%¼qíTqUðÿÑxsÊ?ÿº7ìçwƒ?ZnÝ|.œh?ì§úÆÌ%ðBü ÿïž;çü¥ýp_ØéÄe=õáRï4à‡ØÙø[uÈõÿ9ßî}ðK×<ö —¾ùÙ§ÄK¦ùÁÚ鬛|kíÅüß<þò}7ydÏÜü"^«¸\¼ G²æ;ÂaųY÷%™óŒ—¿áà-vLÜ%N®_ùázg¯zÚÖX\Ûx5öŽ…kË3ˆSƒÃÃkO¼ë'ÎxÐô{§~Ù~ñâ9qfðXíœ~ŠŸµÎíSÊùöÞì|y¨ÄgÎWãt8A¼çûbWjG‚ÿü¼8Ù¹‰ÝîYîñâ9k=ì;™”w˜û¹'ŸûüÇþ¡~^.>Ï=ã„Åû¼æ¤Ÿ|ø¥íS¤Šï§voÅÕ‹núü)¯úÒFà[x ÿ²àÆo\zëe»O}èƒ<ñ¢už)?ÏNÔNå|¹Ï‹O\ð§?qt×¾ògñSì_í…Çd—ð»­ü¤5޹®þ¬Ï?P¿ûà¾/9íÇ{½üÈÉ€›ùË)ÿ9ð´Ó:‚ò¢‹Ÿ´ã£nÝàùC¼ü×s0ÝuÅŸÅpaþ?ºmµ'í;J=ŠúÆäó‹3؇¯R½{ïË®;¯Kvüáýž÷ôŠÓÇçÞcw’§èùÎý’—ì9Ïý,ÿÏO‹“òû­?j_[øWùP¼;=å·¯z]ùyuæmVߊn[òãò’òaò£³òŽS]ƒÆcêïÓ'Û:,ùuò~Í7ò£t,äR÷Ò8V€óä=»žñ_ã¹8ê¤äûÕOÓc¡KÓzçQÝtç›d_Ø ýŒí«Éy¡û`Ψ:y¼êÐ]ˆ?¥sÚy5Y·Q¿Lãy]ù=ú²êñÜO}šµ¯Sûߺ‰ê¦¤'}ªÍ?ªÛQ¿fzÿ’/÷ûÕùÉþ¶žGcò»­C²ïѧ輷ÄÝúIZ¯{1ÖáîùM°ù_}“ú@õ‹d¿Ôµ7­¾5ý2ò¨ý~ý¢©Si½2Ý%ùÛ<§Ï·^==Ç­ãHu¨«ͯt^Ükë-¯/9®{Ç¿D/¯}öúFú£ÕÕk}jú;çÐïé£T‡`¨³©Žô¨µu½ê·R¯¨Ž]ý§ù—ÉG7nbOS·QݼöQ׋kÔè»jIêŽRWT?×}õGTgnzÞ†õJfûÕÓ‡m½œÏÞ u±3˜zÂÖŒô-:—(8ýQç¨.FÝ`ëA‡àËÕñ´4ϧ^žÿWŸØºUß›ú[u3 Î=öµø!çȽv?þüÆÏíqÚ¾Ýzýùì6]ŒÖ—eGsZ[Z]£Ôqµž*uµÝ?z©W¯¾:ÁÔWT_7ûÚÏSŸ@0ϧn¯}ôôɘ—6õ­[m}rî!ÿRúÔêbŸªëªß”NÁ½õ)ëw[Ï•~³úØê†¥ßVeë£R/Á/Ð;ª^Lê":¿‚žKêè« ¡>,þ£ýEôÕ‰ÓÉVG“úeõp[ë^ã/Õ;Ë߉ãƒÿ‹OŠcS?S½­¬WûqÔ·›Bï'vκ«S‡Ÿô¿Ó;7´~¸ùCôJ2_£÷Ôü8€.ý‡ô-·.•NDÎeí¼y ±³íÖߜݺóà‹öU§^¼º‚yÏÑü´AJÝcâ}±ÕM]TëÜømºûææêc—ÜKõ‹ñ{Õ] Îh}•>kúÝé÷Çòò$C\‘>æY82ñ¦{ÚÏMVõŒé"§N ^Uo‘¹éÝg~¤}²ù÷ÚÏÔßÁiüAë¡é+šw`þSô£Ô/ª×gÿZgO‡•nº*þ?~%õÍÏ/»ŸÕG ^¬NÑhÞ‘ub§ÆöAŸ‚óA‡?¢gÇo·ú ÙÿÎ÷áÏô/_©óTÿ:ž¯d]Ûê·ÁéÖi\«ÎÛ3úYêÏÁú܃çÝ¿ê+æ3W¯Ì¼Îàîëçüló~º]ãÀÆqé«v~;—Ô¼ºÇê¦éòªËÝR_YünŽ:ÿ¬¿Ðý`/è»e_Ôv>–~ ø_úrSÇ;´ïË=Îj®þØé~ú5êˆï]ï;{–ùt.R«nT±ºù¬Cÿ.àoZ+žM}¢u+žÒ'<šã϶/G=8œBOH¼“ókÿÚÇ’s{õòƒžö¨™³‡¸*¸¼ë6šãæ÷ôCúùê3ê‹ œ¾²Y}ÉÁ»×ÍÙíƒ{¾ëžY}ƒÕ ÓÀN¥¾¼uÌpLú·kïÌigçùÕ±z¿òñ÷ú8àEvªuÃ#;ß~Ä“òü³¹‰â>÷¡ó®£—Ⱦ´¿Uÿ\tý̱vÎõ‡°ãèÅ.tn*½ú(æx™[A)ç§vrÔ—\½ÜèôÆ^µ.•ýêüÍi]îPóÝ9‰g«¿¢2ç£ýO÷îÙ5/´sãGÛ—šûëýÇúÇK¼Ý¾+}²ô¸Í¦ì|›7¾Ü±þ¼TýÔø¥ö©Ð5§›onEì7\ïù;gœN<{â'bÇÛ;ásñM#¼[¼¦X¼¬_Ãóøy<]ýcúå?¨ó§‡kN¦x+çy¬‡Uý‹ìcí_x©Æsú˜èk²Õ±õ§v^DpJúÞËëëSçW÷‰»ØñißPyÆâ‡èà7ëWõLŸ§qµxÇ:‹SèI&¿?ÌG¢ç4ÆÓõ³#žš½«]Èóüù¹¯yÇÎÏ~É  ïé÷ ïâ9|¾Ëò~üeÞO½†¾œêoF/³:Ä÷æÉ«ûÎŽ–ïLܾ®Ìoî<]s‹ø}x9zž£~òâ2qØ´Þ{Г埢?ØýÅ õôsrï“(Þsûûx’Ü'~»u^ñkÕG‰w~ýÙ¼ûtÝýÈi|Û¼»Ÿø¢úúÎCçf&þ0b4×hèÃMü^©Ô[G±|]qZ~^ÞD|ê>çtotÿË›¤.ßó°_âêÎý¢{ž:CyÖÁÃÛÉ+©CÑ×3žW×~ÎØƒÆ÷æ”æÜÐÓð¾t:_Œ¾_ü>>?ì:Ow®¸>ÆäÙSW2èýѹÉ÷w^yÄt åÉÌý >7ð»ô9ÜËðêú†àÙú½øƒêžæ}ù¿‡Ïq¿ðÝüÏXÇ´÷Yß|úòÄÓÎQçáä{Z¿¢ÿ>ô¹ü@uêè&f?àÆÆ½÷Ö÷*£®*u›ƒßÉ{ö¹‚/èÍÀ“å¯ù»è‡t®'ÝóƒƒÇüYõÖè2ÄVçe¤“·ÈúU'¸:1Y'ûQÙø?ûÞû”ubçá'8/ûÜõ.Ï”s#åû[×ß‹ýõ>Í_ÑïÌý1WºóDâ7£ë4ì_úú:·O™ŸçïØ)ëIªs:â¿òÍËÄùTù㬫óÃ^w.Ùø½òAø»>çH¯±ýÁé'çOñÕÏŽßkßdp–ø§sDáyó§º1í룧"¯XýY|©u‹}.¾¢“{Å>T·4üuyHº¥±¿þ½ï<ƒGšuÄýâqýˆæg~\&ÏÑ{F§"¼½{uokGÏ–_ϹÏÁn¹ynôã_ä\÷¹ª×äü6~ŠTê¾z{~ùzòºSÿ¯î©ëV=ìÄGüõU}õ 7Ïür–Ž{uðùîwî+Yþ0v½ëÜ#úmSû;Ôµ†·£C×¾å|¾zñfû¤s~ñÛ‰Z§-ŸÈ¯T,õ&#Šââæßb?ª“xÄ=i]Bü…¿v>{ÏÉþÈ+U¿ˆÎ@ÖýlyÌæáàq„¼|ô¯k—¢Cˆ—¬‘‹nÊH/dÐ1MP(ÝÞ?õ#áU[ç—ú |ž:ûæec¯ªÃ»ãþ‡o/Îi\Ÿ÷°âNïk ÜâóäwÝ‹â€Ü{qsÚ}Í>ã3„W³~Žù<}εƒ÷žÏQ{+ÿËN4™™âÖ#е—t>`ò~Å¿úÌÍc 2¾üZq:›]†§ö¥õ)µ3êz’‡){5ö{¿F6ùDú<­‹p޲_ü†¼¾zÔñÖŸÁ5­ÿ‰ŸÅ[”åGÃõþ#uÛ}ÞÄÃú*ÿ¤þºùrº‡£97òþâ.u[­³J¼Zdú”æp…ïè<.qtì!µó¥Â7TW)}«âN:vðƒ<]u(²Žü$~Ù\ü²8 óG·už(½—ðÐÕ-å}’'è>òOô[?¥þmŠO†xP=Nôµ[þ¨z:Á™âªê…Ý[WvЭˆÝ­~`ö¥úæËá/rîðLå3ðª#¾½sNÔùÉcËKæ<ÂÝx{øºuuæ›Çg~•9,±ìUpQyu9S~¼uâˆÔ¿„Ÿm¦õÇ?ŒçsWϘžjìËî4ŒÏè½U'Èž¨¿”_Çßdó>õÿΕx öÝ\ÅĽWêÞFñxûœÔE™ë|Ѻõyæ‡ï­K2è#DŸÇy¯.YìW󉱱»µC=—Ñ7§SY»<}ŽêPá“à9ëѸeŠ‹Æù–Ú³Æ9‰§ÓØ8B} ~©õmøÎàûÛº¼‘þ8|RÃ|^ëêFóÛÆuS­ï‚Cÿ¸¿âï_}Ùì«8Â9¨Þ[êmàÀÔqs„’¯±c=¼Ö¹pNó®ñ¯Ö©ù«Ø'÷±~O<Ò¼íH›ñ½õ×Ù‡ú‘äå:¿$8/}*µsåiÔ7ãcÔO%_ —TÏš®¸¼¨ñ6ñÞ߬6Ä7­·¡wž}„ ª×ŽW ^1ßÕz™×g]:/'ù¤+v?õáÛotÉ0O‘žqüøÕo8|—]Ýr¨'Š}†}oæ7ºrêe‚ßõ™ÔŽ©ƒÕ{tθ¼|ì¾Úœ¤Ö¿dí+\ÙöѼò±ž¶ûLïØ{wn'Vsø/9·=¯yÿ^3gl˜÷‘:u«üEë-ÔM©çÊý¢7,®—©§+Þ¯ß94æ´Ç>¶žm¤{[¿K=ßÛºó‹²nWŸØGs"²×o½ûcý¼¿õ9Üמ›ÑJsÙä…ìGó³~/÷²sà_¼Aâ´ê=šg›ø„ÿañÜø¼öãÈ?fýœkç¼ý=æ.êGI|T{š}í³äÙ3÷ ßåOëE§¶ó`bGÛin}öÏ{UçZ]h첸×9ïü®äKÙy8ÿÆ?·/ ñŒõ½î²NÜó]oi}Eç~ß»Îgȃ[WÏ—ýn*–8¹y½ðûìšõl}Gî«úg8‘Ÿ2¿®óøÜsúÉÉ?á+à÷›o(}רÓâó=S×zó*/¾ïÿØpð»£z»ú¡ìCû‹Â;á_ä‰ÝƒæÔõÉ‹©Ï5Ç.Ï §ˆŸwŸÙvßϯÑ{­Þ´ý(øŽÄ1µ£9/Å üIî {f=;?Ø¼ÙØ!ëߌïÑ~èÑsµþ>ÈyW×>ÑýÏ9ª.5ýÙä¿j7ô3¦ßQ¾Š}h}Zâ1ï˯¸çµëøÄœ—ÆO±ëö¹ïy¾âà‹¬~ã ûm:K¿›OvÞר^þ­ÿÊ>¸gžË}pÆøÄÿûy¸Ê>\;³ÊÚ_¸æ¬¡ß‚=Å7­ÇP÷ ºy?¸¾¼BÎ{!6—…Ýíü œóâÆÄ«ãzRç^ÏÑ…³Š«àñ¼ºXþ s²Ÿ?g.lâ»ÎÍË=â?ZçIŸ<ïaþ+{×:^ýãê ñÏ9/O!Έ]«?Î}èœiºùùžÎéTw>Æ}„çZ¥4ëP%¿wõC_»þª;={˜Ó™}÷½íÛ0‡%8­ºüÁcʼnßä_[‡8òÇõ»ã~-:ìtþÅ3ž+÷Nƒõ´_ÕUÏ÷9Kc¾€ùY—ΑÏùÃϲüyëÆó÷ìÿxQq¿«úÐ#¾ ¸(q™u`—Å·p\ûm²îå ³OîkëÐcg©;ÝÅ'Ø7|BõíÍÎóˆ×z.cÇþ—äï:-Íu›uÍEWâI½_uùãðâΧ}w¯nüæ7Ï8ü—›üLðcýðh®Vyç]ÝJêªÇsíÝÇν0×6ûyÃ~§lò¦ç<¢ïÇOu>‡8/ÂϹô7œtÿ†¹Éá‹ÌÉçƒñ>ßÙ§Ñ[ÏÕþþלûàâ+ÖÚtÿ½/ÈSö>åßoº`›Ÿøï›w_äÛØ |€ïqojçñ¢Á…êŒøø¸¼Xð¡ç‚7áþç~çØkVÿnñø_¼ó潟x-÷w¬2æáZ›sй±ôà<%}¼•ùXæ%À£æ£:çt>ðú á¯äʳª7O¿|×¹.97ð¦÷d·÷f}:%çÄï»ïõ7Áxùλ4o(~µqa>×ç©ï¸î›Ï:rÝOï4ôË÷Ü4Ò#À·oS=˜¸Nÿ{ð^ý`ö³ù}á‰CõI÷šƒÈ.Çn¹—úÖß®Ú÷—õÐæ…ã¿RGïý­3ý(÷íÊ_ó«»\ýýaÞyòà×_ºÖ¯>·Ùû;W¢ýÁt9r.ʃÈoãÓÔ¹âåøcë WžÃ= Û>bù)ßoN]xŸæcÕ騋ÏçV·(~ÊϯêëÓ\ãióTòøZñÿ Ï}á«>·Î.=Ïö™_cwÄKîUûÔK$^Ü{Räüˆ_ƒ«ðÐtbZ¿“:ëÎí¡«cnaê—Ä3í¿Icô’†ù$©Ï°îþåí«K÷[þY?>yKº?ÕÙË¿Ã5᛽ÖÌ#vOÊ Ü»?F=QëÔI:÷ôçÔݵî0çÎV-ŸýóÆ/µÏòAáeÕyê›±ÿÍOåçþà›ôQŠ/ZaþLt\ÛÏ›çÎù鼈ÎSÆk˜¾ÎC3PÞ9úÕe“·¿wÿ}uÈå›å™Ýûêé¤~¦ºwÑÕ¥Ëí|5>Ì=T/¢ŸÇ<úŸê^ÊsšWGã-â'r^Z·Ôù²Áñ­c•¿T”8§ù'úOyÞö‹‡ÕÑÇ^VÿŠ~ˆ¸.÷¼q€ú3yÏÄæj±;Åê´ÌË9Rï=ÅæçÛW/¨keçà˜žºN#ž¯}üæP©KRo ÎTW€ÆKð×å'àŒœ3õ—Õ•™ÚÕÖ×{¯ñœî±~Kû¶³p:|ÀoqrçßÑû ÿ?%>a×Z`NjìYãrü¾¸#¿ç´NS ½JñFÖ¿º2é3iß{–ÿoýÏ´>dÐ7‰Ÿ¬þ×´Þ³¿ùëßæú‡ÍÎiÖU~ÒçTg"º`ìjçîå}Ù=8Ì9Ç‹ÛÇóÚÚw;V^>ýÞÑ‹æ¯Ó•ÔÏ6ê;h=”ØïÆáåÄm—à˜Ô•ÿÔŽô9Ã×ãå¯èR·OçÞ8¨ó`ÛO–õ…«/·ãùÓçXýiúìé8Oú¼‚#ð[ÞŽ/žÓÿ€¿NÝzu<étÓý3¿Öü¹i}xëp/ÿÈS·Þjù;‡:f}múó}ꊇdÝÇîë¨ÎNÒ¤î¶z‰‹|¿þù"ç ü¨þTüº¹¡tyÔÓTQýuô%œ·ú§àgç¡z 9GâšâÔØÖmê >®”:{õ"Y_yæÆO‰óŸö‡Äž¶o?u™ô~Õ¥_õÜ7žtãq¿ò<ü#}*}6êôrñe×sçw6§zpAûò'½c¿WÝŽô;6O’uקоÝô[ã'ªó ?9/éóž÷À«Å7NΜ?z’ÕëÈSåþ.Ãkžzþ¾>ÔÃføvžÄ;úûÑ<ÇA/ˆ ¾/@Ež:ùòkê{ãOZ_ƤN´~+ç¨úøjñ[ÖE\ZE¯,þ¤¸ 8½ýjùžÖó%§cû\ÿT½;uzÁ‹Í‹ÒNœÓº÷&÷Xž[×| :¹üœ¼wñ@ü”|¼0ªÿ×9ÓK//VM¿wìˆùàÕs¶?±Ïx=ö±ušÓó_œB£óC§¸±ñ`ñŽz@þ0þ½z‰?š?ËsÓqP‡ÕüqüìXÏTždŒGéø÷æóƒ«›4êëäÂß ú ñåáÕ•áÒ'/>UOÞ~ÉÔÓv~]ì]æw󣟠Þ. nî\8o¬ƒYÿ7ê §´U}Lê€Ê/ѽ£Ã þNMú~j‡Õg„÷ö§{¿:ÜxN'Æ}¿wÿyq)¨=òÜᇇ>Guôô‚ì_¾¯zÐü þz¯ô_S¯Žn“χ§àVñ=åØê(ª'NŸztñ‡w?¦÷¦ºí7„“éâoèÿô‘èüògíóVC¯#~¨:ù‰ƒøí꜆ïk?Qôë øZ^¾×‡’x¾}ô’w¤˜ù  _h‹9Hú䪟ä½àbþ>sÒÙÑöƒG‡Z<`^+;ÉÄß×¾ßü‚W|抟½­ö3ç¸ö¦úg©ÏwÿÿêFÄÿá3àÄq??gýšÿVï,¿ûÇtÞ7]@~0x§}ËágšGR—ÄOåûÛ»<Öû+¯–ó¤ßŸ'µ+û ^æßZGÒyòø Ï•ó#ŸÛ>—Øq~Xÿeõ6ôéOãúöÅÔNæ>òsx>:~®:s™ßV<÷̽ê~V? 8Ľä_šO :ñoê^Çují× Ÿí<êW¥?Ñ8Dß\t𪙓:ðæ¿ÓN|È^To(öjÄ_6ŽâÅmÅåúKé·Æ¿Vÿo¤?;ôœÆ·ïRœB—!ëTÝŠÌ«}νãË;©« ?ÍÖ_$oA÷¬ü ]\¸‘îZÎcûÿcç«“û Ž”m|ô@ô·Î¾Yxiò~±÷É·ñCîóÏtþŽ>ŽØYë ž©ó,r^zŽÂ6ŽÆ‡Ò/ nl­¸8q*{Ðy4Ó?>.x¥|Û½×}à5é‹ñ·tÒó\ìÚ:^uëêÝRÏÑú€ð§xï7îòýpþ.‘ÇZv÷ï~{ñ­Çõ“ù¾ëw}ïw™wÏÎ+þ7Û·Ž¦õãòô¹ßÍ?ë“Qß?¦>ÏùóžÍ%ÎÑ¿Ò~ õúˆ3/P°ø/ÃãŠÇ’WïyQŸ?qÓN[¬yÜJk}Nû¾Óëµ0÷I½/œ¤/̽ô÷ê“Ú÷–sÔþ‘Ô÷Ó1‰žhuQœËêÆ>«÷¨®]žûÚËõ„5¾¼`è“ ß(ù§ê&ó~xή'?vƒá¼¯…¿¨½øË®+õÉËý»qŸªõÿË~›=ÿùۜԺ½ÖKçyœuMêÂ{N²ŸÕßÓ§€ï ûàßÊ—¶ž0÷E¾¬ß›: ¸ÏùðgëfØY:bê£ÔÉêûšòÅ Ö»ùŒðrÕE÷é¤^²÷Ð<—‘ý±>ÕÃ~”óùúJ¼ýà?Øx·yŸà9skäÿ®{ÞKçœzÄ;†9-©Ÿßü”uqn«³¦æŸ‚ØKv\}¼ÄuÕ]¦ë[Œ}†¿bÝØ{ÏÑjü¸ôÒã—}쀛˧Wï7û];žïs/Ä외¡ùÉéút^tò^ƒ¿Ê¾³ꫪO‡e]ÄÍ{ò[ìzxðâŠÔ«×'Y:qòí;ȽeÛw;è<Ø7þúÛùËÚ;<ôÅ´)ßÁmå‡sž­ŸßÏ<òA/ÛýrÏ“WSÛ~ýÈê'õY'_æÿ«ï–<[qŒ¸®Vïá|ÖoLëàÊ3x.öͺÊïvå}=W~žlßñt?æÈsŒóüsë‚Ô™ñ¯ð‰9ª™<Ô5æ~´ŸJ?—¹#©Ç(_Ü‹'óðšóɹOâ¨Öß©¿õmT'!÷®±ŽúEÜ—ê è'ÁéJ<Å8·×~ó'[¾qµK­w×_Šç”`×Z'2šßÙ<0ºX±§ôðœóê÷äóÝwñ]û_sî[AG(ù€ÎÈùSÇ$幯>ö¢“ß¶äâú)ç¸vŽTžzyö>h>,qoõáŽôŽžÓÎÃ5*ü?ž1¼€úçÖsæ9š'[âÏ˯™'ƒ/ oí}[>îãÏ_ˆ?sOøöC%Ïì=Äu>÷š\ý•Gl{Dó1ø#ù6ø…ÿt¯ÜÏkž³ã¢‹7üÙÐ'—úÀêЩæÿåÉsžØíñ‹úùÔ¿ØçÜç³G­“̽bïá&÷½ñ^ìmN?Lâ|„{^¼©?*öKü`?;%ß+‡ª_l½nü(ž¯þ>ŸO·¨û; ¸Þ»uá¹·í•wUÇÁŽ$/ؾ¹ä…í¯u/>Ò—x»óÉb?ÿ?Þþ<ÞDzmûÇ×ZÖ¼*Q†æ’H%γ¤\©hB%4k 4+%]¡Õ•¤I)„•ÊYæYf™¾÷u}¶÷v>ëçÕ}?Ïýúõ—¬õùœçqìöOÛî:—üþþµÍõ.nŒó*}=ìÊÛÿëïÍã6C7ˆ³ÒÞ™þH£ñqÖæN“¯ýî¢8³\Ó+Çœ>09‡Ò ¾~g¿8wRÁ½8Ï|œ3¨qóÃÕ‹3§y÷Êó>å¹±ÇqæÃæTª÷fœuð‘IK¶l‹³î:ðØûþŽó¢ià 1ç–Yïý_Vø¹s•ÿçyõÿ]çÌ>lTËÙ——sÖ|0ºí°>qÖš;V×{_œ¹»jƒ j>gvô„¸RIê“Ô3ã¼µ¹òK7³+={f¥éÉïé¼ý¼zßìrmßjußü8»ÿ´”66Ϊ4ú‹F‹.ñ{øû:^Xsûão¹^˜Sûž?¶lœ[»ÄµÞø4Î׳ץ«zÄYƒš]°rÐËAÎܽWz°oœW}ôôÙ­ÛÃÇ,=áÂG2ð¹å ©9«Ü´îqN|Æ«ϸ!ÎjýðÜ'o¾>ί4ubí³×ÄÙÏ~øô”%ÃýÿÅ'g•í±ë†cÆûyJì\²½ÂÜLæ„â¬]Ý7ŽéW'Îìÿæè«•ˆswzçÈŹ9»Ëvš÷eœ½ä©ÕWì>Ò畳yÞIÓ£ôY>ø;Ÿ¯:7ûáãœSÎ\yýº8;êÓèÖo³â¼fK ¿1çã÷Ë}kóoíóŽv˜z rl¹÷á‡ëÒ¿ó}eÆ3?–çäÞvï»­âì]Sö¼äÃ8sxvî¶÷{ø~ÑŸ¬g¯ÿâËÆÛÙ—xÿ ËßTŽüD¢ï]?iÊÂä}³.ë~RÁ9m㬮¥«W˜¼Áú™õÁMU~Dœ¿ôôÇ›žº:ΊFÜ“¹´Ar)þ-ÿ\fÆ _íÌäžòrV·züŒä{'ÕjÐoâÎ8³ÆÛE3§]ç9â³GG]çõßÓ7þþ‚ËV ØóV?gö]‹oÊ|©»ïy@Ðì\Þ¤cN¯Ù{rœ[zñá§åmŒKL9ç¹×ls¯mÒøý‹wÖô¦7.)ÝØöŽÏÇnä_d=âž±¿Öóæi&ÕŸŸØ_ÞùÓy3‰þb¯°³è=þùÃNç*ßûÃoËÛnùÞõüyþhßá®®>~//Å?ïûƾ!¯Ù[^šz}¿F¾oæTéCÂß"Æ#óÞm=jñ½öc¹wí>}ûÒê–[ðýšôÊï=ñŒå¯79)‘7äEóWþ^Ý+ÏíÏ•C.eGÝ·™»äóñoL^—ÈwªÐöÜøQòÆ9â¯ðÃÙßœ<öðQöïÌ'k>2yN½göðÎ=gõJbÏ%÷œWÞðßV ®s‹qªñšðFnó´ªwîl¿Ž^Ø?Iž RsÖ‰?'ëœÐgô?ô›%šk¾å«Ø{zÌg#ùÉ©Þáä êÇY§L»·ÉMƒ}_üçÑÿw_烟E^|þú;þÀúҧ㌊%kã7Èÿ%ø”sþ¼ü»»Ç±¿à¼ÁIªßŹÕ]Ù6޳sš¾˜]ñhË;ö<·uV³Ÿž~,Î9ìåøìj ãÜ®§ïûòíØï.Éíÿù˜wšd|‰¾€O¬‡zNp ú—>.­ä©+?µÿà÷À9¹óŽúü²…%ü¹à#ü'þ =1>Óýÿ€SŸëzúè¸AÏ‹\ñgî©i\sË­¶ƒÈ úˆ=ä¾òsf•ÎÛ¼$.¨´îö¦—Þk¼šu‡•o=u]ò9ç÷mõ¤õ;§ìse÷ûÆv6Ä÷ÄS¶÷òßÙ5Æl{ýâ3Ü:%sÕª_%vEú…ßÅþ#ÿùMN¯ØíÍ_\„~Áñ^è?OÝÆú&ûn}–þ"ÖGᑼ´«G•}óOã ô‹÷#¾à\°;ü~ö)ïÝJ\m¿lû(ü®+†«ñ‹zOp¸=oàϱSú¹hfï× z¯Žù¸Ë™ô}WŸU¤æZ¯‚™‹Án¢¶;²Ïöëĺ§ü[>ûÎxø|-;C¼˜7¤ÊèuûV%q¬â?ãFùÁœ±ßλqÃñ‰ß.ã¾ñ+Ž÷j±ÿÀѳÜÿî÷NÄn;¸?ø/¸Û3Åëô¹ù½e'sNé}fá '$ø•ó×}8^Ò}_‚oå¯r¦õyyý)ý­·œ'Ÿ`?t¿ø?ìAÎe‹þyå/%x_v}á{%ÇáÞª8£á̼çvrØÅçh¼aùÕ{;žD¯Û®sߊGrvíxô·V5ðÏéýý>Ò[ãsòwä'ÙÑÜË&´úéùI^MvÉú$».¯`omwþNÞ˜ûN݇ûç±£Ö/ùMìy_ÇW’?ç9À%ŽÉþ`h³r=Jð³ì?G÷—׺Ñߟ½Úr„þ·Ê#öçä¥'œcÉZ?þOë)÷ÊŸÌ9.×j_¸ó<²oö‡}Žú¾ýÄQI¼ ¸Íq—îÍù6ù)ðH‰ÿÔ?þçÝ?n~‡­el?¿·¥>—ùþ$oÒïÝ3îW¾ŽûbŸ¦ãméAvû3·•XcýÅÿ¢/è¹ó5äñˆ$ß·èû´ßÀù(ÎÇv_Ï©ù ˱ó›à(ìv µ75yn¸ÓyqäCsÆU’#Þ¹ÁÎ…x ê¼»âA×Wð§ò?~>ùUÅæePÿA1;Nü€_"_m?£suþIòŸ%OŽÆÏÉÇò{ùÏîºáŸg•·¿0žOË?!ŸÈ½ìœçÔœ?ïÉŸòäÏÀ}ÄKa½‹÷P>Ãs_ÔÀŽÑ_ÕgÀmØaÎÉõŒhÕ__9Ùø‰<ª?:ƒìŸ_öüa¿û\ÙŽÕ¯¼Ñññä×ç¬8+wÚǽ¯ÛO¡ØGçÈGSO㜥—Øqü«å@8œÏãûŒð‡zOâüy]Î=gÀ ?~òÔ•ÎÏ»þ¨|‚ã9á_p¯?Ÿ<ì¼kàRì(÷FÜL=FóýÎû[¾‚÷Ã~9¾çùuÎܧql×¼[ÚæîJpò-9¦nF\ˆþ`gðÛÆįè!u겟äE\ÿKÙ=óÈïRG¢þGü&9Gn¨wX¿ÉãQïÒû¸î¿å<{ÅcÅô?ƒ?•ܓŞcÉKˆïÁyô9Í™ÔfÄøKû{ø9x’øäÍòÁ}êß¹ëu#Õ…eÌ{eùT<$9¥ÿÕùÄÜ5E½ÿ©mœg½~û=i~~ôƒóQÿÎ/—Ë) z:æ“©#¸®.ü¥{7¯yüü5kϸk{¹Ä.!7Ô9ˆãôÎûÈòØwçmÑWâÂÀ:~”¹ÎHÞû‰¾p~ø?É«å_þ×rF=BvÕ÷-{çx:ˆK¹Wò\½w|ðë;1oâ8ûÃ.Ç‘÷‘<æm©U¿Öà…Éy‚o¨ß pö›úwêÆ–?}.¼®ËŽ¡w࿯ê-öø3ýžx=Õ¹Ù¿ÊØ^’—§^ŒÞs?Ü#r¥Ÿ#î$?dù%Ï£ø ÜVØaÿåÝ·—µ|°¬Ã{ßÜçzô3_PÇ}ÄUàcô1Hú«—-yß~½ÀnÔš5}ú§7ÙÞú~d·É`—mwd—œ?Õ¹å×(•×¢þ<¿q]Áš=­ÏÿCâä_ Ê®¿ø™¯þá¼úDÝ üˆ¼ƒWù|>ûA¾™ûo<»mÔ‹-+ø95—‘Äò»®S“‘<7ÙŸ«Nà:–þôùèûsw7¬ÙqÝÈäü¹'yGìv—÷§¾nÿ&=&îäçÁ|NÞÁßk?ûk û+û=ÉgÁklp‰í¸¡`wÆÄW¯—ÔMx/ä_øœº,ÏC]Ó}Ez^pòB]¥07ÿû/Çk;ÊûðûùíóÞ»ùû݉Üé𓼇ëÄO¡?“€7Áî§Ð½»ÏïKÕèÿt\Œ?2ÎÂO—ç©nÃóùd'ó»ž3dü„Ê >—÷ýM/ó¯Nx8.Ù¡hÐOŒOúÀ¿êG!/ä¾ù3ã=ß_Øõ°*ãK 2Ÿ”ëpôQPw£>îþáÞ JÏ{±N½sŒ«ð?îO¡ßŒ~7ü¼úÃ çƒ°ÏØYäÂùwúd‡9ï"ü†~æŸósz÷÷üÎÓos?Øað´ó Ôççø÷èS>€çs}ž| ~ \$Ïû:_%û>Ê}vöŠŒ‡ŸMÎMç>"/‡^ÿ¹¯ FaÝMm7û9éAÿèÿ"¿*¿ë¼¡òéþ|òDäëä'Ýo¤ç7~Ã?Éþ§¦>Ï¥ôþÁDñ;äeȫȎ€ÓmTç(tTµÛ.Núôÿ±—È!Ïí>pù8Ù1îßç-y§~ {dÞìúáþ&â^½vÊñC o˜ßŸ:LþÜ»,u¬q¯ñ”ü¼qq äŸŸ§o1O¼bî·³=åþC<‡^S÷ âìJÁ–œ&=j¾d;H¼XX»Ô‚o{Õ¥Ê|‡îKÄ®QçS¾¦äæ=¼ïKãQâ-ÇÉ’wê:ÆÄ9Aûž?©Bû¼¯²’þ*òŸÔ™d'À‡yŠ·ÜÇ&\ëz7yUpŸôÏuIúidgðG…Ê{ÙÙm}Oî[¢.¯øŸûåç,Gä‹©ѯAý€ü+y$úi¹gwA›Ón®XçÛ«üéG5è9úW땜#œhûO-=7þÀ^§ÊPW?Ò׬ú´ñþ˜|ùyêGôyÐÂs©–? Ê·´èä|<ö }ë‹®ÃPg“ü:ŸŠú’Ñ+Ç’ú]ÝGž‘8Sñ¯p<ÉöKúÄóò}øgî-O}’ø}p¶ýxœ§sæ¾8gã?údT¯×PïpýWy ò\a;ë>aù?×d?Ü'ô͆r縓:6߇?®¶½ÆÒŸ$fù"oËý gçðwŸ£>>a×Q©3JOÝEˆÞßqµîKuqó@9@?u'݃í0ùQêj©zçnŒ ¤Çà!×±¥Gà0ç°/ôé}ÄÈ/~¬dï¢E£¯9¼ø| }”ô÷(N£Ãõwáÿø\÷NÝ{ë9áð‚þ«¯Ø’u£ýubòàöçVë…»8Ǹ}%?aûƒ}VÓuêØù Ÿêü8ýÞú^ò5Ä¥î?pó}ßÚîdTlþkÏŸž5^È=+yØ1{N]ö§ósà:˯prJžÇv•~LxÅùCúsȯƒ³…È‹§ˆg.é—À®SgÒs9®#ßI½_v…ûBøò€ô¸ÞÏßeGÂø½1î•ü§KÞÉOã8ú|‹õ»©ÏÙöŽù7éñ¬ûéã ¯ Ü¢þ5שõœä׈_‹Íq? ßÌa·pîAÿ€õš<>sô=«¿û î þpó*âÓÔܼõÔõFÙç tŽäsÐ ÎK¼x–7çÙè{Sc?E?¨ƒq.žÏ úŒë…»y÷ûÑKœ©ø=¯Ïá*ÑÚçä¾/ò×ê p}VöÀx¿.9AoGÂ.âW9wÅõî¢ïŒ|•ä‡:(ýý–{åÇЫ°_.œ;sÝXû¼ £mù·ýñ½ÏÁy'ê äuÚÖó‡÷þa¼Ä$ö×q.óQàáM×=ˆôüįîW$îb~ˆü§žýÉo¶úµr›Æ›ÅN¹?Ròè¾³°Ÿšú¤p¿ãáVãô‘8L÷é¾#ùê˜îk§o“¾ òDÈ ý§àEåñèû5ž]Æž›ì—˜ûÂ2§ÀÜ ý8ú<ãKô: vE~ÉýŠÌ2×)á~Å[Ôe„#œ'rÝ< ñ^ïÉß¼óÅç¿y%ÉÏ꽌#‰ßuÆ=ÁÜ„ûU‚>p™óDÌÐA^“º'ùMü;yÅUàÏ Éî‚/é;µ}ÃîÓ' ^Ãþ3ÿ@—7*^uŸóÒÔ „'=¯«ŸûDùyÏ“ªßÑýNÌèüÂ9,Å)æ§çœÀ áÜ®ý%óÄóä}¤o…Â3Ô=ÿ#{l ¿ãwÁÛ®ï1ON}M¸Õý䨿â‡áEÀ¯«¼Ä\%vÎó¥ÔÇÁ‘Äø-é‘û}éÓE¨s«Þ)Þ4÷‰:ÎÎ÷ܺâ‘•÷[¼åÌd:1ø@yŰÿyõœyFÉ뎺_ü‘çMÈÃÂó ûpÿ}ÊÄ1䳈3™W`®˜¹cì3¸SrJü ß÷œãúŒeï#ìˆû$àmH¼^>Ûú'? ¾´~ˆ/Ás ²óÔó>—ß÷¼±ú <÷%<ƒ>º~Íœ}¡Ì]1¯>ÀnG"¿Ç<7ýÁÌÉN™ç€ymúŒþÚoœÔaôû®+PÏ ž"ùp_µü¾çpÉ á×e§l'Õåú;õ!=vÌõ.á*ç匣…=Ký˜|4sÏØâ É“ý*ø+œsc®–z5ý_äeè‡ _O>Ur–/ï{ÓŸžP\a~ò¾Øoá[ò5ÆÒ#ò‡æ­Ð=¸_™9´ ïм,}0ηÿÃk 8Ýñ<Ü—âzÛMɉñžž+´îßÇ),ì}àæÝ·_fëøNvÓsÔ±w̯‚Ó籘‡‘?1_‹þîùHòþòÛž’Ý¿â¯×¤‡þåu°‹Îs+°ß²¾ç€Çy`ÅÓ®ï‘w‡oCvüÅû¢ßüé¹wìõî÷/¸®«8Óýhà%>ûÃü ¼ ô‰à·±7Ä/ô+îBþù9êÏàÝp>×vü9r@UïǼžï[úMß‹ç@á"¯îfN¹Ñï{¾›yâKùú8'úÖ‘[ûMø$èÓ—½öÏ!çú^ã&åmɧúû¥ïô¿ß¦ßŠŸg.{ƒ<¹®>Â>£_ÂçæÐs[^ÉóÀ£Áó2§Ž>âûÌÓ$?±?bÞ?èöd³÷ÁõnêdÁüµqÏ¡xÉüS:G×è‹a®Šøœzs_è“pŠóEz×wˆsdWùÓyòŸª[á<¿æ=Ñ« .à¹ñ—Öê\ÊS´}$¬÷°ß¦Ï”~ʃÒ‡ÿþ•ëŸÎ3Q?&?-¹1®B¯m™O_y·9*pIê¹¼Ÿ)ôïÎW¡¯ú×uùì8>ð¼TÌ‘WFÎáÛQ¼íþMúÔ7Šßb<ïõ=æ\Ô7æ¹aê!:?ü–ó>²WÔÙÌ‹E|ÉÏ3#;a?ð`ñÿ¯Ó=ù߉“%ø+×-™£'oA>˜~ÁT|b ÷áÿ蜛¹űôc¹Oƒ~ì2}Fºì‹öÚ^;ÞSƒÏGñ?œ+ø“º£óßÌ0D'¨?/˜Ûäs<ÏΜ!¼Jàê“üù3ù ê…àBü¹í|MÌÏòyÌ3ª>è¾lùIí_Oæ•©³ÐG¿s‚Ôý™¯Ó÷Û¿ëó\/%þ\aǘã úŒÜ—’ìãáoÏU¼'î'¯“ÿ%®|¦û³dÇÁ ØþDnœÏPžÏ}ÍÌ#À'„¼“Ÿ¢¯Ux<ÎA¹ÿ /ü|XÌ)Nq]‹9í‡_»tX­“£Yæã\ÒóÖÅkßnÞvx±á7ÝÜjÝ¿ütIôûØ×Ç´.ùŽ÷³À#¾æÖ¾Ý§=öv´õÛ=c›œüX´ªbî+gÌmtø{ÌÒ™óvzÏ ûc6Tùç°>y¯F[þÃÝœ}.ÑØõOüÔýª›Íï +ÏËçÀÓË>‰ÍÝ¢û^©‚ù†WÕÍû¼Âö®Ñ†–U~.ßì8ó­ÂcËÞö ð}ì›ø£R“‘]vÏ3?êÜ÷žùôÓ5¢#âWʼÝÉ<Àð½Ã§Ï~ò_Oš:½ÕýC£Ÿ»í©º)í³„Y¼Àðso4µÉmõNˆ6LøýÙGnV½µgõëãxO:ü¸ì›Öï{??Ïçð=ì#§¾þ6?¡Ï5ãåKuiû«÷y¬8¡æ¸ý]ÍËß7<ÍðÓnxá¸/tôÞ¬Éey±Ü”ï̳¿¾âûeNè<1Ë×Ú‹yâúSï‰6¥ôÌè¾ö9Àw o3ç;*öQlÙ=ðЇËïŽÖìŸ[¢Ë7Ó¢ÙÏ½ØæÚÚ•“ý»â#†‡Ú<¾¯]ñlþóÍ’ýÐìjU÷ÄRã‹ÖU¹/÷«ZKü{ð„ë‹|ÁÎ^*x–¹'ä`õ¤sÇ—]}½¿‡{×^dî9Ý8è–“›mýÙ¼òâé0¿6|ºæmÖþôìÓú,»úŠ­æ_†/>äþ­FŸMŽVwkñÇKÝïNôFzΟkoÓ©Ó¨Þ_Áä½È˺N=žxL¦ù°‘ãpúɹ²ßÂû#$ðK-çðaÓ¿hÊìS¾û®§yÍá_Ø­ôèƒ]­xcÃÊÌr'û"ô'r~›\{ÃÍ/¯{BOV,ýäȵ?Y¿áe^ßå˜?9ðv‰ý‚æÉÆž.wþ£ï_m½ y™áÙFïþh}÷gMëÔ÷¾ƒ)-~JºÑñ–?ì0Ïß:|áðC³>jöb¬©4£ZîÝs½çŽïÇNÂïï}²ÈüÔ+¾êÐeî3û¢µÇÝX»\ǺÖg}®ïoÉÞ%Ï>sÌxï©@?–ÅÇ>=u~¶õâ½CÚCµ÷ÿHnØ#ÿ·Œ^lÕ¦ÑÌK_:mÖÀšÞ'Áý"‡œ;ûxo>o~½‘õã’}}Ï+—œ=vkûŠÑ¦IG\øä‹#m7ÙÛˆ¼ýX¦îí5ßlmè|]í¶ëxOßo¿)ý7¯¸ì”÷¹qú~ô >õ5oö°iÑçÑʺeË\ôzGï×aÿúd;¨óåsØWº±Ò£çÖ:wz´dÌÁ‹Çî–U©rü=·'¿¯:~>õÕÿÙ‡‘Øsí²½Ö>Î;Áþ#·à€•gn¬þHü…åÇÏ£}œ/ö’= ö÷:?ü9üø+þcö%ûe$7øöl¬»ó…kgŠ_ôî%5ûõù²GÇþ^ß^{¯œxÒÁ[ÈçÅÖ¢¸ÚÐw£A>ìú/]nøè¦ _ÚŽ†{>Øób¿$œNã<ÙûÁû¡wì?ÃÎü^kÁç†ï·|ÌÉfeÅè-ÛIü¤¾Ï÷žMö€ë–Æ7îH{²žåsÝòÛßlrþ…þ|½Ÿ?‡çs¼KûôyæÙÇÞcž³¹^4n§ïßgO#û¸7ì2{PØ«=2¿ö Áw?¯ÖÐY-õµŸçóàÉGÿW§]øåý9³¢•oÕýä¢v]¿ð»à*ãQÙ%öS€ °óÜz žao8 ?Œ^ñï?¶ÐvjÔ ~eïcÀŽ€ãÀëØ{Î}á÷¿_;ö¡aÍ{XnÁm|÷ kïöŒ½+'ÞÜùÎ&M¢•&)Óí$ËrŒŸb¯ò^YuÛ=¿xEŽßü€½Àn³GbnN¯»NúnÏó¯Ukzý¹ÑºÉeM)=Ìø?‰_߀Ð{ïCèzS³†]n3þ'ã_Ù73³¨÷îu>õç³ý–ßt®~~³=ÀoÉyWÉÿÏøò½õÛ?ÍêtéüšÇ%ûW´G¼ƒ?ø#mÑÑM.3ïr,T¿ù“{Û&û@䟖W¸où£«ZÞ8'öD'ú9±SÞ‹Ä'=7{Xø\prþ.oùèÌÚ£Ó­ŸØ!ìúƒàçÑKpòš'7Ñ*ç·DÎN¬ôZ§µïùýðSàô“=Wk&ìÊj|d‘ýxjYúÒ#V«–ìM“ÞáïØÃ„=ÄþËy¦ý÷‘½@ï¦oûþ᫮݊Þù¼çüXù“F5î¶^àŸ°ÄSÜׯ´‘Í;~ÚÖ~rágßΪØoh²ÿH{DØWË}.¿hÅ%Ïù•óLî[8=?/]Þ¼ü‘—™ìçK‹ë^R»«÷ò€#‰¸â îÙùv\µhÏ]GÎìºÝ{\ØóÆÞKâð8~¹™zêÎÁßæEË\ùúö¡S£ÕûwÅ{¦´ôçz¿¸ödz_œâkìûVÀqì ³Oˆý”«kºik4ÞïËÞnÙÒ-SY£÷["çó_bä¾qÆ9Æ3Â¥+[VXtû_øsù<ðyâ¸eotì4æ©÷O°¯mÇäåó|à)Ûapû¾8Oö…³O–sT¾ük¹áÞù}ò:3G_3íø÷úûVMXòRç’—F ¾{ð‡g¶¾ëýPÞ?,ù[öÍõíŒ{Í8{¶+=û‹­kKöM±çGût8Oü;÷~ÏûéÀÈ/níseÏϼwý«ìú,§Ü7ùpx…øû@Ü=ÆN¯¨|õ}Ì)æ‡ñ«ÄsìµÄ>€#üïq`sŸ›§ á½;àað(Ï!§íÜÜ¡|]Æ‘ìË®bßÁ‡Þÿ$îâ=ðÜv  ç¾Ùsé½ŽØ í1Ÿ?‡z¯ì*zι‚Cˆsgëçõ=Þß\,¥x–ÏÅÏ¡‡àNô“|Œqì<~¹_$üo¿$»JÜ n$%ß&œï8ùã^9ÞcT³‚ë´1~Ã/ðïäe¹çM°3·<×kë~X<§ÆRç!?ò¡œ·ò&I½FõóÇVÕù~x~èó¡?&Õ?fž!ÕWèg ®è9UæªØÓª_á\ªžíùoêKÔŸ4ÏI>+™ãQ½É}ŒôÀ÷ËÞ Ý;}æ!uuæè¢ÞK™û{4éysú áÿ‡—[çã¾.ê­ê£ãó\—âûÔo^(æqáMQÌý1êanËóÔû¨3©.|›÷þxúhàÍ€¾ øíé‹T]’÷…ŸÆu2ÝŸù+$ì9¢Æ|´ð`¨¿¹¡—çô¼#üáêÿ Ï×¼\ð€1wßõ<}®ùUtž¹äµ¯*˜!¿ìþrôÑýQô9«¿’¾Ë|ª×»ß ^-úUtïðËÐçgþÍÎÝxôŠDáïÆ®Ñ¿‰]Òü yw4_ÀóÛ.Òǯ¾ ì«û,è/£ÏXý²ô%PO†'Óz/˜x¹ÜÆüLÀgŠœÁƒ—qÞYo\xB×½=ÿ ?+>÷ªÿýs?|Xð/ÁßBŸ‰ìþÔüDôs{cÌ.¹CÿCþóe‰ˆ~6×ÕÕ÷à9(Ím _ÚÞ3wdúh؇#yB.=¤ygÏ×âÿà·„'ˆ½ôê?€þî_ü ÔÅ=w.ð;ý\êC¢¯ËóB̯1¯J_óöô]c'°Óôƒó¾Á÷™0§Aÿ;sdÌ÷À³Îü2ü¦Áþûõznƒ¾WΑyúhéo¦¯F}­úœ~ÙÉ…oyãù˜s“}á¼è3bÏŒ÷§É^bÏ̇¬¾ZôÓ<ô½3gÁ¼"}IðƒŸ˜/Ó>)Ï£ô•Ò'ÏüÌw°3µç6™3@/¤È­î‰ý¨îOsÿ#Ï!{éý*©>,óh›ß‹¾;úbèËV?ô€8-ÑæˆeͿώîÑ}ˆÌåП͜ˆžÓ~Þeìªì çPŒ‡?Ëü?üûð°Ò‡Cÿ ¼•ð\ðóüùöiÞœí9Gæ$Ã~å`>ÛýSÌù°7 ~+ôLöüK<é~4ú"Ù[BŸ(sXØ]äXŸg¹þEÞ±‹ðãá—4‡e;ðOà·-¯ò»æÜcÏÝ?Çœ}²z~úš<@|C}›ôAÃ?Â|%ýÍêwô<Ÿð–ûààñe®ƒø>Xp2{™«Â®|ÚÖ'ñ’/h®Ëó¨àip‰ùê‚9÷ÝÃÄœ!ý–ÌÃÂc®~`öŠ!—Ö7xêÙ/£ç4¿‚ü@1þlú´¹7ú‚ṡþié/ñ söžË ö†xß*{¶4ÇêþL{ÍãÂ>ñ`OIÜÈ~ZöÜÁÓÆÞ+âa=Ÿç=7ôÁÓ×̼|#²ƒæf }ì…aî€sÇ_Â?+s†Ú¿§zy²O:ØËã}ƒì«æ{؃È|ì¦çÞ™ë'Ñ¿.ÿêþGùwÏ)’·×ó}zä^zB^¯Ÿs8wî>\ú˜™{EïÙ¿#¿ç98æÎ¥ÄõÈöÉóÄMâµäÞˆ=oýÖ´Ñ¿l˜“Ä­Äqôi2/ËÜñ2{Lèë öGgô²ðäúç%{¸WÉ'÷‹·yšæf|ÿÌ© bg}ÏÂ<'~Áþž8æM™¯“܆ü’ô—{ŸhÊ>x¿l±}°Ä¹ô}ÃJ\/žü“çý^]ãÅ÷ÞΜq˜ÎÇùö1÷¡'î0¯v~4ø(À§Áž&óŒ±7MvÇüpä¯èOg/‚ü‡y/áy‡ç½2ìo#¯^eÞ^öÃ{!˜c“ž›§†¹öU —˜w8˜1,sÊða÷™ÿ"NÑû³·ÝóøcæA±äósòªÚO¹¿ôµy}'¶Lž—xJq9¼oÞ{U¯"Ÿgæ¤ÿðµ8fî“y¶à^±Î'‘ÇÑü˜ãqÙSò2ž«’Y¾…»Œw‚ý”Þ; &}õØKáð¯ã 浘˖¾€—À?þ}ðç-{Çž5çyÇ`_ý$|¦à âDxõˆÿÀUäI‰3Ù'©<4vÒüsð’ÊÂÿ€Ü…{Ù º,*¿·ñ„¿ÃCÎ| sxÈ<7’wøg\oî6>€Ï‚9døV‚96Ï£)!¿Å}z>H~Œ÷óü“ü¢ÿ¿ôÆö |ß|0äCÈ—ë~ÒªÞÑè•z¯x¿UzÅŽ«®þ!N»°Zïe=ö;/&|J.þ8Ú»õÁ^®?2ÚSrÌuêI_u\¸ö°/ŽºxTtpÒ[c®üGš÷8ØïêœÄGh\±E¹KP‡²<–,»åد_§ýÒûˆe§8O.ùLž‡ùµ€wÒv85ßBŸGœvöo½'||‹ýüTì›$ìx¾mñp>Ì z?kÊŸD—Œh4¨skËúÎ@¯Óÿ×®§†$ûmK¦¥¯¸zãpøàÝO­:yœ6ñÚÅ×Ñ9.Õ&ã–Û»Îò¯¦úƽ?L~Öujú5´Ütåúç{DûÒ*¶¬õÔ¼hoïÌËn³€{t}fo—Ö³ò&=O^%:0pߥ§­_ã½ìwC‰gáó|Žì pI´osÖ¶§w0¿v¼dNQçOêþàx(íŠ÷ë?Ó *v‚>‰ØûfĈ|q¯ÂŸQÑÖšW 9¶_â'N\¹µ÷ùçG³7kÐÇŸ}Uñͨ¨qË×ZtþÎöPüwôQ&vTï…]ç>ÑO󣥿 £ƒ­ó*Ö»ìzóî¤ý§ï²]’7Ç~ÁÛ’š#ŠŠÞªóT»îô¾7拈¨g‡i£¸OýCž;N¯Wyfö½ ¹Ÿè@×θ°ùÈ„ŸDq|—ìUÝßs«ä#Éϧ_þÄUoýýÉÜžp€íˆú…ö}Úpò]_Îv”:{”õ¼È-s4qz»^.XÕËñ—ôÂ}QØäÈy +smôÂGî³%_/þÂè`“;†œõV¦÷Cb'¨S?No2à‚•?vŒÆGT~õÉä¾õy®ƒ±'=¼ÂÔÏäo£ƒoU9eVã3“¹Tå¡=ߘòÌ•˜Ï‹¸S¿‡yþÄz,~FÉE´/åolOà“ð<#óbâŸcŽûN>ÉóçªSrOðΠÿàiÉUt :ýØó¾,t“~ëð':¼|wTÔgLf« û£½÷¿¶p÷¸ô¤nL”¸[øÀy­T<ì“7uê;O&ûÖÇKîì‡xOì„ì)úkÞ&áË'uÝ¿ýV Æ—äCÙO¹ëÁsÿ±õ{‹ÒŽ_Þú˜9«]ç4Ÿ'û6•N¶ßwÛ|ÊÌ[ª. þ /!ý¬×~º´yiÇCi½ÞËyàÀ;á\ å£¨ÆÂz_Í™ðùê{ùü´Kúø™_'ú¾Õgʼ‹ë‘æ‰b>å_Øß#»Â^¤DnÅ©>菉 yã¹KÕÎê9iZÇ-ü»øqé¶]ÕϹ?„¹HÙ­8}y‹ Y;÷¯ÁËÎó¦Xt_ýN&vOùË“ö“*»üé3£½­†M<ûÔJà ü-ñq´ÿ2Gÿsjÿ¿ì¼å<¿÷œË߀ àO"ž'SÁ.g<Тta—#xþhÿˆs =îí¤¾ |l^Š€WŒ::<ÊS2‡§OhS{q»(Ú;iݰÝã?Lò©¸›:‡ùÜ_ ø\öÁú†ÀOùùTWÇîâoŒZÌlT·j–íñ§ß <“ò#ÑÞO?kwÝû%˜Ëp^=pþ•ü?yéæ!Zõ¡Ô;¨Îé>!áSp<øKòm¿AÜD]Í÷$;¶§ó1Ïn¹kªq%þû.÷nùwÉO"—º?Õ é¯u^?n»(9dÏý î«Ò绿Sré:˜ëÒð–ë=°/ô]hO x/Nÿw¿ï„âç©K6,Û·Á'[Œó ÛTÐð§?ŒÃ f­Øþ¯*ôIÆiâ+pÞ3… ¢¢.•_ýî¹|ïÏØÕçîà ß[î|2òÇžeùã ÎÉ{YSò`ÿlÞ¿T¿ý…öëaž;(¾[ã|¾»ÞÎv|‡A.¥¿>oìcÚº›ª,Ϋžðb(?…ŸáOp ço¬âQúÁãtÕÉU_bž3ñ‹ì# O"¥·Öã’MrÖµœöZ´÷ˆÒ?õg³8=C»ËÓ“º­÷Ä Ï™G0¥'ްÃû—ôêÐÓ_uÜJŠ|+r¤<·ý ïÍ~òˆÆ_’Kü ìñ‰ñôˆ>!ðynâtï[PÝÒû’S¸‹¾tç¥ðßæWÎçžÁÑæo—¿ÐžAË;vÂ÷¢½óÄ)äE8g=·ý™øÒ8菉‰¤äÐñz™ôÈî$q§â,â5ûsòºo¾Wø9îäý©À;*»þæýéÿJ›Õ¿ ßÐmîg&>n°|À{n ÿx˜¸Uúe?¾ÇG9ž å%· ÿ 7ºoÛø_øÞ{éáÿP>ÜcÞ,á'ÏÛ§ì˜í4q {.á9&^à^™`Þ|L¾ » ®G(îJòÇò[’.ûà%WäEÀÖ+æoÄ#á¼8Àò®xí@õÃV—¬š|üÜÎó*7~”ü‘G÷yëçÔÇÂ\Hò{àžT~‰ù ×ùJýðçS‹»r‚óÁnb¯Ì×MÜ–ªëØÞã½?Cùâ îÌ}€Sð‡øöÕ„|8Ž;ÏTÝ-yox¿UÃî ÇôõP¯¦¿ž=åw£ýs~~mË©~ó‹‹ç;ë=Ú²{ŠÇ¢Ÿ¶øtÙ“],·%[—Ù¸õ… x¯²ê–SäSöü vÇqiê>,G®ÇÀ»$ÿB>Kö»’È¥âeûOøÆRùFú¯ù¹¤EýQu²‚޹í3nÜùqpòþ–ûË ®zZ‚ûˆ“”ç ÷z+÷‘¿ ï½î•|ªæ1½§\=rÞOzì<(qý’÷m+/¼ÁœOŸ§8ül}”]ú«GªÅù8¾2ï›âpµóˆú¹Òý··Ë9ÚûØ·†\&~‚ý\¼ú®œ¯"è½ú½Ç--wþ»»{ÏNê@ØŸ ù/º¥íªsžn-íõÞÊœ_ÛŒSŸ“ï²ü§ð›q­òE–ׯSy æTè±ÿ¿ðžEþlÔwLkÇÝÈvµ`îæ?{çÝœð¦û½Ý7Ï%}Eú;râ>Wú”àçf/,}3ð¹ o{¿u¥TÊqƒy‹Õ¯ìþx/¥MN‰fñœ÷¥y <Çê#CÌß}CÌÇП@ß|×ð“÷ñ|ا¿¹W™G—~*x©T'dކú?uE÷•Ò÷!ãº"üÔo•Ÿâçéã yƒÉx¿¸ðš?—9!êßôgP7W¿~ÜM¿†÷ÓD}ÿ¦¾ ïù£C8ÈýôïûWͧøÄõvú賆ߖ>úˆèw„Ç’þú»Ø¯Ÿó~qxAÕ·Á{¯p>¹õ!x‹}ªì—e¯ }Îì¹£¿V'?á~ õIߢ¢RŸ[xáÔ—½WüÉ/òè½:7äÎyuÕ…-?ô}?„}Â…­Ë|y˹̗z.Åý©||>É>x*éÛ¡ŸýÄPï§ïü†þôû2¯A¿?ùbéûÈ०?^sñÍÓçê¾Ý¿÷ÑIŸ ‡o{¼ï5Ÿ&{¬˜7@ŽtÎäé\gSÿ y_ðçâ½KÔsé_€=Ø'kÞ@öÛ©ÿÑûØË^cöI‹;êù6ÙOïÇ¢‡ùx‚¾í=¿ì|0£ð>û_òœ“ûCBþkêxäíÈÒGüÍü‹üs8×ç~uü}÷ô•adoÍ¿©ï1.‡Ï˜>;úÃÙ+…ÝQsà*úw°«à÷o1§~ òØKï•ÀîHo½_’~|ì,u}ó«Âeá> ?0—çýô;IÜWËù±Ws!æG¦ß\ Ï·_“|…}þ}òÆÂ]æË¤¿3ØÃC<çýß2_9ÿNÿ.}vìB/˜gboxW¸Í¼Ãšãs¿™êGÔ‡éǰÞ{mw5e{¬ó÷{ž“½7’ ã]öy¤žžd}¾èý[üþ|ö?ëÿ»ÏMþÖóê§ò¼}¿è3ûqáiÿ oaéÛcJùFûCú‰Ð?úäè7ƒOWïå~3æ~èkâécï}Yúyæ³è_‰õ¿ï½°ÁK±>qö8ÉîS·0O<{«Ø«?-{ÈÙM?þœ îfNŠ=Ê3XÎd×¼¿\"ûé=@ª Ðë=Çìe¿æ~¨¿“ßð\ª~ÞuoÅÞ7¬9rãgòRô“iÞ›ûãïöð=Ëo_¶Ü2ÿ¦¾\óÿ o3/{¿Ðå5é·37sÂ)~.î|*ûå¹ñnï2gÈ é—óYŠ/\ÿã½Ù)?cœ îe¿8•>Kæ!Ô_àýx̉³‡¼Aÿ\°‡Ò<öì_Ô}º¯ŸýÒÇIô73¿A¿¹ê~ä¹ ?9cáeüŸù¯™ƒÇ°_F÷î½Oì G?ÙÁüçŒ ÷–êüܾö)y1ý›Ìm0?œ²“ðè&ýuì×¢_v€srü¬½Eâ7Mæ<˜ÿùë\˜û‹ð£ôx®<o?û±C:/÷Åÿ•ÿ>Ù?€{šè£ÛÝuKÞC-ª%þ û«¼í"ñsœÁ^Vûæ€Àì7áÙ#EŸ:{˜ûd_ü¥y$dglŸÑæÙ‡¾WâßÐCú-ècï°Ï„¹ü#}ôì[o Gà7Åÿôu8ï¢û¢>áxNzês—}`_˜÷œ‚»áùW¼â½¢ì‰bÏ1çËó#ÇÌ£ÊÞÒgFžËy Ήýpà%ádÎÕ¸|K?{TT§·?ä^˜3ÅŸ¯¼Øn Qÿ3¿|ìeeÏü’#âïç&žeÎ8ÈÓðØ/÷ÉoyžKy*ãZÕ'ÌWÁü ö¸ùÙAÏ#ÐwEœ)ÿÏ>ßg{O¼I\Åœ v•~qü þˆ9òLì½ âþp=xØ{ãØ¿ÈÞEü«p;yKç þºï#ÙËF>‡ýHø-æId_Áq~`ŽØÏËóŠ÷àIqÞ‡9Ix4ïϹ8¾AoØCþ㼑gÍsR×tþDvÒûÔÙK«Ïqß;òè‹çX‚>9σOe‡ìï˜oFÞÀaê»Þ1ãÆ©oWÞküé¸S÷àsd>»Žýæ÷¸þ;Íœ_0÷†§’¯@©'{n€=,Âë¼7utã~ùµ°Õqo°ÏÀüE©ô‹Ú(®FŽ\ÿ#/‹]bß ù*ð¼ì4}ÑÞ·†‘þzÎ…yZ½/{Ðwú%u.îCú%’}ÃäðŠ‹è`Î{]ØSB~Aö—:nÀÈ=s à:½7õÇÈkP/t¾)üHž{(~"p@ÉçJŸrf…O“¾wøn¤×ÆGÁ÷›§ûMŸ0û2©CÀ·Â¼ûS蟟b÷É'ÂßþœN¾”:G*Îw¡qšâ=ã>òÆà|áXâ!χ±‡žü*òÇœùIü=û£Ð åG/ÁÆžqé—猂=IÎëËžvØy÷íÉþ’ÂSßQ¦QéDeŸÈ´®Ø¸o¥O]OvþsÔy’OŸRßa°æ„¼F÷Ãç—ª´ùû—4Köö’O•öœ­úRÉkzn‹xŸ9iøÓØÛˆ]Ðýyo¶ìDéÖùç6Ïìí%~Åo³§“z¯ê„Þï¨8ÇyPêZò š)†“¼‡Šú#{…‰?¨;É`‡ØÇÃ9zÏ»òèöÈß¼Èί95ä@üLæé ó¯Êïÿ˽×?Â>}/ýØ?õI$õ@ö wXÿ‰»áW®w¾›ü“òºÆ?ÌW³'Qúêzu_ânùYã,ôYv“øüà½iØüü%Ä)9÷¼÷^ó’Þ‡FP8†ûq~ŠúÏM¾'ì"<^<'õp/s¾äOØ+Hýˆ|'¸ž*ÅSös©ßwýßqñ¨ü[ac^?½g¯„WJv¥X=^rgÜ"|hÜþOô•ül8Ÿ ngé}ì×Á]Èu5ø…ôüÆÃ?pœMžGýãŽgÁ•Ì©óÜ=7ËçD‰Ó¨[ùN×W©ç°w<ƒ—À.ê<Ý@]¼8I¼œ’·g®9¬+‚ %÷¶œ/õzò’ìIÖ÷1O Ï€çÉdïð‡þ=ÅçÆ'á÷H^™Kt=<èÏà¾=ŸOýý_z^ûCxÉÃé<Ìk%{kýF'ÿ …ëúôƒ°÷Œü û*™‹§oœð¿„ùPóаLqÏUX»Ô‚o{ÕMö¶©꼞~Ÿú¨xÝ×e|€þ€sd'‘O/¼yOŠãMú„s°«ô[8¯F†ŸgߺâpÇ?Øuâ>ý¾÷&<.Ô_ÝwÀ¹g¯·žÏ~‰<)yTxHÐKê7à}pŠÎ×õ ü’p€ëÐì½gÎï¯ugï“6$ýƒ²#ž'§>"ã¼cÀ?kþWåSŸ±‡Yò`=ÒûbÏé/æóðcÖWÙsúH]‡Ãþ~šy°úü4s–î/o Ø_ ž±ý#¯K<âò¯Þ³ Oö‚8œü¤äÏòäg\w&oL~†x_ç‹~s¾ØIó¨è<Ÿ±/Ÿ¯æT,?Ö#öÍJÌ÷J}ž3ø^áFò6îqÜ®ú!öÜvƒür/çþ½Ï»äÁøÓ}:ÈvAuiãuâQ}ŽùAõ|ÆÏÂ×ôåòùÌýxï7ü¡ô3Pï!®¡î…\ëžyüŠëŒÄSä=À±?£íôÒù@Å æ$E\Ê™ä"¬+ö^yö£s^Êÿ¹Ÿ:ØCýµ>ÂgŸäÈý ’oò¿Îã‚ÃàÉükŸí5rð÷ã®{í4ãTò?à&òûÌÛ`çÁØyòü[ršô¨ùRñ~)ü>õ}ö¬³¿Vv—籿 ø¹Í³IÝ~ò•è7<~ð”±_œü$<+ØÍŸØ>ƒ#Á#à@é9s¢à,ò;ôkÛos¿àøŒÉ¯q²w®—PW¤Erá=éâ ôWä¾úÈ»ÐÿäÿÑ'Ë•ò{ÔIü|AŸón䝨¯ª<¡çë¾É¥ëÍàax<é›OÍÿX¸GøGÌŸ©|‚ëýOeÈkìx”ü çFüïö»+\B?«÷Û÷êû‰JÖÈï™qyý¤нâàbòeð;éçÜ?‚“ßæ<èu=ƒ>Pønƒþ>‡üûý¨oÇšÏ Ü|’²³–Sú7¨‹ oàmòÂóä‘ÜçÃù²_Wý‘¶wàùqçÁ9oÞ“þ áKï?†?S÷î¸UzXØlgÙÊgÿ|ð³Ã§N’ì1õË{ª…_½Ï@ßë¿Ã oóÕô]ÑÇŒýï€È{a·ˆûØÓ­ç4ßøþÔ”qì«ÎŸþPžßþþ/øÇCü{à1N"ŸÎsÀOd|âE}­Ä-æSï·€WÉ·J­Øñ Žl9&/O|Ào|¦û¢/9ôo¶ƒÄãàáó‡)nr>Jõâ:ò>ð¯8ßÌ~å£7€‹ÇRç)ÆãÏþrÙsוéà êÇØú×ÀÎë|Âz´Ï{E¾ˆ¼&~‡|X 'îÃgÎ ÿ͹ý÷ÎC2_ ûq=:}¶ê €9äÖ<ÇôwIïÍ“A~)°þ|ÙM÷i Ç”ž÷bzç$}.Aÿ(ù×Å„w™Srž‹¼0~Guô9u^@òÁ¹šoUò”ô_7èÍcE=›<(ó)²?ømã{Ý—ûköÀϼ {dèWS_’ý˜Î›{·ÿ&þ¦îô+Ù’ÏgÞwð+ü¥Ô½á„WGx’á+çœy_ž;è×ð^î¾jøÂõ~濤¯—Ï¥~WúÖÀ½ð‚«Þíz.çG^Qq 8Ø}çðØÈÓçäÜGO¶Þ›ï_Ògá½\ànæ2±ƒÜ›úù±¼‡ûøøG¹/ü:svä É_Á‹Ê¼2|¶ôQG#ª¸Çû»¾`ï ÒçQàœœ§Õý:ÿŸ ç"ý„7EóBžÃµ]gî„:+ïð¯û>Ð/xJ½·ëÿÊg™¿‹~êPA_¶¹À‚;™û“\'xÿAÀf>ü0<òäÃè'e?ýùzo÷³ò<èuYú‹á­ òãöïèy`êè;ç,¿À½¸®Í~ñÒx¯¼à¼?uvæ3¤ßö#è#ö@vy'ç`ÿÎÜ–ð‹ûb˜Û•>¹®Ïyqßò·a}Ñslô«J.,תW;~„?¤ç²_ç~ÈO*Ïs¸ƒs†ÇJø~?ì¸ø=}^ž‡cÿ€ÞÜî r¿;yúÊeŸŒ¿ƒÿO|ç=eì­ÓÜ•ó&ä©Ð?xÁ±cð’Á÷Éuæé_æü°Ò{óSáÅûÉü±ŸºyaåÕm‡°«Än€gÌvŽçaž;n%î#¿䣽特/î¼€\GeŸv‚ïçïØøÁôkõqû/ùqóÄIx~ì~Ëóð[©”{p\Iž=$_«Ï#>ö¸Dy÷¡ñ©û˜ÈW°÷1˜?Èx¶Â#˶]’ø7Ý'öÔ8 <‰ýg/{™/Opn̵ ×äYÀ‹ÈµÞ?ÜçIžÈþ~YôTŸ_Ì¿‡¨+2߃å{Ù¢¸CqÂWŸqs@ô³’ÿ/ZQûf^®´Êúö}{?|hâ}æ9œ¡L_©ò'æÃÎ0'ôixß[°}0¾g‚ô×q7}Ðð7<äéù<üy}TãÀá÷ø>™æL=¿&y¥eœƒ^ÐoDß*ò…?àOî }'N æ짨W'WƒØc+¿H}ý'¾õ{å7ñ¶Ïħąð´ wà ö™H¿ùòMa|é9ám÷éK.ÜŸDþýÅîcŸ™ß%®eÎ’¸€øý¥nÃ=7ѯ…W‘}Ü}€ªÏ’·ò¼ ù³÷û~Ù— þ‘r?ïK>Hçj;M†ÿÐ{Ûïƒ_&Ÿ QÀS‰6Þáýé?Eîà'e ¿OÝ»¤¼¼ ø]ËùTá`ÛñÇüž¢_<Ê{’g’ÎÓy>Ùﳓ^»o;˜wÀ.øóÉß°×X8‰?}²óâiLò?äȃÓתû #”s¿¯äÕvRþÇ}QÒ#òA®×Q'K>/˜—Õ=ÇQ?6ßzFüÃï뼂¾Ü¤žÁ÷ág‰—ØW lãl~_úM]’s‚ÇÅq‚äÅü*Ø-úB¿“÷ÿµ*--­TZÚq§GÛÿc/zDK—7/äå_F[ÖUzl¿Ìh[ô5?å½­ºížß?¼"Çß–â ‹Ö-¿ýÍ&ç__g´ííüøÒÖèÏ?ë}S½Æ±ÌßD øqágþwñxDûüÑmâ²Ñžó2¹#Úþøô¾ü½K´óØ k²öŽŠ¶ÝÿÝšÓ¬`i´í­ šýò"øØeÑÜ}KŸì·oœÿ?繡e•ŸË7;.ÚÐùºÚm;Ö‰æÿ<¾ÄÈ}ã¢Í­Ö]ðËO—D ?ûvVÅ~CÙ -š2û”ï¾ëý™²ç>Ÿeß\ßnÁ¸×¢-'œ¿9çê·£­×=éíçEÛ¿ëã×¾î÷äœÿLwW÷UGFÛž¼èݹc¢íO}¿y«A¾Wäé÷±¯i]òh剕^ë´ö=ßçœügVVŒÞŠ6 šÚä¶z'ø^Ùo²åów_}¼iû ¢Õ7ïl6¢~F¢’·5ûç–èòÍ´hçE ªNXzS´)í¤gFŸðuôGçÒ¯½´y´â«]æ>³/š>õà?7-ëtY~: ü3zýrs•Ž~÷Øo?-T¿ù“{ÛFË+Ü·üÑÕ­_âi¶¾Qñ¤Âê}ýïÚãŸÛÙøã>ÓK<m9¦þ—G´Œvtû±œÞ+¢•¯þ Ï‚9Ñï™å7ÿ0èjxÒ}>{œ3hì%Ñö>ÑI&å±o;ÚzËøy=övÀžX+žgÉõ;ÊžZ-š}éÐWÿc<ÑÎÿœ_A´í?®¨¸«RbwÒŽn~Z´®^‡ìß/mÙ=ðЇËU©rü=·ísž÷க]ÿQ´¸ç)¯6ž½ÃçöGÚ¢£›\f=^=éÜñeW_mZRæ–{Gt¶ÝÜ8è–“›mýÙ÷:õÔƒ¿Í/Šþ¬ypÝöÈv_”¹é±~~ªüúÓû¦ŒV-_UvÞGu¢%—ÜsþCƒkZÞ6OlÝ?.šͪ½pxé¾û¢?‹¶¾¹ ÚwÖ;îåÏûn;¯ã¥½l÷–Y^¯}Ó¹úùÍvöðûnoŸVþêoñslŸ–×®^©££5.þùëq{á±–~ýìöFu«Z¯þìûîóœòD´và„šãöwÖM.ÛhJéaÑš'7Ñ*ç7ÛQžÏŸ+9_½üýÞÍ)aÿƒ]Ñ~ìh{µQ%?¿k¹å =Ûrוžhþ5öÐr€=Þð½;»Õ¸tì+[ž¹ÿéÙ˼Ò?ÚYsâÇÃæm³Úñà#ÏžûáÑÚ[Ætê4ªò“|äkûŠ'Ý÷aa´åðQÿØZé£hYËßÚå\¼Â?·õä¶ÛLëîsØÒñ¦Jß”Üc;„_ÁmùqÀœ›––µ\y`ò2ÝNŠþ¼ðÓ7Ëô+e;g½j7{5}™ýöyCïñ¿+=zn­s§ÛjnÙŸç¿ë±§›ë]ÜxÈÀŽÑŠn?߮Ѣè·íßwh3¶…å »#ÞlûWüŸx”£M]v}ߪlßfõ>нΧѮôì/¶®=.ÚÚùƒ/‡œXd{0krÁÙù++q¾>WäeùÒEE]Úþj{‚¿Û\¹Lÿþ—¥Û`ÇÑ É¯?yU}:Ú¼döÂ+Ÿ|ÍòÍß§¤}2cH“¶>_älcÚÈæ?mýQ©ÉÈ.»çEÛn;û•Fg?Ïó"ÿs'¾|oýöÙŽà'Ñ{ä€{ã<-o² 꺠Wùîþ>p ¿?ZÞòÑ™µG§G‹/z÷’šý‡FÛ__´æ‡]‡Ǭ¹µo÷i½Øwá¹K?9ríEÑʺeË\ôzGã5‹ Æ,¸nU´ûàÉ¿<6{Z4¯ÖÐY-õeoZ´sãçæ¼×Éç†ÝÖ>Û9ŸWŠÙò‚¿Ó^t¿rÃ}ò|üÉûï¸õ„×ü5×ÿi¥’ït¼f„õnÇÝ•Nêü{ôûÓ?tNoô†õrs·è¾×_ª½wÖ}ùå>YàóÚº¯ÑÂq§Ô·Ý°\KîÑ?êv?9;~7šÛýë6£*í®ññ÷]¡ïï[SiFµÜ»çZ­»zÊÅ{¢/ ©8áÒÃm+„wxOôßò"yåßñ_“Ëþòb¹)ßa¿¿¹|\ÅrNŒæüXù“F5îŽvU9kI×k¶Ø¾×Êîb‡¶Ìo3åÌ›gíÚ8qu­a¹þ9ð÷…ÜrŸÈç‡ÝÁ?­N»ðËûsfÙ.¯ª˜ûÊ3F.‹}zêüìhÛ+;߬ÿÌuľ'üã¢sY:sÞÎhíÅ¿—糿—ý'ñ<+ZqêŸwyߣöÄ÷‰¯ÄzB¼Ççñ½Ø â™]%wëòq®ãüøœŒ?Gh’ñV/ì®\íñ®õÊ'çuÔ¼ß_É8,Ú¾qàˆ-Q;ûü-r¦ùkãôŠ{Ï¡q$þ½²¼wûíæ­Ä¾Ïßþ#¿û¢¯mZqYçžü?û6göÞxÝ ÷êØ ïøQâÌ5ve5>²Èçl}jðí¤³?ù%yçÂ/ì\`?€þ/éyëâµo ÷=b ~nו—vøëuåßñ9‚G|¯ò«œ?{™Éðþàç·‚£±›ŠOà9À1ÈòNþcçÌý7Õ1~Ä>ϰ|ÊߨNÈ?¡/Èøzå[u?¹¨]WÛì°ã/á#Λ}ߨí=•·¾°|{ã½õöžrIÓj~pòGÊù,ý;8ïǶÚN:ù½‰ÇñSàDðï‡|r®øóïîùà¹;Knq‚!oâûRTø3ÁÃò—øìyNð(þmUݼÏ+lïjy&Î_öFÇNcžz?Á§²‡àòHÈ!çÉ9ò=ÈòÂûHþ“xXveíÒaµNŽfùs±¿{úœúÛ”¶·:þ!_àóìÓ§ï¹5ovžyDÎñ‹äQÁaäGÀy“»–®×äŠýÞ+ÞØ°2³ÜǶ!žçܸðíž‹+Ô¨¾åLËø›ø œƒÝ%®ÿcÉ ›~<¢c´rÉÙc·¶¯è÷®ñÞØ}䔸»ŒÃ?â_È 7ØAî»þFŽvßRÏ{Ÿ²Ÿ!o¡}™¾gòŒ|>ñ[1ý\ÚlÑçoÎóý’Oçýí×eoÐâZí‘‹Ö/?¹Z…W3£©sžúçêwZ?Œ…ÿÁÇØOêè ñÖên-þx©ûÝIÜ.Í?à ì98ù—ñ{䫉Ãù^ì5ù¥õ]Žyð“Ï9/I~vÕ„%/u.y©ó²èù0ç)eO‘ áÛÏ?5«_¿ÍI|#;Hžuõþ]ñž)-m·}.zï}¥†vèøÖê$ß*ý]^tvé¥Óž°½Áo£wÈ!öœø„øË¸6ðOü»ó‹ºGâ$öì? ‡ÆÏòCøcÎ\Îç!'ºÞpÆ…ÍG:Nà\7ò™ÄC®Ê¿|pÎKÓ.Ÿø§ë¢È«Ïœ­xŸ{rý}Ò{Wƒ7u«Ûú¢jÇûwòäø‹}•?½}ײ¤ŽÎ}SÏAðCøð&òÉ9Q÷wÜ®|öaoúeƒÖ÷Äq ÷.àçÁc¾Gù%ñI9¿J<=ã}¸gî»BüC}\Š¡nÞ`ÿÜo ¸såû—nwõ1û¶º>‰}X•­òòºßŒ#ÐSpšãs½?zA^ yAþ‰ ÆTøä¹ûßßæóÂŽxvù©O–XÌ^jÛ ô½X}?,{½æ¢î}²î~NêûÔãO —rÞ¼ùkä˜8gÏðëšùxmË/õ:òÜÄïà ì!÷‡žZNõÞÔÅ]ÏR}Î?ÏûÉž†yž®¤Þ…œ’Çây‘[íñ²âœ6M:âÂ'_éûCŽÐkäùßàÈËïDŸy×oå_ÅÛí8•¸…|Uè?y>pƒö+XÎc~Ÿ|‹óÒúSûp£Ù™U—·hÖØz‡œáOÐWü¸Š|ÿ_sÎ7£'Æï²ø¾¿ ¾ç™ñ[a~ÖvVG~Éó‚;]Ôçƒ9gíñŠö,©3ño2¢ÝƒJ]|dž¾¶_¼O˜‡B8â§ _™öóØ{-·ö‡ÒoþøÌ~¿¯¼ rãsÇHo6,ûpÊsíïŒf=ÔúÆÇö÷`‰«]/Vþ»F½ÙquQý¿È½÷ó9àrp8v;‹Ÿ˜›Ó뮓¾[çú ø<ã<…ê³Ä}ø/þä<©ñ{î “¼û|"ÿô±`¨#àò%äÏÐoì™û6dß©wºÏLñ ~Ÿïaÿ7x¿ì>Ù5>ß}c)=u|]´\ÉßXuNØ=ãEá1þûç¼ÈçO¤äŽýãÎÛðyª‡ú¹ÀcÈ­êÛI–âòäÄ+¯­ûañœK3‰‹öN+Ú~åÍOYOÉÙÞ)¾¡> Þµ½â=±wÒ?ãFéëÅA?ÐÒîy¿oo<Ì~{üó|ÖÙ)ç3‘#åÿñWÆ%Ôi•‡@À1œ~ÄuAÙ ú-ç²ø!ü0ùòôGº>•²¾'ûgÕ'ø;ÏG<ë¾ì¡p3çA‹} oNŒãýü‚ó ú~ê:øsìëÿú>ü÷®c—-»´…?—<õM× õùØyìrå:±pçËï‡þûeü*û€ýñïKO×uêùðÄc2½W›x…º vù¦ ÎsÿŽ>{°¯÷ÚWŸ>g…Ï»Æ{ 'Î/)Ÿ® n'Ä=¯Ìè}Ñìê%“~Ù9ê4äg¨g§8!¿Å÷aÿÈËŸ#?ƒž£Ïøuíw²½"¾w¿/qb? ÄýÜùù}­Ë/*Ø^×÷Üq>ØQúU]W!.P^—çå{ð»î¿UŸƒó]’cüø{@üÍ¿;ß&;Ç÷…ùü q%v¿ŽÚqõGû_¹¦—ñq¸—~8ÎAïáºQ±ïÕý?“¼ûóW–ž œw˜O—ã¯9WוÔ?Aß ÏÉyÑGÂ9ñ|a>ˆº÷I> {îæs8äyÿÀÉeJTnC\m»Êïѧ€¼_Ÿ»ÿˆ¾åÉÿßTØmäÛ}ú|ì-z´²e…E·ßù…ûÁÉá¿ßÖyWP'pžFø›:ŸÏï¹~§¾2ð5u\¾y ¯‚8ÿA~yÁ^ƒßˆïñãà!×Ãéo>Cîñ«î7×ûïüU/ïx8ZzË çÍûè_Ñ‚ÌÉå_Ó<ÁKÂôÍp?È›ûk¨×KN±KÔ] ð'ïa®þžÓ~BÏIŸ‹í˜ô»%îâÿ“ßÁ¢/èŸíŠäûÍï“ÇÀŽ/ƒ3ð[!þqŸì¸ƒ¿óüÄí<v\ã|x†sVço?ßÈ-øIrZÔ¸åk-:—ä-d·Á!Äkäí]¿%¯F=Øñ"up}~—û<Ðû‹òo¼¾Õ÷Š>£ŸàËý#ÎY0ô¸·}à÷‘ªßÁ¸„>Wùã1¸Î8‡¼¬ò^a¾yÀ^R/ ¯Î}€Kø<ÿ]vüõoð.÷à|‘ÎÕyò0êŸö<q…pŸ¯ó¶¾/óã‹OµZî~âOì}^Ô5ü¼’/ìŽâ.u\ôÂv™8)ˆ‡¹ço–—¬|焞 "ï¹óyØŸqÓÊÕîѰÐõuô{ž¹þ,<ý~ûÁèõÇVmjû^æ÷±ÄÇä•Ð'õ!&y‰ÔÏ'~ºb¯žƒ~9ÝïI¿)v™ú&yn>Wv#éÃ<ÓÉ\ý!ù`úÞÿÚÇ‘|uþ”ýOîMuLþº8†<Žóëêwÿ¥Ë Ý´áK~—ûp¾Arë8Pö»®Æï¡÷ÔyÁåȸü‡=áþ¹'ð¾ûDdGÉãS‡Ïð|ôûѧ@Ÿ~ÔŸKGö?D¿}²®#3G¡:õæZø\â\繤?àNü†û§…;è‹uœ¦¼ rÍßå¹`nOòã¾P塨‡¹¿@ñ?r‰ßFN¨ z^Iñ¢óƒôW ‡Ó¿úYð±çV„[‘OòFΗ(^B®–-Ý2õ—õ7†òžè§æD¹òήGã7Àó²»Ôé'_ÚÏéù©Ãð{ôý`‡¸WéïQì9‰ÿ”HòÒ+ü7òC}Å}1Ìï*m;'yw•þôü›Î…ïçç=7À܇üŸ~>éÃÒýsøG×íeßÑ÷ýèsñ›®+ÒCŸ…òÒ¡¾»~Î|™ð®ç/ä7ý§ž9â>É+g§ã0ÏÂ÷{Þ¹úP”7qýJ}S»¦Í|ñòÉ>âyì~Éu?ÙW½W2g§{G¿|Îz/äÏ}oÒì—ó0ä‘tŽàAž‡¾çQ±ô÷2ç…pŸÄäG¸×õžÈ·ç²!oÆÉÁüþÅüŠg÷V/¹iäÙÛ·27_ìøù°>Kn©›‚Û±¿ž4uz«û‡Zï¸oÏ Éî£OôUú=äoɷЧC}<Æy€«é—sÝFß.D.˜Ër@?.D®8çK%ÏØê¸ø%Ήç Îÿ9O&ÿÎ<5ý—‹ä§°—|ý©<§ó²×ŽË‚ùMò|vŸ>ú9=O£þòŽÌ©‘7§¾†_@ÎÜg‰]’\`ÿøwòÑØ+ôÝ~U÷ìsQ#ú3óÒ—N›5°fÒ7¥ç÷Ü7}èú<ä…øùü.ï©aWô¯àßú;Ÿ’ˤ¾(ÿ„ž‡ymp z…=6.Ö=Òo]rœ©÷D,×è³ðzÉ<­¿_øÇúG¿óºWô_qmÂo"yö|¼òH|>x”ü-ÏC>½Ä¯ûs˜Ñ{{n'u~ÉùêÜx/ìrÀsðþî#T^ÿC×ü0è>ßvZzŽÜ¸ß[õ#ó…0·£ßÃÞâ‡,‡úùûþô]c«U)Áð©Ðç ¾.ãûÈ/›—@ù-ðu&ò6ü¾õNr‡¿ó¼žôkàÑ?lù¦Ó^ûsŸ³ìþ{Â?s¿ôÅùsÁÃÊÛá?œÏŽà}ÈÏÒ¯Á}rNžóGþôœž”¥Ÿç0oäÎ?/{Ã\ç¨ûOæ€øÿºæ¤=o¡çCþÑK亥yä¿\?Ò9š/@rG~Æü8’sõ­ùù8?Ïe3/Å|­¾ùGïö.Þüc”=Ä?îá|©gsŽÆ{²#Ää=Ëäð³øÏ¿H~ðoÔUˆc­’_ôyRÿ§ŸÃò)}#¯»wÒºa»Çès÷9è^§ŸùÕã#ÎÎOp ó7òS|ŸúÊŠÍ»„~…>!òžC—ÿöy*ŽÁ¾›gI÷ï~½¸Èv¾ äNvøP8fòšg~uï’hz§_/-º1™ Â?ƒ×lϤoàÎM&äoâù±£ÜOÈÃEs¨y:äûD~€Ÿ3o<"Ìñ3_ ïƒò4|.úbžì}”ÌÉè¬O’[×ýà)!Ž×ßÁà¶ÐO™¯F}xÆ[Òúg,‡úyú"±çè‰çd?±K£Ô^\ç”õÆ•èßWÔ¥ò«ß=—ïï!ž ý8çâgûžG÷ï>võ½½Uç©v'Ü™<§ô¹ö{Ê>ø¼õyÎsGæK’ïGýQÄ ¶ÏØ3ì¤äÄ|’û5p~ùÇ>ê¼ùÓó Âm{Ú·;Ù’ð"yLÏÅ£7º7úB±£ü>ñçÊÏ…÷Ž>ñœÌ“„¸˜¿£‡<xL<ɉŸÖ÷8O¾H/±s.ôøŽrM?æ97`§ô¼¶¯ä¥ô}¶{’#æn°¿ækàœ‰—ÔOð{­Ÿ¾?黣GöÌþ’y|æÔ™cR¼Nsþ_ú}óü²ì#v‡x—ºŠçèõ¼è•ût¸/ù]âVã^݇ûcõùƧ’ü+y çOÀ1È!z(»f½g^Y¸~ñpû~Á?žï•<†zæ¸Zö„þã:ü¼Þó³Î»m»Þ‡¸_ý—^;J\¢?±ᜨù·ÈËéÞwêå< .~q\!¹Ã.ÀsÀ½ÈÎúsÆ®â§îWÝì<ýiÜÏÁ®3nyøŸ—°ÃûÔù;𥜛ÛÙ¾r~’ó8­ü¿ó>Œ3æŸxÔ‡wfGû£>ozðxx£ý½‡Üݯ)¸€}íÈ©ùèÓÿ×®§†Ì0žÁOõ“ÙªÂ~ør­¿ÜƒúœÌß o¸÷&¤øÙ=Ç!ÿ™|oªOÞYüçg´ê{púe{Ÿ|ÄÞ'Ľ4¹cÈYoebÏà¶}ÀÏܼ~ãû_ÝrtpøŸoÞ¹êx?_Ñ?õÓÚ<ùi©ýøKøÅ£½­†M<ûÔJ‰_'NHù¿8gÍ£ÛëgœõØÐwëLóï{ÏBÀ³›6ñÚÅ×Ñ9©7¥ú‘㌵ŸÜ1½O'âÜ8íøå­™³:N×þLÉ‘ïOñ„ïY¸~^ôÇóÅYs§5;)ÁÇ©x>~ãPñ̰·Ävdßâ}Ý?xþ)êqÚÃÏ?»ð§îž'T¿zÉÞ’èà’un¼Åi¿ô>¢GÙ)ÌñÙžì/}m^߉-ÙS`½ÓÿwRpßìµ ÎÂþhß(8$N{ù¼%£ïš o²qyŇ}?·aæWôU›—?íÂj½—õØo¾sñ8»ïYçcþlÍ$û7µGbñGZnºrýó=¬ßâë·Ý=xÏŸÍ«ïý¯éÚkŸµä×zæýº©ý2Ñ>ñ9Kž°»q†xŵÉr¥=)¶×éÏü<¨Ü%#⌫÷ôÊ‘Çé¯Îïñû¨­qÚí?ß[mK¡ý8v—ýâ’cë‹yœwnîP¾Î.÷K¡—àJáN¿ø´7FŽà«O:8zåÜ8½]¯¬êeý§¿Á|äšOÅŸ`_5—‘ìNíŸwŸî¿/]œ~âÊ­½ŸxÌz)¹±=Æ>aOñóØoò9à}áñ8}\ZÉSW~œÖ¸Í›+yþR¼à–gúÁiôgÿ1wÆþê”¶w!¿2´þé©çJ÷OÌùùµ-§ZÿÀ¡È;ñâ(ö$8Fú¼oÐÇŸ}UñMïuÁ¿ ¿x>Ïø÷°Úsÿ°¿©_Ô8ü¾¼Å„¬ûã´åO.R¦®å–8„¾þ¢ ë}5¤å žyé™í;qáÁÃÚ]>ñµ Ë zJŸ;ûðgô±îÙÒôù‡ï82Nÿà•kϨ>Ýú‘6«A¿¡Ûâô‘½ï9#í÷ ß¹—°'C{ mG´ÇÂzÞ=~ìy_¢×ÖGä½Á_ 'ô}(?á}LÄ;²oÞ/–vßèÛËqýæ¶Çì‡Â+ÞHòGÊ`§ƒùjöìDE[k^5äØ~ì· _ˆÓÿ &8_žÒý+n0žQ^ˆý3γЗ®û4ÎÖ}9o©8#¹OÍ ¡g’»8m\åªSÓ¶ø^•/µ_î‰swzçÈY^Øï‘¾æé±•r=&/ î–?rœŒßײÇœÄù€»áÅÎ`ÍáùCâî=ý¬×~º´yiìnœöú¸›ŸÚºÀñ6ûÈ°ßøøT˜ÿ#Mÿ·ü~Â÷,ÿ‹ßu~eÿæ¾»nïyýbFÓçoXyÉWK^‰CÑæ|Ð+í5~Ö~ÛôJu•8ýñ¨ëù£¯ržƒx„}ú\Ç£àå üùEK{½·2çׄ¯AvóÂãÈ/+¿`{ƒžäŒÈì]鄜/&®“=Ið¡pŒü6{ ¼žNåSÐöcEû[î/3¸êi¶“ȇâŸìx×÷½•Ÿ$~ñù‰ÿîÐþÛÝ¿ϸ]÷¬¹ﳑ<&~_zH¾'kͫ댽ÏûüÈ‹ƒ³dOâŒÒŸOYÒë ã%ð—óÚß„] >Aœ~оVïÀ“'ÂîaŸñ3òoqúÎiÍ;VJ¾¿Á~?íµ½Ó>YÛ7ì/x…û!on¾óT^•½YÉ=Ê¿"7Øì=ï+ù_8_B^@y öšÚŽ8?¥=HÆ{òßôm…Ïœ‡àç¤OĵìïJðt 7¿ã/Ài¼Ÿ¾2nÝ$Þ$_kû¨¼óª¿8ŽKÝ£÷±Ên;.Ã^bŸ”/²&'œ§·üܘ‚N>ž‹<¹ä-ÉcJ¾ô^ì9Küï6º¸ü ®¾Àïhw1ýv¼þP\ËžFùGÛyâò5¼7zF¾¾yâ$åAÜßÅ|k8wmþú‡©¯+_ns¤òöüœ÷Ò¨®ã9ç€gŒz}©®w¨¾ËçÂKÇç3Ÿl^|xˆ©C«.I^™þ*ì‹ù1Uguÿ¦úÃþ8÷“«Nßù“„Û™¥Ï€ú›ëêªS07Êó3WFÝÏõ øÓƒyúÇÌgO”êa!?yéC¢XsMæóÔýÐ 1}_!ß¾ûæ9õã¿vìCÚ÷0+õ$ø ¨'3OÃ<:õA×Á”'6ó9òïðR¸îo/q”ò×î/<0ïϹëè’oóyê¹á‘v™ê‘ õ3#'ÔÍ·¢º8õdúy¨ßÙþ(Àü¹å\s¼ý*ìàžéƒFà‡ñ>õ9`?ˆŸÄGô­"ÇÒ;ó¢jŽytó•Ê€7èk€†¾$츟9?êæœy;Þ§Û¿ÝäÔã’þxÕõ±‹Ìѧľø{©7pÈ¿ö¿ñwúQé¡ï½cš«t¿{$gž¿R=Ú}0zOæL°[È7þ<sŽô3á¾(ö,¤ê‚¾OìˆëÖØ!É%çÎ}3gËÜ­yéÔ½…|ªø Ë=ûÔï½dï’gŸ9f¼õ»Lÿ¯ý2|ôÉ)¿€ŸËûèw ú™›§îï9Eés]è7<>ÌQ¸Þ÷”¼%ýÆè9|¼ò_Åæè~[öíx/Žü#q:|døGì­÷vINˆÿ¸7æIÀùæÍůÒ÷¬s`èßÅosÏž•¿@~=÷Fÿ‹ì±y¤áËbÞA¸»ãy[=}'œ¿x lÍsÍœžú`y߃üúê}Ÿì a. …cœ÷¯b¯¼?†~Qpç¨þ÷{é\ñï䕨{Ÿ†ùràoP¿çJŸ çä}TÂÇ íXñÅ–¾ž§1ߥöøÉXN©?0×%üáý :'æ¹ñÃÜ÷ˆŸý—÷:Òß"ÿ€òæ=Ö=P×AŸÑCÏ<ÄÔ'~Ï|ü²ìYð^=ù÷p®ÃsðsÈ®¢<'v×sÔdwÑìy÷çÉÿòsà pŸË½0w½hÏ]GÎìºÝòÏ&¸…ÏÁ…óÈómœ#~¾{pvÿŠß‡;à>ä`O*þŠy@øñ_Þ»¡øéÏ£_ç‹}ÄÎ`·=ç ¹5.a~YýSä}°Çœ›ç\è£Òœªûé»d?ªòªØ×2?€E¾<§¡÷¡ŸœÎÞ¯}êømó“°ÇFïK¼ ?Žòß¶ð}xOì4ýÜ<'÷g»ª{¥¯˜øˆxþŸ N–ì=’]÷Á#á~zýIÜ Þð>Õ͘«pß¼cš+ Œ=DÿÜG¯ç„¿\á¹Böéýˆ[ÀùÄYÜ·ùl5ÈÞ0ö<¹^vÌ{9˜ûÔ÷¿ !?8Ÿ‹ÿ'/€~"¿ìÇ3Ÿ€ü2ïCœN=š8™ïõühÀ§N~Î{:è3–= yËl¯Ø;"?I¾_æ ègc.û‹â9‘#ä˜sõ<7¼ðéߤ|ãWxýôíºŸY8k<&ì$qsà>üy˜WZpaóú\3Üzç8SöÏs ìMÔ8rG| o¸ž úÁñä»Ü¯Nž;#œE|Ãç£wø5ᙤÿš<‚ü+óøÞÛM2sFôíÐw«sâ}°ŸÖKÝ¿q3ϱ¤ú™}¾Øcì$þÃqœ>×s“Ò'ô ´sÜ¿ê•Åúü‰g½×[þ|¿`ï8;½`_ï¼nåxÊ{*¥ï–[æF$ÿÔµñ[à.ò<}Nþ\p²ž|í¹ú€ˆ¼zî}(’KÛ_õYc¿Öy¢ÄEÎss –Sò!’'æÂ‰OØ…\±ïünzéãÉ`>Î|1úy¾¼®yÅKãy'áGï;‘¾‘7O«nÿ‡ý!oÅsLú|âaÞËó(:_ô|„ÜaW‘ î<Ÿ€ï û‡ý„×Èñ ñ„~ÏÏO2úÍû¢×Ä¿ð’ò'v’}¨ìy/ƒ‰ƒÀÛáÜü½ÿ.Þ®„Oþ§”ß-Æ›£óKð)ûL'Áƒæ9Dø”Rr‘äy„ë8×€§¿ÿqæ;¾!åÑ7çÍ‚ïc¯þ–ù=ârôøœ¾‹O´)š5ß¼”àjòßó¯wïèú‡÷>ñyà âAÛúÓSõýä=/ZqIÇs~MöÁû|”‡óÏÃ߂އs‡ðb{ÿÝÄ›;ßÙ¤I2÷ÿ˜øRÀŸÒób8~Eð:÷öc™º·×|³•qO¨·ŠËŠñèà—¹ßo—ú8?JÝ…{¡_Eñ²¿Gsæþ;û#z¬Aͯ÷§ù>ÉC²Þ|©²küÿþív>›l<ÉûsoäC½WFòD݆¼ÿ|çú‘üÁŒO_˜¿¬üCþ^ò øwì7ö‚øƒ¼ùvã^廈ÿà Çÿy÷Ðòžø_òEÜ/rî§??ŠüWqÌåó9ð…R¿ã½8?ì öÜ"uOÅ~Ùâ¼}œƒW½Y|Ìé3_ýMçêç7ÛÙÃÏEV¼4i‡øÏu ðý÷ò{èû´ ‹ÿ¸£áVãâÜ¿ »Ãó‘?€¿Ô{ý¤7ø5özjž2ÑÇ”ý(Æ‹?þ»F|Êó“aÏúžYæy)iŸÌÒ¤m4þ¥e~Ö)™›Ó{$¼#ö¹â<É™SöIϗر ¾â:²üu9ðþ‰sÆÎiîÚŸóÉñoïÜööæbÿ_xûØ?ª<4|ˆ÷Ÿ’@¿u¯þ<î?ÂûO¨z{É'%ü–à6öWÁß3´Ú1Yßþ›wLñ,ö ¼BÝ,ä9e¿‡ó>úÿ³œs윒ý›äy.ì0öEûCŒG©‹‘¯w’aõÌÙÏ½ØæÚÚ•©GûùÐæ6…3üﲫþ»ÎÝ_4eö)ß}×Óú?-χY^á¾å®>hžpÙ¹¤~%{És“?%N Ï…]W§˜=ÂPç”>zOºâ–Ä4¸÷̧ŸNpz¿üJ3G_3íø÷ZÆff=Öú¸G¼G›|üzÎð{|ÎÒ‡äßåØgFüÊÞç@‹½7ö—ú²pÿý¾ô­Àçƒ_úçɯâÏÈៈ»„û‹=ÃoŠÄ¯ñ§ä4á)QûH| óHôZïƒù²ñdÜu•ù½WC¸“{ÀŽ ¿ÈŸÇ~/â ùq/þRöÃy&ô ¼…Ý`_&y#áõПÓ7êu‹Jœ¾±Ñ#ÅÏÙ<È)ÜœØñ‹‡ú*|迃7yÞGù¹ä9äŸÅÿæÿ/}OæÄÕßÂï¤úK±÷àž°gâ_)ösôÓçq¯Ê%óæ)=-ö9ò{Åþ¨7z®$¾P=Pyÿx±UOHìQ ?ûïè7u3üqõKø›ñsá^ü|ø¼¿>§ÿ÷ÿ—]Mò’©ºe1ž_å­ŠÉAèÇÁiÒ›äs/Ê~»oÙÏÏ(n‘¿(~?êDÿägüïàkÅ_þÿäß°gè#~¼t¨ûÂ.ôùÞO•.ûÕþ}ç{ñÓ¡=ÃÁK‡}‡7 ?ŠÝò~ƒ ;Ln ãnåM{¥x~i|㎴'ëÁ»\¬?…¼ïÚ õ½Òa/ÁOŠ#ýïøËÐ?rŠ—¿–²{îÇãü©ÿ’Ÿ_pnÁs:¨þÇbÿŸ¼1v…:Pèo8êÌä#ðëàpxy¡¿Ây)Î+¶’¸»>÷€‡‰7°#Ô‰9Wá¹Äßþ—ßÃß—ûß%àšbùFêeØmôHrR¬ÏÃq«âxò8è'rE=æÓú,»úŠ­ø{~¿ž¦/7°»Åñ²Î‡ºýÁà ôÜ…ý ÏǾâü¼ëˆÊÿcÝW£ø†Ÿ#¯é=ØÊǃÃèc >L=ÔûT/†G:ä{ ëëî“¢€:-üÖìÏПôs˜‡Uu2ê*®?Jî½'(È;ÿ&ÿïœùé™·€ÿ™ùý>¼ÞæuÇÿ‹×\qiâÇ”¢Ï…z7}žæk#"}CŸÝï©÷#¾vŸø´¸ì$ŸG½‘:-ñ}hÌy7y—òYîcѼõdž‡º3vÓ<ÌðC©O†~-A’ú¯ûñ…'Ícª¾÷+ÁWIýœ¾Ùoò¹ô›à×è?¥®ã|¬âƒº)ý”¼7yiäÅ{Aà &/Á>á*ô€=[[lòàHïW ö`y†òÇÄ«àeú è«E¯À|?xÖ<ÁÁ|‘ûõøCòäW™«ðü–ä‚|£yP¥×ü<ùkòvôUs~ì—#/Çû£—ÄŸø#ï«¥Žï·úîø}êA扖±ÿ ûE\Ͻ‘Gà|Ü_ ?9¼Ò#ïÑs˜Z}ýÄÛØWž›s1ïžô‹:”õTù&öCyž9úíõ޶Ǫcð<è÷Xê{Ì ¯'¼~ê«ñ|’úµÜGM} ^vx§áµWŸõ,êôxÎ@vüGuxï‰Õ}RgçxÎ-uIœÁ|†Þ‹ø‹çœ¾íû‡¯ºv«ï‡¼šû‹Ø¯ ¿AÝÍû¨C«ß޾1ú¼ˆëèGA¾ÈßÛ^‰oÅõLæËô{Ôué§p\~»Îy¢æ-eÿˆ~~ ê·~>ö3ËÿQ_1ÿ­ú›èߢ_‰º7ý6ø]ê®ø1ôÜs ôy¨ŒyFü¹÷KÒïÆ<Žø)Ì[«¾xp-öÅ<¹’cò”î÷úëþª$~bvžý0Á^l÷ñÉÒWê}ìÚÿþõüýøÌÒǤ{Ânº¯Ž}"²'ðU‘Ï£¿ÎsfôéI>Ù£~_…{áÑ#úkÈçyþ¹xZéKÕ{x~ èçÐ_dœÃܲ~\ﺷæïS~Ÿ½9Ø ð<òȾ$ä »K½ËshðóüÇØ+æ°gè!çlÞMý>rMß x×|»øË ŸÃ{ Ø» ó3ß8|·ô!¨ÿÆö^ç@¾ÜÎÍ‚#è?¦/yG¯Á…à"ü vó(¶ïS}ØWxÐòæ§–}BÎ/Àg|°ÿ¿Âœ–ž|¢ûW…c¨Ÿ‡vßú¬ß7àèk$OD~ÌþOÏC<ñü ÷É~9öJGÔ/gþë`¸ysõÿÑâ{òoá\+ö—¼‹y|yoéyóóóK¿®ìçÚá+ÖŸäs¼wSùÇ7znó Ë®0ž÷}³QvÃ{¯à·æþõÄ•áÞgï§eƒù<Ù1×ÃÕ_ú-ﻂŸ˜¾{ö†±_F?Çü¸÷Té^—}=Ž+äˆã|¾ø§€¿|"~ÙxVu—0…c·½w¼¥žŸÿã¹ég Îïz2|:oãNá#Ç]Ô)õÿ‘câ 0ä^Í'©ç ë øgä~]Î=€ŸxïÓÔ÷€Ï˜'áçàK¥^bžå™È›×Iù\ðŠó¨ºGÎË|Qð{*%cþ·¿ÎÇZ?ð–?ÕKÜ‚~ ïâo±[è£yXÄWGÞ™¾xmÌßFþBr€Ý3Ï'q¤þÝ{ç•ÿÇoqnø+ì/ñxÿÇÜ+÷Èüa8o†·–ó6þ¤_ƒ< ôyÄ.{ÿ‚öhàß¶{[‰˜ë7Of¯F¯ÑSãDp§äÚùöÒ“WÕyš?UúÍþ1p1ö{BÞ¿ë|­Î‰óð<ºâì:þùŸu¢ÂYž{—¿×"waþÙ¼'’'óq“¨þ ç#áÍ ¿@çÀûÙÎ(®ÆÞ`ïÍ_$9GO¨‡!÷ȸ{/MXG¡E½)Üω|€C½ï>áWpCÈÃã9fú¸ôw×%‡Ø9ìy]ì÷éý¢üž¾ßêžÍ3%=q_´øwx~ûoÙpøž{ÞÛ{!äGíÇõ=ø}ü#xþë¼,Òäü<àÇ‘/x¿çƒ/u?äϱŽŸá;¥¾A~‡|¯êaðt¸@É#üÿÞ—¢÷7?³ì,}7<'ùú­½ÿR¿;}wØò*èx‡s¢oûJ\¾Q^»ØsäÄùhé¡ëªóÁòXôa„ùü›çÛá3#îgn^û£¼†ýàÔ¥"OÌ ú~dwÌ޾éÞÈ{¹n'ËXNô|äyxoð–ãÙ=>¼â~Uö— ·zŸ(û­áÍS<&Ü“ù\È7(€½ç{¸Gø蛤^ÌscŸè£Ãï“—@¾¼G5ÈsŽü>¸’}¼yyêHð¸0gB>Ìq€p}Òòq‰æÃšoù*NâqÕƒÍK#ûG?'}ר#ò½à"ô {g}Ð9l ú·‘Oú-_²î×Ó¹£·ÄýîËÒùbï‰#Ù×DŸ,Ÿ‹_dí€ä»Í9p?øYú¨Áûo^KÉõpö iªçgBþHú8¹/øZÇû²óäýÀ-ô£À?™W‹=Äêg®ò^ä ˜;â}øÿîóUßçF?,öŸ¼óaà ü*õ~äyñ^#ñ“·r~Löûž/Òç„ܺ^  ÎsRñ=ñŽûw·r?[¾ð;<®g‘W ì-zÿÃNºß1ˆ3|ž’CÞ 9 î¤øÇû-—PÞƒç@ø=æ~˜[ä<8gø%×Ö½P÷ë.ü÷§’gÓÏá§É/‚ûè£BŽy_ð±û¥É“ Ç#Üý‡øÇAŠ#yOó¶ ÿÀÓ‚<‚+¹7ô€ºúCÝÒ}?ÔÇÁÒä=Ä€8/ãÆ ŸÌóÔç%/ä5¨OšZ{¿ù9ÇÙð/ËßÚö><ò’È“õLrÌÏÙÎë>á7%~÷þî OÇýëÊç Þ›üç ¿/}ðà2×ÓT_!Á®R¿‚÷½ÃŸ×áçxOü3}*Ž¥7Ô£¸?þÎ6ïÛ ÐýâG8WâNú3‘wꛎS©ƒu/Þ{Àý;ß®ç yó±ûÈ=úoù ú¾'â[ø=Ý'À ùeøÜŸ®sÃ.ðœú3ÎW«K¥…ý~æÓ·J¿l'À±Âí|>þÍ}n²£æ/…g‘}ø+áüòËœ8=ûø˜¯ã¹lw„눳™ßv\Fß2|œðKÞÉ㺯€º‡ònk&ìÊj|d‘åŽ8_çQŒ_ÌscàÅ?È=¼È/ò_›ýŽÎÝñì{¡ü¹ÄéðÚª¿†<)¿ç=ç²göÄÔC䟦žºsð·ùEæëáÞÐ{òÊ#§ýÿ y4ùsÿÏßþ¼ú„ü÷pÎUx.íé¿¿ãß çTùïœ3sDú3©k¦îëPçXlžYóÿkï †ø‚Â9j×IU·>äç(n:ä¿ WjNûüÜÁ|j1>ü3q9ó¢Ì©ª?êŸò·„|oVÈû‘ÌAþuŽÚuHxn‚s…¨Øç†sÜÊ‹ÿ¯ÉóÕÌ‘3F»Èï!?þŽ€ó?ô•ê>Üׯý(ÿí÷ xþŸÏ‹¾Å@.þÿýŸûÁûò•þ¯/såÜ3<â!)öóá^øŸB~1Íwû÷Ä“ø·Ï¾ý¿~/ï)Kñ¨$Ÿð—`7ƒ¾’°>å¿ÃcK¿‹öNšWLû><—þW^¨¿}åþÇï/üñßþyÅ©ÿãïÁƒa%øWRøûïõ:5žs¢§â« x¿Šûûà¾5‡ðÿ¬'Ñßþ¼xþÛ?ðGüíÏÿ=yÆùsª'$ò¦¾«àÜB¾ÿ®üÁ7tè甜¨Nòbò÷Tw,Æ;HŸ„òYÅùVS}†‡ä¡¾ðv—{åëU×,öïð‘ÿQÚßû#õÒÌ\l€'%æw"_ó¿%ÿê[ù_ó;š› ùRŠó$)O!¹ ùCþöñKœ£ùEïŠå¿ýÜÿ—xÍù>ÍÍþíÏ+Ïóÿo%¼3ê;¥¬¼ë…ý”‡ˆÈû…<–ÅøÉéßú/“óJÅÕÅ>_¼Vÿ[qß!>IòâÔÓÂ~\ñsòsþ›Ïû·Ï/Jàÿ¯?OýùÿãßïçÉ¿ü½TÜ!ÿù“`/Aq<¤û½ÿ>‡Ÿçl®ÛYì9àc£î¨úA’/P¿tØðïZ>ҬæÿÎ~øïÌéÁcEÿ?}Çð‹ÀðJÚo«ß”zEÀýw< Ì]$ú.{Ãsþ7‰§Su­¿}¾9ä ¿„þ’ùÞ€ÿíÍŸ*~8ªòð‡äQ¦ÿBù÷Ÿùš¯;”-ösð±Àkðúý÷íç_ù¾ùsÞ»¤ú§ò¾‡Æ!Š£°;ÊoøßÅ_|èxWóvÚP\SùÓ¿}nú~׿Ï3¦ìFh׋ýœêCûyÚ{ñü¯RiiÇî|8õ*êežŸN¦ŽNý…:>ü-ä©ù¼ý'—)Q¹M²ÏY{©‡1oL“çÕ‡@=Ý<>ú“~Òƒ}ò¦N}çIÏÿz²æ”Â}Ôô}Q _ >òñ¼??Gß"ý¤ºÞpÆ…ÍG&}¼ô“³'TŸgÞ4ý _}<7}&ô/Rç¥O’>Z檊û¦Ç}ýìKU? õMΟyþ÷S>$Ù›I¿®ðÓþ–ûË ®zšë¼ý*á(yKæe8oêqÞ{È^NõÙ…{œ!xùÜÄýI¿8w÷Iî|^ª7›wJõ}æ¸göì0çG¿(rM¼ËœêªqÚ÷'[³aÂG£¾kìçÍ}£§ôŸ çô±Po¥ ¹¡Ñö9Ô<¸åJ?ï8^ýžÈöÎs­ª?òÿyNÛ'ölª¿}—™w‰=íðó0ÇÁ>3ÅC¡ÞpÞØ=ì‡çÍåG}¯êOA?˜Ã‘=‹Ó+vÜXuõIŠæ+ÜW!;ÃsÑoÈçóý|®ëºÔy5çäç•]4Ï{Ñàu“=öžláκ5<¥ô³y^Q÷ -ïÝöü’wæO'ô<¬—xï¹ü$}ˆÜ³õ—÷¾ðþœ_¸žþÛMø·à‡ÎÀ.POÆN“g³Ëcw´78©+kþÈ|F[¾Ö¢ówI_£ôŽz48ÀþJûÁÌÅ~æ`6þ†ÏÝw澪óª$¼*è;sÌ—`—±_è)òmÿšü"þ è–¶«ÎyºE—({ìuÈ¿o¾?=Ÿçr¤ØM>;æùBÝ}ÂØ äÂú+yA?°§ð^â·á{²}•Dþè+¤Wþ?N?üÉyË^èk¹Àþ׸úÄxn÷»«Ï{žⷌCÔÇBÿÏi»%½Cß÷8gÁÐãÞ¶|š÷‡}’²³È߃ܠÿžcW"ÿŸ¹÷/Ë Wð§`ßÐÞ {P´´×{+s~Mö¯£ºoæ,ïô™Áû¨sÄЈ¿Cþ¸oú÷Íÿ‡ý—ß¶œèþèÏã=°è¹ùìØs]Óy'ëe—ÁGô?-·àwî—=Âì©CïõœÈzË9qŸžP–û“t.ÖÙaúçÜOD\£óá}vqËÃÿ¼Äódà:p±ç•$<¿í.{æ‰ØoËüótº_ËS°÷Žþ äÏ}rÌ›Ên GŽôy<vœy`sŸ›§ ‘ð^2‡¨ûÀ^‚K¸ú‘ô9b¾~$ó¾Ê~Øné9åwã´3Õ­šeÎ1~Óÿy­B?ŽîˆÓçîxý½¯¾‰ö?PæèNMâ ì÷‚Å^£_ØÛAýü*'w½ó¦Ï¿"|o9Ò9h¹éÊõÏ÷ð9„{³±gÌ™Z¿%¯à}óv©Ù¼ÂÌaIN°ëø)â­}‹÷uÿàù§OðœÄíà!ãSýý`økžÏxXr>|ŽåVö9‡òþ踅¾rôŒ~]ì&?o\,¿o,½ïa‡ÛÔ¿g9§ ç?‰wáË'bwÀ÷Æ«Ì)«ÿÐç§çõ|¶äËòŸ¤îÅóÂóÖcölë¹l$÷ÈeÈC±ÙI¯=ýUûyò*ÄgæT¼…~¯@¾ÑÏAÈ^„<8Ès´|¾ÿÀÍ{?€?ÐçƒãñG¡?Ã2çóbÞþpÅÃÆ!Ò/ä¿k|.»C¼g»,UÝùúÈmçô<ØYîû` ¯à½ÒKåAâ´_zÑ£ìËöÞs_ò“®§<,ÄAÔµœÏÀWðœ–Gý;ýñÆÅÔÛRv=N»î»§Þú±íÑö³V^R»ºÏ›½QÈ-xþ`åw>šÒob²?HòÁ÷ãÏä§âô³^ûéÒæ¥"w¾Iò _(|)æÑ—¿3‹ü³ï—sÓs;.•"îbÏ‹óJÎöÞ“`¾ßs\ÂÅö:IÌë¬ó oë¸Wûø|üú ûgÓåÏ=Ï}îs‘=ÓÎþ­÷„o1žvÞXöVö5N?qåÖÞO<–è±ì®ý{X¤¿Þ[¤¿»>E\'{總Láðeœì#â|¦ñõ‚Ã7ùÌ[/†xZàG܈_â~Ñ/â=×UƒýOàoìä9N»oôíe8Ã~Ãv_øÉ<#½ÆŽÚŸ+n"¯äz´üšóÀò×öSÔσ|ž÷(ŸÁ} ¸ž‡ž8NÔóÀÇåzý'ó=Îõ/âSãò§Ô …ƒ¹ê<·ñºôûÀýQ§ ý›ý$ÏCÞD8-úPŒ3äÇÔ§§½|Þ’ÑwMNê|ðTIž¨G™ŸOø‹þâdç£ØÇÀ¾Íýܼ~ãû_Ý–ð–r>ÒìåþÞCnˆŠnKxÀ5çŠ>HÞã´'Ÿ|AÉ'í×ð¯è±ù.ä7±ÏðÕ„yGçKØßC=\÷ÌóºA~Ž|)ÏÇ}a±G’7ž;±;Ôýù>ê øÞ_”ãõ­Åöè:£Ùü"Ÿøÿ†|;oŸ²;qúÈÞ÷œNx~tÞà4ó¾Á‡¢¸‚¸}uœ¡üù_ï£Bï„g‰èO0ï¹ìïåºüøìOCnðÏ)¹ÓÆU®:5m‹í òÏïWoœgúe¸çðûCÿÀ烇°Øåý]ÛõªÚeƒíúNÜÀ½€c쟉å÷ÀÆ‹Ô郂¯”ýCzЯ“Ÿs\¤Ï'Þ3Ž“œ¸î­ççü̋ȼ9<À²æÿ ö˜9#ùâ÷9gx˜7'¯ŠŸqÿxDxGqŽù6ÌïNý˜¾!ù žÃqŸžùmä‹÷'Žs\Þgo—ð¢õF¸Æu)}}Cƃ’'â×åtô¯ß ¿ØžÈžR¿>pØ÷sf~…?4Π¾bÞ5é±ëòÔõ½®Çè¾ý{Âø/óû(ŽÃ.˜oOzÀ¯˜o)õÿã´+Þ¯ÿLƒªØù¸Ä«Û›þœ>Úø)Œ“á=Â.zÿC€CÈÛ`ïåW½?$ýŽÓ¶TÝôû¯>9½'ùxêOôÿq_®×¿“×¢.Ë>,åŸ°Ûø}Í£ÆmºßSfs]瑼Wƒz~À§Jÿ"ürÆ«È }Ò׿„3Ð5¯rl¿„ÇPz€Ü‚{Ì~”>äy,—Ê£®ÃèûÜ'dÞnòó²×äÙÀ ÞÇJÝHvËsUð«ûFKüVˆKÑ;ì§ëaúåéâôriÛWeÎp¾Äñ‡âEô!ÌcYÏ¥Çô»s°kÎÁû _'¼ªÊ£Qç÷~ öqª^Æ{«îgžúÆ+—v>˜ôƒ€Ó„ Òz½—óÀw\¯qý$ÈïKOŒ¯‘/×)„GÉSq¿ô?ð¹è“ómŠéG¡Ï¶¯ò“ØW×›‘{â!å•|þ²3à]ç ÿúïÆOÄ£Î;)_Šþøœ$Oa¾¹v÷õ©ï̼ÁêÀŸp^î㢅¿âyå_?É7É?â/ÝŸ¦sDÿÉ{¸®Á>òúð(+®q>"Èx/ùýç6~¸ïÒÓÖ¯Iú3•u\M¾]v¿Ãû(>ÓÛõêpÁª^ŽW±×È=çj¾oò ô‡Ð/Á^Ù3ó +Êïó§÷üøÁyAúeϱÿ¶×àIý¼ëþÁ^ äÃþ‚=Vð¥QŸMù§8£bó_{þô¬õ˜¼œïM÷Íó¹“þNâýIÒý7ô™0WN¦¾ ”ð«yÒ…Âû_pîcÒ÷o‚+ÈS ßø}‰·B¼Ïs9'?ò’yÏ ýÔôm§)C½¹=8üÏ7ï\u¼ó‘ØÇ/äß‚ýtèuXçç=™7t~•ü³ô¹Òðð¿·ÁM®KR§?Xx ¹tIx;ä}êì¡N­ü?O\?‘ý õ ìyųÌ=зˆÜºžH߈î{â½®ðS—âooÿùÞj[ ­'ÔóÉ#¯eœ@Äþtò—ðÙ³§V¿O_rïúù ýIÿ}•æm‡7Jzhžyî•}º²û΃€¯#ôŽz!ý²+ηá¿Àß:ç‘ØÛ›Š[’< }ßa¿ƒäÇyùç›$γ)®Ãyž†ý—úƒ/Œ}ÝËìãL{œñx¥[ú(•à5Ý'û ¨Ïd<[á‘eÛ.)6×C\ƒ\zî•>lpžë¸ä‡•³~Ð?Á¼‚p˜óPÂ%ÔÿÝoLÞŽ9üü‡ð¶ÃÉÞIÙ)ï' ö¬šïYöÜà>Dò1ú^÷íèÞÙïMþÕ}±ÂiäóŃ弳÷8ëyÃysøÔ¸/â3øû<ב²ëia½ýµ!ÿ¨ó&⥛9úšiÇŸ¸—ú¡?Ç{aô|Èy*x;ÑSžÓý‡à>êùì¡Q|AžÚ{¦”' æFÉ›øïÔ¹±ó;Ìo9¹0/é?Q|vø¿‰fߨÿ/áë ¯'åï\ŸôÞ.ñý¹?åBž¸Ä.¦~®Ø<$v¯X}¿ŠžP÷Õ÷³o&Ü#d» _Ÿðü›|®ù7ñ×äáðÌíéó½wû¼¯øžáeò܇ð³ñ¨òÔÀæ Ï%} âsJòüŠw'ïiÒ¿»¿CrµøÀ·“~ß‘ð¶rÿ«–¯*;ï£:!?B¬ü„÷Þ+¯ãøX8ÈòP~"ìÿC¾Ãø™þöþy^B~ƒ½Ã¶[Ø!òÞòØ]Ç3’[xPÉ£ð¹îk¢Aq«yçe,ìßм3ïaÞRÍ·qÎâ%óùˆÙòŽs?¹ð}´ô¥8Ž&þ¦Î¯û†o•y8ãÙAø³½GIxy†ç•~@øð[ØCp;ø‹ù÷Å«îŠÜy¿'ý?òðaÚoS”ð\ħÆUÒc÷‰KŸ©û‘EŽ\÷¢Ou Ÿ+󥊓=g ¯½Î1ÄQÈ+|göçä+$ïŽ{°KO°ù˜Á?à2æ éÐ¬Ì7IN½Ÿ˜yNxþƒ<qòá|¼ìòì> á.þï‡OûNrü£?½¯’¸˜ü‚ž“ü·ó’Oï;”_¥þí~kì5sòsÄžÛÞ±Gö=ìg0Ÿ¶îÕyUÝ‹çÞõœî»§ÿ˜|7ýwÔñèÃ×Ï›÷[õ'ôžRì~Õõ'ÙUÏíë\*ÎùÂ÷‹=qü+=ó~0õßy®@õø$8o÷WHˆ{Øãå:;}w³ž‡b®û¬çàïÔ¥yïC‚OóFœ7ùgïïe/ûWéa~†üœü&ñùyïµ` ûG…áG´<1§-û#>Ì„'8R?|ào½7PòD<þE_]ßNÙ8½éG{´^ëú±ûx%ØYøÝW£óÀOÊž'ûf˜“ æ\Ýo«üyï㦿˜>!æçÉçWзɹÈohw‚Ëeï‰OøÝ<§'½§c?ªçµ½Á>P—Ô9ñ{áž ÷Q2Ÿ¨|!üB÷×à ¡¹ü…ý8¼WšçsÝŸM ýbŠ/WTœ‰¾ð=ô·aŸÜ·L=>ð!uýé<sâÌ ÓÏʲê7Æ ðU}ªÖ³€ÏÇ< ª‡º/YvÜvˆ¸»§ÏǾ’ÇGÌ^–ÿáyˆÏ°ƒôKâ ð:ïï>áó¨Žg¼I_~MvÚxCþ‰81œg2ÞBø>úéÉ“(η×_šÿŠþßÔ½&qúÏ|µþGsOô¡z.Ž9[ÅÞ?eXù¾°ÿ€9Rì ÷ NäÞÀýž— ?àôÍõiæ‰Ù;¬~ ç·áy øûŒcô}Úûb;^`¿8ùRã7ðüFô×w¡7ÆkðR—…×?¥8Jùwóÿ¹Š|3¼hz~ãMòGôcÃCð"¸~Ì…}cž×@Ïái“½ÀŸou¾\Kþ’þ!æƒà; ¿Æ¾lòxôµ³/”¼óxÏ ¼²Èþ¾ÿ¢ìÝêIçŽ/»úú$?E~[õp2ò̘üLœ5¨Ù+ ˆKu,~LûyqV×ÒÕ+LÞ——µbÙ¾s⬴w¦?Òh2ÎìxaÍí¿çÔ¾çÁã-—XûÏËÎ|¸nœ·¥VýZƒƹ—Mh7ôÓó㬻<öþ°¯ãÜÒ‹?-ocœ3"³w¥>ŠKTÜoñ–3ã¼Ü†ßOl·:ÎÚÕ}ã˜~uâüÃj½p÷çÄ%Þ´eË;gÆé¯Îïñû¨­qö¤Z úMÜéß+Yv˱_¿<ÎÊËYÝêñ3èoIž¯aƯ¿ö_¿ß÷ì9õOû%.\{ØG]<ŠÏ¥¯'ÎÌù¦Íâ#?Š3Zõ=8ý²‡ãìÊGÏžYizœ›š'ˆ³J7øvúýâÂöeÓs*43§y÷Êó> ”=ö²³ÛÆ%¦œó\k¶Æ%õžª«Ç¹»Öì¸ndœ]»ê?ì½Ýç—Y¹{‡ Ûg6É©RsgÃ8¿Ùê×Êmï9±¬æ Æž~mFœó\­“ZýÜ-Îíÿù˜wšTZw{ÓKïóú> ò­ã¼çÊv¬~åqÖ¸?\—þ]œþK»í+öõŒó†T½nߪ8{^ù¶×¿8#γ^¿ýž´¸Ä)s¶Iÿ"ÎÙ<ï¤éQ8wÈŸ=:êâ¸ä6º¸üq^Ãì&­×\ç ÿmÅà:·Äy‡U›|Æ##|ê KåìªRçÖEqÆ€*wÞÒ¢SœÙlôÂnÓ?³;¾vÊu¥.ó[gîú1û™8kb§éõ,g={ý_6Þgöé8£bÉÚqΤ6#Æ_:8Î9ìåøìj ã­XvfÕsâÂ!‡Í©Tï͸Äe½2Ìo§Íê_Ðo趸~/Õß—l’³®å´×âÜVþPÿ³Îq‰cZÍivßcqÁklpIœßaËÀgßçÝ?n~‡­eâìÆoN{ø(üeœ±k[Û6íÊÆyÕGOŸÝº}œ^kùö~]ˆ³˜uÆ[jZnõ{qö]‹oÊ|©{\bnÉeWÍš—}Ú'Óï—jRøó–¼G⬃LZ²e›ï9·yZÕ»FwŽsãksþ¶8mÝMUçUÓÛ ~nLA§¸°aÖŠíÿªgô²ðäúçÅ%÷úS3¿Š &UaŹí™‰3k¼]4sÚÅø…8{íQÓ§/¨gÝßaå[O]g9Êißyíäj™q©þ[ïí|̹qvÛ2ªÿó@\âýw.,S¹8§kÞ-mswqÞä—ãÌ·K(»»l\0wóŸ½ónö{òÿ¹ÝCœ9÷£3òë|°¬Ã{ßÜgœ²ó®üãöÅéË[LÈÚ¹?ÎnuëÍÕ¿¿(.Œ¶åßöÇ÷qæ‹+µ´,Î9¥÷™…'œ`½B?KL/ÿîîqc,ùÓjÐsô¯qþæ/>ÿÍ+¶9CjÎ*7­»ïµ uÅÆ}+}J¿Nœ;âøÏv}¾(.,wXÞczÆYe{ìºá˜ñ–§ìÃFµœ}yù8'÷¶{ßÍhN[›[êŒqÁ¯^9Ο›%{•ÝÚ?J ‹ÿŒKê}8ìþP}qNŸ«gß~ù’D>RÏéßãœòÖæ6Ê/Ý<Îí0ä°‹Ïÿò‰-»íg¸ìANZ劃íï2[]ýõ ¥þôßwJµÜÞ}ÿq‰K¶W˜›—ì]´hô5‡ÛÞd]Öý¤‚sÚ2'íçϪ4ú‹F‹.Ið™ìDîýóv—/y­?WbƉÛ~Üû_¸°É€ VþØ1.lSq@ß<'jÜ£~@ûëÛùýãG[=és.¨QXwSÛͶÿºúRãLæé4_xØÑâJ%㌵ŸÜ1½O'Û»¼ƒ¿×~ö×q^ëFw|öê¸ä[ûóN?y°qe^‡?Úw¸««å*+qOæÒ~¾Üi÷¾f\l½P=Ñs£¹K>ÿÆäuqÆ–æW}Ûw¾Gðg^jÎ'ÎÔ¸ùaêÅ9ñ¯V<ㆸDJ_㌆3\ðòæÇ,7Èzž3öÛy7n8žý¹ÆEàGãFÝ_vNÓ³+Íœ‹õ9ÉiÜé#wný6Ëqv¿Ë{dmî4ùÚï.²Ž#ÞŠ³:~Þ`çéσoÉw`ŸÑâž;Æ}‚ßñûy§ýÌÇÔ‰s»ž¾ïË·cÿþ‘÷°]<à7±§àâ‚ÿä×þÅý{ß²âù8]ø¥äæ=¼ïKûMüvás‡ÝrÑû¥âìá{Î8êúÉ­ø_î=Ò<›çé97Ëì0¸¿­÷¤?ßr‡ŸÅ^ƒ£…gãÜSÓ.¸æ–[7€±C%›—­~]Áñä³ãLÙpò ÞA_ѯÌÚ¯f?sħö—ø9ûÝ~À®’?´½æûJ¦¥¯¸zãpÇÄEÈ3úÅùá?ÑÌ./ßùåúµ¶]•ßÛxB\rzÚê¦ËGÇƒŽªvûÀÅqö[ß·ÚåCãƒìc¶½~ñ™‰Ÿ]úPî/íòsÙnÈob¯Ñî'§Õ›§~´å‡8³ÇÂÚo~þ­ñpNõ'ïhPßqþ ¹ä|9/üñ2zÃçà×ðÈ•ãòò¼oî[›kŸwtrœ³Î“8Ÿ{-¹´p÷òçþK.'~³ûìUøeú-wØ!p<þÅþ±§~ûÆ÷‡Þ–»·Â¸“/Hìï/{‘‘êÓñý‚ýÞÂ!y‹j÷j~©ãÉsr¾²7¶wŠ3äÏý9nøñ“§®4.Ò|pœ;ï¨Ï/[X‚üO\8ñÏýsVr.»¦ìyɇ>ÏRµ³zNšÖ¤X¼…ɪõóÆ¢鯱ê{Nüžî9D>‘üñ-Ï‹ýÿbŸU§‹KêÿçVnò¯ÙWLö÷ä®)êýûOmãŒZ”.ìr„ã{âTp8 {îÃŽä)¾'^*¬]jÁ·½êÆÙÏ~øô”%í?öÛ:—Ü>gùúÌA¾âZüñß“U}n«×^9,ΩԯT…–Ùqnë¬f?=ý˜q,v¯pן?½rô‡qá ãNùùâåq‰»;Ù¡óq–kä9H±è¾ú.LâeáUϤæ«ã¼]3¶>“w‚ý8rÈ}‚,ï²È÷fÿ¯|L®pMþ³»nøçY忯8‰û%Žâ9gÊ?g2íÞ&7 ޳§µîÙ­Ï9‰_ïÊÿs>¾Wì¬üöƒ| Ÿ¾âáÇd‰sðøOž?ãêý½räǶ7ømð…íϯûwòØwìvÂñ‰ð›ï95æ{#…?àû jÍš>ýÓ›|äaäï“8³ýì›Æ ;5.ù\éSάð_qBã‹Û]Z´ÊùžÛz'\UÐ{Ç¿¾óq=ö§0•g‚¿Ïþ{"|á9¹Wµ¯põmW ß®?ºÏUõê^ô¹™§Š>æéèK¦Î®zIØì½ð#Ã[©ºŠyòà»LÕ ž7Õ¹™/§>cÞxÕ]©ßP—óž'ú¸˜£Öó¬îÖâ—ºßð#ó¼úyó!Óï>Ÿ:[8÷î~/øiô^Þ£ çgß÷”¨ßÃ<8ª1ßä~Kún‚ùE÷K°?~QÕÍ\ÿ¤/·êðzùçT£O›yúeÜïH¬ÎÃû‘à{¥QsÿÜ[ÈSd>Jñ$›·MŸKÇ<šªËRgbÍ<¾šÇN[þäÂ!eê&?O½Mõ7ú*̧¨óe>Ïõjõ‘¹?‰ú,õxíÑp¼CÝ[òɰûõx/øÆTobÎÞ®ýÑ Ÿ7=x ç§=üü³ êž=xØÛ*{DTF޼§ˆ}%êÂ^¢oÔ…Í»!ûÉ{#çôOx¾Lý<Þ#=Á>x›üó/ôÅ"ôíÒ§ã÷ÿà=ìgRç졤ŸLþ‡÷4o}Óðߪnm>+x`Å“É|¼yûèkFá Ï‰½Wð/èÜ7ôc¸ÏlÙ{÷È>°/7ä› ß|_ì{Ò¹"ä§áÄφsÜÞ÷!y[´ç®#gvÝžÌ%¼1è5~˜þúS©û»ÏMþ—þær9/äÈóÊSá#EÞ6¥ôÌèþLÏÑÅ~+õ!Ì™oZúïþ6ü}nô³h¾Ã{…¿¬ß²ÓôG!·Ø'ë {u‚çBÜ÷Á{7˜ïa®“¾uüžä ž+óåë©ï¦o°iÌu=¬§ð„ûð<§/<úðs¨_ÙüròÞg€½¾ÂN1ÇJßy9dCü^òæ°0禥eý9ôáÂ÷„ñïæ-dîEýpž{'Ñïªóõ¼}Lò/Ìmùœƒ=jرÀ~ZÿÌ ¼bIõ¢×à.p'ó½ËÒ—±z\Òÿêý/è/r yÄ»‰þß`ÞùGÐ×IŸ–?O¿/?ó¬xþü$ùGî‘7øcÌC¤ÿo^ux{á)•?ÀnÂããù çIß6ïÁü#~—=;È3}Ñî§ö°¸+ègÙ'žúy™á9åOÜWJüUÒï'^Gþ5÷ÒgϾ‹çÿ…óØapÿŽ@ÿÀiø5žßv^·“½O0§ç~3æ$dßÍߣ¾GÎÅ{@$ßæçc™pýcà/ǵô²73°–#ù÷ÕÑ¿ìõÔ¹%}ùì;dÿˆüý¡Žåß½ïûμöHrÊç)NˆÓªÞÑè•z¯X®ÝOž²3æÇ1¯¼úÃwÍþX=Ÿùï裧o .óÞGöãèOÎyM÷³{'^T¼g>Π_Pv‚þŒÄ³ÿþQøÓñ‹ä9Çzïµä;ê~^ö5c×Ào²[æù‘<ò¼ØQÎ…¹pÁæôÁ_¯+ÿïKÿTÒoKŸ1q¶ü[8gdydÞ˜ýÍÌ1çÅ>!æìäܯ+œ>á=÷3ûctÎá>jλäyúMunægg_‘üù¤¥Þ×*\o>Ý'zîýFð8)¾Òž$çk̃Ç~Ð`O8ü|áœ0~þ8ø8±¯šÓp<ò;³§<Nâþ|.º7Þ ;=?ëÈa»ºÝ˜ô»ý½œ—÷``Ù×+yñ~åsÀåáLÏÁ“@ÞLòÍ}¹Þ8É™÷¤IÿWa_ƒ¾eøKwÊÏz.BþÍñ$rÍϳO7à‘æ¼¼'‰}zš¯p¾ˆ9Ý7ça|A> ø)¤7ž y_xî`Äñøœ=Z²î×–|²×¨¹Gâ"ï T^`Ÿ˜{Õóz¿%{òØ·ÉÞ*á0â é7ýD ñ*üjÂŽ/˜ë“7ß3ü£²¿æï—}öóHŽ‘wÎÅ{i‚¾Ÿ/¿ÿ)óýa<­¸¼†ÝÀ.xNRò±±Ò£çÖ:wz¢©sõ¹{¿0{IÙSH~ûɹ1þž˜—¼Á^JÅž“€—A~ÞæC»æy¬Àï’@ÞßGžÀċ‘ONzÊ÷zß„Þï7^UþÃxþ5òd’kϧ /£ÇÜ3ùbpypóAÊ¿!çÆ’óÓIþˆ_Ík²ä=Üä¹ò ðDJÏœ?aއ8¿Çž4x1˜_’½ ó#È%ÏæGó7Rï'‹zIÊ.:ï.ÿXl¾´þý¦Å¼Þ'AMsìì¯2Ÿ;¼³Šû_`yp6sÛÌï±ÿYçD|Ï\"sGÆ)è~H÷_ vÕ< :_xÙ\Ò}/1_>ð{k®säœðßä ÍÇ^¼”Ü%q³ì¡÷>‰‡><ìˆçtñz~×Kూ/eÍÊ:Ÿ†^¹~¤ó2<°ÿö>×#¥¯žïÏ¡oìÓÏ·°ýûãëFÕš^nrOØSùeäÞ|‡Ô›ô¼Øï¦Ážüˆþnû‡¾‡¸¼ì|§ü7þ•óÂn·<ùÌEP7Ÿ8Ï‘´ÿ‡W[vŒórAyKÏ¢WŠûÈç›ß(ØKáüùFøè%_›*ÿÞ¯KÍŠÉ^EÙ}ÿ"c>æø™×c/³òBØIŸ/õlæ+áí×ü´÷|{ÓðwÔ³Àóø{ò…Øgó=Áo O²ž½q]DöÔòN§nÊœ'ü*Á<þrÝ䲦”–Ì¥‘o_ëóÌßÉ\m`¯øêæmßkÈ?c}#îgž½‡‡Bùì+q-üÂæ§„ÿWóì7ðœ|°OÞ<{ìíD~ÃvLzîÿóýÃ,<æ¹àOó~{æF‘+æ>4ð<÷ò\¡×áþ'ð<“Ø)÷ЇÄñÎuçÝÁÑÊ{ƒÛÐì»÷°·Ž<·î‡çööÀc§É×Éîð^ž—<ÚïÁ;Ëžxóï“÷¡z\ïK¾žûƯ˜‡Wrãz5vÞ æƒ…/ÌF^•yyxW„¸O×#¨·ËÞzŸâÖÇÙóõÂñæ{Ðï[®é‡A_Ø?ìIF¯À×èù’ ó˜ÂÏ¥óv_xÉ|ÔÂoÔì·•g'OÆÝøexIœwÒ{‚»øwž?hjÕƒÌ[Çþé»ûl°wz/ê‡Þ'Ì>é­ãþ oÃü¾ðúP¿Áþéy±ðÙx^\üuØ1Ç%A=Ìû¼ä?ÇÏ(qõ6ñ¥ã/Áù¼ã¡`ß)ùîÛq üÔŠGŒWÅÛ†ývÝXÏIþ,Äûèò‚!ßi~=ùY×õ%·æ¹öÃ}#AÓõOÕw½…–Cí0üüðL OìÓœl9áüÍ9W¿]|¿&yöžû‘=.|OÒõ%ü8I*¨;z¯™äCú•ô‚¨—Ëî›Ï¿M½^?O|ƒÿ²¦ïUrbw¸×¼ïìgn#®7ÿ r„š~.v‡> âOôÀu újÙCŸ{î‚ü—¿'ÈGáW°#ì0ž!nÇb½ÿ]Ÿg~jö´Ð·¿!yCÙiÛòÄÈ {±$¿îW.ÃÏ'e\t¼ŽR:ö•È/ØoÒBÞž:«þt>\ùÛKú…$¯®7¡OL¸‡"äoâžÈŸ¸î Ÿ)õoÉ!÷`ß~Ê}¾’SïS ð©û%÷®Ï“¯×¿cÿÍÏßvFrj>®ç£'®Wêó,Ïàð,q<ùhö:Q'¢^EÿžÞuóx÷®xûqß"{Žô½Ø9ÎaÓE—]ß·j§$_"¯üJœ6ø´ï·Î?'á¥W~6äýûáœw²_J÷Ž=`_µó!Ò?øïoW¼„ÿBñàóšÒ7ÄDåYÉ™g^7öËê½ÈSy?£ú?½Où½§ûŸéƒý¡¾ì>$â!ÝŸí$q'þ‘>GöOÂÏœôÌû¬Uçáœ]¦G.ùyú/$Þ_C„žÓú@I°·ÙuiòÌô‰ çÛ¿of?%sä ^[ÇQÄçÁžjêø!çE…ópŽÀû7S~޹%÷sÊîòyœ3õEôÔ{…ƒÍ ~c/ þWxülȧŒ%ÿmJúË”Oá=8ë…ôÈÿ÷Þcöý‘wQ¾‰ó û»Ü¿Ï-ñ)û¦¥GÂÉ>_ú˜ˆ+à;¦nÀžGá+÷‰é¾Ü7-…¿r}U?gþ@ü‹âcôÅõ,òƪ‡·ð>ìiÀ?ÁÿÈ{È8ÿìÙñ–÷»'Sï½áïØ ã@ÙúâÈ£;¯/9¥Nö‡¸î@^¿ËóHïÈ» ‡øÍ_{‹]ô|8†ø#˜G1/ó/ðÕÁk¨9 ü«ý€ž½vßy;x­ÁóôYÑÃ^>ú¢‚9,p’ãsúLØû©çßxn‹þòôAÒWHœŽžò^ú>÷¥Â/ˆ} ø8íGÙÛ ÎdoƒÞ»eœËï ·Q õÚýÁôGêçÍ×Iœ½”€kÉ—¹¿C¸ÚýÄÂàKì6rˆ_'Ÿ@ÞÞûÀìWfÿ <¸Ôá[$®–ÜÃ;è: Þƒ¼òÊ\]X_ÇyŠ8„ùú¨eg9WŸKÀÓê:䆼•ñû d×1·ôß™ï^РҸ‘ó$ÌýÑ/$ù¤?ÆažsQߪç¨ ê\°¯î/SœÆ¹›/—=ÌÌï©^æ>– „?vŸü²ô?3J?$yyõ ø÷˜Ÿ /Cv}XQùêú,˜Sl.ÖóH)Þ5çó÷§n$}ðù ·º_€}´’kòPÈ'ÏÁ|y•'û–ÍM‡s£=EôO¡×|N Ç:à>#Ý÷ë2ïÈ\¨î7nޱ=#?Üœü†ù¤éw¥Sõoü:vßû1¼~1‡a<Ìa{ÞTõ9ò¤Ö;úáÁÁìm¡__ßC^ÓùéÁ–€Ø÷Î<‚ðõ×Ïè§%¦®Ås1·¬Ïq=V÷„?w }ÝÔõ%'æU'¯Œ>Sÿ&^`þBçÆ¹¸¾£çóžü¯¾'äÇŸ¹ßz+xœ<.üÏú^ïÍ¢;ªx…¾eâ=ÇéœçH?$ïCŸ.~‘ú)}pªks?à,ÏÇè¼ÍÏËyÊÞsÏæûÕ}xNÞ_ú®À²gàK×ëég¿"þ÷þaü ñ©òòœ‹ç²”·F¾±‹àü¥÷>éç½Ï›½óqü-|ãþWξ>ÙÇM“ޏðÉGz/#¿Ïþ Ç‹ä£Ùã+9ø”=Ü:wæÝ\'öì—²÷îä¶ÛLëžä¥ì&žõ¼¼÷ºGòæU—¼ÿ:¤ßwß…p%}‰àn×Ëäב{êYàûeÙyöùï©ýM /„ÎÍò¥?GR|Èüù}üzI½•8<‹ä†¼6ûÚˆóðä5¹ŠÓö¿·ñ÷2o'uÉQ¸/9åùáq‡¹ß4àG·ÿeމy ÅOGOø¢ûC¥-ßœ—ùÔ%OÚ'é9qúù°ÆQÊËQ·Â®ð¹öAß+ç⼀Π{Àç‡{nÜô»¸8èKw}>Ù>ßxýJ’_÷¹ûTÐ+æØÉxFzãüù~x xOêäCÙËþ#áIäÀ}º©~4øÆ’þváBêKàÏ;™Û×>ÛÉ _°dÌÁ‹Çîuÿ+~¿.t~š}¨ŠÛÜ÷Á~úˆ¾ï”ý&Ÿ°nÿÚþ'Ü7Öùn¿§p¼ýœËÚjŽÛß5ás§^Àóõ3â”°¾Ùoä{?Uºì×dFŸcþæ{õ¹^8®Æ “}­ô;²¿Sç~ç`‡ÀS®S‘W^Æ.z?¡â|üñçŸä¯äÈyÉø–ï_¤}¿Ô Â|ú\lÿ óeìßúaìë÷À £ŠÅùs'¾|oýöó3®»â‡ØC‹\Ëïs~öëŠw¼G/ØD ÷„}Dž\GþŽiÙƒŸuj—ÔÇØË@?Åæ%™·ÖüšëPAŸ"{ÿÐ×äð?®ÃþµŸ;© ÊŸ9^§I®é“÷0áF~Ïsz>çeïÃ=Êä{½Šç“<†{k‹ÍeÑŸG?‹ì0rãùOðpŒûTÈ?ROd/­ìÅš‹n¸÷ɺW$üVćò?Ü3ŸCÞÏý3ôÀƒE^Jò„¼¬zkÏê×Ç/Hæ‰å‡ì/©×ù@÷2‡È|›î•ý£žÿbß ¼$Š»é»s=Tz¿¸ç)¯6ž½#ÉóÊß?“·Òû8•º_ó›p¾Øi÷5KÎÁoþ¹ãn¬]®cÝ$^Wœ|ð­*§Ìj|¦q.ßëó ¯E^XvýÓ‡mŠfÍOx`”ô~Wùùƒn9¹ÙÖŸGK’=ò¾¸‹¾sÅÍìÙ4ŸsHè±ìËœügVVŒÞ²üþç›w®:Þç®Ç/‘']Ú=ï÷í‡YÝ¿ðö`ÜŸ!ü<#ßıtò'ðÈ©ßùãw½Ky2Ç1ðÚ¥ôÒqí{ÕäÇÍ‹ô“Ï÷dy/’W$ß {p_&ý<äc™C•ßt<7ñÚÅ×ÑÙúe^BúMˆ_È_ã§ð—Âe®O¨Ž`ÜÁ~WŃØ}Ï%RÏ x3è“WRv\+ü„ÿwÞü£ô½ñ| ç&9ðþvù—p®Áõzö`IÀ½èsØGF½3¯| ôc}=®«3· {îþVáÓp(~п§sÀ.¢7ä‰Gpë„ð Àƒ1wÇëï}õí˦nu[_TíXø<× ®ã<=Ÿ˜ÂMÖSâGü»ïM|ÃâýÇ>Åi÷¾½ìg$8^xés`OóòÊ{šGFñ0çG¿q8ŠóñÞÊ€çÊsûô¡Â/B=žIõ«rððù΋1¯/;ä<*ó"Ê¿†{7y_âü¥äÀ}Üœ—÷Ò/Ÿ²_¶·ð@˜oë¯ýöð'{©%¯Ž+d_‰Ýÿ£zìó¦>Dz{àuð²û¯·ðþÎ÷Ðï(y÷þGæ‘©Kû-ÍûW~ó¥¸/™~Gì†~Ÿ<Ÿ÷üÂwÜ}AÎýƒâÏIŸR饯–f%ñ{²ÉWõ`òBÎÃËÛŸ{}Íc"ÿæ9NöuÂg!üEßA¸7Ò<ðÁüÎóS§¥AçoÞRæ R{ß’ø‘<žs}Å÷ËœÐyNÒ׆=çÑï ßžä?èº yð ŸC] >DáÞ¼ ucá½8-µoÆ÷i¾^ðìþƒ<ëiðª ×oìüðà¡ßÔ(Æ?aþ7Ý»ôØ< æA ö·r_Χ€ßy®0â=ÏŠSwò+Ô ÐîQ|݉=—Ÿ1ƒæ„Íß‹—Ò‡ÇÞtò"òר5ôÈx:%çqz»^.XÕ+N¿ü‰«Þþú£bûLÝ¿£:‚ó9:oæa©ÛJïìwl÷ƒù­pÿ%zùGÚ¢£›\æ|ªy›Ô÷ÊóðôMgs¼äw›ƒÓ·Yxs¥¤ïZu_ä;Äó„û¾]ê|Ä…âaOøûèßg¾Böˆþ)xc‡Ÿ÷¼;¾€?CråýÛôo+¯cœÍœ{´u^¡îwðÜœð+÷G<â=ØÌËs¿ŽéQ܆\#Oî?¡^ôù¿M8Ãò$¹¡>k#u ðµû%e§xNôÁýƒŠgø}xZ´×Çö…yEÉ©û¦ÉC¹_šù"=/xLvÌ{Í'K!q¥î½²gn…<¨ì<ס?"ÿäú‘äž ä—8ÚòÌœ8üâªëÛ*N5¯-¼ìäƒô<äk°{ê_ŽÓŽ_Þú˜9«sœ¥Jòö‰™7+õ< OóQÌ­ÃO!|š^±ãƪ«p}Ós‰Øqå Ï£_Ö_úz°Wú½÷]zÚú5ŽãÍæ|!v.äsðþdÝ+ýOÅâxú@éK¦¾ÂïË~xÎQv‚G¨/¹O>zxûÔ‡j¿ôƒè>’>{õEy;Ëj·qRÈ“eü¯s—~’{§Ï–|ˆpxÁýÛÔAñ»ð£“gVq.yoì•Ïï¯u­8íûŽ“¿­Ù0éߣ’ûàSϧçohwyzn±þwžâK×oõûè±ççéÏ^÷º./¾;iœFÝü£û'.#ïéy:ɃùðÓ:GûåGÀ³äeÍs'ûæ÷"ˆü°×]úEü…4ïsoÄɼ7ü9à@~¾ùÉ9—z|G¹¦Éû#7Ô¹”ßA~øwã>ÅmŽg…ãÌ3­Ÿ7&ï#¼KÝ+ü9Ïï³wx‘¼¤ÞËs-Ô}˜;‘ŸÀ¹¯ ý ޤ.BŸ8|uÄÍô}Ãs«¹î;È}¸J_ê æwO}¥Îç0?&y7…ûWÜŸôé„sjàäÑszôéÓç(.ÑhPçÖI?I8Ÿˆ~§âFö™úyWÝvÏï^‘SŒïùdÞ»dÞäS~ÙõÙ=ú†ÜG!{fþ úOè`U8Åuæ$æ1§ÏŒøOÏaÞ!øÀIð«ï"Ž„wè¯ù ûCâ'âFò9Æ/ÂSô•ºO9Vô’~é”ÓoþD‡—“¾:ê6È9ø ûJ^@?güêøžJá ÎÇó_ÄYòËîã x&ù=ô@}¨ìô÷™ç'•ßfV´¤ç­‹×¾1œ4¬yŸSøïÌ‘Ìï0¿åäÂ<ÿÿѨÚM6÷Nô^~‘¹Tú]ØßË~@í—Ž¾Y^²òv„rE}ÛßóÎi}–]}ÅÖhY|ìÓSçg;§K?9ríEÞ›Æ^Pöê¥íÜÜ¡|]ôy/´ø´‹É‰û4S¸2N+ù]Ç×ýÐv|U·ßnÞúHM.ûË‹å¦|çùâߦï+ür’ûœGU|k<Œÿ¦ŽÿÙY÷å—ûä·býešõóñùº‡8ãÓÃÉ¿+“¼u±sw {OúHúµTW‰ó¢ià %þOöbä w¾°sA4£è¡Ö7>þs¢÷]Óf¾xùdË!ú4¿ÞÈúqɾ Ï…ø2ÙO—qðÉÒ/MlçÏYßå˜?9ð\´fqÁ˜×­òÿ'/‰]ùþô]c«UÉï³zùû¼›S"ZøÙ·³*öšô¤ü±åŒ~QâOò|猞©_€=‰>§ì}(‡þœ•&)Óí$ûƒY._ó˜"âé8wÈŸ=:êbÿ¾äÉ{‰3Üç”Â~ï·ÕþÎü6‡õüá½Dßó¯wïèú‡?w]§žO<&3ZWå¾Ü¯j-IÎA|¥z.ô¿GûÊÎ37V¤Šûoõ~q íf¯$ò´ò­ºŸ\Ô®k´à¡® z•ïî}ÝâíOÎOuŸqÓÊÕîѰý‚þ|öO»odzÝö=˜Ømõ‡«>áÿO߇â[ÿÿo?½þتMÙƒl\;¡êíu&Ÿ”éû’¿õï‘ÇP¿F1;¾%íÿçqþÜ»,u¬ûUg?÷b›kkWNîíí’Êî.[LŸÿ·™–ì›ÏReôº}«ˆGÙë‰ß)¦ïœ[Æç|óú,ÛÕèçn{ªnJûÌߣ>ÍDÄ»©ù»bŸ»ìŽÆ<õ>çèß+ÑêegV=ÇvRûУµ]ojÖ°Ëmi‡øýçÉy¤öÁZN ¦í8yÍ€£åOŸ×ºÕÒûéïðóh>Ñ—=Jüˆê8ô“­Z¾ªì¼ê°ÇÝ¿·…ïOí-uœ„=X~ÑŠK:žó«ûÇd—¨c²g6Z¹äì±[ÛW Ÿƒ|,y4ûcpù÷å¦ð}œ~ø“ó–½Ð·Ø=èç¿Ì^͵ÿ¼ì̇ë:Ï?çÇÊŸ4ªqw4ðè¶|Óiorï)ü_ìsÙòÁ9/M»|âŸ>ÇÜÝ kv\7\åþþÏ?]Þäë=«ðÞg[bnÉeWÍšâ¼Åïc_Óºä;ÆÛØžçûçOíÕzìöDo«õÂÝGœ—jxX³—Jþ—þßM^óâ̯î]©ðÉs÷¿¿-éûSÌõsÍ/«OÊ?òž-]Þ¼ü‘—iüž5¨Ù+ ˆ–U©rü=·í¸ßõè”/vn²³ÔkùžÜä˧~ØVLîóúïé›wN×8gÍ£Ûëãsà|à‘¡onÞOF~qÛèhC•ë“÷ªóÌœÇÊŒÞÍ®^ÒÏ3ªYÁˆÎuÚ$ç9ý¨=Gÿê½Õæ·V óà5ú_…—•,ö^üûïì.ñÆ%Ÿ9¿úëIS§·º¨í‹üH1{¥¼oÚßügMì4½Þƒ¥Ñhhµc²¾}~Q‚toÊ[Æ%zìkÍÉt<Úqpñ±ž7úúªÆåv»?‘Ø;É7qåÒ¯ŸÝþ_j¨¸§˜œ,š2û”ï¾ëIž}ÐÉ\ºòo+ÞØ°2³ÜÇÄqnéŇŸ–·Ñù Ù .sô1®š°ä¥Î%/źo@ö/´—ì·w=ù[Tâô¹:ί4ubí³×`7âŒù'õáÙ‡ò;ðì%r‘Ê»bw=' ½š‰ýW\O_*ù]pWö)ïÝê>|ö—k{"ÚÛ\ g(ˆ¼åv=}ß—oÇæ ãùeGBûZì}ú"sÓ·}ÿðU×þWüùè¸×Ÿšù•óÖ«';¾ìêëÉ÷…v"Z½W¼gJËÄ^¥ü–ÿ>sô5ÓŽ?q/ýqÑâq÷ç?úþÕþsÒ°ïW*½ûÁçás„òTÌŸ?—Û¯æ·Ï{ïæïwÛß-¹äžó\“Ÿgß´ó¨è+< äéŒÛåÏé¤zî¾¥OöÛ7ÎvyRSL?¹>×ýÁòWê;KúÔGa¾Nå_ôî%5ûõ9¨;9ŸT<Ä}Êÿ,;påëÛ‡Ne ˜ÝÕ^pÛ‹ŒŠÍíùÓ³g‡“x<…câ[ϸiQ™NI/µO1Î8eç]ùÇíÃÏ&¸Zyoêx%JµÜÞ}ÿqFÓçoXyÉô8ÁQ©¹@ÿý°Ú{OܧïœÖ¼c¥±æûT<›Äg©Ž¾±Ï¾Dû*;ßÚ\Íùê9¾ o-.8ᦟšâ/ý=ÌÓΫ5tV‹A}ÙKî'﫹Žâ¸as§É×~wù;ø-Ov4¸¿ä{Rñ‰ÿ¾ srùÅ×4w¿•çôRù›8«úÜV¯½ró\qAê<Œ×C9à<ÀQk*ͨ–{÷\âÁ„Ï$•.öžøsð$ÏG^‡üh^¥¯‡]yûÿyNÿCwºëpÔ)Ì£¬ºÑÞ_”ãõ­ž»óþ òòí§ ç^飥?Šx"ÁÓ«ŸßlgdÎ ^(òøª?€SWÕÍû¼Âö®É<³êTj2²ËîyŽ‡è““}Ix„èoƟßA'ÕA˜ß¡_ƒ¼4úF_÷K~Õç¤zý>Êç$ûž”7…g~êÐÔ×É ˜OVuZóYJßÌ;‘êçà½Ü§O=Ûýìo€?D~»‡<ÓM?§ëúª¿ç]yb¥×:­}ÏöþNê¿äÙˆoˆ×À+äƒè„ç¹ô7¼ ªûÿX¦îí5ßlås¿yîŸÏÅnb§é×ÇŸqΜö’yå»]W"¿Iœü;òà½ã¼¯p1û#ÈÓ`§ùó3O¡=¿%šk¾å«»éz–ûáT¿gNÌþSþÿ€¥žƒ]¡þn#x%Ñ3õ·2GKŸó;ø+ü1<6|®ç™Ó•~/¯pßòGWôù6p6õú'ˆ‘'ð;óô‰p¿à ü„ý¬ž‡y 桉Í[¢¾UÕ¹‰mÏ—·|tfíÑéö7䳂| Ï;äOg>„9 ï©Ké+óÔoÝïƒ_²ÿÜÒwôkÇFl¹ÿ í9ò›Ñ¦û=e6×uœÊûãßÜ·ð{;_®s÷1ñÆqêscŽ™?ÉçcçðWÂýÔUƒ‡¨gƒ;œV?…÷b°œù.xÂd/À®ç š§ÃîÑwb9DÞôüÌá†<³øEì£ö«kã`Ïü„üHœöðóÏ.ü©{ÂoÈŠäÇ{¹e°ãôe°Wê/Hö"èžèk$/ê¾õùz_<}Tðâ)¯C^ ü´BõÛCð%{ŒdŸÐ ï=LÅ]Žû‘3xíð?æ•×ç˜Iv—?‘_ì s~àîýµŸÖ§ñhê~]oÅ>8.P}Ö<*콄=—ÿñÞ½8Ç|œÂä£K|^þÝÝãÆ$üŸò»|}ZÆåðkÉþK^™ß´ Ns¿’ü=~Ï}ûú>ô ì#ö¼°úÍ$¯qú3?*wÉ÷ÓsîØuä…:½yï ·ÊcwÑo€ÿ[vá—÷çÌržÖýìå“}Z¶tËÔ_Ößh‡¡~Až|Í­}»O{ìíd~Z¿½£ÿ½äÞÐKž›>9ûeü:û,R¸Øç„ÿä>øú1y/ü9ñ}ŠîOâlò¡Ø[ó· ¯ãl?„WxåAþFÙMìªùø$ŸÆì1Ñù™_Høºó ÌŸÒ×E|Cü‡|óžÞ£¡ø”<Ýúå'W«ðj&Ïïù{ì‹â0ÛWã áx"ìw?·²—Pv›:øLúåþ%Ͻé\ìG%ŸÞ)\]bn¿ŸBN¸Wp6¼‚äŒs¥w|Ž÷È«>è¹æTŸ‘ç@ïé|À­ÔUÀëÈ ýÝÔ9™ã0I嵜§âsÀ÷›Ó½®ü;ÖÏ7Á{/½å|Ìÿ¥|8ÿGÿ÷¤|lœqÞYo\xBË3¼iÔ7Õ‡j¿m~6á&ìŒ÷*>Å ç»?•8ÓüpôŸ«o”|û§%öÓ²Ëà5ì)ó¹!ß´q6<²üœ÷0÷+¼Ã܉÷v“¿‹^¼¯ q’B©Ó —¼?y6ü¢ùJd_™/•^Å%²w<Þ땲ž;¤¿ÅuZÍáe6lØðõ×δ0N"¿¬þ2ìjÆã•né? T2?,ü<³÷Æë½W'ÑsÙSÏ_ 7˜‡M~žþö»/ž}GäIÀ9úÎ9ÆnÁ‡d6'vÓ|Ìû{‘ùÿª3[>ÜÇÏ2åñÌ?Á¾¿@îáËE°ÃØ[úÑ<'Ì•c‡É+b/W¨lÞå÷—é÷‰ŸñŸìiñ|$qVÏ9IßÉ'×ïÃï%\T¬®dž>ákâ[ó¼·À¬øy\ÑrȈSÿ¼Ëx–ü!¸y“¤‰~pöÔóìÃ`ÎVó_øgúJ½—SïẀ>ù'_€½×û¹ß‘¹ ô>(äœ{æóC¾‡<v‘xý1¿%û 'Ømü0ççûm§ø|äYñy;ó‘ê}ÈkósÈéì̪Ë[4kœð?ຟùà]eþ~kä}Vª[¤ÿÒnûŠ}=c™³Âî¢Ïà3ì ÷€Ý’ÿT_„ý8=ñ~på÷É#³—9úpî(ä?Cÿÿ8‰ôž xu‰ÏÙ¿Â^.øaz½—óÀw¬¯ÞW¿nJïãŒUî¼¥E'ç}ÉwyN–ÿ¯||§Þ#¢Âܼ‡Š7|ÿè=y pAxΞ “~à‡íŸ5ßA=Muc矘w.uÈ·*ûëz£÷çÁë!¼Œœ_ËèÜñ×G¯ð|zá{¤ß0…ËÝJ=Ô<-Â?æùÔ÷3·Þ//:»ôÒiO$ó'ÌÿÀã ÿ/úù×¾´„§Xòé}Ì/ÁïÄ$ù'òÔëÈ©åþ êRÜ›ìt캳ú¶ÉÏ2ŸFãôSõøøÌçµî¿Hä}ðck߯óeªzŽKÏI]Ös–²¿®+ê÷Ôï‘ô/ô²ðäúç9OŠ¿X¾tQQ—¶¿º(œã¾CÛöwÊ^‡{.è!oC¾Òü½ðÜ€äÇÍwìu3OüºgxóÔžðºéÍ7¥{xûØ?ª<4|Hâ_á÷‚7•z†¾ÇsôÌ™Ë^S ¾&ïƒ]åç–ªßüɽm=I4äõ\3sÉì’ ?„_6#ç”Âö?ž3T<¥y÷‰r¿Äà/ó–)ß`ž~ÙSÕ#\4¡ìçï<œò–Ø âø€×¾çÁÉœ«çk¥äe‰ëÁ%æs†gPþßüÅðHÊ®ýíÝy°eey.ðNwŸn x FÔ2˜ÆÞ"*à'@™d‚jpBƒ(QQDAdF™d–¦EP ÝÏïÙ×Õuë¦òÇ­[•ÝU«NŸ}öÞë[ß÷ÎÃóÒ‹ì©ÿÍjxö?íÛç`'t.Tú¬Â'í )žœFtJç|à„§*üâ>ø·øsôÊ¡~ËMw=·ô“ýÍÛúÈ/Ýtï ÎOâ5üÛÎɂ˻;ò¼ú}€÷Ö|ÿGwqÒ³>öoç"pÅŠëžú‰ò¥9qãól½±>Ssløáä;ù!§¢ýûù~þIqêá¤'-ß ç«s³râ3Cÿ­x ãõ§IܦxUƒþsò¥}ÿƒz°ÚÍyCtNxòXÅí1—Á¼qxѻŠ=Š?«³->1< sÉà Äž*>¥¼Ž¾Jçá³âŒ%Þl]âeì5ú\œ¤~\†È±Îyƒg†òœž«¸F¡ÇâåÑmŸc€Rüw~vê–=©8U¹ÿЯ³ßk©w‹|o¾5ôÚùŸæFþˆO:ôoNp‚b¯u^IüuñõÌÅSÍ>UnÃ/6(vVûÁã/‰sðê—Žù¦r‡]?³Ã²ÇívìM“ùßáWö»µób‰3S\´ò_ñœoäŒú/÷E/ÅMÞ¸uKä¥>õà%uÞý€صÅÅJ>¦ö»1õô}Û9”ð~ÌAH\P<ˆþ?j¿ÜøŽ‰[‘Wè6ý£ys~¸Þ™{¾·v»º~iöCý\åaòA^/þ‰ùdð[Æ~kñ:åÛáåÒ?ü8õÛôIôEç3vN0üíèç)Ÿ&.iŸ®xïò}ßpßu“9®¹_ø|’o‚GùÛ<ð@Ž5BïÆ¿d÷šýmîµxBâs‡™ùLÅ—ཊC:Gû#þßÌ÷8§ÎJ†ß»nTô Ü ôÆ.)ÆŽÝTûž$næóê9;…¿>Nòá «ƒ‡[<¨{hþ6rÚ<Š®Yó®è½æy+o:w%ù |¿µqôι—ŸHü\Æ9È}~½5/Úoþ²¾¿õ ±7åukïÇžÖ·#OÞú)}†c¬zºó"Ÿ—‹¼çÏ4þa.äxŸ†}TðDjoˆ3ÑÉ«w}ü0òƒ=‘¼ÕŸη¹½±·p1º?ú¹ð£¸Dó­p¡á­ìwv-ùðï7®õ­#_ñÖæƒè{çØù|áWþ'¹K/;oõ‹å[x™ñçkg±Sbo/ ŽSøT¾ ø{á«Ä™kϨ·ÀGú?O>hŸ†9_üô±^h¹¸èÉ#É×èg'kMürïß~´Ý1[nôÌò©¸ªøxë“÷î<õ2yÞëß¹êI¾mÓÆ}Š?o2û:¬§+Nmè¿ñœÔÙ7 gâÓäYq¾ÔyÅ^¢OŠƒE®&n*žÔy¾âæcyì‚âKªKˆžÖÿÔùDÙGqžúÇÉc¨ó’gW¯É¾ìüuþ|<õiÑËúSñ9€^«Ý;©õÙ?ç׺ÕÈç,¯<˜O?š¿éûfö\²ù$?¹É¿Š›ÄGÕ™+=˜ç'¾o¿Å:w"qŒÆ‹É‘ØWò"äHçÔ™kh¾ËØ~œÔïDŸ6ÎmN¬¹µæÁmæg‹ÛZ·øRôTõŒ>„øê Èqy•ÖC„ÞÅõÀ5SG nA¿Šsb¿ ëõc«7%wг¼CçˆE®Ë _5ƽ¨}!nh=Çž|;ÿI¾A\•ˆ^øOä¡z(õSürE½ œ 8`·ü>®ÏØ«êE¢¯Ûÿ¬ï!tÖú-ëèþèŸKÜ­}R±SÄø7é·n}ΰ¿ ýÛwòZ½L÷3v”8è²¾{ÆuVóÁÁ›Ó_:™ßgŽjêCÄSÍ d6•øø ¸àoý£êƒÔ¿ïF=ƒ¸F¾¿ñ\ç\ž/ýKî³›¬sù§wßjûÑÏ{?”þÂG¾y•oßëóð}ª7n}Î÷Þñ²'ï<©#ˆ=ÆDúÖ¼vxS×oþ«›¿uç‘C‹ÿÃW$÷Û/–¸—ú#u.ú!݇_ßxÜØ~¨ÝvíÅßœÿÕûOi}në=ôCÆŸm¿ |ô’u\¸Ö?½ëþKl¡zšÆÅòóÒý¿ÿ¼ß¾ê¸ö_áÓÖç>èÈ9è?‰}ÒùèŒ?Ä3ì£óUg£žšÿ®‹gkNfêEÄ“èCϯžC=$}ªþ¡õNá+ö•ù•ê¢íCë*Ã/?ÜàºS8á?ôÇMê–¢¯Ô+´î6òÓ}­ý‹âçànÕžä§Z=ѺÒЇúÕÊŸÌ]»î™¯|â/>aR÷ 2û¥Ž@^³tzPÿ†È©Ê õÌñãØÏõO¢áV5®_á§D®£èLžG¼?‘Oúñz£.]xÓ'WúðQõk‡ø)Þ׸ý¾w}Cì*ö‡s!w†üJ®ékagX;‹ž^¾íßÿÕ5_øDõ?ÿÝ~Ð ô½~dçÐüYø]“oìûŽnÚ÷CyLõž‹ÿå~ìßÓ:Öø·>ðì§¾ïaÚ¼.œþºŒÜšàÿE~ª3¾OùW¹‘ýÀäùêþìû‚ÿ-ŽÀ.À¿Î{ˆ»Ñ~»ì#?ª}™ùésô*»A>æ–cvÿÄKw>¹þ@ð»nôÞ~`sÃãÇÙtùݵ—Ùå¾'ûP¾‹“ïŸàψ‹'^Kßáö }ƒßɹÚó¡çâ}ú<Äcz¿Ø«ýöiô|¹W¾×W›}j¿dÖ-ÞÝ9êÿãÖ£ž¸ë7ŠËm_Ä ÔÓËä–óD×ôMqÔEÞˆ÷¡#õpì|ÆîD7ôžûð/|ŸsÀOö‹=qåW=æªãm|@½Bíö¼_¿eöq‚#ï·kÜ*û+ïQ¦ðÜ| 7¨uQ‘K蕜dÐw¾‡=Y¿*|\zÜ$xÂÕä¶¼{¼ò,ö’øçÐo'¿åi¬—Ý,Þ$òƒ3WZoÉW?źíWé4rCÜ;ãwö«x}âûÐ}‡>ýÞ¾êð—çh½LÖnØaü^öŽx7{×}í»}+:=~ªçįìV~‚8“x£>1ñ vžç&_ðëPO‰ÿÕ#Ñûø¯ñø?ì{™È«Ä“Çஇ¿ð :âÏ褗ä¡Ù¡ìL¸ãí3Œ*^>Ùkä:;Þ,ú¢gÐ'{Þ9ѧìòþ꼦ü,>Cô½Æ^¢¯ØuæV¢O狾øò¢Î¹ñ¨ì? §¿Åëà]ˆÕß4G0?ɧa_~í²<;T¾°òDýì`> }Åß諸]¡ëÚA‰ÛÕ—¨ùg_ÅÇÈ úŸ]½è};>éœk^™Ü„ãÅO`7V~ÐOù;ûKÜŸ_½É.O{×»Ö™Ø7c9¤~´dÜç§Ol´Ê޼í¸/Ÿ5š¹ï)›üõºïU;Z4g­?ùôcF£¹Ïøø…Ï{媣Eûû ¾tð G o<ø–Ü÷Èþ4bæ„…³w÷nxð¹GóÝþµŸßý„ÑÂó~ðŸz`ÝÑÌ–‹¿î=›Á£-úܺ?Xý’ƒF3GsÒž:¿øÎ™G$ï«}F©O×ߨ9ÁÓÍÿèÝ/¿xîIê+Fó×¾j³æ~«óx’Ÿ-ÞiÉ ß~Ù¡íI>¸xΩ£és-¼óƒ½ì#›Ã-úÊÌá{âà –œ2ï3‡\ÿÜѼ5þá—¿>ìÔÑâO]rÒ÷~v•:èÑìWžðõ{O½¡uéëÍßè¨Ñ[·Þ¯û¿8çµèêß¼èk{YãÄ[ÍÅÒ¯Öue®ÃhÞª§žãû^PœómRçižBÏ >ÇÂ}?¾öKÿèù£Ytðï^óªŸ=a´`‹çìþ¼ßþÄógì›ùR4³áGòðûý O8à=—=êÃæaÁÿWG0Z°ÍÞWï÷Ú—×GÓ’WÜòñÕïøæ¤/xlæ-ÿÅ®?>å¬ÎYZüŠå+Ÿó±¥úÏ-Üc“ËïšÿSyÎÑ¢o»Ûì½£™#ö½ìOVÙp²îì£ç ž*ãÑ‚ .þ÷ß¾fn÷ifõ—¿ðä?ÿ¤:ÍÑJÇß´Ï¿œ½ƒ: Ñì›®¹oÍU^Òû.xÜIßÚü†çŽfWû곎ûÞÍíSד¸Íhñ¥øÄ›Ÿ¸7ú‘?­´ÎÊsÇn?-Z¾ÅõúÙÕmzÃû_ø½·©÷Í¿çÆ»}õŒù£™S6ø‡Ç]¿oׇ¾fÞ}ý†ÇœúÝѼ{ïÚm§ÝWƒs]û%x£%gwÏoц;ïù„Ǭ¿õÒú¿õw£»äãáWŒñʯ¾ãÎû&óeÆu}=ÏÊ!ü=Æg-9ÿñï9èýç”ðá¼W_òò…¯®ÜHÿçhÑÃ>4Zï©×ÃñÍ.ºoµý¯9Íü8xV¥ëE÷þê­Wl½nq%3‡y4ÿœ¶Ï­½ä_ñ)#urÝ—Ùµ¶üÄ•/8s4»é·wÿâ‰gý'¹ôë<àÏʯÏÃ닎Ýâ•ÛüY¥·Ôít^lêQÐ ù§/½ç~0¡¸Ýé³Í}ÖZ—/ÜåúÒ‘þØÔµÏÎ:gúÛÃxánêA*oàl-úù5Oºté:£Ù-nÝr‹ã>ßs[òB_=yí{fÖ:hŸg^q‡yyŠ3okÁjï¾÷ï×øæhvô’Gž¼Ñ]=G|²øÉ|È¿þõÆ•[øÁóG^–þçxðkïûåªÕÇäü×EGluåvÏ¿q¢gÒW˜º®òûàûÚ_7œVù¹/ö¿-ÙçÎOú™ošÓT>Jÿþ¤þwlŸš‹Ôó^4û†]>;oëΑ!Ÿæ¯±õU¯Øõm“õ˜¯—û“ë+­vÛs9ýïZ·i½•“ßyɲ—>ü€âdþHõ>'ÇS§9ÑkÑ =Ÿèwó*ñAߟï›þú‡½ûÅ¿(ŸgNeçöÙ¸pèëÙC¯¼yÞÞ‡NôîQ—üÝü/ƒ=4ZøÊÑN_üÙæµuLé™þ‰}Fïêïœ=â'Ÿõ´cG ?çüí~ó–öKô¼?7÷£›Þx\õÿ¢ÕÛkáGÎ.}.ÞfóíÏ]ï–Ñ¢3vúÊ7Ÿ÷é>gðù«_ÙŸ‹.9âC·­}TõÅü_}çŸyÚhö¨SOþì£Îè÷³k3Ï̼Eø;{!rºç¡ßrÜïÐs'Ÿéoz)szŸ™øÐ§Ývëhá½çßÿÕç·¢ülŽœ&ûyåc|—u©³è}Ù¯³ÎøGŸØ¹©»ÍìûÌuï~û§ª'Ø{³×<êÔM¯Ÿß9néOªÜS·áù­7újb/çyøðó®¾Û§¶ÞõÚžÓÌW¾úä/?YýêhvŸÏ=ì9}Þœr¸ëeGѧ»¸8VãzèêÕ~>绲ø±»›/È\!ó®ÊGì€Îs žmü‘‰|‹Ü4×gæ–û7š»ð¯à¦Ô® þDç}.8þÕÇ?jͯŒæãV•çµSŽ=d¿Íß{GýsÔ𹊠öµ×]ùü5‹Sé}ì‹ðaõVê¶jo»¯}J¿ÎhÁƒo9ãÆ;ïªÝõŒçг“>€1N;°v¿Ã¹“‹ø_[ëáÛÔe—gIù~ö¼Ÿ÷·_?`Â_™û«/¼øÖÙÍ—¬úÊÎû-NNÎ òWØsè¦öDìCz¯öbpÓSÏÝ}È\¶ò¿/õÆ+Òuø/8“çÍœJö¥ý&—ì›ýˆ?T: /ù§ô¢ïc¹ÏÊKïZò†ÛÏ­Í>‰}>±GÎXi—·~ìÑ¢óg~ò“ËNïßkwŽçêTÿâóœ§|{å¦s6w…~°žƒ]ɾïç"çõ%Òïô?Š\ÈœKø£ù7^ó±GòÌî[í½ìþ_°ô+;Ï,ߤ~y[ûzߟØ1æ Å^©ÿ}ë£.½ôº'þ—ûETNe]äè¢Ã6xÒÖ¿³¸ö¥÷‰|éï±+èrÿ“KõÆöxùL\Ä\]vPé1rž~ŠýQ½ n²àÞƒþýäl\?—^©ÿ¹™¿OìŒøä;‚<Ñ’Õ—l»öuï©übwo<çžýÍ>yÎ_¿xÛ×÷ïè—ÜawˆËÄÎêýjçóè´r=ö-~JíÏÄ='~LοvŒ8×ò½fþལÅñ‡ØßäöâÄ»êïl3sï iÿUq‹Çöñhfë­ÎúÇ?úeíµÆÛ6|Êû/8üîÑ‚C_ö­Ó¶¸»ó%½r­ç/¾ôôî»ØÜ¯è¡¡^¹L¯àþ^qøÓÿÆÏ^<»Ù¹ßÙý¡}ÆÛ¾øÙ/™Äë"WÈ]ñ$ôgÎ^ú·+ñ÷¢µÚÊO|bÏ!óF ×úã+/Ü¥=¯ÆÇs×&r>zÞ \rŠ'×ùUkÆžå_,>lµ}ŸþÂWÕïæò7ðõâ§Ÿté•Ûì1šÝñ¾?¿{ùÓËGânµ³²nqFò=£KûF±sŽЫýfG/Žýá9Øü˜Ú9ÿÅ›-Ür›ŸnÕ}ö¹E[óä/Üy^çzV.ÆNX¸ôˆÍ_ÿÝýÅÏûi­ã’,.OúNÕ½È7È3ë_U§)¯-¯N®x¹©‘Ï—gÒŸ+o×>¦äGÄÛåOåÚ·ü õê :wžRüMßO¡ùWu×ÉCª_m]Bò𽊓š<’ºFù1yÊö=çùS3™'–>=øîúÕÑ×ôÔ³§ óSÌ%T—áœååSZçü†þyÈÌonýqûqÓï]üó)ržòðp¦õµÊ#™Ó‘}hü_}ƒ÷Ãw²í¿0&û WX~F=€<`q7ÒïPü‚œçU¥Džvˆw«? ýØŸâH/®xãYG祟ºutXŸ_¼/û / sORG­nÙïì ô-Ï&¿Ö}Îü„kö¼÷«Ýö…Iý”z›Ô÷Úø=òºp"äÃõW°oÎ]è³ÕgTÝUñÞS—`¾¢>Sõ§í’_SÇçLµ÷U—¥^œœpnö¿xæpÁuÏh½dëÃWú.‡r«ùn¸°é÷—ïַ霚W4‡-øÆ­×…{—:€âÁæüéiýBêÐ-À¬‡~l̹éëÑ·¢ïU]9¬^¾‹zpïëüÔ·«ÏpêŠR/ß~a¸oòÜúu­³øzü+u:ú›‡8€òÀ×W*Ï­N`ñ±"÷Zש4õêiàͪ#ƒ[\øà{‡*}}ä/ú†wgA¬ú¤Î9II罤îPߣý%Ÿéû0¬i]kê^ôíÃ%l}cÖ‰œkqÂ_ê•Ô Ï4ý¹îÃ>0OßÞø›=do¶/_ݽ¨žBÝ=\®ân‘¿‡‹ßùë§Ü1çëKo^þ¥GÞzÁo«ïÐû“{ì‚è×~}îóÃú:ô`n»ztFþ´k¬·'óXÇ|º®kñø+ô þ_öyIΪŸSm¾_çW‡ÐÓå¿=üƒ6>±õÅñ‚ƒ9¡î£s4óœêù¼Ÿ}§¥sÖ’§lßuêËû{ê<ŠÛ~ ÿD/åyØ¡ìÚê™ìGçh…~:/-ö¤çW‡« ©{Q·Ä.*Ž[¾—ÝØyÏpóÌ‹ z½¸¡cöwêYŠ÷COà«â–F.ªwRÇ\\µà™ÂpÞinû5v¦º)õXI>¦þ³öMìKýðÅI÷ý7†ž$7}oq[Õ“†^#—åÃÊgô®÷gdè„_Cîv?àdD_Ñgí3ˆÜë¼™ð;?^bí ÈAöQíÍÐoûÜc·¨ÏS/GްÛÙ)è~BçfšÓ»¡sÍÂ?pÔ:ÇÚµÐMñš²îÎõMÜ‚]k_k‡GŸ—oÂWæÇ$ö>€KÐù"‘_õ3¢'j?ÂÄË4Ö{»Kuþ_ä?;¢¸fÙ÷+>Mž»ôü—Λ‰¾m=¿~ppxõå´þ-vz<ü†/Ô³¦î­çƒ.7¼´âN§þŸÊ¾n¿Rê;ÙK­WûC›ñck?GÃ\¢Öí©‡VÇ=c¾{ªs¥ÂðSÈŸöEÀk±v¥~ý[ü”΃›|KrÔßñ³õªó^~Ö¡w?t£âïðsáHò7èý…_õóg-=åžÉü¤ÐQûÞÑqì ç¬OQþ˜üV‡ìýÅ9ŽCFüo>ÄÜã?ü’¿xúdþ){…>í¯èwóŽÅÕøÑ9¾O€~ªá¼TøOíý‹¯Ñ?<&u⣠?þ;ŽÝ¦ßn ºðwÏÍ¿Áø˜]×yYƒysúuø =ïÈÑöŸDw.sèßð?[·>e¯µÿ3ç§®šýÓ~Ó𠻸sm£ßÄ<§xcñå"gõwkô<ýÙ~vuüÜÎJœWœd8·¸ýÀéc ~?„â·¿ßWs '_(¾jêȇý#Þ/NÀ?÷:ÿª}¥ñwà‰ÓSµ×È¥ì?œO÷ÓQ¼•Øì[žýú ~~ö¹“þOq"óŸ`7Ùþuû{¿o,ާ~šØ¿ä_äpqñ§¿åjçLÄÞoÕoÈ?懣WñÈÎý0—:ö*û•¼#à³Ð§úmÄ«ÈI8núèq~ }Š>Éñ uðÉWž·Ï!rÿ8ì(¾íâÙªÿœà~åÜ‹‡’¹Kê&ô5êÇð}õ3Ì!…ãúl<)zŠþÆOö[ü„ý°ý„éK"—èiýìcýŤ·ÄÕÒ·¬ÿhˆ/ƾùé~?{øÖ‹®è9껂Y<´±9Áë0ww¼ûP|þœù!®à9ôëc2'PÝ5ÿ‹Þvþ艾j\=qfz-öG×[|?óûrâ„ö >š<_ç²ÇŒ,ŽéBß’xy!Ÿ7œ?ˆ_áëˆwäøbqncï°ûš ß™‡HNá7vBñ¾Çù×Iü{\?Ø÷“Çž§ýÐcý§~´¸ÕìÎ_Ž_Þ9èð{ÇþnχœÖ§Ú9xæjÇ^`ß²¯ð5¹Hoûœ9mèßãÁGâ%pwm}%¿½8ëá³ÆMÄùcŸÃ! 7Ì‹Ægì¦âR$/Z?V?¹;‰[¶/Ë¢ÈMó”áµÑp‡ý¼ø‰ž`Wòç²/­Ó%'ŠgÌ_ÿÖþÙØÃâ˜7ó®‹®]X¹À.§ßÙ?Å{’GŒ|BOô:6ýÝ“ykñÉe÷+ÎIú;ïö¯¹ýƒ½±ó£éö1>”‡€áüèvú©Œ]ظSκ…Ó@>ÑÃì[û¾@'øšþ³ŸÎ©øD±;ðu³kšW=ãwñ)üHÏ±Ûøwž‡MNá/r¹8Ñ'ìÖúŸcþžÄ볯Õgé-t^w®â‚µçBŸâ`ìö±Ý.ZºñÑø…ô>7Awòºú8‡q'úºýÙpã°ûÅ“ØuöIþ¡8Kæ)&ë9ÔÿÂåŸf—%nW<üÎaŽG¡v_âAìtc_ÊÿÁ£åïÕO‰&/:´·Û§~¼á/×X~ù5÷´/Cþ¹8áWëë܃Ø]_ìÕö!§®FŸ°ù¦ä8¹È·Õù}Äì=|OîŠ;ðWñ »nX"~b®,\~ú'oàµ\q÷¹ûìô×,½vÁ#¿|ï;_U?}û^Ÿw_Ïé¬_-ü?±çò½Âã ¿.½èÁã/Þäkõ¿ÄEôùÂmãg›Gî;`ˆÃ©ÿ—~)Žgòjô~9ý†;nÞô€eÝò¯þ-ÿspÅñ‰_„àˆÐ[ò›è¿Ê›²{S—V= ¯Çþ´.B¾1þûŠüìyf?Ñ;ùD|é ÿ|Ï]ÿüóâ D´‚'§ùåòÍêØ=9‡ÒÁ¿ü§çºÉ¼ÂøÕøÅþˆá³ÖÁ§Œž·wô/yNÿÊ“‹‘[7í¿é’u6¾®8ÞèÁ~5qúâ6 7ø ‘WðÿèkøÌü©úoðiàCÆÞùø¿·ìªu–wž”xKçY$^_<ŒØÁð®ƒ33gð¯tC?ÓÿìfóÊɉâßÂG‹žeWá3zÜzᮈ3g6çW|Œð»ó÷|>L|Ý‚Ÿå§ùGø”GÿäCñë’ß /Éiûc=ì,úZÜ_Þæ†ó¯\ûœsÞ3‰'þÃî+nê7>˜ïCoèqhÿÐ7=þñOØy» Îy WÈúCW“ùâ°±¿à‚;O¿wþ'œàÈGrîý$vÖ‹¶XýÞSžÝ¸51òÈ}ù;SÔ8qè€?%žÙº¦1NTùÛ>u>iúÂÔù2ö9îØêS§¡Ÿ“ü,îˆzþ >«‘ï…óW–Üag¨§b79Wy4~ z¥ïÔAèÏB‡üç.žMŽvnkö͹ˆ¨M|¸y1z\½³û•žïV·¤ÿ­õó¡yÄö£DOèÇêÜôð]äÂdžfþ^ûA=çøüë/ª=¶ŸÍÜfú[}QûN#¿Õ#û~Bq–c±ƒÄ‹øïô„ºýèN?Û±ÓÚ÷ÃOîy™Û˯ ’;í?ŠÿÚy¹Ÿ8iç”±s"Û—Æ¿ÌçØÉoù¢>Ò}ÕÅñ'åëÅ Ì+KŸ5û¯øÌô‹|]ñó£¿ÈýÎ'N¼Ðþô¹£/Ñ«ï-½‡ïØ“­ãHBë bg£gþZêÞjω«“Õ‰_ç>òS”Ö¹#‰ÓÀé¼’èé®/t¯_?GNŠ[ˆ_u6½È?Nݲ×K¨ûØõhíÛ‹œ¯]¤/)ÏÝùö‰Sz~~]çû˜CyÀNl\T„:¿ëù𵸄º"qLv=,o[¹z¢ìûcÕŸäuvJãÙ/qaqíÖÁëºë¿²cùmâ¼äBí¥ôÑÂ=ÕINòûåSÛ_¤|—*®ÊÜ·/=p£“^4Á«§¿c׋ó¶ï[\2q†Ô¿Mæ+'/^¿%ç×~fódÑaä+=Oþ³‹Ñzl|’]¾=gñÁ_~ÁQ.7î‘õÖß6ÿÈ<®ôˆ£ˆ÷È‹’#üszÌzÄ1Ä:Ç@^'ñµa}ºã7ÿ”|"ÿZ¾¡õH¡sxÆüÇöée½â$∩˜ÌÕT‡“8SòÅ'ƒ³Áî¸êùǾýW«¿¼ô©>Hœ?á|äwá*tîMô‰¼ùG›|Ç«¾ _Év^‰ú«ä©å1è ö’8#L6;ʾˆ8÷Ρ]Gô^ç•™GyÖyup2âGO»¸±ô„ó‡i]äù×^±ÒWØx§Ê-û-þ®ŽBþK¾J<Ž!NmŸš¯Ìù¨Mz˜7h~ß9?õiä’ø¡ü¨xHã6ÙyðÎuýÊK‰5_¦~:õBä1;[¼Öùñ›Øó.x骯ûÌâÉ<óäeäÈE÷o¿«GÔïêöð9}B“äÿçŒ/ŸûãcWýYå»Ô¹ò/È/y’ΧˆÝÝyp9§øƒõ—ÄéÔ/ËÏ£§Î}É}ýÞz®|ï5|ñ¯9öÈÆ]ùñê_¿ùÁ›öüúþ»W§ÿ°qµÆE#×ø‰ä'{N~¼ùàÈs™Ùgüóç|é²Ïm¹[Ï“=DΰÛùIíC2·T_Xì¬Á¼•®Ÿ|#o;O&z|¤ÏÐùC±ƒøCµwÙAÑgêR¾¹…Îø'ìnz[]l÷Ç|ÖaDî+Î(oZ\—䡨1üSëTïÓyð4ò\è“>җ䜽O<7ï;ü8¬›œ“_¢¯É svÅôat.pì¿‹»ÁÇ)½%¾9:©›ŽS/Ï»ÿc¢}¨ö‘œ$ïëGFžÉ‹¡7ûHß’Kâ°êÈ úqÙ{ÖþèWþªõdÎÝóð—¬7ëŸÄÁó=¿;°t“|zçE©oÊÖí‡>ÕŸµ<ë#Gè…a=Ž:ò؃=ö(zîœóç¢WÉ‹‹®:øý·Ü¼Cý*yûJŽÜtô¾ûŸ|ðq}nö 9>ùòfôœs×H/WþfÿÌï6G8r8vÇD.Åž4¯ª8P‘?ìÝül}ÙzQyÅÄÍȵÐaïÇϺꂵ¾´ù:o¬Þè\Üäwäá[W—õó“o ク¬²û!¿þäÒËNüÇkoZs¯úEì*Ÿ¿üyü³|rÝÚ¡­3 ÿñ÷Ù)pOÄkÉgq¯öÃ&¯".$ÞåýâÅ·H\-ñ=ø£“‹wà VOüÒÖ™áKõ÷ðœgâ'Ò¯ð¶Õ!ˆ/áŸö‰DN‡8q:÷½ÿÄÍÎÜñ´+k'ÀÞèd^yòô´zcø«ø Oq|?œÄOZ'“õÙwõeòêžGýVþ^9j_ͳI_`ãüúˆ|Ÿx¿}äWû Ÿ ~Nq³ál°ãÕ?èl> çhÿùKâŽô´:Aùׯƒâøýçÿa¿IñÄ‹K‰K›«¼ÌÖ éóúñè~<_ñ ëMEûêá18wu^§wý]¼J¼^ü@Þ8õÐÅ“€Ÿÿ°ør±ãð©¾D|f¾ŠçÆÿž£x‰ÛyîÒcìðÆaÐM~öùƒß8Ï\HÏWhŸzqäÇ8›Íÿ Ï™¼k§¿™Ü ÞÒ*t†OÜþ"ú„_k_å}ª#Õ·:G•}þäwñ£üaí­Ô)ÛGëŸæÅèóAwêò‹ç¿ žIp5*È[vQãár]¨ó—GWòÖY>ü³Ž_߸ñwn?{^ãuö?õ˜ÅYdï¡'¸vC|ûé{Ëסy"z(x£¹¯?áû|èåzÏ~“«¾W_3»Ê>ð'ÊŸù¼ý7\ïœx‚âœÁoè‰Ð…¾>øúPÄ)Ñy®6üZ?6õ7cŠ{¶-õßä*ûÜy¦©y%ÏEþ¸/9À>h_3ÜÉÈr¬ûœú }êâ"YWçȇÆÎlßKql’§i^38Zä…:û‹ïåÉßà©LæbŒq“·/ŽQøÜóæ­œOq¤Æ|Ÿ¸û­î†\mÞM>Œ^};->V~HÝDò_“~ÌäËáÏÙgò·z¼ŠœßT—Hnàù ñðuû§éwþ´øšççï CòÆóË·È»Š#âÏÐ!œö‰½9,î9}¿¸“:+ûŸŸyNv«ü.; ¿ë»wõŤ¯“GÇ6¦u±}Oí¼q~¦8“‘_ÅÑ.ÎáxË•#Á© ­K¼ ½VŽä¾ÕÏ¡‡â¨fÿÅ}<_ù.vFé+ò6~\gôÖ|4.ôÎŽŒßÒºÏU\“ȵâð$ŽX}»ºöjúÓkéŸÞŽ\exþÊ ç„_ÔµxÞð¹ÆþRÏNAwä­sÂg±{j±Owõ_ì£êÙðIè·¸í¿G>Næé=ùè?ï€û<¾§¸o¡Kù/~€89d>ZqéâÏÚ?r/*zBá†_ïøÈ˼{bÇEŽáËä§ä—'ýýø!ôSúË[¸ÿ=oõÝΉ^ªœŸÅ s>ôhž;r¼ó<ȵæŸÉßèuñ4ëU×#S{2z•<¶¾ú¹‘«ö×ùÒwì â|å|ñGq»ƒ›EŸÓ«~¯]œ:Bôæsy® ò¸™Öü±}ÿbGVÁùн¹4±_snä5;Ž%Ç*·"çå¹Ù%êAصüWy‚ì“9v{.¸Òü~yÒÊýèòPÜÁ|~7ûßþů0/¡~,: ÝWüˆ<^ùN<©xX‘ÃòMõg"ï«ïا™W»4ûK.–O¢‡‹¿:._D®Éð/ØÏÎd?–îÂÇâkŒåÏpNbõ+=ïêo…ŸÍA„‹{ß¼™®³ñ‘Ø%ÅUç<¹8[ë¤ÆuеÿÑ«:%ô\;b,/Z7À?àÏÁÇDçä ~`WÖ‰üö¹Î€w? ½V¯$Ñï‹\qì`öaùŠ^Œ¾M=E×S{!ôÃnOCgô9º…wH~° ‹‡,;Ïëä;€Ö|Cô£|vã±—Ø ¥ÇžtìÌ NGìïo½Iè¯umy>?ÕÔÉýùËÕg\Ï·Èsy^qVþ{¿‡&shG€Û%îá>üûœód®bôRýIç&~‘çWô;}Ë뼂ðQõ%œñ×ÌeÿÈŸ©&î¨}è¡oú´s—SŸV9‹Žb§ù~çÍ^ž;Ù?ïGݧø§‹d‰þ"§­›ÜÀïâ‚+Gî_&|à~ý{䨺­â”ðêé­Î•HýGíû»H^Ÿ?x¼Ÿ“y\ñS?Éóªƒð<è¯r+qIóŽÔ]8/òbP?ù]|&û N´yò‹ü‹]UºO,úV§Õxì÷ø»W;¿zÚsÓë;e_Ð)þ/È#äüèOû*ŸŒ>èÓêñÈãöÛÄþGä¬s®ý“> th^^Ÿ;߫߶ý Ñ3üïc’ô¯¸VýÜÈ'ëPÎoðyv[?7Лô½G7O"¾M/eÿäÇJá õv=7y„<'ÿÀþvn¿‚^?gGލ³Bgòÿì_x¡îÛ819g¾`⨭§Œþü1¿ÕoBÇöAý2~ÏëæÙ•nJϱ_ôe´N?Ï—¼ÉÄÿÌú‹G›úYøs'm²á²×¾méç×[ó¢ýæ/+΃<<|”ÏüÙ7mõ‚_,ýÆmï¸ð ½¶ÏuÅ¥÷¯|Ú¯QÜ×ås¿þ{œ‹+š§ÕÇž:´Ö{x]¾^ß¼|vûûo|ïïਾ¼kßnêõR‡ÐuÀåJÃäõàØXŸúž3\õY[¾à_[÷ îâü×\8÷]›?îË xðpÎÙùøÃvXåNøý{pyúûeK¿¶á–??¼¿ùæuV¾}¯Ï/=õÄmyÖ¯²ôì5>ñÙí¼½õvòÌêóRGÕÏË‹ƒ¤þ©¿à³ÝºÇlÝ¿«S‚뤞Êßí§º¬wé‰{{ÇÒ\»ÂóŸ¾`ÿë?¾ìØâ†Üøž×/»õèZ‡¤~ŸŸðˆ >pðÖ?Zú“¾ý­ƒöZµõBè@ÿ©ºv¿g{ßÐEׯ¬~ ݱ£Ó‡Õ}üöS¶ÛøÌ‡ô¶s·O×íuàuï[ó îþPuÃýõ:þq~ðOôɸ_ü—~þ´-Ž~˼_ÔºS|a_í| ?Ñ…ý¼öY_ýÛÑ*G.=å’Õ7|÷f+/ýäŸwçÙûÿƹ®pnøý¡óã×ÿà%ÏÿÎ/;Ï…ý®þmØÇŽn®þ·vùÛ=öêëê‘àÝ?/ëL¿Rߟº°þ®Žïìž¾Ñ+îywë1Ô+F®÷ý¾m“uÏú9ÃuMðS/ÙõW‡¾óþ=õý¯°?öW Ÿ«ó„„®"¯úyõáð¾ÿ¤‹.ÝúM_ìßÝßOrÎ÷™úîñ'Ýö˜§¼¼ŸûçÇÜþø½NøÜ¤Z}êC¯+<œr]XpÛ&|4~½¿«Cçٿþ=ô¾Âs9gò.Cè»ï‡ëú˜ì_䩺TtM?+è=é:?täóø ½±ëR/ÙïQeùü | ÞýŸó+‘“C<òÁOuªÅ½ûÕ+È]tb¿ìƒz¬œ[?÷ŧ®±à»ù‹ôs~oýz‰Ü§/'ûšçd?„¾»ŽÈ­¾¿z;ü‚Žáx†î'x=‰‡³èåê¾ÂÔ§ O¾““äsêí&81éwÈýú:=ìóê`ñ½c_óþ‰}õ«ï£ÏûÌ}ó~î×Ë/êÙgêÏüé.?}—«ŸÈûoþÑðyëXáü‡vþ é½øÇ}ßÉþÒao:î®îƒõÓÃ9TÎ.y(^Šnì£úüÄYWX?þuÞ‘+ØwîëÜç°Â÷ñ¢ð%¾€ËÞ/yô²Û·ßìÝ'÷%_‡v':Ôß NO©?ö»ûÇ>è÷WútرÎ}à_¸kêïS¯>YWèËßé;v‡s½vŸk_wæÊ‹'vgèľâgë¦÷áŸ8vIäÜDžÄ>ø?Ù+ž“}F?[ŸûúINçç ßç~ìaô¤¾Œžwžô ÿÈ9’ïÑKCºŸÈë|sNèÙþ #ëÇ÷êË­—ü`ÿ[¿:GrÑû¿ºÃõ÷üã=×­°Å9Ç;Wø;ÿO]}poú÷¡<öìXtÁNŽÖý$à˜Ñ7žÏ9E¯—®Ôÿë«À—ìNuÑìtNÞw¾w@'µ‚#µÂ¾X‡ó#7=—ïWmpƒð±znò±z2òþAçô¥û øh…u’ âBÑ+ð¿¾ïê{r$8¬}=Žïb÷®°ëõ<ö÷3 Þ¶ÍcßÒç&'½NÁu~ön$½dŸò³û‰®ì#œ0ë*ŽjêÓÄÈ{ñ9uñøŒÆWìpñŽ!’öÅúÅ-ðÓп —ЕçSŸOoéÇŸŒñÑðç€.z?yZz¡|—uÃ¥BgúøÙÖ w[üÆó»?{Þ÷“_é\Á@úБ>Lö¶÷çܺ¯îŸŸ+ðø¸¯;Gñ úŽŸ=ôõqÕK~ùœ‰ÞëýèW|ŽOùì|û‡^ÙÁ—ýv¯m^õö‹»>ôç§u‘ãü9Gútð•>PöxÞ?ñGS‡â|ÈúŠ|ÀO¾WœEß³ý½éuWì¾è97W¼ówi·‹[9!Ÿ'ž5”÷ì‹Ì'ÆëêÏ댼šô)û]V°Cÿ^‘~áÿ=Œ³Òñ'ýKéã¶?ðûñEp¥VàS|o=µ‡ç¯2gÎcÿü¡·Ì^ÓkzM¯é5½¦×ôš^ÓkzM¯éõß¾æM¯é5½¦×ôš^ÓkzM¯é5½¦×ôú}ÍŸ^ÓkzM¯é5½¦×ôš^ÓkzM¯é5½þ/×Ìôš^ÓkzM¯é5½¦×ôš^Óë¿u-˜^ÓkzM¯é5½¦×ôš^ÓkzM¯ÿÏ®…ÓkzM¯é5½¦×ôš^ÓkzM¯éõÿàZ4½¦×ôš^ÓkzM¯é5½¦×ôš^Óë¿tÍN¯é5½¦×ôš^ÓkzM¯é5½¦×ôš^ÿÅkñôš^ÓkzM¯é5½¦×ôš^ÿ3¯™ßá'Ï3óûßîºý[·ßu¯‡þ÷°ßÿuüêÜgøÏºþ³žÿ¬ï?é?å?øÏ†þ³Ñàv Þ°ë¶{¹[װöoØûM{>ô¿†oß}Ûݶ÷ö•óâÌ{n»Cÿ¿Ûö»ôÿ»¾aÇþÿ{¬û¿ýßêî±þúO[ß_f÷Øv—½÷Z¿Ç.ÛNþû†þw½ ûU;ïîvówÜsÁrïù¦}žfÉ«ô‘ñÓÏyà?Nž'ÍH} gss/data/stan.rda0000644000176000001440000000440612247272076013461 0ustar ripleyusers‹ÍX PTG}ò1:*~@@P@Ðq>dî óÁˆ¸@Р2ü„E`Q”ñƒ +¨¨\ÁhÄ5Œf HˆVW±LÔu êf5ñâ¢ÄÍ"ï¾—}]P×JíT gn÷íÛ·Ï=Ýô{ åáB^8¢(=JŸAéé÷ÿ4Ðëÿ3‚2 F¿4RµšU¥oöòwÿפÿÛ|jà£Uˆ›×иLGãl/›D£íäÕ4¡=ÑÇm½HãþZ5t¿äúåÛÒ8íÃ4V ¨ÿþ€ 㢀öŸ²h<„ñ•Ø¿}×oæôô‚!JÇõÓÒóÂÁ=¸nl?Hè `£€Û¿hLŒD¿{4z3|6b{NØ„ãkBß*ŒýsýSh¢¡t7ú#ؿ׹–&‚±ýmÄôŸ…vµ)åyÈpç«ÚOãj¬s•ó@>*‘÷ÊpD_9 ëÃågëU+h@‡úØw•›ïÞs4î¹Kc!¶ïA?O´åˆVˆåÈK¹€Ëÿ®^wc^%7¸z)A•`žË»ßVw`>eÈSòŒ|J0Ni ´3p}%¨»ÔAÉG\]ï@7qù/Ƽ•èWŒu(ž‡èEc<êÎÇá:¶£Î \ÇRìO@Ì÷GÄ}³ºˆ»OópœóÈ‹§1í\Šv$â\ïÔõ Ä0ìߌºÙŒzÚÄèë(clÔËFä[‡ºÐáºb±})ÆÍÀú­Çõ­'Χ ç<‚Läo ò›ÉÝW´µ8O ÆMŽäê1çB¿å˜OÇE!KP‹ÃÑ? ¸çâ1ž™Ÿá1P78¯lýˆùÄ„ˆç<1¡3Ÿ!ê¢&t@Ô‘áÑ™ˆ«"ô 't)!ôÍÄw#ø`ò¡K/¢ÞºÁõÆ”QÕûÅŸˆOÖŃXßÔ“ŽûœÉÌ'#ø”:P¼©‰xJBw¾Ä8w¢ÞCðÊÌçLä¨\Wd^d\Åyª ©‰çj9Á«;Áó˜ÈW<¸þÙsܤ¯óXÐü›’¾“kï†Ïû,§YZ­¾8¼~ü,­êïãÁ!uN¡Éœ°eê²ÌPxn»-˜ñ»Ó2 &‚à##“âVo£ç…¿}ý½˜ô¼«yñå|êyR<”Ó%bó;¼» æþ Hï §¦ãÑ7ìY?×Þ[¦Ù‹ p]8¯=à l%Ÿz6ŽÀ¶¦Vzâ»}I³-A”z:©>Ñí·µé’h>¹|;“v³ZP¯sy«¯ ‰}~ó¶>°Í§wøŒ™ZF|WMSÓ†3iKÀ¿³Ú8?èk•wŸ”“"š'0ϯ­»ö,ü?WqÇ3žU#Èž­pƒ,Jw\¹¬üÛ(Þç ŠÓ•Óî-þ8t‡'ØnwôÁH˜»ÌtÎc˜Yè#í0î¾7>^¢£#²ÇÕƒÜsªëä7prΡ2çg±ó©Æú_©€@T,ÉYÊ'¦¼ž´çàj­_ Ý ¬~•1÷ôô‚AºiýãË  U²»ôgP›E›h,X~Ä£3w·6iAQî[23åˆ\»ø66 X——ÞnÁæ«0Wç+ϾySŰPÄÆ77ƒ,(ØW±C “¿W©LcÀmËý£WÒ—€´­yÅìÆtžuÔœ)}ÒæÅ]qãX]K“E wüÀÛÐZèQÆò= Û6ƒ)WÜ¢»_ ì·ùÕ­“ÏÏy  ÜÞñÈãpyÐÐùü©Ìïéð<ðGä[²yŒÑ¨¯V€oG*ßý‹ÙóÀù¿xÛn·³Œ=g|nŽî)ú— T‘ç—7ùeŸÎ¹ÅeE/­Þ[}­w ˆŸ(¾°þgˆòbçm3•=Ž`W0ñ”Û!8<_õ~Ô¥QàÝÔÞáÙÞ -¿3o¹³O¯Œ¸]; ìžÉfÙ·fƒ×M÷“w?8^7ÆÚR^ì¹+úD±LùôLbìUŠâµ_/Qü…•>ã»A$‹_ë½í9ˆ,[N•~y‡=ï&zow>´Üþùn…ï ð¨¶M ÐOÜGÌù4âvÆÞ]=uÌyîÒ¿†•¥ƒ[›é¦äSàÖ~ÿü‰Nv_9–ÆXÜÿ< \7gî«ç«En݇>ÁáeY 5¬ù±§ܯ©'óÀ[Nà‚ü8£Î7Ô,‰æ Á)¡¹.â¬f\’üÛ‘OazƒKP/ì¿Ì/?v¶¨\ {.N¥÷«äiÕþ¸lñí_îõœw熫4+cSûŒxyŽ/Ôµ +cñ÷ÈT­F›–Š–¾f9Û—6àÆ7:%)ƒÏÄ4~ùÒžÞîT#9qt¢&•™˜iäÅh´~\Šæe\êß/¿ÿUdï/ÿgss/data/bacteriuria.rda0000644000176000001440000000170512247272076015005 0ustar ripleyusers‹íœ[S1†—Ý‚PDQPQQ±Òlv ž@EåÚ+nk)3á0SªÞú“ýà¶“}: ÝäK¶Ò™‡|Ð%O6ç´ÓþØÚaù¼ã8®ã9CŽë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òZİf-Qgss/data/gastric.rda0000644000176000001440000000073412247272076014150 0ustar ripleyusers‹Õ•=OÂP†/-~@¢!qqppp&ÂA“C…P*¤½€FÅbb$ Q‘ÕŸàèààOppppptdpF[Î[’’ã¢á&å¹÷ž÷Þû‘6¼ z£^ƘÀDæb‚hvÝ‚ùãbnæ19–’t®eŒ‰SæÐŠOšOl¡Íº-´fc!b|–¨<w¡Ë!žµg' ˜/"¿}ó%Ô+A_j;¹ýþñ¾ŽWnOæ‰êUðXîl„Ÿó¸“Õuú걎zõWâ%|]å‰×|?‰Íb þ[Äöo \WÀU0 F°îÖ½n"¾…ø6ÆÉw¢ Ÿ Æ)¬;mëNÃßòU䩈çð:öY¿Çyøˆ‡8¿cä—‘oÀ—ó¬àzŽžñy’”D®¸êm  BjAJŠ*îü¼@‘¸åò<@x€¾€¯‘@ªpâõÛÒþQ+±g°Tv¾ïÛ‡µ×á¿{?ýèÓþÅO/ …3…³…× gÎþóÜ™Ãÿy­p®pá°}ýëÏ}ö°P8{õé—ÃÿÞ9ìû‡ié›§¿ŸŸ<ýûótmðìoºYxö7mÆ÷½Å£ö\ô»í­è¿ýúžýMßçµh7öæ»ó¾ãzÑÿb´Õ˜·ϟĸË1®ï×ây'¾C÷‡±ÞÑv£­Dÿ­ßÝ×ø£÷{ßÅ÷w+ÚAÐu3ÚqÌ׋ïgbÜf´çâ{;èZŠq¢?û]ˆ¶ýÏG?Þ¿'þ,E»ýkÑÿµ˜·Ï7ŽÖMûy=¾_Žç•h›È9èD¾•háã ô„þуñ 9â{µ·×âû ú/Åûɧ+:~tŽã;ü®Çø%­³ýoBϽ£ùàÓr¼¿%½AN«1}-Å8äRÖúD¿F´ØA7Öý0ÞcWã9Þ‰çwbÞ; >,æüÇ^‡Ño‚ýÄxøÏ:£ £¬}ìa·1?ãÛ1~X7ZæOåBnßð{©ÅûÍ7~ì…—£_3ÖE>wcžºÖ½ß¡§ãzâÓf¬Ãüøï¯Ë®Šš~¼ã6bÜbÐ…Ýve×CázÚ~Ëñþ†ì¹œg¿Ñbï7£ÅÞ¡s=Ö›‘ò[ˆö øu´Ÿ½rœ}/æ½]Ø?ú|^Œgæ[eýxÏ~Áó«ñë&ÿRQ[“ýMÁ‹G?p ;ªãw‚np¸÷øè;r£?ö:Œy;è­ü_²kä‚^bß±-|oa7¬ÇüèCÐu]¸‹ß Ÿ£ÿ%í|Áÿ²Þ{Ñ‚7ØC)ž¯K¯ðãð‰?†oíhñ­x¾&œnKΕèÏúèz~\E_ãyãØÇ ý±Wùì¥x^”\P¿•£u÷þÏèß›ò%ñ·{ö-úÓ—ñóŒKñxWÎa… óßñ}UüÇ.Á#ðû÷¦ßÿÄçz´øiôãí˜gô8—GŠðGñ}'Ú;oåò½"~xï¯ñ<’Ÿ ?žäMãý?ñCOr|XÊýûÞßà'ôÆû˜7­Ïüge·ÄàÂyéë˜ýƺàB¼ïkƧx‘ø'úóu*Š;/‰/ãq Ï? },+o.)Žeþ–êù ô«ïø$Ö]êŠÖ·T”7oµtžˆüÁ½¦ì»iªN×Ä·²üYCqã­UÙo;¯;&ºÈ“û¦Wñχ²÷†ê4=ù'â•¢ì3íOõ·äÏunŽºŽë¸QÒ=¤’üJQõ³¢ü ø¸,}[UÁù%û¹¥ø %¿Ù”>¬ÈßaÐÕÖ9WÊOdÐSÒýæí*ΫêÜ6é»ì·)=m+?n(¯h)_¯É®‹ªw·å·¸Ï±ª:TYxˆü:º?rKuè$/éÕ’ì ©¶§<µ¦{ì¿­ºLIùt:<ÿ¬)ï]ÎV¥ÏÄ×uáwÅõÙMUû+ª~UÑ~jÊokº·R3~‰ÏUå]é?ûäžÔªê›á¾ë;– ëöE—ñµª|»*ýéH?/ ×ʱt>*y5…?ô+Ê>*ªÛPk§áêœïr_n>=µÔ§w9‡ãžY¬; ; Î»Ë9†î¡Q¿ã|ããxÇü›ÌKݘ¼›÷±óoèürÿóO˜ŸsíàçºöÏy<çêœwm1oö9‚¾#'ñ¾ 9·â¾raû%•\6c¾íƒÜ^8/âd>¢çÐÃû|Öò{¡Ü§à=úýèíºåt°Nš}cŸª²NWç9ØQ²ÕÙvLžÅxäκØzϽ„mì:=i=ø0RÝs[ë¡§Œ»#ýMòf]ø¸Ÿ?sO»EÖE/çHÈc{dîñBo|ß@bü6zË:Èù3òYÌï'1ϺîÁr.–ôOušdO1|ߣ`ÿù}Ù´ôÓŸ} 7ÀîkÀ÷¡ôy :côbC÷o¨S¡ø±uÑõuè‡q/,áçƒÜ›`Ÿì{¿ »¯ûLcѱ.=Núò ç»íû+É ŸàÅ _:á+ú–üJ!¿WŽÞ%¾ó^÷yi·¹ŸœÏ 9N%û'ŽŽ•O¥s1âø N¡·ÊÓÀ~Ç0Ö=§„G•‰ìfC÷þé<á|&/Ç_QßMöü ÷Óèëï.æuWèHøtOt/ûÝÐ9ûJÀmøÎ>Ò{ø`ùH GuBòuüz¾î Wzò÷Ü›'~Ên°¯‘èÊÿe©!ÇÙ¾ä ß6…—=ùIäùq~7—âý7¶È;•Á?pD¿—¹k?"\GvãÿéÇüðïö4öqÿ~m üÏÝËÁõ±â×±â6ø1tœ@ÿƒ\Ϲ?ùâtšã¸¹®¼~£GwçqãŽü5ü%¾áž(tágwäÏñ«Ä#èü¹ƒ¾Âó‹x9ävÇ>†:ïéwN»ZgWq8öN¾;‘)N+Jù/ý”_nÉ?OäGÐgôwËy¼ô”uð‡à9yy̦~8’?Á‚/àÏäxâ<~¬¸u]x ß6…Ø xÏ3zÓS|È=ç-å§ ð/à)øžäyäH¿[Å?ð>&®ß]l(ßuܸ®ú8¸&¿2TÞM]c¨ßKà?»ú}fšÜ‘>ñ¼ÊϦüö^þ»Ý±îy¤~Äoè9r&.BÏU‡零§‰~ï˜p~㯽¾òà‘òê¿·¿•ÿľïå÷¤±£môc?Ï7‰Ç’__o«†!7ô¨'¿‡½Ð ¼Ú"ÞEo G¸N]ŸßâŸcê…cþöþòýíó¾?¯}Ñ¿“öÑ}̺ÞqýNúþ´ôŸ–¯ÇÉïE×yQ½˜UŸæ­Ï£sVýüׇÓîïyã祇'ÕÓ“¾Uò·~ÍÊçYõkV:fŇÓêãËÚÿIqô´x|Rœ<-®ÎêÏgõ¯ÿ«x`Þú0/½Ÿ—ÿ<©~žT¿fÅ©YñôeÇEóò‡§Õ¯YãêYýçiù=«œfÕ¯W­³úyù×—å_u\ÿ²ìjVü›WüqZ;Ÿ5ߘwÜòªâ˜ydzâÔ¼qs^ãgÅÁYõoÖ¼pV½~ÙyÛ¼ãÇyóïeÅi/[?æ3ÏçCþîù«û_~þèð—Ÿ~‰—g?ûÍCþù‹/~Ë?öå/ùçÃÏ¿ÒDþú듽}øß™ýg«=­¬æ+þü‹ûX‘—?»ÿÕý΃‡‡ãŸ¾{úß9«W|™Tgss/data/datalist0000644000176000001440000000015411701656064013545 0ustar ripleyusersColoCan LakeAcidity NO2 Sachs aids bacteriuria buffalo clim esc eyetrack gastric nox ozone penny stan wesdr gss/data/aids.rda0000644000176000001440000000260612247272076013434 0ustar ripleyusers‹…™kkG†Çv ‰¡ÅPÈÇR‚J1¾È¶"YÖ¬î«ËÞ$»þ*§’â–~ÝŸ¦ŸÔ_P*Çón™Ç»ØÍîÌœsÞóÎ9g¤¬s¼{³kŒÙ6;fËlïl>>ÛÞü·ež™÷ƒÕÇ÷wÆìü¸ù|ÿò‡Í«×öÂ|û³¿:ù òÜÉ_œ|ãd7/ÝxójNž:ù““6÷çéyûj|Œy-'nÞÞKïü}~YÌÓ:á@J_»bÜs2Ê}¼zÐ7ròûO€Ïì>æ×¡'v²uýÜÇõæ½Õ>¹?Þ‡Ÿ'àM€}S'ÇNb<Ê}ýé0všû~"^{ˆó%x§ýºÀCz›ð£^§N²v8æ>o-â‚缜ÀÏÄúúõ¾ ;jðCvŽsŸ§?c~8éœH.±¯â4ÎSðW¼oÃÜç‰pÒó!xÔÆ:ÍïƒçŠSâäÂÅáZü/xþŽqŽÛˆÏ['ýzOq^šàWÝ”ç6p:A9ƹ9_úˆCŒó4gîy>Êîö0ÿÔp^N°žyXþ¿Äy?G^~ž ¿Þ"ô€K =Ø[¯ÈŸ}àu¿0¯¸×qnFÀgŒ|È:Ò¿uœËø"=5ĽÜcðZ¸-×¾ÿmœ_=ŸÂÙ5qr†sÙƒÝè-Î'ÎUû =ùpŒü§sa?åãöoÿ1ÎSŠzú‰!ò¼ð\"žCôZ¡¯¾õTþu±~XQ_¨gÂùùôõd¿"®â—pÈïVEý‘ÿcäÕ‰ÏG¨{ÄC}äy:DŸ©8\Ãÿ#à”­Ëíßæè+"ô‘Šû}ô~ŒQW—"Xßÿða?Ù!ÿëÈÿò´ø˜ò~v€ç3ä“qŒÿ>æ‰3ð}„sPàû;¦<¿Ï–àKý]öó°K|à}õþöQ_ºðŸ¸Çyù}Ÿq¡Îõ—˜×@¾é#ŸÉŸžÿ†<¦8kþu­<ÁÏ$/¿?³ÏÈP¯,òT u#2å÷÷òñ9ÎCž_¢_ ˜­KÀ³&âÝBž q~.}¾ý“î©îaç_êù#Y±îÑøyù¸j÷}4oï ýOùó¼\ïgˆkço„sÝc^O¹®iÊy"Ÿ0ßµa×)ïs¼žøþmˆu!¤ìi`Þ¼ð½dù(D¾"?§È7¼?°_ïÊyè›à<óûÄ9úŽùÎVðÁ¢oí¢¯Ô¼9p<ŽqŠûDÙæèúäòËxz<æÐS3åyj ž¶€W»ö‰/êô }Š­À¯gÊû9õ1ú%õQî11êGÊ> }ÑuFù™zRôÜ?Aßš@Oa/üÒ½5AKñ}©öÉ0Žp//ìUÿ–ûuœ8¥°'©š·†]ÆgÀw‘—ÛÃÏ%ðÑó öDør>ï í5>ŽÚÿ û>¿Ø”¿OÀ¿ýc‚ûFÊïÉßß3sð[Øò8÷sëëa<5oû¸_ Üè¯ìH*pÉ€›xÉu©)¿DU¼$mùsâêû'﷽ᆲ>ßÞm>ì}ûqÏýà÷ñË»¿þÿüáÖ}ÞYý~‹õ/¾þñ÷öøþþGÄ5[¯©èݧÕéáîûÕŸ«ƒ_7ë7£ïÿýRSÎgss/R/0000755000176000001440000000000012247270403011300 5ustar ripleyusersgss/R/sscox.R0000644000176000001440000004421412113213734012563 0ustar ripleyusers## 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000002322711753576004014421 0ustar ripleyusers## 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.R0000644000176000001440000002437111562701644013671 0ustar ripleyusers##%%%%%%%%%% Binomial Family %%%%%%%%%% y0.binomial <- function(y,eta0,wt) { if (is.matrix(y)) wt <- wt * (y[,1]+y[,2]) p <- plogis(eta0) list(p=p,eta=eta0,wt=wt) } proj0.binomial <- function(y0,eta,offset) { if (is.null(offset)) offset <- rep(0,length(eta)) p <- plogis(eta) u <- p - y0$p w <- p*(1-p) ywk <- eta-u/w-offset wt <- w*y0$wt kl <- sum(y0$wt*(y0$p*(y0$eta-eta)+log((1-y0$p)/(1-p))))/sum(y0$wt) list(ywk=ywk,wt=wt,kl=kl,u=wt*u) } kl.binomial <- function(eta0,eta1,wt) { p0 <- plogis(eta0) p1 <- plogis(eta1) sum(wt*(p0*(eta0-eta1)+log((1-p0)/(1-p1))))/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 { p <- plogis(eta+offset) u <- p - y w <- p*(1-p) 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)) p <- plogis(eta) u <- (y0$mu+y0$nu)*p-y0$nu w <- (y0$mu+y0$nu)*p*(1-p) 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 { p <- plogis(eta+offset) u <- (y+nu)*p-nu w <- (y+nu)*p*(1-p) 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.R0000644000176000001440000000121407506515074013110 0ustar ripleyuserssmolyak.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.R0000644000176000001440000001716512125176554014451 0ustar ripleyusers## 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.R0000644000176000001440000004566511613070410013254 0ustar ripleyusers## 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 { repeat { mn <- la-2 mx <- la+1 zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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]]) iter <- 0 flag <- 0 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 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 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") eta <- rep(0,nobs) 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 adj <- 0 repeat { dc.new <- dc + dc.diff cc <- dc.new[nnull+(1:nxi)] eta.new <- as.vector(sr%*%dc.new) if (!is.null(offset)) eta.new <- eta.new + offset dev.new <- 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]])) dev.new <- sum(dev.new) + t(cc)%*%q%*%cc if (!is.finite(dev.new)) dev.new <- Inf if (dev.new-dev<(1+abs(dev))*1e-1) break adj <- 1 dc.diff <- dc.diff/2 } 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") eta <- rep(0,nobs) iter <- 0 flag <- 1 next } dc <- dc.new eta <- eta.new dev <- dev.new if (adj) next if (disc<1e-7) break if (iter<=30) next if (!flag) { eta <- rep(0,nobs) iter <- 0 flag <- 1 } else { 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.R0000644000176000001440000001666711614102652012721 0ustar ripleyusers##%%%%%%%%%% 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]) } p <- 1-1/(1+exp(eta)) u <- p - y w <- p*(1-p) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=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]) } p <- 1-1/(1+exp(eta)) as.vector(2*wt*(y*log(ifelse(y==0,1,y/p)) +(1-y)*log(ifelse(y==1,1,(1-y)/(1-p))))) } ## 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) if (!is.null(offset)) { eta <- log(p/(1-p)) - mean(offset) repeat { p <- 1-1/(1+exp(eta+offset)) u <- p - y w <- p*(1-p) 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/p)) +(1-y)*log(ifelse(y==1,1,(1-y)/(1-p))))) } ##%%%%%%%%%% 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) } ## 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) } ## 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) } ## 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") p <- 1-1/(1+exp(eta)) u <- (y[,1]+y[,2])*p-y[,2] w <- y[,2]*(1-p) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt) } else { if (min(y)<0) stop("gss error: negative binomial response should be nonnegative") p <- 1-1/(1+exp(eta)) if (is.null(nu)) log.nu <- log(mean(y*exp(eta))) 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+nu)*p-nu w <- nu*(1-p) ywk <- eta-u/w-offset wt <- w*wt list(ywk=ywk,wt=wt,nu=nu) } } ## Calculate deviance residuals for NB regression dev.resid.nbinomial <- function(y,eta,wt) { if (is.null(wt)) wt <- rep(1,dim(y)[1]) p <- 1-1/(1+exp(eta)) as.vector(2*wt*(y[,1]*log(ifelse(y[,1]==0,1,y[,1]/(y[,1]+y[,2])/(1-p))) +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 { p <- 1-1/(1+exp(eta+offset)) u <- (y[,1]+y[,2])*p-y[,2] w <- y[,2]*(1-p) 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])/(1-p))) +y[,2]*log(y[,2]/(y[,1]+y[,2])/p))) } gss/R/mkfun.factor.R0000644000176000001440000000410410653407206014021 0ustar ripleyusers## 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.R0000644000176000001440000001027511524624030014607 0ustar ripleyusers## 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.R0000644000176000001440000003466612241276214012556 0ustar ripleyusers## 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000001327011540502662014373 0ustar ripleyusers## 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.R0000644000176000001440000000630511522372712014656 0ustar ripleyusers## 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.R0000644000176000001440000000505707630317234012304 0ustar ripleyusers## 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.R0000644000176000001440000000433411522224022012675 0ustar ripleyusers## 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.R0000644000176000001440000001640011607665356014242 0ustar ripleyusers## 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.R0000644000176000001440000000552611563241000014212 0ustar ripleyusers## 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.R0000644000176000001440000003027411613070446013333 0ustar ripleyusers## 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.R0000644000176000001440000000710412225304624014663 0ustar ripleyusers## 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.R0000644000176000001440000000117707503626522013512 0ustar ripleyusersgauss.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.R0000644000176000001440000005715612247270403012655 0ustar ripleyusers## 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000006146712246636443012605 0ustar ripleyusers## 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000001557711614167252013350 0ustar ripleyusers## 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.R0000644000176000001440000005054412125153032012764 0ustar ripleyusers## 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000001013212225144412014731 0ustar ripleyusers## 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.R0000644000176000001440000001573411656310412012567 0ustar ripleyusers## 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.R0000644000176000001440000006005012017260350012733 0ustar ripleyusers## 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000000334512113213254012531 0ustar ripleyusers## 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.R0000644000176000001440000002370511613070300013152 0ustar ripleyusers## 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.R0000644000176000001440000001773011630042012013042 0ustar ripleyusersdsscden <- ## 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.R0000644000176000001440000004126412113174512013171 0ustar ripleyusers## 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) repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000003771512125153070014275 0ustar ripleyusers## 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.R0000644000176000001440000005377612125434016012637 0ustar ripleyusers## 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000003711512126167312012711 0ustar ripleyusers## 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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 repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv.s,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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.R0000644000176000001440000002637112113174230014713 0ustar ripleyusers## 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 iter <- 0 flag <- 0 adj <- 0 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 ## Newton iteration repeat { if (!adj) 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") eta <- rep(0,nobs) 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 adj <- 0 repeat { dc.new <- dc + dc.diff eta.new <- sr%*%dc.new if (!is.null(offset)) eta.new <- eta.new + offset fit1 <- 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)) kl.new <- fit1$kl if (!is.finite(kl.new)) kl.new <- Inf if (kl.new-kl<(1e-4+abs(kl))*1e-1) break adj <- 1 dc.diff <- dc.diff/2 } 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") eta <- rep(0,nobs) 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 (adj) next if (disc0<1e-5) break if (disc<1e-5) break if (iter<=30) next warning("gss warning in project.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.R0000644000176000001440000001535512116456152013326 0ustar ripleyusers##%%%%%%%%%% 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 p <- 1-1/(1+exp(eta)) w <- p*(1-p) lkhd <- -sum(wtt*(y*eta+log(1-p)))/sum(wtt) aux1 <- sum(hat/w)/(sum(wtt)-sum(hat)) aux2 <- sum(wtt*y*(1-p))/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.R0000644000176000001440000001432012125153120014273 0ustar ripleyusers## 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.R0000644000176000001440000001716411630053152013215 0ustar ripleyuserscdsscden <- ## 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.R0000644000176000001440000001223111655575660012721 0ustar ripleyusersdssden <- ## 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) } ## 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) } ## 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) } ## 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.R0000644000176000001440000001421512125363724013055 0ustar ripleyuserscdssden <- ## 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.R0000644000176000001440000004537012116456124013107 0ustar ripleyusers## 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 { repeat { mn <- la-1 mx <- la+1 if (mx>log.la0+6) break zz <- nlm0(cv,c(mn,mx)) if (min(zz$est-mn,mx-zz$est)>=1e-3) 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) Description: A comprehensive package for structural multivariate function estimation using smoothing splines. License: GPL (>= 2) Packaged: 2013-12-03 06:03:41 UTC; chong NeedsCompilation: yes Repository: CRAN Date/Publication: 2013-12-06 18:26:59 gss/ChangeLog0000644000176000001440000003507512247272017012666 0ustar ripleyusersTue 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/0000755000176000001440000000000012247271134011654 5ustar ripleyusersgss/man/bacteriuria.Rd0000644000176000001440000000207410654123420014432 0ustar ripleyusers\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.Rd0000644000176000001440000000161211000500336015054 0ustar ripleyusers\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.Rd0000644000176000001440000001215212241513631013453 0ustar ripleyusers\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. } \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.Rd0000644000176000001440000000142111547006050013265 0ustar ripleyusers\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.Rd0000644000176000001440000000323311702363406013461 0ustar ripleyusers\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.Rd0000644000176000001440000000126307630457114013605 0ustar ripleyusers\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.Rd0000644000176000001440000000065711614344706013574 0ustar ripleyusers\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.Rd0000644000176000001440000000300611553522120013556 0ustar ripleyusers\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.Rd0000644000176000001440000000256311702402552013205 0ustar ripleyusers\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.Rd0000644000176000001440000000313711563250746014745 0ustar ripleyusers\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.Rd0000644000176000001440000002003312241514434014037 0ustar ripleyusers\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. } \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.Rd0000644000176000001440000000257311605423644013273 0ustar ripleyusers\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.Rd0000644000176000001440000002064212241513465013263 0ustar ripleyusers\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. (2013), \emph{Smoothing Spline ANOVA Models (2nd Ed)}. New York: Springer-Verlag. Gu, C. and Wang, J. (2003), Penalized likelihood density estimation: Direct cross-validation and scalable approximation. \emph{Statistica Sinica}, \bold{13}, 811--826. } \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.Rd0000644000176000001440000000211407322505702012744 0ustar ripleyusers\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.Rd0000644000176000001440000000320611553524564013576 0ustar ripleyusers\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.Rd0000644000176000001440000000245110653773150014551 0ustar ripleyusers\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/INDEX0000644000176000001440000003171711660664676011723 0ustar ripleyusers## 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