Created
December 3, 2020 17:01
-
-
Save JackDunnNZ/b04d15fc48fb33db9cff248582c6bc46 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| --- /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