Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
--- /Users/jack/Downloads/glm/glmnet5dpclean.f.txt
+++ /Users/jack/Downloads/glm/glmnet5.f90.txt
@@ -1,9 +1,6 @@
- mortran 2.0 (version of 7/04/75 mod 7/4/87 (ajc))
- subroutine get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace
-*)
- implicit double precision(a-h,o-z)
- data sml0,eps0,big0,mnlam0,rsqmax0,pmin0,exmx0,itrace0 /1.0d-5,1.
-*0d-6,9.9d35,5,0.999,1.0d-9,250.0,0/
+ subroutine get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
+ data sml0,eps0,big0,mnlam0,rsqmax0,pmin0,exmx0 /1.0e-5,1.0e-6,9.9
+*e35,5,0.999,1.0e-9,250.0/
sml=sml0
eps=eps0
big=big0
@@ -11,7 +8,6 @@
rsqmax=rsqmax0
pmin=pmin0
exmx=exmx0
- itrace=itrace0
return
entry chg_fract_dev(arg)
sml0=arg
@@ -34,24 +30,20 @@
entry chg_max_exp(arg)
exmx0=arg
return
- entry chg_itrace(irg)
- itrace0=irg
- return
- end
- subroutine elnet(ka,parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam, flmin,u
+ end
+ subroutine elnet (ka,parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam,flmin,u
*lam,thr,isd,intr,maxit, lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),w(no),vp(ni),ca(nx,nlam),cl(2,ni)
- double precision ulam(nlam),a0(nlam),rsq(nlam),alm(nlam)
+ real x(no,ni),y(no),w(no),vp(ni),ca(nx,nlam),cl(2,ni)
+ real ulam(nlam),a0(nlam),rsq(nlam),alm(nlam)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: vq;
+ real, dimension (:), allocatable :: vq;
if(maxval(vp) .gt. 0.0)goto 10021
jerr=10000
return
continue
allocate(vq(1:ni),stat=jerr)
if(jerr.ne.0) return
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
if(ka .ne. 1)goto 10041
call elnetu (parm,no,ni,x,y,w,jd,vq,cl,ne,nx,nlam,flmin,ulam,thr,
@@ -65,25 +57,24 @@
deallocate(vq)
return
end
- subroutine elnetu(parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam, flmin,ula
+ subroutine elnetu (parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam,flmin,ula
*m,thr,isd,intr,maxit, lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
+ real x(no,ni),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,g,xv,vlam
+ real, dimension (:), allocatable :: xm,xs,g,xv,vlam
integer, dimension (:), allocatable :: ju
allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vlam(1:nlam),stat=jerr)
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vlam(1:nlam),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -118,11 +109,11 @@
deallocate(xm,xs,g,ju,xv,vlam)
return
end
- subroutine standard(no,ni,x,y,w,isd,intr,ju,g,xm,xs,ym,ys,xv,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),w(no),g(ni),xm(ni),xs(ni),xv(ni)
+ subroutine standard (no,ni,x,y,w,isd,intr,ju,g,xm,xs,ym,ys,xv,jerr
+*)
+ real x(no,ni),y(no),w(no),g(ni),xm(ni),xs(ni),xv(ni)
integer ju(ni)
- double precision, dimension (:), allocatable :: v
+ real, dimension (:), allocatable :: v
allocate(v(1:no),stat=jerr)
if(jerr.ne.0) return
w=w/sum(w)
@@ -130,7 +121,7 @@
if(intr .ne. 0)goto 10141
ym=0.0
y=v*y
- ys=sqrt(dot_product(y,y))
+ ys=sqrt(dot_product(y,y)-dot_product(v,y)**2)
y=y/ys
do 10151 j=1,ni
if(ju(j).eq.0)goto 10151
@@ -186,29 +177,26 @@
deallocate(v)
return
end
- subroutine elnet1(beta,ni,ju,vp,cl,g,no,ne,nx,x,nlam,flmin,ulam,th
-*r,maxit,xv, lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision vp(ni),g(ni),x(no,ni),ulam(nlam),ao(nx,nlam)
- double precision rsqo(nlam),almo(nlam),xv(ni)
- double precision cl(2,ni)
+ subroutine elnet1 (beta,ni,ju,vp,cl,g,no,ne,nx,x,nlam,flmin,ulam,t
+*hr,maxit,xv, lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
+ real vp(ni),g(ni),x(no,ni),ulam(nlam),ao(nx,nlam),rsqo(nlam),almo(
+*nlam),xv(ni)
+ real cl(2,ni)
integer ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: a,da
+ real, dimension (:), allocatable :: a,da
integer, dimension (:), allocatable :: mm
- double precision, dimension (:,:), allocatable :: c
+ real, dimension (:,:), allocatable :: c
allocate(c(1:ni,1:nx),stat=jerr)
- if(jerr.ne.0) return;
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
- allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(da(1:ni),stat=jerr)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
+ allocate(a(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(da(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
- alm=0.0
- alf=1.0
if(flmin .ge. 1.0)goto 10271
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -221,7 +209,6 @@
iz=0
mnl=min(mnlam,nlam)
do 10281 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
if(flmin .lt. 1.0)goto 10301
alm=ulam(m)
goto 10291
@@ -239,7 +226,7 @@
alm=max(alm,abs(g(j))/vp(j))
continue
continue
- alm=alf*alm/max(bta,1.0d-3)
+ alm=alf*alm/max(bta,1.0e-3)
continue
continue
dem=alm*omb
@@ -359,23 +346,22 @@
deallocate(a,mm,c,da)
return
end
- subroutine elnetn(parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam,flmin,ulam,
-*thr,isd, intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision vp(ni),x(no,ni),y(no),w(no),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
+ subroutine elnetn (parm,no,ni,x,y,w,jd,vp,cl,ne,nx,nlam,flmin,ulam
+*,thr,isd, intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
+ real vp(ni),x(no,ni),y(no),w(no),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,xv,vlam
+ real, dimension (:), allocatable :: xm,xs,xv,vlam
integer, dimension (:), allocatable :: ju
allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vlam(1:nlam),stat=jerr)
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vlam(1:nlam),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -410,11 +396,10 @@
deallocate(xm,xs,ju,xv,vlam)
return
end
- subroutine standard1(no,ni,x,y,w,isd,intr,ju,xm,xs,ym,ys,xv,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),w(no),xm(ni),xs(ni),xv(ni)
+ subroutine standard1 (no,ni,x,y,w,isd,intr,ju,xm,xs,ym,ys,xv,jerr)
+ real x(no,ni),y(no),w(no),xm(ni),xs(ni),xv(ni)
integer ju(ni)
- double precision, dimension (:), allocatable :: v
+ real, dimension (:), allocatable :: v
allocate(v(1:no),stat=jerr)
if(jerr.ne.0) return
w=w/sum(w)
@@ -422,7 +407,7 @@
if(intr .ne. 0)goto 10651
ym=0.0
y=v*y
- ys=sqrt(dot_product(y,y))
+ ys=sqrt(dot_product(y,y)-dot_product(v,y)**2)
y=y/ys
do 10661 j=1,ni
if(ju(j).eq.0)goto 10661
@@ -474,26 +459,24 @@
end
subroutine elnet2(beta,ni,ju,vp,cl,y,no,ne,nx,x,nlam,flmin,ulam,th
*r,maxit,xv, lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision vp(ni),y(no),x(no,ni),ulam(nlam),ao(nx,nlam)
- double precision rsqo(nlam),almo(nlam),xv(ni)
- double precision cl(2,ni)
+ real vp(ni),y(no),x(no,ni),ulam(nlam),ao(nx,nlam),rsqo(nlam),almo(
+*nlam),xv(ni)
+ real cl(2,ni)
integer ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: a,g
+ real, dimension (:), allocatable :: a,g
integer, dimension (:), allocatable :: mm,ix
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ix(1:ni),stat=jerr)
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(g(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ix(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
ix=0
- alf=1.0
if(flmin .ge. 1.0)goto 10771
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -512,7 +495,6 @@
continue
continue
do 10791 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
alm0=alm
if(flmin .lt. 1.0)goto 10811
alm=ulam(m)
@@ -530,7 +512,7 @@
if(vp(j).gt.0.0) alm0=max(alm0,g(j)/vp(j))
continue
continue
- alm0=alm0/max(bta,1.0d-3)
+ alm0=alm0/max(bta,1.0e-3)
alm=alf*alm0
continue
continue
@@ -650,8 +632,7 @@
return
end
subroutine chkvars(no,ni,x,ju)
- implicit double precision(a-h,o-z)
- double precision x(no,ni)
+ real x(no,ni)
integer ju(ni)
do 11061 j=1,ni
ju(j)=0
@@ -667,16 +648,14 @@
return
end
subroutine uncomp(ni,ca,ia,nin,a)
- implicit double precision(a-h,o-z)
- double precision ca(*),a(ni)
+ real ca(*),a(ni)
integer ia(*)
a=0.0
if(nin.gt.0) a(ia(1:nin))=ca(1:nin)
return
end
subroutine modval(a0,ca,ia,nin,n,x,f)
- implicit double precision(a-h,o-z)
- double precision ca(nin),x(n,*),f(n)
+ real ca(nin),x(n,*),f(n)
integer ia(nin)
f=a0
if(nin.le.0) return
@@ -686,21 +665,20 @@
continue
return
end
- subroutine spelnet(ka,parm,no,ni,x,ix,jx,y,w,jd,vp,cl,ne,nx,nlam,
-* flmin,ulam,thr,isd,intr, maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr
+ subroutine spelnet (ka,parm,no,ni,x,ix,jx,y,w,jd,vp,cl,ne,nx,nlam
+*,flmin,ulam,thr,isd,intr, maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr
*)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
+ real x(*),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: vq;
+ real, dimension (:), allocatable :: vq;
if(maxval(vp) .gt. 0.0)goto 11101
jerr=10000
return
continue
allocate(vq(1:ni),stat=jerr)
if(jerr.ne.0) return
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
if(ka .ne. 1)goto 11121
call spelnetu (parm,no,ni,x,ix,jx,y,w,jd,vq,cl,ne,nx,nlam,flmin,u
@@ -714,25 +692,24 @@
deallocate(vq)
return
end
- subroutine spelnetu(parm,no,ni,x,ix,jx,y,w,jd,vp,cl,ne,nx,nlam, f
+ subroutine spelnetu (parm,no,ni,x,ix,jx,y,w,jd,vp,cl,ne,nx,nlam,f
*lmin,ulam,thr,isd,intr, maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
+ real x(*),y(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,g,xv,vlam
+ real, dimension (:), allocatable :: xm,xs,g,xv,vlam
integer, dimension (:), allocatable :: ju
allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vlam(1:nlam),stat=jerr)
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vlam(1:nlam),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call spchkvars(no,ni,x,ix,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -768,16 +745,14 @@
deallocate(xm,xs,g,ju,xv,vlam)
return
end
- subroutine spstandard(no,ni,x,ix,jx,y,w,ju,isd,intr,g,xm,xs,ym,ys,
-*xv,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),w(no),g(ni),xm(ni),xs(ni),xv(ni)
+ subroutine spstandard (no,ni,x,ix,jx,y,w,ju,isd,intr,g,xm,xs,ym,ys
+*,xv,jerr)
+ real x(*),y(no),w(no),g(ni),xm(ni),xs(ni),xv(ni)
integer ix(*),jx(*),ju(ni)
- jerr = jerr*1
w=w/sum(w)
if(intr .ne. 0)goto 11221
ym=0.0
- ys=sqrt(dot_product(w,y**2))
+ ys=sqrt(dot_product(w,y**2)-dot_product(w,y)**2)
y=y/ys
do 11231 j=1,ni
if(ju(j).eq.0)goto 11231
@@ -833,27 +808,24 @@
end
subroutine spelnet1(beta,ni,g,no,w,ne,nx,x,ix,jx,ju,vp,cl,nlam,flm
*in,ulam, thr,maxit,xm,xs,xv,lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision g(ni),vp(ni),x(*),ulam(nlam),w(no)
- double precision ao(nx,nlam),rsqo(nlam),almo(nlam)
- double precision xm(ni),xs(ni),xv(ni),cl(2,ni)
+ real g(ni),vp(ni),x(*),ulam(nlam),w(no)
+ real ao(nx,nlam),rsqo(nlam),almo(nlam),xm(ni),xs(ni),xv(ni),cl(2,n
+*i)
integer ix(*),jx(*),ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: a,da
+ real, dimension (:), allocatable :: a,da
integer, dimension (:), allocatable :: mm
- double precision, dimension (:,:), allocatable :: c
+ real, dimension (:,:), allocatable :: c
allocate(c(1:ni,1:nx),stat=jerr)
- if(jerr.ne.0) return;
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
- allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(da(1:ni),stat=jerr)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
+ allocate(a(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(da(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
- alm=0.0
- alf=1.0
if(flmin .ge. 1.0)goto 11341
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -866,7 +838,6 @@
iz=0
mnl=min(mnlam,nlam)
do 11351 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
if(flmin .lt. 1.0)goto 11371
alm=ulam(m)
goto 11361
@@ -884,7 +855,7 @@
alm=max(alm,abs(g(j))/vp(j))
continue
continue
- alm=alf*alm/max(bta,1.0d-3)
+ alm=alf*alm/max(bta,1.0e-3)
continue
continue
dem=alm*omb
@@ -1006,21 +977,20 @@
end
subroutine spelnetn(parm,no,ni,x,ix,jx,y,w,jd,vp,cl,ne,nx,nlam,flm
*in,ulam, thr,isd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),vp(ni),y(no),w(no),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
+ real x(*),vp(ni),y(no),w(no),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),rsq(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,xv,vlam
+ real, dimension (:), allocatable :: xm,xs,xv,vlam
integer, dimension (:), allocatable :: ju
allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vlam(1:nlam),stat=jerr)
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vlam(1:nlam),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call spchkvars(no,ni,x,ix,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -1056,16 +1026,14 @@
deallocate(xm,xs,ju,xv,vlam)
return
end
- subroutine spstandard1(no,ni,x,ix,jx,y,w,ju,isd,intr,xm,xs,ym,ys,x
-*v,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),w(no),xm(ni),xs(ni),xv(ni)
+ subroutine spstandard1 (no,ni,x,ix,jx,y,w,ju,isd,intr,xm,xs,ym,ys,
+*xv,jerr)
+ real x(*),y(no),w(no),xm(ni),xs(ni),xv(ni)
integer ix(*),jx(*),ju(ni)
- jerr = jerr*1
w=w/sum(w)
if(intr .ne. 0)goto 11711
ym=0.0
- ys=sqrt(dot_product(w,y**2))
+ ys=sqrt(dot_product(w,y**2)-dot_product(w,y)**2)
y=y/ys
do 11721 j=1,ni
if(ju(j).eq.0)goto 11721
@@ -1111,27 +1079,24 @@
end
subroutine spelnet2(beta,ni,y,w,no,ne,nx,x,ix,jx,ju,vp,cl,nlam,flm
*in,ulam, thr,maxit,xm,xs,xv,lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision y(no),w(no),x(*),vp(ni),ulam(nlam),cl(2,ni)
- double precision ao(nx,nlam),rsqo(nlam),almo(nlam),xm(ni),xs(ni),x
-*v(ni)
+ real y(no),w(no),x(*),vp(ni),ulam(nlam),cl(2,ni)
+ real ao(nx,nlam),rsqo(nlam),almo(nlam),xm(ni),xs(ni),xv(ni)
integer ix(*),jx(*),ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: a,g
+ real, dimension (:), allocatable :: a,g
integer, dimension (:), allocatable :: mm,iy
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(iy(1:ni),stat=jerr)
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(g(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(iy(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
alm=0.0
iy=0
- alf=1.0
if(flmin .ge. 1.0)goto 11811
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -1152,7 +1117,6 @@
continue
continue
do 11831 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
alm0=alm
if(flmin .lt. 1.0)goto 11851
alm=ulam(m)
@@ -1170,7 +1134,7 @@
if(vp(j).gt.0.0) alm0=max(alm0,g(j)/vp(j))
continue
continue
- alm0=alm0/max(bta,1.0d-3)
+ alm0=alm0/max(bta,1.0e-3)
alm=alf*alm0
continue
continue
@@ -1298,8 +1262,7 @@
return
end
subroutine spchkvars(no,ni,x,ix,ju)
- implicit double precision(a-h,o-z)
- double precision x(*)
+ real x(*)
integer ix(*),ju(ni)
do 12091 j=1,ni
ju(j)=0
@@ -1330,8 +1293,7 @@
return
end
subroutine cmodval(a0,ca,ia,nin,x,ix,jx,n,f)
- implicit double precision(a-h,o-z)
- double precision ca(*),x(*),f(n)
+ real ca(*),x(*),f(n)
integer ia(*),ix(*),jx(*)
f=a0
do 12151 j=1,nin
@@ -1344,16 +1306,14 @@
return
end
function row_prod(i,j,ia,ja,ra,w)
- implicit double precision(a-h,o-z)
integer ia(*),ja(*)
- double precision ra(*),w(*)
+ real ra(*),w(*)
row_prod=dot(ra(ia(i)),ra(ia(j)),ja(ia(i)),ja(ia(j)), ia(i+1)-ia(
*i),ia(j+1)-ia(j),w)
return
end
function dot(x,y,mx,my,nx,ny,w)
- implicit double precision(a-h,o-z)
- double precision x(*),y(*),w(*)
+ real x(*),y(*),w(*)
integer mx(*),my(*)
i=1
j=i
@@ -1387,44 +1347,41 @@
dot=s
return
end
- subroutine lognet(parm,no,ni,nc,x,y,g,jd,vp,cl,ne,nx,nlam,flmin,ul
-*am,thr, isd,intr,maxit,kopt,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp,jer
-*r)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no,max(2,nc)),g(no,nc),vp(ni),ulam(nla
-*m)
- double precision ca(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl
-*(2,ni)
+ subroutine lognet (parm,no,ni,nc,x,y,g,jd,vp,cl,ne,nx,nlam,flmin,u
+*lam,thr, isd,intr,maxit,kopt,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp,je
+*rr)
+ real x(no,ni),y(no,max(2,nc)),g(no,nc),vp(ni),ulam(nlam)
+ real ca(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,ww,vq,xv
+ real, dimension (:), allocatable :: xm,xs,ww,vq,xv
integer, dimension (:), allocatable :: ju
if(maxval(vp) .gt. 0.0)goto 12221
jerr=10000
return
continue
allocate(ww(1:no),stat=jerr)
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vq(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(kopt .ne. 2)goto 12241
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ continue
+ if(isd .le. 0)goto 12261
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ continue
if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vq(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- if(kopt .ne. 2)goto 12241
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- continue
- if(isd .le. 0)goto 12261
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- continue
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
if(maxval(ju) .gt. 0)goto 12281
jerr=7777
return
continue
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
do 12291 i=1,no
ww(i)=sum(y(i,:))
@@ -1495,9 +1452,8 @@
if(kopt.eq.2) deallocate(xv)
return
end
- subroutine lstandard1(no,ni,x,w,ju,isd,intr,xm,xs)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),w(no),xm(ni),xs(ni)
+ subroutine lstandard1 (no,ni,x,w,ju,isd,intr,xm,xs)
+ real x(no,ni),w(no),xm(ni),xs(ni)
integer ju(ni)
if(intr .ne. 0)goto 12521
do 12531 j=1,ni
@@ -1524,9 +1480,8 @@
continue
return
end
- subroutine multlstandard1(no,ni,x,w,ju,isd,intr,xm,xs,xv)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),w(no),xm(ni),xs(ni),xv(ni)
+ subroutine multlstandard1 (no,ni,x,w,ju,isd,intr,xm,xs,xv)
+ real x(no,ni),w(no),xm(ni),xs(ni),xv(ni)
integer ju(ni)
if(intr .ne. 0)goto 12601
do 12611 j=1,ni
@@ -1561,31 +1516,29 @@
subroutine lognet2n(parm,no,ni,x,y,g,w,ju,vp,cl,ne,nx,nlam,flmin,u
*lam,shri, isd,intr,maxit,kopt,lmu,a0,a,m,kin,dev0,dev,alm,nlp,jer
*r)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2
-*,ni)
- double precision a(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
+ real x(no,ni),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real a(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
integer ju(ni),m(nx),kin(nlam)
- double precision, dimension (:), allocatable :: b,bs,v,r,xv,q,ga
+ real, dimension (:), allocatable :: b,bs,v,r,xv,q,ga
integer, dimension (:), allocatable :: mm,ixx
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
allocate(b(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(r(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no),stat=jerr)
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(bs(0:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(r(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(q(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
fmax=log(1.0/pmin-1.0)
fmin=-fmax
@@ -1646,7 +1599,6 @@
if(y(i).lt.1.0) dev0=dev0+w(i)*(1.0-y(i))*log(1.0-y(i))
continue
continue
- alf=1.0
if(flmin .ge. 1.0)goto 12841
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -1665,7 +1617,6 @@
continue
continue
do 12861 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 12881
al=ulam(ilm)
@@ -1683,7 +1634,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -1863,8 +1814,7 @@
return
end
function dev2(n,w,y,p,pmin)
- implicit double precision(a-h,o-z)
- double precision w(n),y(n),p(n)
+ real w(n),y(n),p(n)
pmax=1.0-pmin
s=0.0
do 13341 i=1,n
@@ -1876,16 +1826,14 @@
return
end
function azero(n,y,g,q,jerr)
- implicit double precision(a-h,o-z)
- parameter(eps=1.0d-7)
- double precision y(n),g(n),q(n)
- double precision, dimension (:), allocatable :: e,p,w
- azero = 0.0
+ parameter(eps=1.0e-7)
+ real y(n),g(n),q(n)
+ real, dimension (:), allocatable :: e,p,w
allocate(e(1:n),stat=jerr)
- if(jerr.ne.0) return
- allocate(p(1:n),stat=jerr)
- if(jerr.ne.0) return
- allocate(w(1:n),stat=jerr)
+ allocate(p(1:n),stat=ierr)
+ jerr=jerr+ierr
+ allocate(w(1:n),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
az=0.0
e=exp(-g)
@@ -1908,44 +1856,38 @@
subroutine lognetn(parm,no,ni,nc,x,y,g,w,ju,vp,cl,ne,nx,nlam,flmin
*,ulam,shri, isd,intr,maxit,kopt,lmu,a0,a,m,kin,dev0,dev,alm,nlp,j
*err)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam
-*)
- double precision a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(
-*2,ni)
+ real x(no,ni),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam)
+ real a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ju(ni),m(nx),kin(nlam)
- double precision, dimension (:,:), allocatable :: q
- double precision, dimension (:), allocatable :: sxp,sxpl
- double precision, dimension (:), allocatable :: di,v,r,ga
- double precision, dimension (:,:), allocatable :: b,bs,xv
+ real, dimension (:,:), allocatable :: q
+ real, dimension (:), allocatable :: sxp,sxpl
+ real, dimension (:), allocatable :: di,v,r,ga
+ real, dimension (:,:), allocatable :: b,bs,xv
integer, dimension (:), allocatable :: mm,is,ixx
allocate(b(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ allocate(xv(1:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(bs(0:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(q(1:no,1:nc),stat=ierr); jerr=jerr+ierr
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
exmn=-exmx
- allocate(r(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(is(1:max(nc,ni)),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxpl(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(di(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
+ allocate(r(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(is(1:max(nc,ni)),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxpl(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(di(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
pmax=1.0-pmin
emin=pmin/pmax
@@ -2040,7 +1982,6 @@
continue
continue
continue
- alf=1.0
if(flmin .ge. 1.0)goto 13631
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -2062,7 +2003,6 @@
continue
continue
do 13661 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 13681
al=ulam(ilm)
@@ -2080,7 +2020,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -2329,14 +2269,13 @@
return
end
subroutine kazero(kk,n,y,g,q,az,jerr)
- implicit double precision(a-h,o-z)
- parameter(eps=1.0d-7)
- double precision y(n,kk),g(n,kk),q(n),az(kk)
- double precision, dimension (:), allocatable :: s
- double precision, dimension (:,:), allocatable :: e
+ parameter(eps=1.0e-7)
+ real y(n,kk),g(n,kk),q(n),az(kk)
+ real, dimension (:), allocatable :: s
+ real, dimension (:,:), allocatable :: e
allocate(e(1:n,1:kk),stat=jerr)
- if(jerr.ne.0) return
- allocate(s(1:n),stat=jerr)
+ allocate(s(1:n),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
az=0.0
e=exp(g)
@@ -2376,8 +2315,7 @@
return
end
function elc(parm,n,cl,a,m)
- implicit double precision(a-h,o-z)
- double precision a(n),cl(2)
+ real a(n),cl(2)
integer m(n)
fn=n
am=sum(a)/fn
@@ -2456,8 +2394,7 @@
return
end
function nintot(ni,nx,nc,a,m,nin,is)
- implicit double precision(a-h,o-z)
- double precision a(nx,nc)
+ real a(nx,nc)
integer m(nx),is(ni)
is=0
nintot=0
@@ -2475,8 +2412,7 @@
return
end
subroutine luncomp(ni,nx,nc,ca,ia,nin,a)
- implicit double precision(a-h,o-z)
- double precision ca(nx,nc),a(ni,nc)
+ real ca(nx,nc),a(ni,nc)
integer ia(nx)
a=0.0
do 14581 ic=1,nc
@@ -2486,8 +2422,7 @@
return
end
subroutine lmodval(nt,x,nc,nx,a0,ca,ia,nin,ans)
- implicit double precision(a-h,o-z)
- double precision a0(nc),ca(nx,nc),x(nt,*),ans(nc,nt)
+ real a0(nc),ca(nx,nc),x(nt,*),ans(nc,nt)
integer ia(nx)
do 14591 i=1,nt
do 14601 ic=1,nc
@@ -2500,41 +2435,39 @@
continue
return
end
- subroutine splognet(parm,no,ni,nc,x,ix,jx,y,g,jd,vp,cl,ne,nx,nlam,
-*flmin, ulam,thr,isd,intr,maxit,kopt,lmu,a0,ca,ia,nin,dev0,dev,alm
-*,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no,max(2,nc)),g(no,nc),vp(ni),ulam(nlam)
- double precision ca(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl
-*(2,ni)
+ subroutine splognet (parm,no,ni,nc,x,ix,jx,y,g,jd,vp,cl,ne,nx,nlam
+*,flmin, ulam,thr,isd,intr,maxit,kopt,lmu,a0,ca,ia,nin,dev0,dev,al
+*m,nlp,jerr)
+ real x(*),y(no,max(2,nc)),g(no,nc),vp(ni),ulam(nlam)
+ real ca(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,ww,vq,xv
+ real, dimension (:), allocatable :: xm,xs,ww,vq,xv
integer, dimension (:), allocatable :: ju
if(maxval(vp) .gt. 0.0)goto 14621
jerr=10000
return
continue
allocate(ww(1:no),stat=jerr)
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vq(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(kopt .ne. 2)goto 14641
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ continue
if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vq(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- if(kopt .ne. 2)goto 14641
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- continue
call spchkvars(no,ni,x,ix,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
if(maxval(ju) .gt. 0)goto 14661
jerr=7777
return
continue
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
do 14671 i=1,no
ww(i)=sum(y(i,:))
@@ -2607,8 +2540,7 @@
return
end
subroutine multsplstandard2(no,ni,x,ix,jx,w,ju,isd,intr,xm,xs,xv)
- implicit double precision(a-h,o-z)
- double precision x(*),w(no),xm(ni),xs(ni),xv(ni)
+ real x(*),w(no),xm(ni),xs(ni),xv(ni)
integer ix(*),jx(*),ju(ni)
if(intr .ne. 0)goto 14901
do 14911 j=1,ni
@@ -2647,8 +2579,7 @@
return
end
subroutine splstandard2(no,ni,x,ix,jx,w,ju,isd,intr,xm,xs)
- implicit double precision(a-h,o-z)
- double precision x(*),w(no),xm(ni),xs(ni)
+ real x(*),w(no),xm(ni),xs(ni)
integer ix(*),jx(*),ju(ni)
if(intr .ne. 0)goto 14991
do 15001 j=1,ni
@@ -2681,39 +2612,37 @@
if(isd.eq.0) xs=1.0
return
end
- subroutine sprlognet2n(parm,no,ni,x,ix,jx,y,g,w,ju,vp,cl,ne,nx,nla
-*m, flmin,ulam,shri,isd,intr,maxit,kopt,xb,xs, lmu,a0,a,m,kin,dev
-*0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision a(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
- double precision xb(ni),xs(ni)
+ subroutine sprlognet2n (parm,no,ni,x,ix,jx,y,g,w,ju,vp,cl,ne,nx,nl
+*am, flmin,ulam,shri,isd,intr,maxit,kopt,xb,xs, lmu,a0,a,m,kin,de
+*v0,dev,alm,nlp,jerr)
+ real x(*),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real a(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
+ real xb(ni),xs(ni)
integer ix(*),jx(*),ju(ni),m(nx),kin(nlam)
- double precision, dimension (:), allocatable :: xm,b,bs,v,r
- double precision, dimension (:), allocatable :: sc,xv,q,ga
+ real, dimension (:), allocatable :: xm,b,bs,v,r,sc,xv,q,ga
integer, dimension (:), allocatable :: mm,ixx
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
allocate(b(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(r(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sc(1:no),stat=jerr)
+ allocate(xm(0:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(bs(0:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(q(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(r(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sc(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
fmax=log(1.0/pmin-1.0)
fmin=-fmax
@@ -2776,7 +2705,6 @@
if(y(i).lt.1.0) dev0=dev0+w(i)*(1.0-y(i))*log(1.0-y(i))
continue
continue
- alf=1.0
if(flmin .ge. 1.0)goto 15221
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -2804,7 +2732,6 @@
continue
continue
do 15241 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 15261
al=ulam(ilm)
@@ -2822,7 +2749,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -3046,46 +2973,40 @@
subroutine sprlognetn(parm,no,ni,nc,x,ix,jx,y,g,w,ju,vp,cl,ne,nx,n
*lam,flmin, ulam,shri,isd,intr,maxit,kopt,xb,xs,lmu,a0,a,m,kin,dev
*0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam),xb
-*(ni),xs(ni)
- double precision a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(
-*2,ni)
+ real x(*),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam),xb(ni),xs(ni)
+ real a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ix(*),jx(*),ju(ni),m(nx),kin(nlam)
- double precision, dimension (:,:), allocatable :: q
- double precision, dimension (:), allocatable :: sxp,sxpl
- double precision, dimension (:), allocatable :: sc,xm,v,r,ga
- double precision, dimension (:,:), allocatable :: b,bs,xv
+ real, dimension (:,:), allocatable :: q
+ real, dimension (:), allocatable :: sxp,sxpl
+ real, dimension (:), allocatable :: sc,xm,v,r,ga
+ real, dimension (:,:), allocatable :: b,bs,xv
integer, dimension (:), allocatable :: mm,is,iy
allocate(b(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ allocate(xv(1:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(bs(0:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(q(1:no,1:nc),stat=ierr); jerr=jerr+ierr
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
exmn=-exmx
- allocate(xm(0:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(r(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(iy(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(is(1:max(nc,ni)),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxpl(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sc(1:no),stat=jerr)
+ allocate(xm(0:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(r(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(iy(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(is(1:max(nc,ni)),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxpl(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sc(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
pmax=1.0-pmin
emin=pmin/pmax
@@ -3180,7 +3101,6 @@
continue
continue
continue
- alf=1.0
if(flmin .ge. 1.0)goto 15991
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -3212,7 +3132,6 @@
continue
continue
do 16021 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 16041
al=ulam(ilm)
@@ -3230,7 +3149,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -3521,8 +3440,7 @@
return
end
subroutine lcmodval(nc,nx,a0,ca,ia,nin,x,ix,jx,n,f)
- implicit double precision(a-h,o-z)
- double precision a0(nc),ca(nx,nc),x(*),f(nc,n)
+ real a0(nc),ca(nx,nc),x(*),f(nc,n)
integer ia(*),ix(*),jx(*)
do 16661 ic=1,nc
f(ic,:)=a0(ic)
@@ -3540,38 +3458,36 @@
continue
return
end
- subroutine coxnet(parm,no,ni,x,y,d,g,w,jd,vp,cl,ne,nx,nlam,flmin,u
-*lam,thr, maxit,isd,lmu,ca,ia,nin,dev0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),d(no),g(no),w(no),vp(ni),ulam(nlam
-*)
- double precision ca(nx,nlam),dev(nlam),alm(nlam),cl(2,ni)
+ subroutine coxnet (parm,no,ni,x,y,d,g,w,jd,vp,cl,ne,nx,nlam,flmin,
+*ulam,thr, maxit,isd,lmu,ca,ia,nin,dev0,dev,alm,nlp,jerr)
+ real x(no,ni),y(no),d(no),g(no),w(no),vp(ni),ulam(nlam)
+ real ca(nx,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xs,ww,vq
+ real, dimension (:), allocatable :: xs,ww,vq
integer, dimension (:), allocatable :: ju
if(maxval(vp) .gt. 0.0)goto 16701
jerr=10000
return
continue
allocate(ww(1:no),stat=jerr)
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vq(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(isd .le. 0)goto 16721
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ continue
if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vq(1:ni),stat=jerr)
- if(jerr.ne.0) return
- if(isd .le. 0)goto 16721
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- continue
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
if(maxval(ju) .gt. 0)goto 16741
jerr=7777
return
continue
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
- ww=max(0d0,w)
+ ww=max(0.0,w)
sw=sum(ww)
if(sw .gt. 0.0)goto 16761
jerr=9999
@@ -3600,9 +3516,8 @@
if(isd.gt.0) deallocate(xs)
return
end
- subroutine cstandard(no,ni,x,w,ju,isd,xs)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),w(no),xs(ni)
+ subroutine cstandard (no,ni,x,w,ju,isd,xs)
+ real x(no,ni),w(no),xs(ni)
integer ju(ni)
do 16831 j=1,ni
if(ju(j).eq.0)goto 16831
@@ -3618,51 +3533,47 @@
end
subroutine coxnet1(parm,no,ni,x,y,d,g,q,ju,vp,cl,ne,nx,nlam,flmin,
*ulam,cthri, isd,maxit,lmu,ao,m,kin,dev0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),q(no),d(no),g(no),vp(ni),ulam(nlam
-*)
- double precision ao(nx,nlam),dev(nlam),alm(nlam),cl(2,ni)
+ real x(no,ni),y(no),q(no),d(no),g(no),vp(ni),ulam(nlam)
+ real ao(nx,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ju(ni),m(nx),kin(nlam)
- double precision, dimension (:), allocatable :: w,dk,v,xs,wr
- double precision, dimension (:), allocatable :: a,as,f,dq
- double precision, dimension (:), allocatable :: e,uu,ga
+ real, dimension (:), allocatable :: w,dk,v,xs,wr,a,as,f,dq
+ real, dimension (:), allocatable :: e,uu,ga
integer, dimension (:), allocatable :: jp,kp,mm,ixx
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
- isd = isd*1
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
sml=sml*100.0
devmax=devmax*0.99/0.999
allocate(e(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(uu(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(f(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(w(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(as(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(jp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(kp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(dk(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(wr(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(dq(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
+ allocate(uu(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(f(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(w(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(a(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(as(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(jp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(kp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(dk(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(wr(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(dq(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(jerr.ne.0)go to 12180
call groups(no,y,d,q,nk,kp,jp,t0,jerr)
if(jerr.ne.0) go to 12180
alpha=parm
@@ -3696,7 +3607,6 @@
continue
call outer(no,nk,dq,dk,kp,jp,e,wr,w,jerr,uu)
if(jerr.ne.0) go to 12180
- alf=1.0
if(flmin .ge. 1.0)goto 16931
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -3714,7 +3624,6 @@
continue
continue
do 16951 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 16971
al=ulam(ilm)
@@ -3732,7 +3641,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(parm,1.0d-3)
+ al0=al0/max(parm,1.0e-3)
al=alf*al0
continue
continue
@@ -3877,8 +3786,7 @@
return
end
subroutine cxmodval(ca,ia,nin,n,x,f)
- implicit double precision(a-h,o-z)
- double precision ca(nin),x(n,*),f(n)
+ real ca(nin),x(n,*),f(n)
integer ia(nin)
f=0.0
if(nin.le.0) return
@@ -3889,8 +3797,7 @@
return
end
subroutine groups(no,y,d,q,nk,kp,jp,t0,jerr)
- implicit double precision(a-h,o-z)
- double precision y(no),d(no),q(no)
+ real y(no),d(no),q(no)
integer jp(no),kp(*)
do 17361 j=1,no
jp(j)=j
@@ -3963,9 +3870,8 @@
return
end
subroutine outer(no,nk,d,dk,kp,jp,e,wr,w,jerr,u)
- implicit double precision(a-h,o-z)
- double precision d(no),dk(nk),wr(no),w(no)
- double precision e(no),u(no),b,c
+ real d(no),dk(nk),wr(no),w(no)
+ real e(no),u(no),b,c
integer kp(nk),jp(no)
call usk(no,nk,kp,jp,e,u)
b=dk(1)/u(1)
@@ -4001,8 +3907,7 @@
return
end
subroutine vars(no,ni,x,w,ixx,v)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),w(no),v(ni)
+ real x(no,ni),w(no),v(ni)
integer ixx(ni)
do 17601 j=1,ni
if(ixx(j).gt.0) v(j)=dot_product(w,x(:,j)**2)
@@ -4011,8 +3916,7 @@
return
end
subroutine died(no,nk,d,kp,jp,dk)
- implicit double precision(a-h,o-z)
- double precision d(no),dk(nk)
+ real d(no),dk(nk)
integer kp(nk),jp(no)
dk(1)=sum(d(jp(1:kp(1))))
do 17611 k=2,nk
@@ -4022,8 +3926,7 @@
return
end
subroutine usk(no,nk,kp,jp,e,u)
- implicit double precision(a-h,o-z)
- double precision e(no),u(nk),h
+ real e(no),u(nk),h
integer kp(nk),jp(no)
h=0.0
do 17621 k=nk,1,-1
@@ -4040,42 +3943,38 @@
return
end
function risk(no,ni,nk,d,dk,f,e,kp,jp,u)
- implicit double precision(a-h,o-z)
- double precision d(no),dk(nk),f(no)
+ real d(no),dk(nk),f(no)
integer kp(nk),jp(no)
- double precision e(no),u(nk)
- ni = ni*1
+ real e(no),u(nk),s
call usk(no,nk,kp,jp,e,u)
u=log(u)
risk=dot_product(d,f)-dot_product(dk,u)
return
end
subroutine loglike(no,ni,x,y,d,g,w,nlam,a,flog,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),d(no),g(no),w(no),a(ni,nlam),flog(
-*nlam)
- double precision, dimension (:), allocatable :: dk,f,xm,dq,q
- double precision, dimension (:), allocatable :: e,uu
+ real x(no,ni),y(no),d(no),g(no),w(no),a(ni,nlam),flog(nlam)
+ real, dimension (:), allocatable :: dk,f,xm,dq,q
+ real, dimension (:), allocatable :: e,uu
integer, dimension (:), allocatable :: jp,kp
allocate(e(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(uu(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(f(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(dk(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(jp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(kp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(dq(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- q=max(0d0,w)
+ allocate(q(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(uu(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(f(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(dk(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(jp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(kp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(dq(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(jerr.ne.0) go to 12180
+ q=max(0.0,w)
sw=sum(q)
if(sw .gt. 0.0)goto 17651
jerr=9999
@@ -4104,13 +4003,12 @@
deallocate(e,uu,dk,f,jp,kp,dq)
return
end
- subroutine fishnet(parm,no,ni,x,y,g,w,jd,vp,cl,ne,nx,nlam,flmin,ul
-*am,thr, isd,intr,maxit,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),g(no),w(no),vp(ni),ulam(nlam)
- double precision ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
+ subroutine fishnet (parm,no,ni,x,y,g,w,jd,vp,cl,ne,nx,nlam,flmin,u
+*lam,thr, isd,intr,maxit,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp,jerr)
+ real x(no,ni),y(no),g(no),w(no),vp(ni),ulam(nlam)
+ real ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,ww,vq
+ real, dimension (:), allocatable :: xm,xs,ww,vq
integer, dimension (:), allocatable :: ju
if(maxval(vp) .gt. 0.0)goto 17701
jerr=10000
@@ -4121,26 +4019,26 @@
return
continue
allocate(ww(1:no),stat=jerr)
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vq(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ if(isd .le. 0)goto 17741
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ continue
if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vq(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- if(isd .le. 0)goto 17741
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- continue
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
if(maxval(ju) .gt. 0)goto 17761
jerr=7777
go to 12180
continue
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
- ww=max(0d0,w)
+ ww=max(0.0,w)
sw=sum(ww)
if(sw .gt. 0.0)goto 17781
jerr=9999
@@ -4177,34 +4075,32 @@
end
subroutine fishnet1(parm,no,ni,x,y,g,q,ju,vp,cl,ne,nx,nlam,flmin,u
*lam,shri, isd,intr,maxit,lmu,a0,ca,m,kin,dev0,dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),g(no),q(no),vp(ni),ulam(nlam)
- double precision ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
+ real x(no,ni),y(no),g(no),q(no),vp(ni),ulam(nlam)
+ real ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ju(ni),m(nx),kin(nlam)
- double precision, dimension (:), allocatable :: t,w,wr,v,a,f,as,ga
+ real, dimension (:), allocatable :: t,w,wr,v,a,f,as,ga
integer, dimension (:), allocatable :: mm,ixx
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
sml=sml*10.0
- isd = isd*1
allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(as(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(t(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(wr(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(w(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(f(1:no),stat=jerr)
+ allocate(as(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(t(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(wr(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(w(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(f(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=parm
omb=1.0-bta
@@ -4256,7 +4152,6 @@
continue
dvr=dvr-dv0
dev0=dvr
- alf=1.0
if(flmin .ge. 1.0)goto 17971
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -4275,7 +4170,6 @@
continue
continue
do 17991 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 18011
al=ulam(ilm)
@@ -4293,7 +4187,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -4454,8 +4348,7 @@
return
end
function nonzero(n,v)
- implicit double precision(a-h,o-z)
- double precision v(n)
+ real v(n)
nonzero=0
do 18401 i=1,n
if(v(i) .eq. 0.0)goto 18421
@@ -4467,8 +4360,7 @@
return
end
subroutine solns(ni,nx,lmu,a,ia,nin,b)
- implicit double precision(a-h,o-z)
- double precision a(nx,lmu),b(ni,lmu)
+ real a(nx,lmu),b(ni,lmu)
integer ia(nx),nin(lmu)
do 18431 lam=1,lmu
call uncomp(ni,a(:,lam),ia,nin(lam),b(:,lam))
@@ -4477,8 +4369,7 @@
return
end
subroutine lsolns(ni,nx,nc,lmu,a,ia,nin,b)
- implicit double precision(a-h,o-z)
- double precision a(nx,nc,lmu),b(ni,nc,lmu)
+ real a(nx,nc,lmu),b(ni,nc,lmu)
integer ia(nx),nin(lmu)
do 18441 lam=1,lmu
call luncomp(ni,nx,nc,a(1,1,lam),ia,nin(lam),b(1,1,lam))
@@ -4487,17 +4378,15 @@
return
end
subroutine deviance(no,ni,x,y,g,q,nlam,a0,a,flog,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no),g(no),q(no),a(ni,nlam),a0(nlam),fl
-*og(nlam)
- double precision, dimension (:), allocatable :: w
+ real x(no,ni),y(no),g(no),q(no),a(ni,nlam),a0(nlam),flog(nlam)
+ real, dimension (:), allocatable :: w
if(minval(y) .ge. 0.0)goto 18461
jerr=8888
return
continue
allocate(w(1:no),stat=jerr)
if(jerr.ne.0) return
- w=max(0d0,q)
+ w=max(0.0,q)
sw=sum(w)
if(sw .gt. 0.0)goto 18481
jerr=9999
@@ -4520,14 +4409,13 @@
deallocate(w)
return
end
- subroutine spfishnet(parm,no,ni,x,ix,jx,y,g,w,jd,vp,cl,ne,nx,nlam,
-*flmin, ulam,thr,isd,intr,maxit,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp,
-*jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
+ subroutine spfishnet (parm,no,ni,x,ix,jx,y,g,w,jd,vp,cl,ne,nx,nlam
+*,flmin, ulam,thr,isd,intr,maxit,lmu,a0,ca,ia,nin,dev0,dev,alm,nlp
+*,jerr)
+ real x(*),y(no),g(no),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,ww,vq
+ real, dimension (:), allocatable :: xm,xs,ww,vq
integer, dimension (:), allocatable :: ju
if(maxval(vp) .gt. 0.0)goto 18521
jerr=10000
@@ -4538,14 +4426,14 @@
return
continue
allocate(ww(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(vq(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(vq(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call spchkvars(no,ni,x,ix,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -4553,9 +4441,9 @@
jerr=7777
go to 12180
continue
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
- ww=max(0d0,w)
+ ww=max(0.0,w)
sw=sum(ww)
if(sw .gt. 0.0)goto 18581
jerr=9999
@@ -4593,38 +4481,34 @@
subroutine spfishnet1(parm,no,ni,x,ix,jx,y,g,q,ju,vp,cl,ne,nx,nlam
*,flmin,ulam, shri,isd,intr,maxit,xb,xs,lmu,a0,ca,m,kin,dev0,dev,a
*lm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),g(no),q(no),vp(ni),ulam(nlam),xb(ni),x
-*s(ni)
- double precision ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
+ real x(*),y(no),g(no),q(no),vp(ni),ulam(nlam),xb(ni),xs(ni)
+ real ca(nx,nlam),a0(nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ix(*),jx(*),ju(ni),m(nx),kin(nlam)
- double precision, dimension (:), allocatable :: qy,t,w,wr,v
- double precision, dimension (:), allocatable :: a,as,xm,ga
+ real, dimension (:), allocatable :: qy,t,w,wr,v,a,as,xm,ga
integer, dimension (:), allocatable :: mm,ixx
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
sml=sml*10.0
- isd = isd*1
allocate(a(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(as(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(t(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(wr(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(v(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(w(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(qy(1:no),stat=jerr)
+ allocate(as(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(t(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(wr(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(v(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(w(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(qy(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=parm
omb=1.0-bta
@@ -4688,7 +4572,6 @@
continue
dvr=dvr-dv0
dev0=dvr
- alf=1.0
if(flmin .ge. 1.0)goto 18781
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -4710,7 +4593,6 @@
continue
continue
do 18801 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 18821
al=ulam(ilm)
@@ -4728,7 +4610,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -4910,20 +4792,18 @@
return
end
subroutine spdeviance(no,ni,x,ix,jx,y,g,q,nlam,a0,a,flog,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),g(no),q(no),a(ni,nlam),a0(nlam),flog(n
-*lam)
+ real x(*),y(no),g(no),q(no),a(ni,nlam),a0(nlam),flog(nlam)
integer ix(*),jx(*)
- double precision, dimension (:), allocatable :: w,f
+ real, dimension (:), allocatable :: w,f
if(minval(y) .ge. 0.0)goto 19221
jerr=8888
return
continue
allocate(w(1:no),stat=jerr)
+ allocate(f(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
- allocate(f(1:no),stat=jerr)
- if(jerr.ne.0) return
- w=max(0d0,q)
+ w=max(0.0,q)
sw=sum(w)
if(sw .gt. 0.0)goto 19241
jerr=9999
@@ -4951,20 +4831,18 @@
end
subroutine cspdeviance(no,x,ix,jx,y,g,q,nx,nlam,a0,ca,ia,nin,flog,
*jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no),g(no),q(no),ca(nx,nlam),a0(nlam),flog(
-*nlam)
+ real x(*),y(no),g(no),q(no),ca(nx,nlam),a0(nlam),flog(nlam)
integer ix(*),jx(*),nin(nlam),ia(nx)
- double precision, dimension (:), allocatable :: w,f
+ real, dimension (:), allocatable :: w,f
if(minval(y) .ge. 0.0)goto 19281
jerr=8888
return
continue
allocate(w(1:no),stat=jerr)
+ allocate(f(1:no),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
- allocate(f(1:no),stat=jerr)
- if(jerr.ne.0) return
- w=max(0d0,q)
+ w=max(0.0,q)
sw=sum(w)
if(sw .gt. 0.0)goto 19301
jerr=9999
@@ -4990,51 +4868,48 @@
deallocate(w,f)
return
end
- subroutine multelnet(parm,no,ni,nr,x,y,w,jd,vp,cl,ne,nx,nlam, flm
+ subroutine multelnet (parm,no,ni,nr,x,y,w,jd,vp,cl,ne,nx,nlam,flm
*in,ulam,thr,isd,jsd,intr,maxit, lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr
*)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no,nr),w(no),vp(ni),ca(nx,nr,nlam)
- double precision ulam(nlam),a0(nr,nlam),rsq(nlam),alm(nlam),cl(2,n
-*i)
+ real x(no,ni),y(no,nr),w(no),vp(ni),ca(nx,nr,nlam)
+ real ulam(nlam),a0(nr,nlam),rsq(nlam),alm(nlam),cl(2,ni)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: vq;
+ real, dimension (:), allocatable :: vq;
if(maxval(vp) .gt. 0.0)goto 19341
jerr=10000
return
continue
allocate(vq(1:ni),stat=jerr)
if(jerr.ne.0) return
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
call multelnetn(parm,no,ni,nr,x,y,w,jd,vq,cl,ne,nx,nlam,flmin,ulam
*,thr,isd, jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
deallocate(vq)
return
end
- subroutine multelnetn(parm,no,ni,nr,x,y,w,jd,vp,cl,ne,nx,nlam,flmi
-*n,ulam,thr, isd,jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision vp(ni),x(no,ni),y(no,nr),w(no),ulam(nlam),cl(2,ni
+ subroutine multelnetn (parm,no,ni,nr,x,y,w,jd,vp,cl,ne,nx,nlam,flm
+*in,ulam,thr, isd,jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jerr
*)
- double precision ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
+ real vp(ni),x(no,ni),y(no,nr),w(no),ulam(nlam),cl(2,ni)
+ real ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
integer jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,xv,ym,ys
+ real, dimension (:), allocatable :: xm,xs,xv,ym,ys
integer, dimension (:), allocatable :: ju
- double precision, dimension (:,:,:), allocatable :: clt
+ real, dimension (:,:,:), allocatable :: clt
allocate(clt(1:2,1:nr,1:ni),stat=jerr);
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ym(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(ys(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ym(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ys(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call chkvars(no,ni,x,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -5103,13 +4978,11 @@
deallocate(xm,xs,ym,ys,ju,xv,clt)
return
end
- subroutine multstandard1(no,ni,nr,x,y,w,isd,jsd,intr,ju, xm,xs,ym
+ subroutine multstandard1 (no,ni,nr,x,y,w,isd,jsd,intr,ju,xm,xs,ym
*,ys,xv,ys0,jerr)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no,nr),w(no),xm(ni),xs(ni),xv(ni),ym(n
-*r),ys(nr)
+ real x(no,ni),y(no,nr),w(no),xm(ni),xs(ni),xv(ni),ym(nr),ys(nr)
integer ju(ni)
- double precision, dimension (:), allocatable :: v
+ real, dimension (:), allocatable :: v
allocate(v(1:no),stat=jerr)
if(jerr.ne.0) return
w=w/sum(w)
@@ -5202,36 +5075,33 @@
end
subroutine multelnet2(beta,ni,nr,ju,vp,cl,y,no,ne,nx,x,nlam,flmin,
*ulam,thri, maxit,xv,ys0,lmu,ao,ia,kin,rsqo,almo,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision vp(ni),y(no,nr),x(no,ni),ulam(nlam),ao(nx,nr,nlam
-*)
- double precision rsqo(nlam),almo(nlam),xv(ni),cl(2,nr,ni)
+ real vp(ni),y(no,nr),x(no,ni),ulam(nlam),ao(nx,nr,nlam)
+ real rsqo(nlam),almo(nlam),xv(ni),cl(2,nr,ni)
integer ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: g,gk,del,gj
+ real, dimension (:), allocatable :: g,gk,del,gj
integer, dimension (:), allocatable :: mm,ix,isc
- double precision, dimension (:,:), allocatable :: a
+ real, dimension (:,:), allocatable :: a
allocate(a(1:nr,1:ni),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
- allocate(gj(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(gk(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(del(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ix(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(isc(1:nr),stat=jerr)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
+ allocate(gj(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(gk(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(del(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(g(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ix(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(isc(1:nr),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
ix=0
thr=thri*ys0/nr
- alf=1.0
if(flmin .ge. 1.0)goto 19791
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -5255,7 +5125,6 @@
continue
continue
do 19821 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
alm0=alm
if(flmin .lt. 1.0)goto 19841
alm=ulam(m)
@@ -5273,7 +5142,7 @@
if(vp(j).gt.0.0) alm0=max(alm0,g(j)/vp(j))
continue
continue
- alm0=alm0/max(bta,1.0d-3)
+ alm0=alm0/max(bta,1.0e-3)
alm=alf*alm0
continue
continue
@@ -5435,8 +5304,7 @@
return
end
subroutine chkbnds(nr,gk,gkn,xv,cl,al1,al2,a,isc,jerr)
- implicit double precision(a-h,o-z)
- double precision gk(nr),cl(2,nr),a(nr)
+ real gk(nr),cl(2,nr),a(nr)
integer isc(nr)
kerr=0
al1p=1.0+al1/xv
@@ -5445,8 +5313,6 @@
gsq=gkn**2
asq=dot_product(a,a)
usq=0.0
- u=0.0
- kn=-1
continue
continue
vmx=0.0
@@ -5466,7 +5332,7 @@
if(a(kn).gt.cl(2,kn)) u=cl(2,kn)
usq=usq+u**2
if(usq .ne. 0.0)goto 20271
- b=max(0d0,(g-al2p)/al1p)
+ b=max(0.0,(g-al2p)/al1p)
goto 20281
continue
b0=sqrt(asq-a(kn)**2)
@@ -5492,8 +5358,7 @@
return
end
subroutine chkbnds1(nr,gk,gkn,xv,cl1,cl2,al1,al2,a,isc,jerr)
- implicit double precision(a-h,o-z)
- double precision gk(nr),a(nr)
+ real gk(nr),a(nr)
integer isc(nr)
kerr=0
al1p=1.0+al1/xv
@@ -5502,8 +5367,6 @@
gsq=gkn**2
asq=dot_product(a,a)
usq=0.0
- u=0.0
- kn=-1
continue
continue
vmx=0.0
@@ -5523,7 +5386,7 @@
if(a(kn).gt.cl2) u=cl2
usq=usq+u**2
if(usq .ne. 0.0)goto 20371
- b=max(0d0,(g-al2p)/al1p)
+ b=max(0.0,(g-al2p)/al1p)
goto 20381
continue
b0=sqrt(asq-a(kn)**2)
@@ -5549,8 +5412,7 @@
return
end
function bnorm(b0,al1p,al2p,g,usq,jerr)
- implicit double precision(a-h,o-z)
- data thr,mxit /1.0d-10,100/
+ data thr,mxit /1.0e-10,100/
b=b0
zsq=b**2+usq
if(zsq .gt. 0.0)goto 20431
@@ -5580,19 +5442,16 @@
if(it.ge.mxit) jerr=90000
return
entry chg_bnorm(arg,irg)
- bnorm = 0.0
thr=arg
mxit=irg
return
entry get_bnorm(arg,irg)
- bnorm = 0.0
arg=thr
irg=mxit
return
end
subroutine multsolns(ni,nx,nr,lmu,a,ia,nin,b)
- implicit double precision(a-h,o-z)
- double precision a(nx,nr,lmu),b(ni,nr,lmu)
+ real a(nx,nr,lmu),b(ni,nr,lmu)
integer ia(nx),nin(lmu)
do 20491 lam=1,lmu
call multuncomp(ni,nr,nx,a(1,1,lam),ia,nin(lam),b(1,1,lam))
@@ -5601,8 +5460,7 @@
return
end
subroutine multuncomp(ni,nr,nx,ca,ia,nin,a)
- implicit double precision(a-h,o-z)
- double precision ca(nx,nr),a(ni,nr)
+ real ca(nx,nr),a(ni,nr)
integer ia(nx)
a=0.0
if(nin .le. 0)goto 20511
@@ -5614,8 +5472,7 @@
return
end
subroutine multmodval(nx,nr,a0,ca,ia,nin,n,x,f)
- implicit double precision(a-h,o-z)
- double precision a0(nr),ca(nx,nr),x(n,*),f(nr,n)
+ real a0(nr),ca(nx,nr),x(n,*),f(nr,n)
integer ia(nx)
do 20531 i=1,n
f(:,i)=a0
@@ -5631,21 +5488,20 @@
continue
return
end
- subroutine multspelnet(parm,no,ni,nr,x,ix,jx,y,w,jd,vp,cl,ne,nx,
+ subroutine multspelnet (parm,no,ni,nr,x,ix,jx,y,w,jd,vp,cl,ne,nx,
*nlam,flmin,ulam,thr,isd, jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,
*nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no,nr),w(no),vp(ni),ulam(nlam),cl(2,ni)
- double precision ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
+ real x(*),y(no,nr),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: vq;
+ real, dimension (:), allocatable :: vq;
if(maxval(vp) .gt. 0.0)goto 20571
jerr=10000
return
continue
allocate(vq(1:ni),stat=jerr)
if(jerr.ne.0) return
- vq=max(0d0,vp)
+ vq=max(0.0,vp)
vq=vq*ni/sum(vq)
call multspelnetn(parm,no,ni,nr,x,ix,jx,y,w,jd,vq,cl,ne,nx,nlam,fl
*min, ulam,thr,isd,jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,nlp,jer
@@ -5656,26 +5512,25 @@
subroutine multspelnetn(parm,no,ni,nr,x,ix,jx,y,w,jd,vp,cl,ne,nx,n
*lam,flmin, ulam,thr,isd,jsd,intr,maxit,lmu,a0,ca,ia,nin,rsq,alm,n
*lp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),vp(ni),y(no,nr),w(no),ulam(nlam),cl(2,ni)
- double precision ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
+ real x(*),vp(ni),y(no,nr),w(no),ulam(nlam),cl(2,ni)
+ real ca(nx,nr,nlam),a0(nr,nlam),rsq(nlam),alm(nlam)
integer ix(*),jx(*),jd(*),ia(nx),nin(nlam)
- double precision, dimension (:), allocatable :: xm,xs,xv,ym,ys
+ real, dimension (:), allocatable :: xm,xs,xv,ym,ys
integer, dimension (:), allocatable :: ju
- double precision, dimension (:,:,:), allocatable :: clt
+ real, dimension (:,:,:), allocatable :: clt
allocate(clt(1:2,1:nr,1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xs(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ym(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(ys(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(ju(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(xv(1:ni),stat=jerr)
+ allocate(xm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xs(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ym(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ys(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ju(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(xv(1:ni),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
call spchkvars(no,ni,x,ix,ju)
if(jd(1).gt.0) ju(jd(2:(jd(1)+1)))=0
@@ -5746,11 +5601,8 @@
end
subroutine multspstandard1(no,ni,nr,x,ix,jx,y,w,ju,isd,jsd,intr,
*xm,xs,ym,ys,xv,ys0,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no,nr),w(no),xm(ni),xs(ni),xv(ni),ym(nr),y
-*s(nr)
+ real x(*),y(no,nr),w(no),xm(ni),xs(ni),xv(ni),ym(nr),ys(nr)
integer ix(*),jx(*),ju(ni)
- jerr = jerr*1
w=w/sum(w)
if(intr .ne. 0)goto 20801
do 20811 j=1,ni
@@ -5834,39 +5686,36 @@
subroutine multspelnet2(beta,ni,nr,y,w,no,ne,nx,x,ix,jx,ju,vp,cl,n
*lam,flmin, ulam,thri,maxit,xm,xs,xv,ys0,lmu,ao,ia,kin,rsqo,almo,n
*lp,jerr)
- implicit double precision(a-h,o-z)
- double precision y(no,nr),w(no),x(*),vp(ni),ulam(nlam),cl(2,nr,ni)
- double precision ao(nx,nr,nlam),rsqo(nlam),almo(nlam),xm(ni),xs(ni
-*),xv(ni)
+ real y(no,nr),w(no),x(*),vp(ni),ulam(nlam),cl(2,nr,ni)
+ real ao(nx,nr,nlam),rsqo(nlam),almo(nlam),xm(ni),xs(ni),xv(ni)
integer ix(*),jx(*),ju(ni),ia(nx),kin(nlam)
- double precision, dimension (:), allocatable :: g,gj,gk,del,o
+ real, dimension (:), allocatable :: g,gj,gk,del,o
integer, dimension (:), allocatable :: mm,iy,isc
- double precision, dimension (:,:), allocatable :: a
+ real, dimension (:,:), allocatable :: a
allocate(a(1:nr,1:ni),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx,itrace)
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(g(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(gj(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(gk(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(del(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(o(1:nr),stat=jerr)
- if(jerr.ne.0) return
- allocate(iy(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(isc(1:nr),stat=jerr)
+ call get_int_parms(sml,eps,big,mnlam,rsqmax,pmin,exmx)
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(g(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(gj(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(gk(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(del(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(o(1:nr),stat=ierr)
+ jerr=jerr+ierr
+ allocate(iy(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(isc(1:nr),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
bta=beta
omb=1.0-bta
alm=0.0
iy=0
thr=thri*ys0/nr
- alf=1.0
if(flmin .ge. 1.0)goto 21011
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -5893,7 +5742,6 @@
continue
continue
do 21041 m=1,nlam
- if(itrace.ne.0) call setpb(m-1)
alm0=alm
if(flmin .lt. 1.0)goto 21061
alm=ulam(m)
@@ -5911,7 +5759,7 @@
if(vp(j).gt.0.0) alm0=max(alm0,g(j)/vp(j))
continue
continue
- alm0=alm0/max(bta,1.0d-3)
+ alm0=alm0/max(bta,1.0e-3)
alm=alf*alm0
continue
continue
@@ -6085,42 +5933,36 @@
subroutine multlognetn(parm,no,ni,nc,x,y,g,w,ju,vp,cl,ne,nx,nlam,f
*lmin,ulam, shri,intr,maxit,xv,lmu,a0,a,m,kin,dev0,dev,alm,nlp,jer
*r)
- implicit double precision(a-h,o-z)
- double precision x(no,ni),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam
-*),cl(2,ni)
- double precision a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),xv(
-*ni)
+ real x(no,ni),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam),cl(2,ni)
+ real a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),xv(ni)
integer ju(ni),m(nx),kin(nlam)
- double precision, dimension (:,:), allocatable :: q,r,b,bs
- double precision, dimension (:), allocatable :: sxp,sxpl,ga,gk,del
+ real, dimension (:,:), allocatable :: q,r,b,bs
+ real, dimension (:), allocatable :: sxp,sxpl,ga,gk,del
integer, dimension (:), allocatable :: mm,is,ixx,isc
allocate(b(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(r(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ allocate(bs(0:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(q(1:no,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(r(1:no,1:nc),stat=ierr); jerr=jerr+ierr;
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
exmn=-exmx
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(is(1:max(nc,ni)),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxpl(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ixx(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(gk(1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(del(1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(isc(1:nc),stat=jerr)
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(is(1:max(nc,ni)),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxpl(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ixx(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(gk(1:nc),stat=ierr)
+ jerr=jerr+ierr
+ allocate(del(1:nc),stat=ierr)
+ jerr=jerr+ierr
+ allocate(isc(1:nc),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
pmax=1.0-pmin
emin=pmin/pmax
@@ -6200,7 +6042,6 @@
continue
continue
dev0=dev0+dev1
- alf=1.0
if(flmin .ge. 1.0)goto 21651
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -6223,7 +6064,6 @@
continue
ga=sqrt(ga)
do 21681 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 21701
al=ulam(ilm)
@@ -6241,7 +6081,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -6482,47 +6322,41 @@
subroutine multsprlognetn(parm,no,ni,nc,x,ix,jx,y,g,w,ju,vp,cl,ne,
*nx,nlam, flmin,ulam,shri,intr,maxit,xv,xb,xs,lmu,a0,a,m,kin,dev0,
*dev,alm,nlp,jerr)
- implicit double precision(a-h,o-z)
- double precision x(*),y(no,nc),g(no,nc),w(no),vp(ni)
- double precision ulam(nlam),xb(ni),xs(ni),xv(ni)
- double precision a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(
-*2,ni)
+ real x(*),y(no,nc),g(no,nc),w(no),vp(ni),ulam(nlam),xb(ni),xs(ni),
+*xv(ni)
+ real a(nx,nc,nlam),a0(nc,nlam),dev(nlam),alm(nlam),cl(2,ni)
integer ix(*),jx(*),ju(ni),m(nx),kin(nlam)
- double precision, dimension (:,:), allocatable :: q,r,b,bs
- double precision, dimension (:), allocatable :: sxp,sxpl,ga,gk
- double precision, dimension (:), allocatable :: del,sc,svr
+ real, dimension (:,:), allocatable :: q,r,b,bs
+ real, dimension (:), allocatable :: sxp,sxpl,ga,gk,del,sc,svr
integer, dimension (:), allocatable :: mm,is,iy,isc
allocate(b(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(bs(0:ni,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(q(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(r(1:no,1:nc),stat=jerr)
- if(jerr.ne.0) return
- call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx,itrace)
+ allocate(bs(0:ni,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(q(1:no,1:nc),stat=ierr); jerr=jerr+ierr
+ allocate(r(1:no,1:nc),stat=ierr); jerr=jerr+ierr
+ call get_int_parms(sml,eps,big,mnlam,devmax,pmin,exmx)
exmn=-exmx
- allocate(mm(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(ga(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(gk(1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(del(1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(iy(1:ni),stat=jerr)
- if(jerr.ne.0) return
- allocate(is(1:max(nc,ni)),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxp(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(sxpl(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(svr(1:nc),stat=jerr)
- if(jerr.ne.0) return
- allocate(sc(1:no),stat=jerr)
- if(jerr.ne.0) return
- allocate(isc(1:nc),stat=jerr)
+ allocate(mm(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(ga(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(gk(1:nc),stat=ierr)
+ jerr=jerr+ierr
+ allocate(del(1:nc),stat=ierr)
+ jerr=jerr+ierr
+ allocate(iy(1:ni),stat=ierr)
+ jerr=jerr+ierr
+ allocate(is(1:max(nc,ni)),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxp(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sxpl(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(svr(1:nc),stat=ierr)
+ jerr=jerr+ierr
+ allocate(sc(1:no),stat=ierr)
+ jerr=jerr+ierr
+ allocate(isc(1:nc),stat=ierr)
+ jerr=jerr+ierr
if(jerr.ne.0) return
pmax=1.0-pmin
emin=pmin/pmax
@@ -6602,7 +6436,6 @@
continue
continue
dev0=dev0+dev1
- alf=1.0
if(flmin .ge. 1.0)goto 22491
eqs=max(eps,flmin)
alf=eqs**(1.0/(nlam-1))
@@ -6630,7 +6463,6 @@
continue
ga=sqrt(ga)
do 22521 ilm=1,nlam
- if(itrace.ne.0) call setpb(ilm-1)
al0=al
if(flmin .lt. 1.0)goto 22541
al=ulam(ilm)
@@ -6648,7 +6480,7 @@
if(vp(j).gt.0.0) al0=max(al0,ga(j)/vp(j))
continue
continue
- al0=al0/max(bta,1.0d-3)
+ al0=al0/max(bta,1.0e-3)
al=alf*al0
continue
continue
@@ -6901,8 +6733,7 @@
deallocate(sxp,b,bs,r,q,mm,is,sc,ga,iy,gk,del,sxpl)
return
end
- subroutine psort7(v,a,ii,jj)
- implicit double precision(a-h,o-z)
+ subroutine psort7 (v,a,ii,jj)
puts into a the permutation vector which sorts v into
increasing order. the array v is not modified.
only elements from ii to jj are considered.
@@ -6912,7 +6743,7 @@
dimension a(jj),v(jj),iu(20),il(20)
integer t,tt
integer a
- double precision v
+ real v
m=1
i=ii
j=jj
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment