      Program RCSsigFree
c
c *** does the minimum and implements Tom Melvin's signal free method
c     and even more minimal RCS detrending
c
c Subroutine list
c      subroutine sigfree(x,y,f,ls,alpha,sfind,nc,crn1,crn2,crn3,nss,idate,ident,iopt,irob,
c     *       switch,reset,hpfilt,tol,mxy,mxs,itrdb,ybar,rxm,runr,nsg,filnam,fil1,rcs,pith)
c      subroutine curvefits(y,f,iyr,n,n1,id,iopt,alpha,mxy,mxs)
c      subroutine curve(n,n1,z,f,eq)		       !hakan
c      subroutine trend(n,n1,y,f,sl,yi)			!hakan
c      subroutine xmean(x,f,n,n1)
c      subroutine supsmu (n,x,y,w,iper,span,alpha,smo,sc)
c      subroutine smooth (n,x,y,w,span,iper,vsmlsq,smo,acvr)
c      subroutine spline(n,y,f,pp,ls)
c      subroutine spline1(n,y,f,ls)
c      subroutine spline2(n,y,f,ls)
c      subroutine robsum(x,n,nc,crnmn,crnsd,nss,iopt,mxy,mxs)
c      subroutine mnsd(x,n,xm,sd)
c      subroutine xbiwt (xdata,n,xlbiwt,xsbiwt,xlbiwt1,xsbiwt1)
c      subroutine xmad (xdata,n,xmed,xmadm)
c      subroutine mdian1 (x,n,xmed)
c      subroutine mfs(x,n,xmed,hh,hl,fsd,rmn,rmx)
c      subroutine qcksrt(n,arr)
c      subroutine cenbyseg(mnsl,x,nc,idate,ident,mxy,mxs)
c      subroutine cenbyify(mxsy,x,nc,idate,ident,mxy,mxs)
c      subroutine cenbycom(ifc,ilc,x,nc,idate,ident,mxy,mxs)
c      subroutine savcen(cproc,icen1,icen2,x,y,nc,idate,ident,itrdb,filnam,iu11,mxy,mxs)
c      subroutine arpad(x,n,y,np,ls,mxy)
c      subroutine memcof(data,n,m,pm,cof,wk1,wk2,wkm)
c      subroutine extend(y,n,ncast,arps,ip,iopt)
c      subroutine plot1(nmax,wrk,sp,ny,iy,xlab,ylab,tit,rline,annot1,annot2)
c      subroutine spaghetti(xy,ny,ns,ify,xlab,ylab,tit,annot1,annot2,mxy,mxs)
c      subroutine runbar(x,ybar,idate,nc,rxm,runr,ncnt,nsg,nlp,mxy,mxs,iu33)
c      subroutine rrbar(x,wrk1,idate,nc,ifskp,ilskp,nr,ave,sdev,see,nsg,mxy,mxs,maxlen)
c      subroutine pearsn(x,y,n,r,a,b)
c      subroutine intfrm(datum,frm)
c      subroutine stringclean(string,size)
c      subroutine trrw(id,iyr,n,y,nc,ifl,iu,iuo,q,tit,tag,mxy,itrdb)
c      subroutine datar(id,n,x,iyr,iu,mxy)
c      subroutine blank(l)
c      subroutine trread(x,y,nc,idate,ident,itrdb,iu10,mxy,mxs)
c RCS subroutines and calls
c      subroutine plt1(mxsl,rmax,mey,ycal,fycaly,lycaly,flag,string,mnpoff)
c	subroutine plt2(mxy,mxs,pltdata,nc,idate,flag)
c	subroutine plt3(mxy,mxs,indx,xrc,f,idate,flag,nmax,sernum,n,ident)
c	subroutine plt4(mxlen,maxit,rcscrv,nmax,rcnt)
c      subroutine rcurve(mxy,mxs,n,x,xrc,f,idate,pith,flag,mxage,eq,ndt)
c      subroutine pithy(mxs,iu,pith,poff,filnam)
c      subroutine detrend2(x,f,n1,n,eq,jdt,mxy,ndt,istrtls)			!Hakan
c      subroutine gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter,iopt,nemax,n1,ne,x,y,yfit,sumsq)	!Hakan
c      subroutine amoeba(p,y,mp,np,ndim,iter,ftol,iopt,
c      subroutine hughdi(x,y,n1,ntot,xy,coef,flag)		!Hakan
c      subroutine gexp(y,nt,n,f,wk1,wk2,coef,flag)		!Hakan
c      subroutine moment(data,n,ave,adev,sdev,var,skew,curt,sens,ac)
c      subroutine xmean2(x,n,xm)
c      subroutine lowess(mxd,y,ys,n,f)   ! added mxd to argument list
c      subroutine lowest(x,y,n,xs,ys,nleft,nright,w,userw,rw,ok)
c      subroutine msmoor(x,y,z,n,m,iter,ier,mxy)
c      subroutine msmoo(x,y,z,n,m,iter,ier,mxy)
c      subroutine sort(n,ra)
c      function gamoff(v,ndmax,nemax,ne,x,y,iopt)
c      function ametry(p,y,psum,mp,np,ndim,ihi,fac,iopt,nemax,ne,xe,ye)
c      function minimum(inarray,arraynum)
c	subroutine lsmake(nmax,n,strtls,ls2) makes an age dependent spline smoothing parameter arry
c	subroutine scatplt(mxy,mxs,x1,y1,slope,int,num,nc,n2,xtmp,rho,int2,slp) create a scatter plot of x vs y and thier ols solution
c	subroutine slpt(mxy,mxs,x,idate,nc) performs adaptive power transformation on matrix x alla cook and peters 1997, holocene
c	subroutine trend2(n,x,y,sl,yi) fits linear regression line to data pairs
*      subroutine ftfreq (x,ind,xind,xymv,acv,freq,ps,xcov,xspect,amphas,xfer,coher,ier)multichannel time series analysis in the time and frequency domains
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      integer mxy,mxs,mxl,iu9,iu10,iu11,iu12,iu69,iu70
      parameter(mxy=9000,mxs=3000,mxl=mxy/3+1)
      parameter(iu9=9,iu10=10,iu11=11,iu12=12,iu69=69,iu70=70)
      real*4 x(mxy,mxs),y(mxy),f(mxy),sfind(mxy,mxs),xsave(mxy,mxs)
      real*4 crn1(mxy,2),crn2(mxy,2),crn3(mxy,2),crnsall(mxy,101)
      real*4 ybar(mxy,3),rxm(mxy,7),runr(mxy,5),tol,curmin(mxs),wrk(mxy)
      integer iopt,irob,iter
      integer idate(mxs,3),nss(mxy),ls(mxy)
      character filnam*50,fil1*80,itrdb(3)*100,ident(mxs)*8,id*8
      character itrun,melvin,switch,reset,hpfilt,itol,cproc,cdat*10,frm*20
      character cook,cset,cmed,ccur,version*7
c new globasl decs pjk
ccc      real*4 xtmp(mxy,mxs)
      integer ndt,p,j,k,m
      integer pith(mxs)
      character ans*1
      logical poff,rcs,tryagain,fok,pt,ferr,itype
c btauto declarations	
      real*4 xm1,avar,rm
      real*4 y2(mxy*2)
      real*4 xind(2),xymv(6),acv(mxl*2),freq(mxl),ps(2*mxl)
      real*4 xcov(2*mxl),xspect(2*mxl),amphas(2*mxl),xfer(2*mxl)
      real*4 coher(mxl),fdist(30),chisq(30)
      real*4 btout(mxl,mxs*4+1),btout2(mxl,3)
      integer ind(6)
c
      data (fdist(i),i=1,30)/199.5,19.00,9.55,6.94,5.79,5.14,4.74,
     *      4.46,4.26,4.10,3.98,3.89,3.81,3.74,3.68,3.63,3.59,3.55,3.52,
     *      3.49,3.47,3.44,3.42,3.40,3.39,3.37,3.35,3.34,3.33,3.32/
      data (chisq(i),i=1,30)/3.84,5.99,7.81,9.49,11.07,12.59,14.07,
     *      15.51,16.92,18.31,19.68,21.03,22.36,23.68,25.00,26.30,
     *      27.59,28.87,30.14,31.41,32.67,33.92,35.17,36.42,37.65,
     *      38.89,40.11,41.34,42.56,43.77/
      data pi/3.1415926/

c Begin Program
      version='45_v2f'
      rcs=.false.;poff=.false.;tryagain=.false.;fok=.false.
c
c *** open data file to process
c
      write(*,'(/t17,''**********************************''/
     *           t17,''**********************************''/
     *           t17,''***                            ***''/
     *           t17,''***     Program  RCSigFree     ***''/
     *           t17,''***                            ***''/
     *           t17,''***       Creation Date:       ***''/
     *           t17,''***         08/14/2017         ***''/
     *           t17,''***                            ***''/
     *           t17,''***       Programmed by:       ***''/
     *           t17,''***  Edward R. Cook: TRL-LDEO  ***''/
     *           t17,''***  Paul J. Krusic: CAMBRIDGE ***''/
     *           t17,''***  Tom Melvin    :  CRU-UEA  ***''/
     *           t17,''***                            ***''/
     *           t17,''***     Max Series:  '',i4, ''      ***''/     
     *           t17,''***     Max Years :  '',i4, ''      ***''/     
     *           t17,''***                            ***''/
     *           t17,''********* Version '',a,''*********''/
     *           t17,''**********************************'')')mxs,mxy,version
c
      write(*,'(/1x,''*******************************************************************''/
     *           1x,''*** WARNING: THERE IS NO GAP FILLING CAPACITY IN THIS PROGRAM.  ***''/
     *           1X,''*** SO IF YOU HAVE GAPS INDICATED BY NEGATIVE VALUES (NO -9999) ***''/
     *           1X,''*** RUN THE DATA THROUGH ARSTAN FIRST AND USE THE SAVE SERIES   ***''/
     *           1X,''*** OPTION 18 AND THE TUCSON RWL FORMAT SAVE OPTION TO PROVIDE  ***''/
     *           1X,''*** THE GAP-FILLED DATA FOR USING IN THIS PROGRAM. CLEVER, HUH? ***''/
     *           1x,''*******************************************************************'')')
c
  112 call blank(filnam)
      write(*,'(/1x,''Enter data file name to process (/ to exit)'',t50,''==> '',$)')
      read(*,'(a)')filnam
      if(filnam(1:1).eq.'/')then
        stop
      elseif(filnam(1:2).eq.'  ')then
        write(*,'(/1x,''There was an error reading your entry.'')')
	       pause'Hit return to enter a new file name or / to exit program.'
        goto 112
      endif
      inquire(file=filnam,exist=fok)
      if(.not.fok)then
	       write(*,'(/1x,''File > '',a25,'' < not found'',/)')filnam
	       pause'Hit return to enter a new file name or / exit program.'
	       goto 112
      endif
c
c *** get unique character string for output files
c
      ll=len(filnam)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(filnam(jj:jj).ne.' ')goto 1
      enddo
    1 ll=jj
      do j=1,ll
        jj=j
        if(filnam(j:j).eq.'.')then
          jj=j-1
          goto 2
        endif
      enddo
    2 ll=jj
      call blank(fil1)
      write(fil1,*)filnam(1:ll),'_out_v',version,'.txt'
      call stringclean(fil1,80)
      open(iu9,file=fil1,status='unknown')
      write(iu9,'(/1x,''THE OFFICIAL SIGNAL FREE PROGRAM OUTPUT FILE'')')
      write(iu9,'(/1x,''DATA FILE TO PROCESS: ''a)')filnam      
      nocon=0
c    
  611 open(iu10,file=filnam,status='old') 
c
c *** first read in the data
c
      ncrns=0
      do i=1,mxy
        do j=1,mxs
          x(i,j)=-999.0
          sfind(i,j)=-999.0
        enddo
      enddo
c      
      call loaddat(mxy,mxs,x,idate,ident,iu10,nc,itrdb,ferr)
c
      ntneg=0
      write(*,'(/1x,''Regardless of the warning, test for missing data flags:'')')
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        nneg=0
        do i=1,n
          datum=x(i,j)
          if(datum.lt.0)then
            nneg=nneg+1
            ntneg=ntneg+1
          endif
        enddo
        if(nneg.gt.0)then
          write(*,'(1x,''Series '',a,'' has'',i4,'' missing (negative) values'')')ident(j),nneg
        endif
      enddo
      if(ntneg.gt.0)then
        write(*,'(/1x,''Missing (negative) values encountered: '',i9)')ntneg
        write(*,'(1x,''Run the data set through ARSTAN to fill the gaps and save the data.'')')
        goto 901
      else
        write(*,'(/1x,''No missing data flags (negative numbers) encountered. Proceed!'')')
      endif
c
      close(iu10)
      if(ferr)then
     	  write(*,'(/1x,''[T]ry again or [Q]uit the program now?'',t50,''==> '',$)')
    	  read(*,'(a)')ans
    	  if(ans.eq.'T'.or.ans.eq.'t')then
	        goto 112
    	  else
    	    write(*,'(/1x,''Program Terminating'')')
	        stop
    	  endif
    	 endif
c
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
      write(*,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(*,'(1x,''Total series read in:'',t30,4i6 )')nc,ifmny,ilmxy,maxn
      write(iu9,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(iu9,'(1x,''TOTAL SERIES READ IN:'',t30,4i6,
     *  ''  SERIES, FIRST YEAR, LAST YEAR, TOTAL YEARS'')')nc,ifmny,ilmxy,maxn
c
  612 itype=.false.; pt=.false.; ans=' '
      write(*,'(/1x,''Compute Indices by [R]atios or residual[S]'',t50,''==> '',$)')
      read(*,'(a1)',err=611)ans
      if((ans.eq.'R').or.(ans.eq.'r'))then
        itype=.false.
        write(iu9,'(/1x,''TREE-RING INDICES ARE CALCULATED AS RATIOS OF EXPECTED GROWTH'')')
      elseif((ans.eq.'S').or.(ans.eq.'s'))then
        write(iu9,'(/1x,''TREE-RING INDICES ARE CALCULATED AS RESIDUALS FROM EXPECTED GROWTH'')')
        itype=.true.
        write(*,'(/1x,''Power transform data? [T]rue or [F]alse'',t50,''==> '',$)')
        read(*,'(a)',err=612)ans
        if(ans.eq.'T'.or.ans.eq.'t')then
           pt=.true.
        else
           pt=.false.
        endif
      elseif(ans.eq.'/')then
	       write(*,'(/1x,''Program Terminating'')')
	       stop      
      else
        write(*,'(/1x,''Error reading input [R] or [S]. Try again or enter / to exit'')')
        goto 612
      endif
c
c *** now find the minimum, lower hinge, median, upper hinge, and maximum segment lengths
c
    3 do j=1,nc
        f(j)=idate(j,3)
      enddo
      call mfs(f,nc,xmedseg,hhseg,hlseg,fsdseg,rmnseg,rmxseg)
      mnseg=int(rmnseg)
      mlseg=int(hlseg)
      medseg=int(xmedseg)
      mhseg=int(hhseg)
      mxseg=int(rmxseg)
      nsegmin=0
      nseghl=0
      nsegmed=0
      nseghh=0
      nsegmax=0
      do j=1,nc
        nyrs=idate(j,3)
        if(nyrs.eq.mnseg)nsegmin=nsegmin+1
        if(nyrs.ge.mlseg)nseghl=nseghl+1
        if(nyrs.ge.medseg)nsegmed=nsegmed+1
        if(nyrs.ge.mhseg)nseghh=nseghh+1
        if(nyrs.eq.mxseg)nsegmax=nsegmax+1
      enddo
      write(*,'(/1x,''ORIGINAL DATA SET'',t30,''   MIN   25%   MED   75%   MAX'')')
      write(*,'(1x,''Segment length statistics:'',t30,5i6)')mnseg,mlseg,medseg,mhseg,mxseg
      write(*,'(1x,''Series .ge. segment length:'',t30,5i6)')nsegmin,nseghl,nsegmed,nseghh,nsegmax
      write(iu9,'(/1x,''ORIGINAL DATA SET'',t30,''   MIN   25%   MED   75%   MAX'')')
      write(iu9,'(1x,''SEGMENT LENGTH STATISTICS:'',t30,5i6)')mnseg,mlseg,medseg,mhseg,mxseg
      write(iu9,'(1x,''SERIES .GE. SEGMENT LENGTH:'',t30,5i6)')nsegmin,nseghl,nsegmed,nseghh,nsegmax
c
c *** process all the data or censor by segment length or starting year
c
    4 cproc=' '
      write(*,'(/1x,''Series processing options (/ to exit):''/
     *  1x,''All series processed as read in'',t45,''<1>''/
     *  1x,''Keep series with MINIMUM SEGMENT length'',t46,''2''/
     *  1x,''Keep series BEFORE a MAXIMUM start year'',t46,''3''/
     *  1x,''Keep series AFTER a MINIMUM start year'',t46,''4''/
     *  1x,''Truncate BEFORE a MINIMUM start year'',t46,''5''/
     *  1x,''Truncate AFTER a MAXIMUM end year'',t46,''6''/
     *  1x,''Keep series over a COMMON PERIOD only'',t46,''7'',t50,''==> '',$)')
      read(*,'(a)')cproc
      if(cproc.eq.'/')stop
      if(cproc.eq.' ')cproc='1'
c
c *** censor the data by chosen method and save it in Tucson raw ring width format
c
      if(cproc.ne.'1')then
        if(cproc.eq.'2')then
    5     mnsl=0
          write(*,'(/1x,''Enter the MINIMUM segment length'',t50,''==> '',$)')
          read(*,*,err=5)mnsl
          call cenbyseg(mnsl,x,nc,idate,ident,mxy,mxs)
          icen1=mnsl
          icen2=0
          write(iu9,'(/1x,''DATA ARE CENSORED BY MINIMUM SEGMENT LENGTH: '',i5)')mnsl
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1
          goto 81
        elseif(cproc.eq.'3')then
    6     mxsy=0
          write(*,'(/1x,''Enter the MAXIMUM starting year'',t50,''==> '',$)')
          read(*,*,err=6)mxsy
          mxsy1=mxsy
          call cenbyify(mxsy,x,nc,idate,ident,mxy,mxs)
          if(mxsy.eq.0)then
             write(*,'(/1x,''*** Warning: No series were found that start ON or BEFORE '',i5)')mxsy1
             write(*,'(1x,''    Try again or quit the program.'',/)')
             pause 'Hit Return to continue'
             goto 4
          endif
          icen1=mxsy
          icen2=0
          write(iu9,'(/1x,''DATA ARE CENSORED BY MAXIMUM START YEAR: '',i5)')mxsy
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1
          goto 81
        elseif(cproc.eq.'4')then
    7     mnsy=0
          write(*,'(/1x,''Enter the MINIMUM start year'',t50,''==> '',$)')
          read(*,*,err=7)mnsy
          mnsy1=mnsy
          call cenayify(mnsy,x,nc,idate,ident,mxy,mxs)
          if(mnsy.eq.0)then
             write(*,'(/1x,''*** Warning: No series were found that start ON or AFTER '',i5)')mnsy1
             write(*,'(1x,''    Try again or quit the program.'',/)')
             pause 'Hit Return to continue'
             goto 4
          endif
          icen1=mnsy
          icen2=0
          write(iu9,'(/1x,''DATA ARE CENSORED BY MINIMUM START YEAR: '',i5)')mnsy
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1
          goto 81
   71   elseif(cproc.eq.'5')then
          write(*,'(/1x,''Truncate series BEFORE a MINIMUM start year'',t50,''==> '',$)')
          read(*,*)mnsy
          maxn=idate(nc+1,3)
          ierr=0
          do j=1,nc
            ify=idate(j,1)
            ily=idate(j,2)
            n=idate(j,3)
            if(ify.lt.mnsy)then
              ify=mnsy
              idate(j,1)=ify
              idate(j,3)=ily-ify+1
              idate(nc+1,1)=ify
              ndif=mnsy-ify
              n1=n-ndif

              if(idate(j,3).lt.20)then
                ierr=ierr+1
                if(ierr.eq.1)then
                  write(*,'(/1x,''Series  '',a8,''  truncation before '',i4,'' only leaves '',i4,
     *              ''  values for analysis.'')')ident(j),mnsy,idate(j,3)
                else
                  write(*,'(1x,''Series  '',a8,''  truncation before '',i4,'' only leaves '',i4,
     *              ''  values for analysis.'')')ident(j),mnsy,idate(j,3)
                endif
              endif
              
              if(ierr.ge.1)then
                write(*,'(/1x,''Please evaluate your truncation choice and see if it is''/
     *            1x,''appropriate for your data. You might want to consider deleting''/
     *            1x,''these series from further analysis if you want to truncate.'')')
                stop' Review your truncation choice!'
              endif

              do i=1,n1
                x(i,j)=x(i+ndif,j)
              enddo
              do i=n1+1,maxn
                x(i,j)=-999.0
              enddo
            endif 
          enddo
          if(ierr.gt.0)then
            write(*,'(/)')
            pause'                          *** Okay, bailout! ***'
            stop
          endif    
          icen1=mnsy
          icen2=0
          write(iu9,'(/1x,''DATA ARE TRUNCATED BEFORE MINIMUM START YEAR: '',i5)')mnsy
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1  
          idate(nc+1,3)=maxn 
          goto 81       
   72   elseif(cproc.eq.'6')then
          write(*,'(/1x,''Truncate series AFTER a MAXIMUM end year'',t50,''==> '',$)')
          read(*,*)mxsy
          maxn=idate(nc+1,3)
          ierr=0
          do j=1,nc
            ify=idate(j,1)
            ily=idate(j,2)
            n=ily-ify+1
            if(ily.gt.mxsy)then
              ily=mxsy
              idate(j,2)=ily
              idate(j,3)=ily-ify+1
              idate(nc+1,2)=ily
              ndif=ily-mxsy
              n1=n-ndif

              if(idate(j,3).lt.20)then
                ierr=ierr+1
                if(ierr.eq.1)then
                  write(*,'(/1x,''Series  '',a8,''  truncation after '',i4,'' only leaves '',i4,
     *              ''  values for analysis.'')')ident(j),mxsy,idate(j,3)
                else
                  write(*,'(1x,''Series  '',a8,''  truncation after '',i4,'' only leaves '',i4,
     *              ''  values for analysis.'')')ident(j),mxsy,idate(j,3)
                endif
              endif
              
              if(ierr.ge.1)then
                write(*,'(/1x,''Please evaluate your truncation choice and see if it is''/
     *            1x,''appropriate for your data. You might want to consider deleting''/
     *            1x,''these series from further analysis if you want to truncate.'')')
                stop' Review your truncation choice!'
              endif

              do i=n1+1,maxn
                x(ii,j)=-999.0
              enddo
            endif 
          enddo    
          if(ierr.gt.0)then
            write(*,'(/)')
            pause'                          *** Okay, bailout! ***'
            stop
          endif    
          icen1=mxsy
          icen2=0
          write(iu9,'(/1x,''DATA ARE TRUNCATED AFTER MAXIMUM END YEAR: '',i5)')mxsy
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1  
          idate(nc+1,3)=maxn 
          goto 81        
        elseif(cproc.eq.'7')then   !!!new pjk
    8     ifc=0
          ilc=0
          write(*,'(/1x,''Enter the common start year'',t50,''==> '',$)')
          read(*,*,err=8)ifc
          write(*,'(1x,''Enter the common end year'',t50,''==> '',$)')
          read(*,*,err=8)ilc
          call cenbycom(ifc,ilc,x,nc,idate,ident,mxy,mxs)
          icen1=ifc
          icen2=ilc
          write(iu9,'(/1x,''DATA ARE CENSORED BY COMMON START AND END YEARS: '',i5,i6)')ifc,ilc
          ifmny=idate(nc+1,1)
          ilmxy=idate(nc+1,2)
          maxn=ilmxy-ifmny+1
        else
          goto 4
        endif
   81   call savcen(cproc,icen1,icen2,x,y,nc,idate,ident,itrdb,filnam,iu11,mxy,mxs)
      endif
c
c *** save data for scanning for best constant to add to data for SSF convergence
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        ny=ily-ify+1
        do i=1,ny
          xsave(i,j)=x(i,j)
        enddo
      enddo
c
c *** now find the minimum, lower hinge, median, upper hinge, and maximum segment lengths
c
      if(cproc.ne.'1')then
        do j=1,nc
          f(j)=idate(j,3)
        enddo
        call mfs(f,nc,xmedseg,hhseg,hlseg,fsdseg,rmnseg,rmxseg)
        mnseg=int(rmnseg)
        mlseg=int(hlseg)
        medseg=int(xmedseg)
        mhseg=int(hhseg)
        mxseg=int(rmxseg)
        nsegmin=0
        nseghl=0
        nsegmed=0
        nseghh=0
        nsegmax=0
        do j=1,nc
          nyrs=idate(j,3)
          if(nyrs.eq.mnseg)nsegmin=nsegmin+1
          if(nyrs.ge.mlseg)nseghl=nseghl+1
          if(nyrs.ge.medseg)nsegmed=nsegmed+1
          if(nyrs.ge.mhseg)nseghh=nseghh+1
          if(nyrs.eq.mxseg)nsegmax=nsegmax+1
        enddo
        write(*,'(/1x,''CENSORED DATA SET'',t30,''   MIN   25%   MED   75%   MAX'')')
        write(*,'(1x,''Segment length statistics:'',t30,5i6)')mnseg,mlseg,medseg,mhseg,mxseg
        write(*,'(1x,''Series .ge. segment length:'',t30,5i6)')nsegmin,nseghl,nsegmed,nseghh,nsegmax
        write(iu9,'(/1x,''CENSORED DATA SET'',t30,''   MIN   25%   MED   75%   MAX'')')
        write(iu9,'(1x,''SEGMENT LENGTH STATISTICS:'',t30,5i6)')mnseg,mlseg,medseg,mhseg,mxseg
        write(iu9,'(1x,''SERIES .GE. SEGMENT LENGTH:'',t30,5i6)')nsegmin,nseghl,nsegmed,nseghh,nsegmax
      endif
c
c *** get curve fit option
c
   10 call blank(cdat)
      write(*,'(/1x,''General Curve fit options:''//
     *  1x,''Spline percent N filter (variable)  .le.  -10''/
     *  1x,''Friedman variable span smoother'',t45,''-5''/
     *  1x,''Regional Curve Standardization (RCS)'',t45,''-2''/
     *  1x,''Raw data average, followed by Opt 6'',t46,''0''/
     *  1x,''Neg Expon/linear any slope'',t46,''1''/
     *  1x,''Neg Expon/linear neg slope'',t46,''2''/
     *  1x,''Linear regression any slope'',t46,''3''/
     *  1x,''Linear regression neg slope'',t46,''4''/
     *  1x,''Horizontal line through mean'',t46,''6''/
     *  1x,''Age-dependent spline smoothing'',t45,''<8>''/
     *  1x,''Median segment length spline'',t46,''9''/
     *  1x,''Spline filter in years (fixed .ge. 10)'',t45,''10''/
     *  1x,''Opt <8> is default, hit <RET> for it'',t50,''==> '',$)')
      read(*,'(a)')cdat
      if(cdat(1:1).eq.'/')stop
      if(cdat(1:1).eq.' ')cdat(1:1)='8'   ! changed default from 1 to 8
      call intfrm(cdat,frm)
      read(cdat,frm,err=10)iopt
c
      if(iopt.eq.-5)then
   21   call blank(cdat)
        write(*,'(/1x,''Enter the Friedman tweeter (alpha) 0-9''/
     *             1x,''An alpha=7 is suggested to begin with.''/
     *             1x,''It imparts moderate flexibility to the''/
     *             1x,''super smoother. Alpha=9 is the stiffest''/
     *             1x,''and alpha=0 is the most flexible curve.''/
     *             1x,''Enter your value, hit <RET> for 7'',t50,''==> '',$)')
        read(*,'(a)')cdat
        if(cdat(1:1).eq.'/')stop
        if(cdat(1:1).eq.' ')cdat(1:1)='7'
        call intfrm(cdat,frm)
        read(cdat,frm,err=21)ialpha
        if(ialpha.lt.0.or.ialpha.gt.9)then
          write(*,'(/1x,''Friedman tweeter not in admissible range'')')
          goto 21
        endif
        alpha=ialpha
      elseif(iopt.eq.8)then
   22   call blank(cdat)
        write(*,'(/1x,''For the age-dependent spline you must''/
     *    1x,''enter a starting spline stiffness. For''/
     *    1x,''detrending individual series, an initial''/
     *    1x,''value that appears work well is 50 yrs.''/
     *    1x,''Enter your value, hit <RET> for 50'',t50,''==> '',$)')
        read(*,'(a)')cdat
        if(cdat(1:1).eq.'/')stop
        if(cdat(1:1).eq.' ')cdat(1:2)='50'
        call intfrm(cdat,frm)
        read(cdat,frm,err=22)istrtls
c
  221   call blank(cdat)
        write(*,'(/1x,''The end of the age-dependent spline will''/
     *             1x,''increase to follow the ring widths. This''/
     *             1x,''may reduce the potential for end-effect''/    
     *             1x,''bias in the final chronology, but it may''/   
     *             1x,''also result in the loss of signal due to''/ 
     *             1x,''e.g. climate warming. You can force the''/
     *             1x,''spline to not increase at the end if you''/
     *             1x,''think you know best. Choose your poison.''/
     *             1x,''Allow the spline to incease at the end'',t45,''<0>''/
     *             1x,''Force the spline to be non-increasing'',t46,''1'',t50,''==> '',$)')
        read(*,'(a)')cdat
        if(cdat(1:1).eq.'/')stop
        if(cdat(1:1).eq.' ')cdat(1:1)='0'
        call intfrm(cdat,frm)
        read(cdat,frm,err=221)nis
        if(nis.lt.0.or.nis.gt.1)goto 221
      elseif(iopt.eq.9)then
        iopt=medseg
      endif
      
      write(iu9,'(/1x,''CURVE FIT OPTION:'')')
      if(iopt.le.-10)then
        write(iu9,'(1x,''SPLINE PCT N FILTER (VARIABLE) .LE. -10:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.-5)then
        write(iu9,'(1x,''FRIEDMAN VARIABLE SPAN SMOOTHER AND ALPHA:'',2x,''OPT'',2i5)')iopt,int(alpha)
      endif
      if(iopt.eq.-2)then
        write(iu9,'(1x,''REGIONAL CURVE STANDARDIZATION (RCS):'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.0)then
        write(iu9,'(1x,''NO DETRENDING (MEAN OF RAW DATA):'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.1)then
        write(iu9,'(1x,''NEG EXPON/LINEAR ANY SLOPE:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.2)then
        write(iu9,'(1x,''NEG EXPON/LINEAR NEG SLOPE:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.3)then
        write(iu9,'(1x,''LINEAR REGRESSION ANY SLOPE:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.4)then
        write(iu9,'(1x,''LINEAR REGRESSION NEG SLOPE:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.6)then
        write(iu9,'(1x,''HORIZONTAL LINE THROUGH MEAN:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.eq.8)then
        write(iu9,'(1x,''AGE-DEPENDENT SPLINE SMOOTHING AND START:'',2x,''OPT'',2i5)')iopt,istrtls
      endif
      if(iopt.eq.9)then
        write(iu9,'(1x,''MEDIAN SEGMENT LENGTH SPLINE:'',2x,''OPT'',i5)')iopt
      endif
      if(iopt.ge.10)then
        write(iu9,'(1x,''SPLINE FILTER IN YEARS (FIXED) .GE. 10:'',2x,''OPT'',i5)')iopt
      endif
      
c -----------------------------------------------------------------------------new pjk
  613 continue
      if(iopt.eq.-2)then
        rcs=.true.
        if(.not.tryagain)then
          iopt=-2

   23     call blank(cdat)
          write(*,'(/1x,''For using the age-dependent spline with RCS''/
     *      1x,''enter an initial spline stiffness to smooth''/
     *      1x,''the mean biologically aged-aligned tree rings.''/
     *      1x,''A suggested initial value to try is 10 yrs.''/
     *      1x,''Enter your value, hit <RET> for 10'',t50,''==> '',$)')
          read(*,'(a)')cdat
          if(cdat(1:1).eq.'/')stop
          if(cdat(1:1).eq.' ')cdat(1:2)='10'
          call intfrm(cdat,frm)
          read(cdat,frm,err=23)istrtls

        elseif(tryagain)then
  111     write(*,'(/1x,''Select RCS curve fit options:'',//)')
          write(*,'(t3,''  -5:  friedman super smoother'',
     *      ''        lower alpha (0-9) gives more local fit'')')
          write(*,'(t3,''  -4:  robust lowess smoother'',
     *      ''         integer percent of series length <Not Yet>'')')
          write(*,'(t3,''  -3:  median smoothing'',
     *      ''               must have odd window length <full length only>'')')
          write(*,'(t3,''  -2:  Age-dependent spline smoothing'')')
          write(*,'(t3,''   1:  neg expon curve, '',
     *      ''no = opt 4    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
          write(*,'(t3,''   2:  neg expon curve, '',
     *      ''no = opt 5    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
          write(*,'(t3,''   3:  neg expon curve  '',
     *      ''(general)     f(i) = a*exp(-b*t(i+p)) + d (any d)'')')
          write(*,'(t3,''   4:  linear regression '',
     *      ''(any slope)  f(i) = +/-c*t(i) + d'')')
          write(*,'(t3,''   5:  linear regression '',
     *      ''(neg slope)  f(i) = -c*t(i) + d   '')')
          write(*,'(t3,''   6:  horizontal line through '',
     *      ''mean   f(i) = mean(y(i)) = d'')')
          write(*,'(t3,''   7:  hugershoff growth '',
     *      ''function     f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
          write(*,'(t3,''   8:  general exponential (b = 1)    '',
     *      ''f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
          write(*,'(t3,''  >9: cubic smoothing '',
     *      ''spline         fixed 50 pct variance cutoff'')')
          write(*,'(t3,'' <-9: cubic smoothing '',
     *      ''spline         pct n 50 pct variance cutoff'')')
          write(*,'(/1x,''enter  option  (x to start over)  ==> '',$)')
          read(*,*,err= 10)iopt
          if(iopt.eq.-5)then
   24       call blank(cdat)
            write(*,'(/1x,''Enter the Friedman tweeter (alpha) 0-9''/
     *             1x,''An alpha=7 is suggested to begin with.''/
     *             1x,''It imparts moderate flexibility to the''/
     *             1x,''super smoother. Alpha=9 is the stiffest''/
     *             1x,''and alpha=0 is the most flexible curve.''/
     *             1x,''Enter your value, hit <RET> for 7'',t50,''==> '',$)')
            read(*,'(a)')cdat
            if(cdat(1:1).eq.'/')stop
            if(cdat(1:1).eq.' ')cdat(1:2)='7'
            call intfrm(cdat,frm)
            read(cdat,frm,err=24)ialpha
            if(ialpha.lt.0.or.ialpha.gt.9)then
              write(*,'(/1x,''Friedman tweeter not in admissible range'')')
              goto 24
            endif
            ndt=ialpha
            alpha=real(ndt)
          elseif(iopt.eq.-4)then
            ndt=0
            write(*,'(/1x,''enter the lowess window width''/
     *        1x,''fixed for all series: a positive integer >2''/
     *        1x,''and less then the shortest series length, or''/
     *        1x,''percent of series length: a negative integer''/
     *        1x,''between -1 and -100, inclusive'', t45,''==> '',$)')
            read(*,*)ndt
            if(ndt.ge.0)then
              if(ndt.eq.0.or.ndt.eq.1.or.ndt.eq.2)goto 111
            else
              if(ndt.gt.-1)goto 111
              if(ndt.lt.-100)goto 111
            endif
          elseif(iopt.eq.-3)then
            ndt=0
            write(*,'(/1x,''enter the median window width''/
     *        1x,''fixed for all series: a positive odd integer >2''/
     *        1x,''and less then the shortest series length, or''/
     *        1x,''percent of series length: a negative integer''/
     *        1x,''between -1 and -100, inclusive'', t45,''==> '',$)')
            read(*,*)ndt
            if(ndt.ge.0)then
              if(ndt.eq.0.or.ndt.eq.1.or.ndt.eq.2)goto 111
              if(mod(ndt,2).eq.0)goto 111
            else
              if(ndt.gt.-1)goto 111
              if(ndt.lt.-100)goto 111
            endif
          elseif(iopt.eq.-2)then
   25       call blank(cdat) 
          write(*,'(/1x,''For using the age-dependent spline with RCS''/
     *      1x,''enter an initial spline stiffness to smooth''/
     *      1x,''the mean biologically aged-aligned tree rings.''/
     *      1x,''A suggested initial value to try is 10 yrs.''/
     *      1x,''Enter your value, hit <RET> for 10'',t50,''==> '',$)')
            read(*,'(a)')cdat
            if(cdat(1:1).eq.'/')stop
            if(cdat(1:1).eq.' ')cdat(1:2)='10'
            call intfrm(cdat,frm)
            read(cdat,frm,err=25)istrtls
          endif
        endif
c
	 if(.not.tryagain)then
          call pithy(mxs,iu70,pith,poff,filnam)
        else
          goto 117
        endif

      endif  !iopt =-2
c ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^new pjk
c
c *** calculate mean chronology robustly or stupidly not
c
   11 call blank(cdat)
      write(*,'(/1x,''How to calculate the mean chronology (/ to stop):''/
     *           1x,''Non-robust arithmetic mean'',t39,'' 1 ''/
     *           1x,''Robust Tukey biweight mean'',t39,''<2>''/
     *           1x,''Robust is default, hit <RET> if you want it'',t50,''==> '',$)')
      read(*,'(a)')cdat
      if(cdat(1:1).eq.'/')stop
      if(cdat(1:1).eq.' ')cdat(1:1)='2'
      if(cdat(1:1).eq.'1')then
        irob=1
      elseif(cdat(1:1).eq.'2')then
        irob=2
      else
        write(*,'(/1x,''Mean index choice not admissible'')')
        goto 11
      endif
      if(irob.eq.1)then
        write(iu9,'(/1x,''NON-ROBUST ARITHMETIC MEAN CHRONOLOGY CALCULATED:'',2x,i5)')irob
      elseif(irob.eq.2)then
        write(iu9,'(/1x,''TUKEY ROBUST BIWEIGHT MEAN CHRONOLOGY CALCULATED:'',2x,i5)')irob
      endif
c
c *** get running RBAR window width for performing running RBAR variance stabilization
c
   12 call blank(cdat)
      write(*,'(/1x,''Enter running RBAR window width for variance''/
     *           1x,''stabilization. Must be .ge. 25 years and odd.''/
     *           1x,''Default window width is 51 years, 0 to skip'',t50,''==> '',$)')
      read(*,'(a)')cdat
      if(cdat(1:1).eq.'/')stop
      if(cdat(1:1).eq.' ')cdat(1:2)='51'
      call intfrm(cdat,frm)
      read(cdat,frm,err=12)nsg
      if(nsg.eq.0)then
        write(*,'(/1x,''Running RBAR variance stabilization skipped'')')
      elseif(nsg.gt.0.and.nsg.lt.25)then
        write(*,'(/1x,''Running RBAR window width must be .ge. 25'')')
        goto 12
      elseif(mod(nsg,2).eq.0)then
        nsg=nsg+1
        write(*,'(/1x,''Running RBAR window width increased to make it odd: '',i5)')nsg
      endif
      write(iu9,'(/1x,''RUNNING RBAR WINDOW WIDTH FOR VARIANCE STABILIZATION: '',i5)')nsg
c
c *** determine whether or not to do spline variance stabilization
c
      if(nsg.ge.25)then
        call blank(cdat)
   14   write(*,'(/1x,''Additional spline variance stabilization?''/
     *    1x,''No additional spline stabilization'',t39,'' 0 ''/
     *    1x,''Age-dependent spline stabilization'',t39,''<1>''/
     *    1x,''Smoothing spline (percent N cutoff)'',t39,''<-9''/
     *    1x,''Smoothing spline (fixed Yrs cutoff)'',t39,''>+9'',t50,''==> '',$)')
        read(*,'(a)')cdat
        if(cdat(1:1).eq.'/')stop
        if(cdat(1:1).eq.' ')cdat(1:1)='1'
        call intfrm(cdat,frm)
        read(cdat,frm,err=14)isb
        if(isb.gt.1.and.isb.lt.10)goto 14
        if(isb.lt.0.and.isb.gt.-10)goto 14
      endif       
c
      itrun='n'
c
   15 melvin=' '
      switch='n'
      reset='y'
      hpfilt='y'
      tol=0.0001e0
      melvin='n'
   20 itol=' '
      write(*,'(/1x,''Enter the signal free convergence test''/
     *           1x,''based on minimizing the mean absolute''/
     *           1x,''differences between the current and''/
     *           1x,''preceeding chronologies:   ''/
     *           1x,''  Original Melvin setting   1  0.0005''/
     *           1x,''  Current default setting  <2> 0.0001''/
     *           1x,''  **** Roll Your Own ****   3  X.XXXX'',t50,''==> '',$)')
      read(*,'(a)')itol
      if(itol.eq.'/')stop
      if(itol.eq.'1')then
        tol=0.0005e0
      elseif(itol.eq.' '.or.itol.eq.'2')then
        tol=0.0001e0
      elseif(itol.eq.'3')then
        write(*,'(/1x,''Okay, enter YOUR convergence test'',t50,''==> '',$)')
        read(*,*,err=20)tol
      else
        goto 20
      endif
c      endif
ccccccccccccccccccccc new Feb. 2012
  115 cook=' '
      write(*,'(/1x,''Use COOK signal free convergence tweaks?''/
     *           1x,''Set each chronology mean to exactly 1.0''/
     *           1x,''and use the more robust median absolute''/
     *           1x,''differences instead of mean absolute''/
     *           1x,''differences for signal free convergence.''/
     *           1x,''Enter <y>/n (default is y for YES, / to exit)'',t50,''==> '',$)')
      read(*,'(a)')cook
      if(cook.eq.'/')stop
      if(cook.eq.' ')cook='y'
      if(cook.eq.'N')cook='n'
      if(cook.eq.'Y')cook='y'
      if(cook.ne.'y'.and.cook.ne.'n')then
        write(*,'(/1x,''Answer not entered as y or n'')')
        goto 115
      endif
      if(cook.eq.'n')then
        cset='n'
        cmed='n'
      elseif(cook.eq.'y')then
        cset='y'
        cmed='y'
      endif
      if(cook.eq.'y')then
        write(iu9,'(/1x,''COOK CONVERGENCE CRITERIA USED - SHOULD BE FASTER TO CONVERGE'')')
        write(iu9,'(/1x,''FOR SPLINE AND FRIEDMAN FLEXIBLE CURVE FITS A COUNT-WEIGHTED ''
     *                  ''CONVERGENCE CRITERION IS USED.'')')
        write(iu9,'(1x,''THIS SPEEDS CONVERGENCE AND REDUCES THE CHANCES OF EXCESSIVE SIGNAL ''
     *                 ''FREE ITERATIONS.'')')
      else
        write(iu9,'(/1x,''ORIGINAL CONVERGENCE CRITERIA USED - MAY BE SLOWER TO CONVERGE'')')
        write(iu9,'(/1x,''FOR SPLINE AND FRIEDMAN FLEXIBLE CURVE FITS A COUNT-WEIGHTED ''
     *                  ''CONVERGENCE CRITERION IS USED.'')')
        write(iu9,'(1x,'' REDUCES THE CHANCES OF EXCESSIVE SIGNAL FREE ITERATIONS.'')')
      endif
  117 rwconst=nocon*0.10
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        do i=1,nyr
          x(i,j)=xsave(i,j)+rwconst
        enddo
        curmin(j)=0.02
ccc        if(nocon.eq.0)then
ccc          curmin(j)=0.02
ccc        else
ccc          curmin(j)=rwconst
ccc          curmin(j)=0.02                 !New
ccc        endif
      enddo
        
      if(pt)then  
        if(nocon.eq.0)write(iu9,'(/1x,''THE SERIES HAVE HAD ADAPTIVE POWER TRANSFORMATIONS APPLIED'')')
ccc       do k=1,nc
ccc         p=1
ccc         do j=idate(k,1),idate(k,2)
ccc           xtmp(p,k)=x(p,k) !save a copy the original input data matrix
ccc           p=p+1
ccc         enddo
ccc       enddo
ccc      perform power transformation
        call slpt1(mxy,mxs,x,idate,nc,ptmean,nocon) !pt - ERC edits to match ARSTAN
      endif
        
c      endif
      if(nocon.eq.0)then
        write(*,'(/1x,''CONSTANT ADDED TO ALL MEASUREMENTS TO AID CONVERGENCE(?): '',t63,f8.3)')rwconst
        write(iu9,'(/1x,''CONSTANT ADDED TO ALL MEASUREMENTS TO AID CONVERGENCE(?): '',t63,f8.3)')rwconst
        if(pt)then
          write(iu9,'(1x,''THE MEAN ADAPTIVE POWER TRANSFORM POWER APPLIED IS: '',t63,f8.3)')ptmean
        endif
      else
        write(*,'(1x,''CONSTANT ADDED TO ALL MEASUREMENTS TO AID CONVERGENCE(?): '',t63,f8.3)')rwconst
        write(iu9,'(1x,''CONSTANT ADDED TO ALL MEASUREMENTS TO AID CONVERGENCE(?): '',t63,f8.3)')rwconst
        if(pt)then
          write(iu9,'(1x,''THE MEAN ADAPTIVE POWER TRANSFORM POWER APPLIED IS: '',t63,f8.3)')ptmean
        endif
      endif
cccccccccccccccccccccccccccccc
      if(nocon.eq.0)write(*,'(/1x,''OKAY, LET US BEGIN:'')')
c
c *** set the fixed truncation years if necessary
c
      do j=1,nc
        if(itrun.eq.'y')then
          ilyr=idate(j,2)
          if(itrunyr.lt.ilyr)then
            idate(j,3)=itrunyr
          else
            idate(j,3)=ilyr
          endif
        elseif(itrun.eq.'n')then
          idate(j,3)=idate(j,2)
        endif
      enddo
c
c *** do the signal free detrending
c
cpjk      itype=.false.
      ioptsave=iopt
      call sigfree(x,y,f,ls,alpha,sfind,nc,crn1,crn2,crn3,nss,idate,ident,iopt,irob,
     *  switch,reset,hpfilt,tol,mxy,mxs,itrdb,ybar,rxm,runr,nsg,isb,filnam,fil1,rcs,pith,
     *  ndt,tryagain,cset,cmed,curmin,poff,nocon,cook,itype,pt,rwconst,crnsall,iter,istrtls,nis)
c     
ccc      if(tryagain)goto 611
      if(tryagain)then
        iopt=-2
        nocon=0
        goto 613
      endif
c
      if(nocon.gt.0)then
        if(nocon.le.10)then
          goto 117
        else
          goto 118
        endif
      endif
     
  118 continue
      iopt=ioptsave  
c
c *** open column format chronology output file and save the standard and signal free chronologies
c
      call blank(fil1)
      fil1=filnam
      fil1(ll+1:ll+13)='_crns_col.txt'
      open(iu11,file=fil1,status='unknown')
      if(iopt.eq.0)then
        if(nsg.gt.0)then
          write(iu11,'(''  Year  SSize  RawCrn  AdjCrn  RawSig  AdjSig  RawSee  AdjSee  RawStb  AdjStb'')')
        else
          write(iu11,'(''  Year  SSize  RawCrn  AdjCrn  RawSig  AdjSig  RawSee  AdjSee'')')
        endif
      else
        if(nsg.gt.0)then
          write(iu11,'(''  Year  SSize  StdCrn  SsfCrn  StdSig  SsfSig  StdSee  SsfSee  StdStb  SsfStb'')')
        else
          write(iu11,'(''  Year  SSize  StdCrn  SsfCrn  StdSig  SsfSig  StdSee  SsfSee'')')
        endif
      endif
      ny=0
      do i=1,maxn
        rns=float(nss(i))
        if(nsg.gt.0)then
          write(iu11,'(2i6,1x,12f8.3)')ifmny+i-1,nss(i),crn1(i,1),crn2(i,1),crn1(i,2),crn2(i,2),
     *      crn1(i,2)/sqrt(rns),crn2(i,2)/sqrt(rns),crn3(i,1),crn3(i,2)
          if(rns.ge.5.)then
            ny=ny+1
            x(ny,1)=crn3(i,1)
            x(ny,2)=crn3(i,2)
          endif
        else
          write(iu11,'(2i6,1x,10f8.3)')ifmny+i-1,nss(i),crn1(i,1),crn2(i,1),crn1(i,2),crn2(i,2),
     *      crn1(i,2)/sqrt(rns),crn2(i,2)/sqrt(rns)
          if(rns.ge.5.)then
            ny=ny+1
            x(ny,1)=crn1(i,1)
            x(ny,2)=crn2(i,1)
          endif
        endif
      enddo
      close(iu11)
c
c *** open Tucson format chronology output file and save the standard and signal free chronologies
c
      fil1(ll+1:ll+13)='_crns_tuc.txt'
      open(iu11,file=fil1,status='unknown')      
      call blank(id)
      id=filnam(1:6)
      do j=1,3
        if(iopt.eq.0.and.j.gt.1)itrdb(j)(83:88)='rawcrn'
        if(iopt.ne.0.and.j.gt.1)itrdb(j)(83:88)='stdcrn'
        write(iu11,'(a)')itrdb(j)
      enddo
      call trrw(id,ifmny,maxn,crn1(1,1),nss,ifl,iu11,iuo,'iw',tit,itrdb(3)(83:88),mxy,itrdb)
      do j=1,3
        if(iopt.eq.0.and.j.gt.1)itrdb(j)(83:88)='adjcrn'
        if(iopt.ne.0.and.j.gt.1)itrdb(j)(83:88)='ssfcrn'
        write(iu11,'(a)')itrdb(j)
      enddo
      call trrw(id,ifmny,maxn,crn2(1,1),nss,ifl,iu11,iuo,'iw',tit,itrdb(3)(83:88),mxy,itrdb)
      if(nsg.gt.0)then
        do j=1,3
          if(iopt.eq.0.and.j.gt.1)itrdb(j)(83:88)='rawstb'
          if(iopt.ne.0.and.j.gt.1)itrdb(j)(83:88)='stdstb'
          write(iu11,'(a)')itrdb(j)
        enddo
        call trrw(id,ifmny,maxn,crn3(1,1),nss,ifl,iu11,iuo,'iw',tit,itrdb(3)(83:88),mxy,itrdb)
        do j=1,3
          if(iopt.eq.0.and.j.gt.1)itrdb(j)(83:88)='adjstb'
          if(iopt.ne.0.and.j.gt.1)itrdb(j)(83:88)='ssfstb'
          write(iu11,'(a)')itrdb(j)
        enddo
        call trrw(id,ifmny,maxn,crn3(1,2),nss,ifl,iu11,iuo,'iw',tit,itrdb(3)(83:88),mxy,itrdb)
      endif
      close(iu11)
c
c *** get ready to make some spectral power information
c
      do i=1,40
         if(filnam(i:i).eq.' '.or.filnam(i:i).eq.'.')goto 119
      enddo
  119 i=i-1
      call blank(fil1)
      fil1=filnam(1:i)//'_spectra.txt'
      open(iu10,file=fil1,status='unknown')
c
c Now estimate power spectra of all chronologies produced 
      lags=ny/3
      if(ny.gt.1000)lags=ny/5
       m=int(lags+1)
       df=2.0*float(ny)/float(lags)*1.258
       ndf=df
       cdf=(2.0/(df-2.0))*fdist(ndf)
       bw=1.258/float(lags)
       ind(1)=0
       ind(2)=ny
       ind(3)=1
       ind(4)=lags
       ind(5)=0
       ind(6)=0
       xind(1)=1.0
       xind(2)=0.0
       ns=2
       do j=1,ns
         do i=1,ny
           y(i)=x(i,j)
         enddo
         call ftfreq(y,ind,xind,xymv,acv,freq,ps,xcov,xspect,amphas,xfer,coher,ier)
c
         xm1=0.0
         avar=1.0/float(m)
         r1=acv(1)/xymv(2)
         rm=lags
c
         m10=0
         do i=1,m
            if(freq(i).le.0.10)m10=m10+1
            btout2(i,1)=freq(i)
            btout2(i,1+j)=ps(i)
         enddo
c         
         do i=1,m
            xm1=xm1+ps(i)
            btout(i,1)=freq(i)	
         enddo
c         
         do i=1,m
            lag=i-1
            rk=lag
            red=avar*((1.0-r1*r1)/((1.0+r1*r1)-2.0*r1*(cos(pi*rk/rm))))
            red95=red*chisq(ndf)/df
            spd=ps(i)/xm1
            k2=(j-1)*4+2; k3=(j-1)*4+3; k4=(j-1)*4+4; k5=(j-1)*4+5
            btout(i,k2)=ps(i); btout(i,k3)=spd; btout(i,k4)=red; btout(i,k5)=red95
         enddo
c           
       enddo
      if(iopt.eq.0)then
        call plt6(mxl,mxs,3,m,btout2,'RAW Power Spectrum','ADJ Power Spectrum')
        call plt6(mxl,mxs,3,m10,btout2,'RAW >10Yr Spectrum','ADJ >10Yr Spectrum')
        write(iu10,'('' FREQUENCY   POWER_RAW_CRN   POWER_ADJ_CRN'')')
      elseif(iopt.ne.0)then
        call plt6(mxl,mxs,3,m,btout2,'STD Power Spectrum','SSF Power Spectrum')
        call plt6(mxl,mxs,3,m10,btout2,'RAW >10Yr Spectrum','SSF >10Yr Spectrum')
        write(iu10,'('' FREQUENCY   POWER_STD_CRN   POWER_SSF_CRN'')')
      endif
      do i=1,m
        write(iu10,'(f9.5,f14.5,F16.5)')(btout2(i,j),j=1,ns+1)
      enddo
      close(iu10)
c
c *** save all chronologies produced by signal free now
c
c      do i=1,40
c        if(filnam(i:i).eq.' '.or.filnam(i:i).eq.'.')goto 120
c      enddo
c  120 i=i-1
c      call blank(fil1)
c      fil1=filnam(1:i)//'_crnsall.txt'
c      open(iu10,file=fil1,status='unknown')
c      write(iu10,'('' Year  Ncnt'',101i7)')(j-1,j=1,iter+1)
c      ifmny=idate(nc+1,1)
c      ilmxy=idate(nc+1,2)
c      maxn=ilmxy-ifmny+1
c      do i=1,maxn
c        write(iu10,'(i5,i6,1x,101f7.3)')ifmny+i-1,nss(i),(crnsall(i,j),j=1,iter+1)
c      enddo
c      close(iu10)
c
  900 write(*,'(/1x,''Normal termination of program RCSigFree_Version ''
     +           ,a,//1x,''Hit RETURN to Quit'',$)')version
      pause
      stop
  901 write(*,'(/1x,''Abnormal termination of program RCSigFree_Version ''
     +           ,a,//1x,''Hit RETURN to Quit'',$)')version
      pause
      stop
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr sigfree
*
      subroutine sigfree(x,y,f,ls,alpha,sfind,nc,crn1,crn2,crn3,nss,idate,ident,iopt,irob,
     *  switch,reset,hpfilt,tol,mxy,mxs,itrdb,ybar,rxm,runr,nsg,isb,filnam,fil1,rcs,pith,ndt,
     *  tryagain,cset,cmed,curmin,poff,nocon,cook,itype,pt,rwconst,crnsall,iter,istrtls,nis)
     
c
      parameter(mxlen=9000,mxser=3000,maxit=100,iu9=9,iu29=29,iu30=30,iu31=31,iu32=32,iu33=33,iu69=69,iu70=70)
      real*4 x(mxy,mxs),y(mxy),f(mxy),sfind(mxy,mxs),crn1(mxy,2),crn2(mxy,2),crn3(mxy,2),crnsall(mxy,101)
      real*4 crnsav(mxlen),xbar(mxser),segmn(mxlen),segsd(mxlen),agemn(mxlen),agesd(mxlen)
      real*4 test1(maxit),test2(maxit),test3(maxit),test4(maxit),wrk1(mxlen),wrk2(mxlen),stdsav(mxlen)
      real*4 ybar(mxy,3),rxm(mxy,7),runr(mxy,5),savit(mxlen,mxser),ones(mxlen),curmin(mxs),rbeps(mxlen,4)
      real*4 tol,t1,t2,t3,t4,sfind1(mxlen,mxser)
      real*4 x1(mxlen,mxser),x2(mxlen,mxser),x3(mxlen,mxser),x4(mxlen,mxser),x5(mxlen,mxser),x6(mxlen,mxser)
      real*4 wgts(mxlen,mxser),eff(mxlen),sigmas(mxser,maxit)
      integer idate(mxs,3),nss(mxy),iopt1(mxser,maxit+2),ls(mxy),jtest(mxser,maxit+2),iter
      character ident(mxs)*8,tit*60,xlab*20,ylab*20,annot1*36,annot2*36,hpfilt,line*410,reset,switch
      character star1,star2,star3,star4,itrdb(3)*100,id*8,istab,filnam*50,fil1*80
      character cset,cmed,cook,yn,cdat*10,frm*20,tf
      logical itype
c new RCS declarations
      integer p,j,k,jj
      real*4 xrc(mxlen),eq(7),yrcs(mxlen,mxser),rcscrv(mxlen,2,maxit),flag,miny
      real*4 wrk3(mxlen),wrk4(mxlen)
      parameter (flag=-999.0)
      integer pith(mxs),mxage,ndt,rcmax,rcnt,fyr(mxser),mnpoff,age(mxser),poset
      logical rcs,tryagain,rcscut,plotall,pt,poff
      character ans*1,string*35
c
      do p=1,mxlen
        do j=1,2
          do k=1,maxit
            rcscrv(p,j,k)=flag
          enddo
        enddo
      enddo
c
      if(nsg.eq.0)then
        istab='n'
      else
        istab='y'
      endif
      ioptsave=iopt
c
c *** get chronologiy length info
c
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
c
c *** calculate the average segment length over all years
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        age(j)=(ily-ify)+1  !new March 2012
        ish=ify-ifmny
        do i=1,n
          ii=i+ish
          sfind(ii,j)=float(n)
        enddo
      enddo
      do j=1,nc
        do i=1,maxn
          wgts(i,j)=-999.0
        enddo
      enddo
      call robsum(sfind,wgts,maxn,nc,segmn,segsd,eff,nss,1,mxy,mxs)
c
c *** calculate the average tree age over all years
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ish=ify-ifmny
        do i=1,n
          ii=i+ish
          sfind(ii,j)=float(i)
        enddo
      enddo
      do j=1,nc
        do i=1,maxn
          wgts(i,j)=-999.0
        enddo
      enddo
      call robsum(sfind,wgts,maxn,nc,agemn,agesd,eff,nss,1,mxy,mxs)
c
c *** plot out mean segment length and mean tree age
c
      call blank(tit)
      tit(1:37)='Mean Segment Length And Mean Tree Age'
      call blank(xlab)
      xlab(1:5)='Years'
      call blank(ylab)
      ylab(1:5)='Years'
      call blank(annot1)
      annot1(1:20)=' Mean Segment Length'
      call blank(annot2)
      annot2(1:20)='Mean Approx Tree Age'
      do i=1,maxn
        f(i)=0.0
      enddo
      iw1=1;iw2=1;iw3=0
      if(.not.tryagain)then
        if(nocon.eq.0)call plot1(mxy,segmn,agemn,maxn,ifmny,xlab,ylab,tit,f,annot1,annot2,iw1,iw2,iw3)
      endif
c
c *** do the initial detrending based on iopt curve fitting option
c *** get unique character string for output files
c
      ll=len(filnam)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(filnam(jj:jj).ne.' ')goto 1
      enddo
    1 ll=jj
      do j=1,ll
        jj=j
        if(filnam(j:j).eq.'.')then
          jj=j-1
          goto 2
        endif
      enddo
    2 ll=jj
c    
      call blank(fil1)
      fil1=filnam
      if(.not.itype)then
        fil1(ll+1:ll+17)='_STD_RAW_Data.txt'
      else
        if(pt)then
          fil1(ll+1:ll+17)='_STD_PTR_Data.txt'
        else
          fil1(ll+1:ll+17)='_STD_RAW_Data.txt'
        endif
      endif
      open(iu30,file=fil1,status='unknown')
      close(iu30,status='delete')
      open(iu30,file=fil1,status='unknown') 
      write(iu30,'(a)')itrdb(1)
c
      call blank(fil1)
      fil1=filnam
      if(.not.itype)then
        fil1(ll+1:ll+19)='_STD_RAW_Curves.txt'
      else
        if(pt)then
          fil1(ll+1:ll+19)='_STD_PTR_Curves.txt'
        else
          fil1(ll+1:ll+19)='_STD_RAW_Curves.txt'
        endif
      endif
      open(iu31,file=fil1,status='unknown')
      close(iu31,status='delete')
      open(iu31,file=fil1,status='unknown')
      write(iu31,'(a)')itrdb(1)
c
      if(iopt.ne.0)then
        call blank(fil1)
        fil1=filnam
        if(.not.itype)then
          fil1(ll+1:ll+19)='_STD_RAW_Ratios.txt'
        else
          if(pt)then
            fil1(ll+1:ll+19)='_STD_PTR_Resids.txt'
          else
            fil1(ll+1:ll+19)='_STD_RAW_Resids.txt'
          endif
        endif
        open(iu32,file=fil1,status='unknown')
        close(iu32,status='delete')
        open(iu32,file=fil1,status='unknown')
        write(iu32,'(a)')itrdb(1)
      endif 
c___________________________________________ RCS       
c
      if(rcs)then  ! new  rcs
        rcmax=0
  112   call rcurve(mxlen,mxser,nc,x,xrc,f,idate,pith,flag,mxage,eq,iopt,alpha,ndt,poff, 
     *    rcmax,mnpoff,istrtls)                 	!(xrc is the regional mean (f is the regional curve)
        call plt1(mxy,mxs,xrc,f,1,mxage,flag,'Initial RC and MVF fit             ',mnpoff)
c       save the original Regional Curve and their solutions
        rcnt=1
        do jj=1,mxage
          rcscrv(jj,1,rcnt)=xrc(jj); rcscrv(jj,2,rcnt)=f(jj)
        enddo
        tryagain=.false.
        do j=1+mnpoff,mxage
          if(f(j).le.0.and.f(j).ne.flag)then
            tryagain=.true.
            goto 1113
          endif
        enddo
 1113	  if(tryagain)then
          write(*,'(/3x,''**************** WARNING ****************'')')
          write(*,'(3x,''    Regional Curve goes south (negative) '')')
          write(*,'(3x,'' Suggest choosing another RCS configuration.'')')
          write(*,'(/3x,''**************** WARNING ****************'')')
          pause '                   Hit RETURN to Continue'
        endif
        tf=' '
        write(*,'(/1x,''Different RCS detrending? [T]rue or <[F]>alse'',t50,''==> '',$)')
        read(*,'(a)')tf
        if(tf.eq.' ')tf='F'
        if(tf.eq.'F'.or.tf.eq.'f')then
          tryagain=.false.
        else
          tryagain=.true.
        endif
ccc        read(*,*)tryagain
        if(tryagain)return
        tf=' '
        write(*,'(/1x,''Truncate Regional Curve?  [T]rue or <[F]>alse'',t50,''==> '',$)')
        read(*,'(a)')tf
        if(tf.eq.' ')tf='F'
        if(tf.eq.'F'.or.tf.eq.'f')then
          rcscut=.false.
        else
          rcscut=.true.
        endif
ccc        read(*,*)rcscut
        if(rcscut)then
          do j=1,nc
            fyr(j)=idate(j,1)
          enddo
          call comint(mxser,fyr,ident,age,nc)
          write(*,'(//3x,''Enter Biological Year beyond which not to use'')')
          write(*,'(3x,''in the estimation of the Regional model'',t50,''==> '',$)')
          read(*,*)rcmax
          goto 112
        endif
        tf=' '
        write(*,'(/1x,''Plot lots of tree rings?  [T]rue or <[F]>alse'',t50,''==> '',$)')
        read(*,'(a)')tf
        if(tf.eq.' ')tf='F'
        if(tf.eq.'F'.or.tf.eq.'f')then
          plotall=.false.
        else
          plotall=.true.
        endif
ccc        read(*,*)plotall
      endif        ! new  rcs
c___________________________________________  end RCS 
        miny=9999.
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        ily1=ily
        n=ily-ify+1
        n1=n
        do i=1,n
          y(i)=x(i,j)
        enddo
        call mnsd(y,n,xm,sd)     
        xbar(j)=xm
        iopt1(j,1)=iopt
        iopt1(j,2)=iopt
        ioptt=iopt
        if(iopt.eq.0)then
          iopt1(j,1)=6
          iopt1(j,2)=6
          ioptt=6
        endif
        jtest(j,1)=0
        jtest(j,2)=0
c
        if(.not.rcs)then 
          call curvefits(y,f,ify,n,n1,ident(j),iopt1(j,2),alpha,mxy,mxs,istrtls,nis)          
          do i=1,n
            if(f(i).lt.curmin(j))then
              f(i)=curmin(j)
              if(i.eq.1)jtest(j,2)=j
            endif
          enddo          
        endif
        if(rcs)then
          poset=pith(j)
        else
          poset=0
        endif
        do i=1,n
          wrk2(i)=y(i)
          wrk3(i)=f(i+poset)  !new pjk version 26
          if(iopt.eq.0)wrk4(i)=y(i)
        enddo
        if(iopt.ne.0)then
          if(.not.itype)then
            call calind(wrk2,wrk3,wrk4,n,1,mxlen)
          else
            call calind(wrk2,wrk3,wrk4,n,2,mxlen)
          endif
        endif
        do i=1,n
          if(.not.itype)then
            wrk2(i)=y(i)-rwconst
            wrk3(i)=f(i)-rwconst
            x1(i,j)=wrk3(i)
            x3(i,j)=wrk2(i)
          else
            wrk2(i)=y(i)-rwconst
            wrk3(i)=f(i)-rwconst
            x1(i,j)=wrk3(i)
            x3(i,j)=wrk2(i)
          endif
          sfind(i,j)=wrk4(i)
          x5(i,j)=wrk4(i)
        enddo
        call trrw(ident(j),ify,n,wrk2,nss,ifl,iu30,iuo,'mw',tit,'stdraw',mxy,itrdb)
        call trrw(ident(j),ify,n,wrk3,nss,ifl,iu31,iuo,'mw',tit,'stdcrv',mxy,itrdb)
        if(iopt.ne.0)then
          call trrw(ident(j),ify,n,wrk4,nss,ifl,iu32,iuo,'mw',tit,'stdind',mxy,itrdb)
        endif
          
        if(nocon.eq.0)then
          call mnsd(wrk4,n,xm,sd)
          sigmas(j,1)=sd
        endif
          
      enddo   !endo do j
      if(rcs)then
        if(itype)then
          string='Initial RC Residual Indices        '
        else
          string='Initial RC Ratio Indices           '
        endif
        call plt2(mxy,mxs,sfind,nc,idate,flag,'Initial RC and MVF fit             ')
      endif
c
      close(iu30)
      close(iu31)
      if(iopt.ne.0)then
        close(iu32)
      endif
c
c *** align the data by calendar year now
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ish=ify-ifmny
        if(ish.gt.0)then
          do i=1,n
            ii=n-i+1
            x(ii+ish,j)=x(ii,j)
            sfind(ii+ish,j)=sfind(ii,j)
          enddo
          do i=1,ish
            x(i,j)=-999.0
            sfind(i,j)=-999.0
          enddo
        endif
      enddo
      do j=1,nc
        do i=1,maxn
          wgts(i,j)=-999.0
        enddo
      enddo
c
c *** calculate the initial mean chronology
c
      call robsum(sfind,wgts,maxn,nc,crn1(1,1),crn1(1,2),eff,nss,irob,mxy,mxs)
      if(irob.eq.2)then
        iter=0
        call blank(tit)
        if(iopt.eq.0)tit='Biweights For Raw Data Chronology'
        if(iopt.ne.0)tit='Biweights For Standard Chronology'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='Biweights'
        call blank(annot1)
        call blank(annot2)
        annot1='Iteration: '
        write(annot1(12:14),'(i3)')iter
        annot1(17:36)='hh,med,hl,min biwgts'
        do i=1,maxn
          ones(i)=1.0
        enddo
        if(nocon.eq.0)call spaghetti(wgts,ones,maxn,4,ifmny,xlab,ylab,tit,annot1,annot2,mxlen,mxser) 
      endif
      
      if(nocon.eq.0)then
        call mnsd(crn1(1,1),maxn,xmstd1,sdstd1)
      endif
      
      do i=1,maxn
        crn1(i,1)=crn1(i,1)-xmstd1+1.0	       !added 10/31/12
        if(crn1(i,1).lt.0)crn1(i,1)=0.0          !added 01/06/2013
        ybar(i,1)=crn1(i,1)				!running correlation bit added 01/03/11
        runr(i,1)=float(nss(i))
      enddo
      nss1=0
      nss2=0
      do i=1,maxn
        if(nss(i).eq.1)then
          nss1=nss1+1
        else
          goto 5
        endif
      enddo
    5 do i=1,maxn
        if(nss(i).lt.6)then
          nss2=nss2+1
        else
          goto 6
        endif
      enddo     
    6 if(nss2.eq.maxn)nss2=nss1
      if(nocon.eq.0)then
        write(*,'(/1x,''nss1,nss2 skip first number of years: '',i3,2x,i3)')nss1,nss2
        if(nss1.gt.0)then
          maxn1=maxn-nss1
          call mnsd(crn1(nss1+1,1),maxn1,xmstdsav,sdstdsav)
        else
          maxn1=maxn
          call mnsd(crn1(1,1),maxn1,xmstdsav,sdstdsav)
        endif
        
        if(nss2.gt.0)then						         !added 01/05/2013
          maxn2=maxn-nss2	
          if(maxn2.lt.20)then				       
            nss2=nss1						             
            maxn2=maxn1						           
          endif						       
        else
          maxn2=maxn
        endif						                     !added 01/05/2013
        
        do i=1,maxn
          stdsav(i)=crn1(i,1)-xmstdsav+1.0
          crn1(i,1)=crn1(i,1)-xmstdsav+1.0                  !added 10/30/2012        
          crnsall(i,iter+1)=crn1(i,1)        
        enddo
      endif
      if(nss1.gt.0)then
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          if(ify.eq.ifmny)then
            ncset=j
            nreset=n-nss1
ccc            if(nocon.eq.0)write(*,'(/1x,i4,2x,a8,2x,5i6)')ncset,ident(j),ify,ily,n,nss1,nreset            
            if(nreset.gt.0)then        
              do i=1,nreset
                ii=i+nss1
                y(i)=x(ii,j)
              enddo
              call mnsd(y,nreset,xm1,sd)
            else
              nreset=nss1+1
              do i=1,n
                y(i)=x(i,j)
              enddo
              call mnsd(y,n,xm1,sd)
            endif          
ccc            if(nocon.eq.0)write(*,'(/1x,''full and truncated means: '',2f8.4)')xbar(j),xm1
            xbar(j)=xm1
          endif
        enddo
      else
        nreset=maxn
      endif

      call mnsd(crn1(nss1+1,1),maxn1,xm,sd)
      do i=1,maxn
cccccccccccccccc - New         
        if(cset.eq.'y')crn1(i,1)=crn1(i,1)-xm+1.0
cccccccccccccccc - New  
        if(crn1(i,1).lt.0)crn1(i,1)=0.0
        crn2(i,1)=crn1(i,1)
        crnsav(i)=crn1(i,1)
      enddo
      if(nocon.eq.0)then
        xlab='Years'
        call blank(ylab)
        ylab='Indices'
        call blank(tit)
        if(iopt.eq.0)tit(1:53)='Original Non-Variance Stabilized Raw Data Indices'
        if(iopt.ne.0)tit(1:53)='Original Non-Variance Stabilized Standard Indices'
        call blank(annot1)
        call blank(annot2)
        do i=1,maxn
          wrk1(i)=1.0
          ones(i)=1.0
        enddo
        iw1=1;iw2=1;iw3=2
        call plot1(mxy,crn1(1,1),wrk1,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
      endif
c
c *** perform running rbar and age-dependent spline variance stabilization on original standard indices
c
      if(istab.eq.'y')then
        if(nocon.eq.0.and.iopt.eq.0)
     *    write(*,'(/1x,''Perform raw data indices running rbar calculations'')')
        if(nocon.eq.0.and.iopt.ne.0)
     *    write(*,'(/1x,''Perform standard indices running rbar calculations'')')
        nlp=nsg-1
        call blank(fil1)
        fil1=filnam
        if(iopt.eq.0)fil1(ll+1:ll+13)='_Raw_RBAR.txt'
        if(iopt.ne.0)fil1(ll+1:ll+13)='_Std_RBAR.txt'
        open(iu33,file=fil1,status='unknown')
        call runbar(sfind,ybar,idate,nc,rxm,runr,ncnt,nsg,nlp,mxy,mxs,iu33,nocon)
        close(iu33)
        call blank(tit)
        if(iopt.eq.0)tit(1:45)='Raw Data Indices Running Average Correlations'
        if(iopt.ne.0)tit(1:45)='Standard Indices Running Average Correlations'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='RBAR'
        call blank(annot1)
        annot1(1:14)='Running RBAR ('
        if(nsg.lt.100)then
          write(annot1(15:16),'(i2)')nsg
          annot1(17:21)=' Yrs)'
        else
          write(annot1(15:17),'(i3)')nsg
          annot1(18:22)=' Yrs)'
        endif
        call blank(annot2)
        annot2(1:21)=' Constant Sample RBAR'
        ones(1)=-999.9
        if(nocon.eq.0)then
          iw1=1;iw2=2;iw3=2
          call plot1(mxy,runr(1,2),runr(1,4),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
          do i=1,maxn
            rbeps(i,1)=runr(i,2)
            rbeps(i,2)=runr(i,4)
            rcores=runr(i,1)
            rbar1=runr(i,2)
            eps1=(rcores*rbar1)/(rcores*rbar1+(1.0-rbar1))
            rbeps(i,3)=eps1
            rbar2=runr(i,4)
            eps2=(rcores*rbar2)/(rcores*rbar2+(1.0-rbar2))
            rbeps(i,4)=eps2
            ones(i)=0.85
          enddo
          call blank(ylab)
          ylab='EPS'
          annot1(1:14)=' Running EPS ('
          annot2(1:21)='  Constant Sample EPS'
          iw1=1;iw2=2;iw3=2
          call plot1(mxy,rbeps(1,3),rbeps(1,4),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
        endif
        do i=1,maxn
          crn3(i,1)=ybar(i,3)
        enddo
        call blank(ylab)
        ylab='Indices'
        call blank(tit)
        if(iopt.eq.0)tit(1:53)='Original Vs. Running RBAR Stabilized Raw Data Indices'
        if(iopt.ne.0)tit(1:53)='Original Vs. Running RBAR Stabilized Standard Indices'
        call blank(annot1)
        if(iopt.eq.0)annot1(1:23)='Original RAW Chronology'
        if(iopt.ne.0)annot1(1:23)='Original STD Chronology'
        call blank(annot2)
        if(iopt.eq.0)annot2(1:21)='Stable RAW Chronology'
        if(iopt.ne.0)annot2(1:21)='Stable STD Chronology'
        call mnsd(crn1(nss1+1,1),maxn1,xmo,sd)
        call mnsd(crn3(nss1+1,1),maxn1,xms,sd)
ccc        if(nocon.eq.0.and.iopt.eq.0)write(*,'(/1x,''Before RAW Orig/Stab Means: '',2f8.4)')xmo,xms
ccc        if(nocon.eq.0.and.iopt.ne.0)write(*,'(/1x,''Before STD Orig/Stab Means: '',2f8.4)')xmo,xms
        do i=1,maxn
          crn1(i,1)=crn1(i,1)-xmo+1.0
          crn3(i,1)=crn3(i,1)-xms+1.0
          if(crn1(i,1).lt.0)crn1(i,1)=0.0
          if(crn3(i,1).lt.0)crn3(i,1)=0.0
          ones(i)=1.0
        enddo
        call mnsd(crn1(nss1+1,1),maxn1,xmo,sd)
        call mnsd(crn3(nss1+1,1),maxn1,xms,sd)
	       iw1=1;iw2=1;iw3=2
        if(nocon.eq.0)call plot1(mxy,crn1(1,1),crn3(1,1),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)

   13   do i=1,maxn
          wrk1(i)=crn3(i,1)
          wrk2(i)=crn3(i,1)
          ones=0.0
        enddo     
        if(isb.ne.0)then
          if(isb.eq.1)then
            call stabit(wrk1,f,wrk2,nss,maxn)
            write(iu9,'(/1x,''DEFAULT AGE-DEPENDENT SPLINE VARIANCE STABILIZATION APPLIED'')')
          else
            ls=isb
            call stabit1(wrk1,f,wrk2,nss,maxn,ls,mxy)
            write(iu9,'(/1x,''FIXED FILTER SPLINE VARIANCE STABILIZATION APPLIED: '',I4)')ls
          endif
        endif
        call blank(tit)
        tit(1:52)='Spline Detrending of Running RBAR Stabilized Indices'
        call blank(annot1)
        annot1(1:22)='  Absolute Differences'
        call blank(annot2)
        if(isb.eq.1)then
          annot2(1:20)='Age-Dependent Spline'
        elseif(iabs(isb).ge.10)then
          annot2(1:14)='Spline in Yrs:'
          write(annot2(16:20),'(i5)')ls
        endif
        if(nocon.eq.0.and.isb.ne.0)then
          iw1=1;iw2=2;iw3=1
          call plot1(mxy,wrk1,f,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
        endif
        do i=1,maxn
          wrk1(i)=crn3(i,1)
          ones(i)=1.0
        enddo
        call blank(tit)
        if(iopt.eq.0)tit(1:56)='RBAR Only Vs. Detrended RBAR Stabilized Raw Data Indices'
        if(iopt.ne.0)tit(1:56)='RBAR Only Vs. Detrended RBAR Stabilized Standard Indices'
        call blank(annot1)
        if(iopt.eq.0)annot1(1:22)='RBAR Stablized RAW Crn'
        if(iopt.ne.0)annot1(1:22)='RBAR Stablized STD Crn'
        call blank(annot2)
        if(iopt.eq.0)annot2(1:22)='DETR Stablized RAW Crn'
        if(iopt.ne.0)annot2(1:22)='DETR Stablized STD Crn'
        call mnsd(wrk2(nss1+1),maxn1,xmstd2,sdstd2)
        do i=1,maxn
          wrk2(i)=wrk2(i)-xmstd2+1.0
          if(wrk2(i).lt.0)wrk2(i)=0.0
        enddo
        if(nocon.eq.0.and.isb.ne.0)then
          iw1=1;iw2=1;iw3=2
          call plot1(mxy,wrk1,wrk2,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
   14     yn=' '
          write(*,'(/1x,''Happy with this spline stabilization? <Y>/N'',t50,''==> '',$)')
          read(*,'(a)')yn
          if(yn.eq.'N'.or.yn.eq.'n')then
            call blank(cdat)
   15       write(*,'(/1x,''Additional spline variance stabilization?''/
     *        1x,''No additional spline stabilization'',t39,''<0>''/
     *        1x,''Age-dependent spline stabilization'',t39,'' 1''/
     *        1x,''Smoothing spline (percent N cutoff)'',t39,''<-9''/
     *        1x,''Smoothing spline (fixed Yrs cutoff)'',t39,''>+9'',t50,''==> '',$)')
            read(*,'(a)')cdat
            if(cdat(1:1).eq.'/')stop
            if(cdat(1:1).eq.' ')cdat(1:1)='0'
            call intfrm(cdat,frm)
            read(cdat,frm,err=15)isb
            if(isb.gt.1.and.isb.lt.10)goto 15
            if(isb.lt.0.and.isb.gt.-10)goto 15
            write(iu9,'(/1x,''*******************************************************'')')
            write(iu9,'(/1x,''DEFAULT SPLINE VARIANCE STABILIZATION CHANGED TO: '',i5)')isb
            write(iu9,'(/1x,''*******************************************************'')')
            goto 13
          elseif(yn.eq.'Y'.or.yn.eq.'y'.or.yn.eq.' ')then
            do i=1,maxn
              crn3(i,1)=wrk2(i)
            enddo
          else
            write(*,'(/1x,''Y or <RET> for Yes or N for no, okay?'')')
            goto 14
          endif
          
        endif
      endif
c    
      if(iopt.eq.0)then
        iopt=6
ccc        itype=.true.
ccc        pt=.false.
      endif     
c
c *** do the signal free iterations
c
    9 iter=0
      small1=9999.0
      small2=9999.0
      small3=9999.0
      small4=9999.0
      write(iu9,'(/36x,''| -------- SIGNAL FREE CONVERGENCE STATISTICS ------- |'')')
      write(iu9,'(36x,''UW MN ABSD     UW MD ABSD     WT MN ABSD     WT MD ABSD'')')
   10 continue
      iter=iter+1
      call blank(fil1)
      fil1=filnam
      if(.not.itype)then
        fil1(ll+1:ll+17)='_SSF_RAW_Data.txt'
      else
        if(pt)then
          fil1(ll+1:ll+17)='_SSF_PTR_Data.txt'
        else
          fil1(ll+1:ll+17)='_SSF_RAW_Data.txt'
        endif
      endif
      open(iu30,file=fil1,status='unknown')
      close(iu30,status='delete')
      open(iu30,file=fil1,status='unknown')
      call blank(fil1)
      fil1=filnam
      if(.not.itype)then
        fil1(ll+1:ll+19)='_SSF_RAW_Curves.txt'
      else
        if(pt)then
          fil1(ll+1:ll+19)='_SSF_PTR_Curves.txt'
        else
          fil1(ll+1:ll+19)='_SSF_RAW_Curves.txt'
        endif
      endif
      open(iu31,file=fil1,status='unknown')
      close(iu31,status='delete')
      open(iu31,file=fil1,status='unknown')
      call blank(fil1)
      fil1=filnam
      if(.not.itype)then
        fil1(ll+1:ll+19)='_SSF_RAW_Ratios.txt'
      else
        if(pt)then
          fil1(ll+1:ll+19)='_SSF_PTR_Resids.txt'
        else
          fil1(ll+1:ll+19)='_SSF_RAW_Resids.txt'
        endif
      endif
      open(iu32,file=fil1,status='unknown')
      close(iu32,status='delete')
      open(iu32,file=fil1,status='unknown')
      write(iu30,'(a)')itrdb(1)
      write(iu31,'(a)')itrdb(1)
      write(iu32,'(a)')itrdb(1)
c        
      do i=1,mxlen
        do j=1,mxser
          sfind1(i,j)=-999.0
        enddo
      enddo

      if(rcs)then

ccc        call blank(fil1)
ccc        fil1=filnam
ccc        fil1(ll+1:ll+11)='_Sigmas.txt'
ccc        open(iu69,file=fil1,status='unknown')
ccc        close(iu69,status='delete')
ccc        open(iu69,file=fil1,status='unknown')

c       rcmax if 0 then mvf  is computed over the entire rc otherwise rcmax = length of rc to use in computing mvf
c       calculate y and store them in yrcs to compute a regional curve from them
 
        do j=1,nc
          do i=1,mxy
            yrcs(i,j)=-999.0
          enddo
          ify=idate(j,1)
          ily=idate(j,2)
          ily1=idate(j,3)
          n=ily-ify+1
          n1=ily1-ify+1
          iskp=ify-ifmny

          if(.not.itype)then                     !Start Ed's changes 12/10/2012
            do i=1,n
              ii=i+iskp
              if(nss(ii).gt.1)then
                y(i)=x(ii,j)/crn2(ii,1)
              else
                y(i)=x(ii,j)
              endif
            enddo
          elseif(itype)then
            do i=1,n
              ii=i+iskp
              if(nss(ii).gt.1)then
                y(i)=x(ii,j)-crn2(ii,1)
              else
                y(i)=x(ii,j)
              endif
            enddo
          endif
          if(reset.eq.'y')then
            if(.not.itype)then
              if(nss1.gt.0.and.j.eq.ncset)then
                call mnsd(y(nss1+1),nreset,xm1,sd)
                do i=1,nreset
                  y(nss1+i)=y(nss1+i)/xm1*xbar(j)
                enddo
              else
                call mnsd(y,n,xm1,sd)
                do i=1,n
                  y(i)=y(i)/xm1*xbar(j)
                enddo
              endif
            elseif(itype)then
              if(nss1.gt.0.and.j.eq.ncset)then
                call mnsd(y(nss1+1),nreset,xm1,sd)
                do i=1,nreset
                  y(nss1+i)=y(nss1+i)-xm1+xbar(j)
                enddo
              else
                call mnsd(y,n,xm1,sd)
                do i=1,n
                  y(i)=y(i)-xm1+xbar(j)
                enddo
              endif
            endif
          endif                                  !End Ed's changes 12/10/2012
 
          nmax=max(n1,n)    !complete length of regional curve
          do i=1,nmax
            yrcs(i,j)=y(i)
          enddo
          iopt1(j,iter+2)=iopt
        enddo   !end do j
c
        call rcurve(mxlen,mxser,nc,yrcs,xrc,f,idate,pith,flag,nmax,eq,iopt,alpha,ndt,poff,
     *    rcmax,mnpoff,istrtls) 			!(xrc is the regional mean) (f is the regional curve)
        string='Iteration       Regional Curve MVF '  
        write(string(11:14),'(i4)')iter
        if(plotall)call plt1(mxy,mxs,xrc,f,1,mxage,flag,string,mnpoff)
        rcnt=rcnt+1
        do jj=1+mnpoff,mxage
          rcscrv(jj,1,rcnt)=xrc(jj);rcscrv(jj,2,rcnt)=f(jj)
        enddo
c
        miny=9999.
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          ily1=idate(j,3)
          n=ily-ify+1
          n1=ily1-ify+1
          iskp=ify-ifmny
          if(switch.eq.'n'.and.iter.ge.5)then
ccc            if((iopt1(j,iter+2).ne.iopt1(j,iter+1)).or.(iopt1(j,iter+1).eq.5))then
            if((iopt1(j,iter+2).ne.iopt1(j,iter+1)).or.(iopt1(j,iter+1).eq.6))then
              if(iopt.eq.1.or.opt.eq.2)then
                iopt1(j,iter+2)=-66
              else
                iopt1(j,iter+2)=6
              endif
             	call rcurve(mxlen,mxser,nc,yrcs,xrc,f,idate,pith,flag,nmax,eq,iopt1(j,iter+2),alpha,
     *          ndt,poff,rcmax,mnpoff,istrtls) !xrc is the regional mean (f is the regional curve)
              call plt1(mxy,mxs,xrc,f,1,mxage,flag,string,mnpoff)
              rcnt=rcnt+1
              do jj=1+mnpoff,mxage
                rcscrv(jj,1,rcnt)=xrc(jj);rcscrv(jj,2,rcnt)=f(jj)
              enddo
            endif
          endif
c
          poset=pith(j)
          do i=1,n
            ii=i+iskp
            wrk1(i)=y(i)
            y(i)=x(ii,j)
            wrk2(i)=x(ii,j)
            wrk3(i)=f(i+poset)
          enddo
          if(.not.itype)then
            call calind(wrk2,wrk3,wrk4,n,1,mxlen)
          else
            call calind(wrk2,wrk3,wrk4,n,2,mxlen)
          endif
          do i=1,n
            ii=i+iskp
            sfind(ii,j)=wrk4(i)
            
            sfind1(ii,j)=wrk4(i)           !Added on 03/10/13 to fix RCS problem

            if(.not.itype)then
              wrk1(i)=wrk1(i)-rwconst
              wrk3(i)=wrk3(i)-rwconst
            else
ccc              wrk1(i)=wrk1(i)
ccc              wrk3(i)=wrk3(i)
              wrk1(i)=wrk1(i)-rwconst
              wrk3(i)=wrk3(i)-rwconst
            endif

          enddo
          call trrw(ident(j),ify,n,wrk1,nss,ifl,iu30,iuo,'mw',tit,'ssfraw',mxy,itrdb)
          call trrw(ident(j),ify,n,wrk3,nss,ifl,iu31,iuo,'mw',tit,'ssfcrv',mxy,itrdb)
          call trrw(ident(j),ify,n,wrk4,nss,ifl,iu32,iuo,'mw',tit,'ssfind',mxy,itrdb)
c optional plot current RC MVF and RCS            
          string='Iteration #                        '  
          write(string(13:16),'(i4)')iter
          if(plotall)call plt3(mxy,mxs,wrk2,y,f,idate,flag,nmax,j,n,ident,string,plotall,pith,mnpoff)
        enddo   !end do j
      else  ! NO RCS      

ccc        call blank(fil1)
ccc        fil1=filnam
ccc        fil1(ll+1:ll+11)='_Sigmas.txt'
ccc        open(iu69,file=fil1,status='unknown')
ccc        close(iu69,status='delete')
ccc        open(iu69,file=fil1,status='unknown')

        miny=9999.    !new 12/10/2012 pjk
        
ccc        do i=1,mxlen
ccc          do j=1,mxser
ccc            sfind1(i,j)=-999.0
ccc          enddo
ccc        enddo

        do j=1,nc
          jtest(j,iter+2)=0
          ify=idate(j,1)
          ily=idate(j,2)
          ily1=idate(j,3)
          n=ily-ify+1
          n1=ily1-ify+1
          iskp=ify-ifmny

          if(.not.itype)then                     !Start Ed's changes 12/10/2012
            do i=1,n
              ii=i+iskp
              if(cook.eq.'n')then
                if(nss(ii).gt.1.and.crn2(ii,1).gt.0)then   !Possible division by zero bug fix
                  y(i)=x(ii,j)/crn2(ii,1)
                else
                  y(i)=x(ii,j)
                endif
              elseif(cook.eq.'y')then
                if(nss(ii).gt.1.and.crn2(ii,1).gt.0)then   !Possible division by zero bug fix
                  y(i)=x(ii,j)/crn2(ii,1)
                else
                  y(i)=x(ii,j)
                endif
              endif
            enddo
          elseif(itype)then
            do i=1,n
              ii=i+iskp
              if(cook.eq.'n')then
                if(nss(ii).gt.1)then
                  y(i)=x(ii,j)-crn2(ii,1)
                else
                  y(i)=x(ii,j)
                endif
              elseif(cook.eq.'y')then
                if(nss(ii).gt.1)then
                  y(i)=x(ii,j)-crn2(ii,1)
                else
                  y(i)=x(ii,j)
                endif
              endif
            enddo
          endif
          if(reset.eq.'y')then
            if(.not.itype)then
              if(nss1.gt.0.and.j.eq.ncset)then
                call mnsd(y(nss1+1),nreset,xm1,sd)
                do i=1,nreset
                  y(nss1+i)=y(nss1+i)/xm1*xbar(j)
                enddo
              else
                call mnsd(y,n,xm1,sd)
                do i=1,n
                  y(i)=y(i)/xm1*xbar(j)
                enddo
              endif
            elseif(itype)then
              if(nss1.gt.0.and.j.eq.ncset)then
                call mnsd(y(nss1+1),nreset,xm1,sd)
                do i=1,nreset
                  y(nss1+i)=y(nss1+i)-xm1+xbar(j)
                enddo
              else
                call mnsd(y,n,xm1,sd)
                do i=1,n
                  y(i)=y(i)-xm1+xbar(j)
                enddo
              endif
            endif
          endif                                  !End Ed's changes 12/10/2012
            
          if(itype)then
            rmin=9999.
            do i=1,n
              if(y(i).lt.0)then
                if(y(i).lt.rmin)rmin=y(i)
              endif
            enddo
            if(rmin.lt.9999.)then
              do i=1,n
                y(i)=y(i)+abs(rmin)
              enddo
            endif
          endif
            
          iopt1(j,iter+2)=iopt
          call curvefits(y,f,ify,n,n1,ident(j),iopt1(j,iter+2),alpha,mxy,mxs,istrtls,nis) 
          if(switch.eq.'n'.and.iter.ge.5)then
            if((iopt1(j,iter+2).ne.iopt1(j,iter+1)).or.(iopt1(j,iter+1).eq.6))then
              if(iopt.eq.1.or.opt.eq.2)then
                iopt1(j,iter+2)=-66
              else
                iopt1(j,iter+2)=6
              endif
              call curvefits(y,f,ify,n,n1,ident(j),iopt1(j,iter+2),alpha,mxy,mxs,istrtls,nis)      
            endif
          endif
c                  
          ioptt=iopt1(j,iter+2)
          do i=1,n
            if(iter.eq.1)then
              if(f(i).lt.curmin(j))then
                f(i)=curmin(j)
                if(i.eq.1)jtest(j,iter+2)=j
              endif
            elseif(iter.gt.1.and.jtest(j,iter+2-1).eq.0)then
              if(f(i).lt.curmin(j))then
                f(i)=curmin(j)
                if(i.eq.1)jtest(j,iter+2)=j
              endif
            elseif(iter.gt.1.and.jtest(j,iter+2-1).eq.j)then
              if(f(i).lt.curmin(j))then
                f(i)=curmin(j)
                if(i.eq.1)jtest(j,iter+2)=j
              endif
            endif
          enddo

          poset=0
          do i=1,n
            ii=i+iskp
            wrk1(i)=y(i)
            y(i)=x(ii,j)
            wrk2(i)=x(ii,j)
            wrk3(i)=f(i+poset)
          enddo
          if(.not.itype)then
            call calind(wrk2,wrk3,wrk4,n,1,mxlen)
          else
            call calind(wrk2,wrk3,wrk4,n,2,mxlen)
          endif
          do i=1,n
            ii=i+iskp
            sfind(ii,j)=wrk4(i)
            if(.not.itype)then
              wrk1(i)=wrk1(i)-rwconst
              wrk3(i)=wrk3(i)-rwconst
              x2(i,j)=wrk3(i)
              x4(i,j)=wrk1(i)
            else
ccc              wrk1(i)=wrk1(i)
ccc              wrk3(i)=wrk3(i)
              wrk1(i)=wrk1(i)-rwconst
              wrk3(i)=wrk3(i)-rwconst
              x2(i,j)=wrk3(i)
              x4(i,j)=wrk1(i)
            endif
            x6(i,j)=wrk4(i)
          enddo          

ccc          if(nocon.eq.0)then
                  
            call mnsd(wrk4,n,xm,sd)
            sigmas(j,nocon+2)=sd
ccc            sff0=sigmas(j,2)
            if(.not.itype.and.nocon.gt.0)then
              sff0=sigmas(j,1)               !Change made 06/01/2013
            else
              sff0=sd
            endif
            do i=1,n
              ii=i+iskp
              datum=wrk4(i)
              datum=(datum-xm)/sd
              datum=datum*sff0+xm
              wrk4(i)=datum
              sfind1(ii,j)=wrk4(i)
            enddo
            call mnsd(wrk4,n,xm,sd)
            sigmas(j,nocon+3)=sd
        
            call trrw(ident(j),ify,n,wrk1,nss,ifl,iu30,iuo,'mw',tit,'ssfraw',mxy,itrdb)
            call trrw(ident(j),ify,n,wrk3,nss,ifl,iu31,iuo,'mw',tit,'ssfcrv',mxy,itrdb)
            call trrw(ident(j),ify,n,wrk4,nss,ifl,iu32,iuo,'mw',tit,'ssfind',mxy,itrdb)
            
ccc          endif
                     
        enddo   !end do j
        
ccc        write(iu69,'(3x,''NC    IDENT      STD    SSF0'',100i8)')(j,j=1,nocon)
ccc        do j=1,nc
ccc          write(iu69,'(i5,3x,a,100f8.4)')j,ident(j),(sigmas(j,k),k=1,nocon+3)
ccc        enddo
ccc        close(iu69)

      endif   !     if RCS
c      
c      write(*,'(/38x,''Mean ABS      Mean dABS     Mean ddABS      Maxx ABS'')')
c      
      close(iu30)
      close(iu31)
      close(iu32)
c
c *** now calculate the signal free mean chronology
c
      do j=1,nc
        do i=1,maxn
          wgts(i,j)=-999.0
        enddo
      enddo
      call robsum(sfind,wgts,maxn,nc,crn2(1,1),crn2(1,2),eff,nss,irob,mxy,mxs)
      call mnsd(crn2(1,1),maxn,xmstd1,sdstd1)
      do i=1,maxn
        if(crn2(i,1).lt.0)crn2(i,1)=0.0
        ybar(i,1)=crn2(i,1)                      !runcor bit added 01/03/11        
        crnsall(i,iter+1)=crn2(i,1)
      enddo  
      call mnsd(crn2(nss1+1,1),maxn1,xm,sd)
c
c *** set the chronology mean to exactly 1.0
c
      if(cset.eq.'y')then
        do i=1,maxn
          crn2(i,1)=crn2(i,1)-xm+1.0
          if(crn2(i,1).lt.0)crn2(i,1)=0.0
          crnsall(i,iter+1)=crn2(i,1)       
        enddo

        if(iter.gt.1)then
          do i=1,nss2
            crn2(i,1)=crnsall(i,iter)
            crnsall(i,iter+1)=crnsall(i,iter)						!!!Wow!!!       
          enddo
        endif

      endif
      do i=1,maxn
        y(i)=crnsav(i)-crn2(i,1)
        savit(i,iter)=y(i)
      enddo
c
c *** high-pass filter the differences according to Tom's average segment length spline smoothing
c
      if(hpfilt.eq.'y')then
        do i=1,maxn-2
          ls(i)=segmn(i+1)
        enddo
        call spline2(maxn,y,f,ls)
        do i=1,maxn
          y(i)=y(i)-f(i)
        enddo
      endif
c
c *** compute the convergence statistics - Tom's average absolute difference criterion
c
      if(cook.eq.'n')then
        do i=1,maxn
          f(i)=abs(y(i))
        enddo
        call sftest(f,wrk1,nss,maxn,t1,t2,t3,t4,mxy,mxlen)
      elseif(cook.eq.'y')then

ccc        do i=1,maxn1
ccc          ii=i+nss1
ccc          f(i)=abs(y(ii))
ccc        enddo
ccc        call sftest(f,wrk1,nss(nss1+1),maxn1,t1,t2,t3,t4,mxy,mxlen)

        do i=1,maxn2
          ii=i+nss2
          f(i)=abs(y(ii))
        enddo
        call sftest(f,wrk1,nss(nss2+1),maxn2,t1,t2,t3,t4,mxy,mxlen)
      endif
      if(t1.lt.small1)then
        small1=t1
        star1='*'
      else
        star1=' '
      endif
      if(t2.lt.small2)then
        small2=t2
        star2='*'
      else
        star2=' '
      endif
      if(t3.lt.small3)then
        small3=t3
        star3='*'
      else
        star3=' '
      endif
      if(t4.lt.small4)then
        small4=t4
        star4='*'
      else
        star4=' '
      endif
      test1(iter)=t1
      test2(iter)=t2
      test3(iter)=t3
      test4(iter)=t4
      write(iu9,'(1x,''Iter '',i3,''  Convergence Criteria: '',f13.8,a,3(f14.8,a))')
     *  iter,t1,star1,t2,star2,t3,star3,t4,star4
c
c *** test for convergence now using the user-supplied mean absolute difference threshold
c
      if(cmed.eq.'n')then
        if(iter.gt.1)then
          if(ioptsave.eq.-2.or.ioptsave.eq.0.or.ioptsave.eq.1.or.ioptsave.eq.2.or.ioptsave.eq.6)then
            t0=test1(iter-1)
            t1=test1(iter)
          else
            t0=test3(iter-1)
            t1=test3(iter)
          endif
        endif
      elseif(cmed.eq.'y')then
        if(iter.gt.1)then
          if(ioptsave.eq.-2.or.ioptsave.eq.0.or.ioptsave.eq.1.or.ioptsave.eq.2.or.ioptsave.eq.6)then
            t0=test2(iter-1)
            t1=test2(iter)
          else
            t0=test4(iter-1)
            t1=test4(iter)
          endif
        endif
      endif
      if(t1.le.tol)then
        nocon1=nocon
        nocon=0
        goto 20
      elseif(iter.eq.maxit)then
        nocon1=nocon
        nocon=0
        goto 20
cccccccccccccccc - New         
      elseif(iter.gt.6.and.(t1.gt.t0))then
        if(nocon.le.10)then
          write(*,'(/1x,''WARNING: CONVERGENCE TESTS ARE NOT MONOTONIC DECREASING, ITER:'',t67,i3)')iter
          write(iu9,'(/1x,''WARNING: CONVERGENCE TESTS ARE NOT MONOTONIC DECREASING, ITER:'',t67,i3)')iter
        endif
        do i=1,maxn
          crn2(i,1)=crnsav(i)
        enddo
      
ccc        if(cook.eq.'y')then
ccc          do i=1,nss1
ccc            crn2(i,1)=crn1(i,1)		!New grab-ass bullshit
ccc          enddo
ccc        endif
      
        iter=iter-1
        nocon=nocon+1

        if(nocon.gt.10)then

          nocon1=nocon			!New
        
          write(*,'(/1x,''OKAY, ADDING A CONSTANT TO THE DATA USUALLY RESULTS IN CONVERGENCE''/
     *      1x,''EVENTUALLY WHEN USING FLEXIBLE DATA-ADAPTIVE CURVE FITS LIKE THE''/
     *      1x,''SPLINE OR FRIEDMAN SMOOTHER. BUT NOT THIS TIME. EVEN SO, THE FINAL''/
     *      1x,''CONVERGENCE TRACE MAY BE CLOSE ENOUGH TO FLAT TO BE ACCEPTABLE.''/)')
          pause' Hit return to continue ...'
        
          goto 20
        else
          return
        endif
cccccccccccccccc - New
      elseif(t1.gt.tol)then
      
ccc        if(cook.eq.'y')then
ccc          do i=1,nss1
ccc            crn2(i,1)=crn1(i,1)		!New grab-ass bullshit
ccc          enddo
ccc        endif
      
        do i=1,maxn
          crnsav(i)=crn2(i,1)
        enddo
        goto 10
      endif
c
   20 continue
   
ccc      call blank(fil1)
ccc      fil1=filnam
ccc      fil1(ll+1:ll+11)='_Sigmas.txt'
ccc      open(iu69,file=fil1,status='old')

ccc      if(.not.rcs)then
        call robsum(sfind1,wgts,maxn,nc,crn2(1,1),crn2(1,2),eff,nss,irob,mxy,mxs)
ccc      endif

      if(rcs)then
         call blank(fil1)
         fil1=filnam
         fil1(ll+1:ll+14)='_RCScurves.txt'
         open(iu70,file=fil1,status='unknown')
         string='   RC     fRC '   
         write(iu70,'(a10,200(a15,1x))')'Bio Year ',(string,j=1,rcnt)
         do p=1,nmax
           write(iu70,'(400f8.2)')float(p),((rcscrv(p,j,k),j=1,2),k=1,rcnt)
         enddo
         close(iu70)
         call plt4(mxlen,maxit,rcscrv,nmax,rcnt,mnpoff,flag)
         call plt5(mxlen,maxit,rcscrv,nmax,rcnt,mnpoff,flag)
      endif

      if(.not.rcs)then
        call blank(tit)
        if(nocon.eq.0)tit='Convergent Curvefits For Signal Free Chronology'
        if(nocon.gt.0)tit='Non-Convergent Curvefits For Signal Free Chronology'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='Measurements'
        call blank(annot1)
c       annot1='Curvefits For Standard Chronology'
        call blank(annot2)
        annot1='Iteration: '
        if(nocon.eq.0)then
          write(annot1(12:14),'(i3)')iter
        elseif(nocon.gt.0)then
          write(annot1(12:14),'(i3)')iter+1
        endif
        ones(1)=-999.9
c
        if(irob.eq.2)then
          call blank(tit)
          tit='Biweights For Signal Free Chronology'
          call blank(xlab)
          xlab='Years'
          call blank(ylab)
          ylab='Biweights'
          call blank(annot1)
          call blank(annot2)
          annot1='Iteration: '
          write(annot1(12:14),'(i3)')iter
          annot1(17:36)='hh,med,hl,min biwgts'
          do i=1,maxn
            ones(i)=1.0
          enddo
          call spaghetti(wgts,ones,maxn,4,ifmny,xlab,ylab,tit,annot1,annot2,mxlen,mxser) 
        endif
        
        call blank(tit)
        tit='Original and Final Signal Free Raw Data'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='Measurements'
        call blank(annot1)
        annot1='Iteration:   0'
        call blank(annot2)
        annot2='Iteration: '
        write(annot2(12:14),'(i3)')iter
        ones(1)=-999.9
        call linguine2(x3,x4,ones,nc,idate,xlab,ylab,tit,annot1,annot2,mxlen,mxser,mxs)
                
        call blank(tit)
        tit='Original and Final Signal Free Curvefits'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='Measurements'
        call blank(annot1)
        annot1='Iteration:   0'
        call blank(annot2)
        annot2='Iteration: '
        write(annot2(12:14),'(i3)')iter
        ones(1)=-999.9
        call linguine2(x1,x2,ones,nc,idate,xlab,ylab,tit,annot1,annot2,mxlen,mxser,mxs)
                
        call blank(tit)
        tit='Original and Final Signal Free Indices'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='Measurements'
        call blank(annot1)
        annot1='Iteration:   0'
        call blank(annot2)
        annot2='Iteration: '
        write(annot2(12:14),'(i3)')iter
        do i=1,maxn
          ones(i)=1.0
        enddo
        call linguine2(x5,x6,ones,nc,idate,xlab,ylab,tit,annot1,annot2,mxlen,mxser,mxs)
        
      endif

c
      if(iter.lt.maxit)then            
        write(*,'(/1x,''Final iteration with convergence (<'',f6.4,'' change): '',i2)')tol,iter
        write(iu9,'(/1x,''FINAL ITERATION WITH CONVERGENCE (<'',f6.4,'' CHANGE): '',i2)')tol,iter
      else
        write(*,'(/1x,''Maximum iterations used without converging (<'',f6.4,'' change): '',i2)')tol,iter
        write(*,'(/1x,''If you are not satisfied, try a simpler (more monotonic) curve ''
     *    ''fit like a negative''/1x,''exponential curve, or if you were computing ''
     *    ''ratios, try computing power transformed''/1x,''residuals instead with ''
     *    ''the same curvefit option that did not converge. Often works.'')')  
        write(iu9,'(/1x,''MAXIMUM ITERATIONS USED WITHOUT CONVERGING (<'',f6.4,'' CHANGE): '',i2)')tol,iter      
        write(iu9,'(/1x,''IF YOU ARE NOT SATISFIED, TRY A SIMPLER (MORE MONOTONIC) CURVE ''
     *    ''FIT LIKE A NEGATIVE''/1X,''EXPONENTIAL CURVE, OR IF YOU WERE COMPUTING ''
     *    ''RATIOS, TRY COMPUTING POWER TRANSFORMED''/1X,''RESIDUALS INSTEAD WITH ''
     *    ''THE SAME CURVEFIT OPTION THAT DID NOT CONVERGE. OFTEN WORKS.'')')  
      endif
      call blank(tit)
      if(irob.eq.1)then
        tit(1:41)='Original & Signal Free Chronology, Iter ='
        write(tit(42:44),'(i3)')iter
      elseif(irob.eq.2)then
        tit(1:48)='Robust Original & Signal Free Chronology, Iter ='
        write(tit(49:51),'(i3)')iter
      endif
      call blank(ylab)
      ylab(1:7)='Indices'
      if(ioptsave.eq.0)then
        call blank(annot1)
        annot1(1:23)='Original RAW Chronology'
        call blank(annot2)
        annot2(1:21)='Mean Adjust RAW Chron'
      else
        call blank(annot1)
        annot1(1:23)='Original STD Chronology'
        call blank(annot2)
        annot2(1:21)='Signal Free STD Chron'
      endif
      do i=1,maxn
        f(i)=1.0
      enddo
      
      if(nss2.gt.0)then
        call mnsd(stdsav(nss2+1),maxn2,xmstdsav,sdstdsav)
        call mnsd(crn1(nss2+1,1),maxn2,xmstdfinal,sdstdfinal)
        call mnsd(crn2(nss2+1,1),maxn2,xmssffinal,sdssffinal)
ccc        write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal
        do i=1,maxn2
          ii=i+nss2
          wrk1(i)=stdsav(ii)
          wrk2(i)=crn1(ii,1)
          wrk3(i)=crn2(ii,1)
        enddo
        call xbiwt(wrk1,maxn2,xmstdsav1,sdstdsav1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk2,maxn2,xmstdfinal1,sdstdfinal1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk3,maxn2,xmssffinal1,sdssffinal1,xlbiwt1,xsbiwt1,eff)
ccc        write(*,'(1x,6f8.3)')xmstdsav1,sdstdsav1,xmstdfinal1,sdstdfinal1,xmssffinal1,sdssffinal1
      else
        call mnsd(stdsav,maxn,xmstdsav,sdstdsav)
        call mnsd(crn1(1,1),maxn,xmstdfinal,sdstdfinal)
        call mnsd(crn2(1,1),maxn,xmssffinal,sdssffinal)
ccc        write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal
        do i=1,maxn
          wrk1(i)=stdsav(i)
          wrk2(i)=crn1(i,1)
          wrk3(i)=crn2(i,1)
        enddo
        call xbiwt(wrk1,maxn,xmstdsav1,sdstdsav1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk2,maxn,xmstdfinal1,sdstdfinal1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk3,maxn,xmssffinal1,sdssffinal1,xlbiwt1,xsbiwt1,eff)
ccc        write(*,'(1x,6f8.3)')xmstdsav1,sdstdsav1,xmstdfinal1,sdstdfinal1,xmssffinal1,sdssffinal1
      endif
      
ccc      write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal
      
      if(nocon1.gt.0)then

ccc        do i=1,maxn
ccc          datum1=(crn1(i,1)-xmstdfinal)/sdstdfinal
ccc          crn1(i,1)=datum1*sdstdsav+1.0          
ccc          wrk1(i)=crn1(i,1)
ccc        enddo
ccc        call spline(maxn,wrk1,f,pp,50)
ccc        do i=1,maxn
ccc          wrk1(i)=wrk1(i)-f(i)
ccc        enddo
ccc        do i=1,maxn
ccc          wrk2(i)=crn2(i,1)
ccc        enddo
ccc        call spline(maxn,wrk2,f,pp,50)
ccc        do i=1,maxn
ccc          wrk2(i)=wrk2(i)-f(i)
ccc        enddo
ccc        call mnsd(wrk1,maxn,xm1,sd1)
ccc        call mnsd(wrk2,maxn,xm2,sd2)
ccc        do i=1,maxn
ccc          datum=(wrk2(i)-xm2)/sd2
ccc          datum=datum*sd1+xm2
ccc          crn2(i,1)=datum+f(i)
ccc          ybar(i,1)=crn2(i,1)
ccc        enddo

        do i=1,maxn        
          datum1=(crn1(i,1)-xmstdfinal)/sdstdfinal
          crn1(i,1)=datum1*sdstdsav+1.0          
          datum2=(crn2(i,1)-xmssffinal)/sdssffinal
          crn2(i,1)=datum2*sdstdsav+1.0
          if(crn2(i,1).lt.0)crn2(i,1)=0.0
          ybar(i,1)=crn2(i,1)
        enddo      
  
      else            
        do i=1,maxn
          crn1(i,1)=stdsav(i)-xmstdsav+1.0
          crn2(i,1)=crn2(i,1)-xmssffinal+1.0
          ybar(i,1)=crn2(i,1)
        enddo              
      endif

      if(nss2.gt.0)then
        call mnsd(stdsav(nss2+1),maxn2,xmstdsav,sdstdsav)
        call mnsd(crn1(nss2+1,1),maxn2,xmstdfinal,sdstdfinal)
        call mnsd(crn2(nss2+1,1),maxn2,xmssffinal,sdssffinal)
ccc        write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal
        do i=1,maxn2
          ii=i+nss2
          wrk1(i)=stdsav(ii)
          wrk2(i)=crn1(ii,1)
          wrk3(i)=crn2(ii,1)
        enddo
        call xbiwt(wrk1,maxn2,xmstdsav1,sdstdsav1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk2,maxn2,xmstdfinal1,sdstdfinal1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk3,maxn2,xmssffinal1,sdssffinal1,xlbiwt1,xsbiwt1,eff)
ccc        write(*,'(1x,6f8.3)')xmstdsav1,sdstdsav1,xmstdfinal1,sdstdfinal1,xmssffinal1,sdssffinal1
      else
        call mnsd(stdsav,maxn,xmstdsav,sdstdsav)
        call mnsd(crn1(1,1),maxn,xmstdfinal,sdstdfinal)
        call mnsd(crn2(1,1),maxn,xmssffinal,sdssffinal)
ccc        write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal
        do i=1,maxn
          wrk1(i)=stdsav(i)
          wrk2(i)=crn1(i,1)
          wrk3(i)=crn2(i,1)
        enddo
        call xbiwt(wrk1,maxn,xmstdsav1,sdstdsav1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk2,maxn,xmstdfinal1,sdstdfinal1,xlbiwt1,xsbiwt1,eff)
        call xbiwt(wrk3,maxn,xmssffinal1,sdssffinal1,xlbiwt1,xsbiwt1,eff)
ccc        write(*,'(1x,6f8.3)')xmstdsav1,sdstdsav1,xmstdfinal1,sdstdfinal1,xmssffinal1,sdssffinal1
      endif      
      iw1=1;iw2=1;iw3=2
      call plot1(mxy,crn1(1,1),crn2(1,1),maxn,ifmny,xlab,ylab,tit,f,annot1,annot2,iw1,iw2,iw3)
c
c *** perform running rbar and age-dependent spline variance stabilization on signal free indices
c
      if(istab.eq.'y')then
        write(*,'(/1x,''Perform signal free indices running rbar calculations'')')
        call blank(fil1)
        fil1=filnam
        fil1(ll+1:ll+13)='_Ssf_RBAR.txt'
        open(iu33,file=fil1,status='unknown')
        
        call runbar(sfind,ybar,idate,nc,rxm,runr,ncnt,nsg,nlp,mxy,mxs,iu33,nocon)
        
        close(iu33)
        call blank(tit)
        tit(1:40)='Signal Free Indices Running Correlations'
        call blank(xlab)
        xlab='Years'
        call blank(ylab)
        ylab='RBAR'
        call blank(annot1)
        annot1(1:14)='Running RBAR ('
        if(nsg.lt.100)then
          write(annot1(15:16),'(i2)')nsg
          annot1(17:21)=' Yrs)'
        else
          write(annot1(15:17),'(i3)')nsg
          annot1(18:22)=' Yrs)'
        endif
        call blank(annot2)
        annot2(1:20)='Constant Sample RBAR'
        ones(1)=-999.9
        iw1=1;iw2=2;iw3=2
        call plot1(mxy,runr(1,2),runr(1,4),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
        do i=1,maxn
          rbeps(i,1)=runr(i,2)
          rbeps(i,2)=runr(i,4)
          rcores=runr(i,1)
          rbar1=runr(i,2)
          eps1=(rcores*rbar1)/(rcores*rbar1+(1.0-rbar1))
          rbeps(i,3)=eps1
          rbar2=runr(i,4)
          eps2=(rcores*rbar2)/(rcores*rbar2+(1.0-rbar2))
          rbeps(i,4)=eps2
          ones(i)=0.85
        enddo
        call blank(ylab)
        ylab='EPS'
        annot1(1:14)=' Running EPS ('
        annot2(1:21)='  Constant Sample EPS'
        iw1=1;iw2=2;iw3=2
        call plot1(mxy,rbeps(1,3),rbeps(1,4),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
        
        do i=1,maxn
          if(ybar(i,3).lt.0)ybar(i,3)=0.0
          crn3(i,2)=ybar(i,3)
        enddo
        call mnsd(crn3(1,2),maxn,xmstd2,sdstd2)
        do i=1,maxn
          datum=crn3(i,2)-xmstd2
          crn3(i,2)=datum+xmstd1
          if(crn3(i,2).lt.0)crn3(i,2)=0.0
          ones(i)=1.0
        enddo
        call blank(ylab)
        ylab='Indices'
        call blank(tit)
        tit(1:56)='Original vs. Running RBAR Stabilized Signal Free Indices'
        if(ioptsave.eq.0)then
          call blank(annot1)
          annot1(1:20)='Orig Mean-Adjust RAW'
          call blank(annot2)
          annot2(1:20)='Stab Mean-Adjust RAW'
        else
          call blank(annot1)
          annot1(1:20)='Orig Signal Free STD'
          call blank(annot2)
          annot2(1:20)='Stab Signal Free STD'
        endif

        call mnsd(crn2(nss1+1,1),maxn1,xmo,sd)
        call mnsd(crn3(nss1+1,2),maxn1,xms,sd)
        write(*,'(/1x,''Orig/Stab Means1: '',2f8.4)')xmo,xms
        do i=1,maxn
          crn2(i,1)=crn2(i,1)-xmo+1.0
          crn3(i,2)=crn3(i,2)-xms+1.0
          if(crn2(i,1).lt.0)crn2(i,1)=0.0
          if(crn3(i,2).lt.0)crn3(i,2)=0.0
        enddo
        call mnsd(crn2(nss1+1,1),maxn1,xmo,sd)
        call mnsd(crn3(nss1+1,2),maxn1,xms,sd)
        write(*,'(/1x,''Orig/Stab Means2: '',2f8.4)')xmo,xms
        iw1=1;iw2=1;iw3=2
        call plot1(mxy,crn2(1,1),crn3(1,2),maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)

   16   do i=1,maxn
          wrk1(i)=crn3(i,2)
          wrk2(i)=crn3(i,2)
          ones(i)=0.0
        enddo
        if(isb.ne.0)then
          if(isb.eq.1)then
            call stabit(wrk1,f,wrk2,nss,maxn)
          else
            ls=isb
            call stabit1(wrk1,f,wrk2,nss,maxn,ls,mxy)
          endif
        endif
        call blank(tit)
        tit(1:56)='Spline Detrending of RBAR Stabilized Signal Free Indices'
        call blank(annot1)
        annot1(1:22)='  Absolute Differences'
        call blank(annot2)
        if(isb.eq.1)then
          annot2(1:20)='Age-Dependent Spline'
        elseif(iabs(isb).ge.10)then
          annot2(1:14)='Spline in Yrs:'
          write(annot2(16:20),'(i5)')ls
        endif
        if(isb.ne.0)then
          iw1=1;iw2=2;iw3=1
          call plot1(mxy,wrk1,f,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
        endif
        do i=1,maxn
          wrk1(i)=crn3(i,2)
          ones(i)=1.0
        enddo
        call blank(tit)
        tit(1:56)='RBAR Only Vs. Detrended RBAR Stabilized Sig Free Indices'
        if(ioptsave.eq.0)then
          call blank(annot1)
          annot1(1:22)='RBAR Stablized RAW Crn'
          call blank(annot2)
          annot2(1:22)='DETR Stablized RAW Crn'
        else
          call blank(annot1)
          annot1(1:22)='RBAR Stablized SSF Crn'
          call blank(annot2)
          annot2(1:22)='DETR Stablized SSF Crn'
        endif
        call mnsd(wrk2(nss1+1),maxn1,xmstd2,sdstd2)
ccc        do i=1,maxn
ccc          datum=wrk2(i)-xmstd2
ccc          crn3(i,2)=datum+1.0
ccc          if(crn3(i,2).lt.0)crn3(i,2)=0.0
ccc        enddo
        do i=1,maxn
ccc          crn3(i,1)=wrk2(i)-xmstd2+1.0
ccc          if(crn3(i,1).lt.0)crn3(i,1)=0.0
          wrk2(i)=wrk2(i)-xmstd2+1.0
          if(wrk2(i).lt.0)wrk2(i)=0.0
        enddo
        if(isb.ne.0)then
          iw1=1;iw2=1;iw3=2
          call plot1(mxy,wrk1,wrk2,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
   17     yn=' '
          write(*,'(/1x,''Happy with this spline stabilization? <Y>/N'',t50,''==> '',$)')
          read(*,'(a)')yn
          if(yn.eq.'N'.or.yn.eq.'n')then
            call blank(cdat)
   18       write(*,'(/1x,''Additional spline variance stabilization?''/
     *        1x,''No additional spline stabilization'',t39,''<0>''/
     *        1x,''Age-dependent spline stabilization'',t39,'' 1''/
     *        1x,''Smoothing spline (percent N cutoff)'',t39,''<-9''/
     *        1x,''Smoothing spline (fixed Yrs cutoff)'',t39,''>+9'',t50,''==> '',$)')
            read(*,'(a)')cdat
            if(cdat(1:1).eq.'/')stop
            if(cdat(1:1).eq.' ')cdat(1:1)='0'
            call intfrm(cdat,frm)
            read(cdat,frm,err=18)isb
            if(isb.gt.1.and.isb.lt.10)goto 18
            if(isb.lt.0.and.isb.gt.-10)goto 18
            goto 16
          elseif(yn.eq.'Y'.or.yn.eq.'y'.or.yn.eq.' ')then
            do i=1,maxn
              crn3(i,2)=wrk2(i)
            enddo
          else
            write(*,'(/1x,''Y or <RET> for Yes or N for no, okay?'')')
            goto 17
          endif
          
        endif
c
c *** final detrending option for RCS or mean-adjusted RCS chronology - ERC 5/8/14
c
        if(iopt.eq.-2.or.iopt.eq.6)then
          yn=' '
          write(*,'(/1x,''Final RCS chronology detrending? Y/<N>'',t50,''==> '',$)')
          read(*,'(a)')yn
          if(yn.eq.' ')yn='n'
          if(yn.eq.'Y'.or.yn.eq.'y')then
   19       lss=0
            write(*,'(/1x,''Okay, enter spline detrending in years''/
     *        1x,''Smoothing spline (percent N cutoff)'',t39,''<-9''/
     *        1x,''Smoothing spline (fixed Yrs cutoff)'',t39,''>+9'',t50,''==> '',$)')
            read(*,*,err=19)lss
            if(lss.lt.10.and.lss.gt.-10)goto 19
            if(lss.lt.-9)then
              lss=abs((float(lss)/100.0)*float(maxn))
            endif
            do i=1,maxn
              wrk1(i)=crn3(i,2)
            enddo
            call spline(maxn,wrk1,f,pp,lss)
            call blank(tit)
            tit(1:56)='Final Detrending of the RCS Signal Free Indices'
            call blank(annot1)
            annot1(1:22)=' RCS tree-ring indices'
            call blank(annot2)
            annot2(1:14)='Spline in Yrs:'
            write(annot2(16:20),'(i5)')lss
            iw1=1;iw2=2;iw3=1
            call plot1(mxy,wrk1,f,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)
            call mnsd(crn3(nss1+1,2),maxn1,xms,sd)
            do i=1,maxn
              wrk2(i)=wrk1(i)-f(i)
              wrk2(i)=wrk2(i)+xms
            enddo
            call blank(tit)
            tit(1:50)='Final Detrending of the RCS Signal Free Chronology'
            call blank(annot1)
            annot1(1:16)='Original RCS Crn'
            call blank(annot2)
            annot2(1:17)='Detrended RCS Crn'
            iw1=1;iw2=1;iw3=2
            call plot1(mxy,wrk1,wrk2,maxn,ifmny,xlab,ylab,tit,ones,annot1,annot2,iw1,iw2,iw3)              
            yn=' '
            write(*,'(/1x,''Happy with the final RCS detrending? <Y>/N'',t50,''==> '',$)')
            read(*,'(a)')yn
            if(yn.eq.' ')yn='y'
            if(yn.eq.'N'.or.yn.eq.'n')then
              goto 19
            endif
            do i=1,maxn
              crn3(i,2)=wrk2(i)
            enddo
          endif
        endif
c
c *** final detrending option for RCS or mean-adjusted RCS chronology - ERC 5/8/14
c        
        if(nss2.gt.0)then
          call mnsd(stdsav(nss2+1),maxn2,xmstdsav,sdstdsav)
          call mnsd(crn1(nss2+1,1),maxn2,xmstdfinal,sdstdfinal)
          call mnsd(crn2(nss2+1,1),maxn2,xmssffinal,sdssffinal)
        else
          call mnsd(stdsav,maxn,xmstdsav,sdstdsav)
          call mnsd(crn1(1,1),maxn,xmstdfinal,sdstdfinal)
          call mnsd(crn2(1,1),maxn,xmssffinal,sdssffinal)
        endif
      
ccc        write(*,'(/1x,6f8.3)')xmstdsav,sdstdsav,xmstdfinal,sdstdfinal,xmssffinal,sdssffinal

        if(nss2.gt.0)then
          call mnsd(crn3(nss2+1,1),maxn2,xmstdstbfinal,sdstdstbfinal)
          call mnsd(crn3(nss2+1,2),maxn2,xmssfstbfinal,sdssfstbfinal)
        else
          call mnsd(crn3(1,1),maxn,xmstdstbfinal,sdstdstbfinal)
          call mnsd(crn3(1,2),maxn,xmssfstbfinal,sdssfstbfinal)
        endif
        
ccc        write(*,'(/1x,''Final scaling1: '',4f8.3)')xmstdstbfinal,sdstdstbfinal,xmssfstbfinal,sdssfstbfinal

        if(.not.itype.and.nocon1.gt.0)then                !Change 06/02/2013
          do i=1,maxn
            datum1=(crn3(i,1)-xmstdstbfinal)/sdstdstbfinal
            crn3(i,1)=datum1*sdstdsav+1.0
            if(crn3(i,1).lt.0)crn3(i,1)=0.0
ccc            if(sdssffinal.lt.sdstdsav)then
              datum2=(crn3(i,2)-xmssfstbfinal)/sdssfstbfinal
              crn3(i,2)=datum2*sdstdsav+1.0
ccc            else
ccc              datum2=(crn3(i,2)-xmssfstbfinal)/sdssfstbfinal
ccc              crn3(i,2)=datum2*sdssffinal+1.0
ccc            endif
            if(crn3(i,2).lt.0)crn3(i,2)=0.0
          enddo
        else
          do i=1,maxn
            datum1=(crn3(i,1)-xmstdstbfinal)/sdstdstbfinal
            crn3(i,1)=datum1*sdstdfinal+1.0
            if(crn3(i,1).lt.0)crn3(i,1)=0.0
            datum2=(crn3(i,2)-xmssfstbfinal)/sdssfstbfinal
            crn3(i,2)=datum2*sdssffinal+1.0
            if(crn3(i,2).lt.0)crn3(i,2)=0.0
          enddo        
        endif
         
        if(nss2.gt.0)then
          call mnsd(crn3(nss2+1,1),maxn2,xmstdstbfinal,sdstdstbfinal)
          call mnsd(crn3(nss2+1,2),maxn2,xmssfstbfinal,sdssfstbfinal)
        else
          call mnsd(crn3(1,1),maxn,xmstdstbfinal,sdstdstbfinal)
          call mnsd(crn3(1,2),maxn,xmssfstbfinal,sdssfstbfinal)
        endif
        
ccc        write(*,'(/1x,''Final scaling2: '',4f8.3)')xmstdstbfinal,sdstdstbfinal,xmssfstbfinal,sdssfstbfinal
        
      endif

c
c *** plot out the mean abs and mean dabs convergence statistics
c
      call blank(tit)
      tit(1:40)='Iteration Convergence Statistics, Iter ='
      write(tit(41:43),'(i3)')iter
      call blank(xlab)
      xlab(1:10)='Iterations'
      call blank(ylab)
      ylab(1:20)='Absolute Differences'
      call blank(annot1)
      annot1(1:21)='   Mean ABS Diff Test'
      call blank(annot2)
      annot2(1:20)='Median ABS Diff Test'
      do i=1,maxn
        f(i)=0.0
      enddo
      iw1=2;iw2=2;iw3=2      
      call plot1(maxit,test3,test4,iter,1,xlab,ylab,tit,f,annot1,annot2,iw1,iw2,iw3)
c
c *** plot out the successive signal free iteration differences
c
      call blank(tit)
      tit(1:51)='Signal Free Chronology Iteration Differences'
      call blank(xlab)
      xlab(1:5)='Years'
      call blank(ylab)
      ylab(1:20)='Absolute Differences'
      call blank(annot1)
      annot1(1:15)='First Iteration'
      call blank(annot2)
      annot2(1:18)='   Final Iteration'
ccc      do j=2,iter
ccc        jj=iter-j+1
ccc        rj=j-1
ccc        do i=1,maxn
ccc          savit(i,jj)=savit(i,jj)-(rj*0.10)
ccc          savit(i,j)=savit(i,j)+(rj*0.10)
ccc        enddo
ccc      enddo
      
      do j=1,iter
        jj=iter-j+1
        rj=j-1
        call mnsd(savit(1,jj),maxn,xm,sd)
        do i=1,maxn
          savit(i,jj)=savit(i,jj)-xm-(rj*0.10)
        enddo
      enddo
           
      ones(1)=-999.9
      call spaghetti(savit,ones,maxn,iter,ifmny,xlab,ylab,tit,annot1,annot2,mxlen,mxser) 
c
c *** plot out the successive signal free iteration chronologies in smoothing spline mode
c
      call blank(tit)
      do i=1,maxn
        wrk1(i)=crnsall(i,1)
      enddo
      call mnsd(wrk1(nss2+1),maxn2,xm1,sd1)
      do j=1,iter+1
        do i=1,maxn
          wrk1(i)=crnsall(i,j)
        enddo
        if(j.gt.1.and.nocon1.gt.0)then
          call mnsd(wrk1(nss2+1),maxn2,xm2,sd2)
          do i=1,maxn
            datum=(wrk1(i)-xm2)/sd2
            wrk1(i)=datum*sd1+xm1
            if(wrk1(i).lt.0)wrk1(i)=0.0
            crnsall(i,j)=wrk1(i)
          enddo
        endif
        if(maxn.le.100)then
          call spline1(maxn,wrk1,wrk2,10)
          tit(1:51)='Signal Free Chronology Iterations: 10-Yr Splines'
        elseif(maxn.gt.100.and.maxn.le.500)then
          call spline1(maxn,wrk1,wrk2,30)
          tit(1:51)='Signal Free Chronology Iterations: 30-Yr Splines'
        elseif(maxn.gt.500.and.maxn.le.2000)then
          call spline1(maxn,wrk1,wrk2,50)
          tit(1:51)='Signal Free Chronology Iterations: 50-Yr Splines'
        elseif(maxn.gt.2000)then
          call spline1(maxn,wrk1,wrk2,100)
          tit(1:51)='Signal Free Chronology Iterations: 100-Yr Splines'
        endif
        do i=1,maxn
          savit(i,j)=wrk2(i)
          ones(i)=1.0
        enddo
      enddo
      call blank(xlab)
      xlab(1:5)='Years'
      call blank(ylab)
      ylab(1:17)='Indices'
      call blank(annot1)
      annot1(1:15)=' Iteration:   0'
      call blank(annot2)
      annot2(1:16)='  Iteration:    '
      write(annot2(14:16),'(i3)')iter
      call spaghetti(savit,ones,maxn,iter,ifmny,xlab,ylab,tit,annot1,annot2,mxlen,mxser) 
c
c *** print out the curve fit options as a function of signal free iteration
c
ccc      write(iu9,'(/t8,''SIGNAL FREE DETRENDING OPTIONS BY ITERATION'')')
ccc      write(iu9,'(3x,''NC  IDENT'',4x,''   0    0'',100i5)')(j,j=1,iter)
ccc      call blank(line)
ccc      do i=1,iter+2
ccc        ii=(i-1)*5+1
ccc        iii=ii+4
ccc        line(ii:iii)=' ---'
ccc      enddo
ccc      write(iu9,'(3x,''--  -----'',4x,a)')line
ccc      do j=1,nc
ccc        write(iu9,'(i5,2x,a,102i5)')j,ident(j),(iopt1(j,k),k=1,iter+2)
ccc      enddo
c      write(iu9,'(/t8,''PROBLEM CURVE FITS THAT DROP BELOW:  '',f6.3)')curmin(1)
c      write(iu9,'(/t8,''PROBLEM CURVE FITS THAT DROP BELOW MINIMUM SERIES VALUE:'')')
c      write(iu9,'(3x,''NC  IDENT'',4x,''   0    0'',100i5)')(j,j=1,iter)
c      call blank(line)
c      do i=1,iter+2
c        ii=(i-1)*5+1
c        iii=ii+4
c        line(ii:iii)=' ---'
c      enddo
c      write(iu9,'(3x,''--  -----'',4x,a)')line
c      do j=1,nc
c        write(iu9,'(i5,2x,a,100i5)')j,ident(j),(jtest(j,k),k=1,iter+2)
c      enddo
ccc      close(iu29)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr curvefits
*
      subroutine curvefits(y,f,iyr,n,n1,id,iopt,alpha,mxy,mxs,istrtls,nis)
      parameter(mxlen=9000,epsi=0.000001)
      real*4 y(mxy),f(mxy),eq(7)
      real*4 wrk(mxlen),w(mxlen),sc(mxlen,7),tmp(mxlen)
      character id*8
c new local ls2
      integer ls2(mxlen)     
c
c *** negative exponential curve
c
      iopt1=iopt
      if(iopt.eq.1.or.iopt.eq.2)then
        do j=1,7
          eq(j)=0.0
        enddo
        call curve(n,n1,y,f,eq)
        if(eq(2).le.epsi.or.eq(5).lt.epsi)then
ccc        if(eq(2).le.0.or.eq(5).lt.0)then
          if(iopt.eq.1)iopt=3
          if(iopt.eq.2)iopt=4
          do j=1,7
            eq(j)=0.0
          enddo
          call trend(n,n1,y,f,eq(3),eq(5))
        endif
        if(eq(3).gt.epsi.and.iopt1.eq.2)then
ccc        if(eq(3).gt.0.and.iopt1.eq.2)then
          iopt=6
          call xmean(y,f,n,n1)
        endif
c
c *** linear regression curve
c
      elseif(iopt.eq.3.or.iopt.eq.4)then
        do j=1,7
          eq(j)=0.0
        enddo
        call trend(n,n1,y,f,eq(3),eq(5)) 
        if(iopt.eq.4.and.eq(3).gt.0)then
          iopt=6
          call xmean(y,f,n,n1)
        endif
c
c *** horizontal line through the mean
c
      elseif(iopt.eq.6)then
        call xmean(y,f,n,n1)
        
c
c *** Friedman variable span smoother
c
      elseif(iopt.eq.-5)then
        do i=1,n
          wrk(i)=float(i)
          w(i)=1.0
        enddo
        span=0.0
        if(n1.lt.40)span=0.3
        iper=1
        call supsmu(n1,wrk,y,w,iper,span,alpha,f,sc)
        if(n.gt.n1)then
          do i=1,n1
            tmp(i)=y(i)
          enddo
          iext=n-n1
          do i=1,iext
            ii=i+n1
            tmp(ii)=f(n1)
          enddo
          call supsmu(n,wrk,tmp,w,iper,span,alpha,f,sc)
        endif
c
c *** cubic smoothing spline smoothing
c
      elseif(abs(iopt).ge.8)then   
        if(iopt.eq.8)then	        	!age dependent spline option  MODIFIED March 2014 
          call lsmake(mxlen,n,istrtls,ls2)
          call spline2(n,y,f,ls2)   
          if(nis.eq.1)then            
            do i=1,n				!ERC add option for non-increasing end to age dependent spline
              wrk(i)=f(i)
            enddo
            nxx=0      
            do i=1,n
              ii=n-i
              iii=n-i+1
              datum1=wrk(ii)
              datum2=wrk(iii)
              if(datum2.gt.datum1)then
                nxx=nxx+1
              else
                nx=n-nxx
                rpad=wrk(nx)
                iext=nxx
                goto 10
              endif
            enddo
   10       continue
            if(nx.lt.n)then
              do i=1,iext
                wrk(i+nx)=rpad
              enddo
              call lsmake(mxlen,n,istrtls,ls2)
              call spline2(n,wrk,f,ls2)
            endif  
          endif        
        elseif(iopt.ge.10)then
          ls=iopt
          call spline1(n1,y,f,ls)
        elseif(iopt.le.-10)then
          rn1=n1
          ropt=float(abs(iopt))/100.
          ls=ropt*rn1
          call spline1(n1,y,f,ls)
        endif
      endif
      
c      do i=1,n
c        if(f(i).lt.0.02)then
c          f(i)=0.02
c        endif
c      enddo

c      ier=0
c      do i=1,n
c        if(f(i).lt.0.20)then
c        if(f(i).lt.0.02)then
c          ier=1
c          goto 90
c        endif
c      enddo
c   90 if(ier.eq.1)then
c        iopt=6
c        call xmean(y,f,n,n1)
c        return
c      endif
c      do i=1,n
c        if(f(i).lt.0.20)then
c          f(i)=0.20
c        if(f(i).lt.0.02)then
c          f(i)=0.02
c        endif
c      enddo
      
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr curve: compute exponential curve coefficients
*
*  programmed by fritts, huzar, bottorf and ray
*  revised oct 1968 by v bockman
*  revised     1983 by e r cook
*  revised by r l holmes    feb 1984
*  revised by r l holmes  5 feb 1985
*
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
***********************************************************
*
* parameters passed to routine:
*
* n:  number of data in z
* z:  array of data to which to fit curve
* f:  working array of length n
* eq: array of exponential curve coefficients computed here
*
* exponential curve equation computed:
*
*     y = ah * exp(-bh * t) + eh
*        eq(1)     eq(2)     eq(5)
* eq(6): iterations required to converge
* eq(7): sum of array z
*
**************************************************
*
      subroutine curve(n,n1,z,f,eq)		!Hakan
      real*4 z(n),f(n),eq(7)
      real*8 a,b,d,e,g,eh,ah,bh(3),rss(3),yf,yl,rn1,dlt,ab,arg,zz,dinc
      data dinc/.0000005d0/
      nit=0
      if(n1.lt.20)then
        write(*,'(''>> sbr curve:  only'',i3,'' values, no exponential curve fit'')')n1
        goto 99
      endif
      rn1=dble(n1)
      yf=0.d0
      do 5 i=1,10
    5 yf=yf+dble(z(i))
      yf=yf/10.d0
      yl=0.d0
      do 8 i=n1-9,n1
    8 yl=yl+dble(z(i))
      yl=yl/10.d0
      bh(2)=(dlog(yf)-dlog(yl))/(rn1-10.d0)
      if(bh(2) .le. 0.d0)bh(2)=1.d-8
      dlt=.0005d0
      mu=0
      mo=0
*
* iteration loop
      do 13 it=1,34
      nit=it
      bh(1)=bh(2)-dlt
      bh(3)=bh(2)+dlt
      do 28 k=1,3
      if(k .eq. 2 .and. mu .gt. 0)goto 28
      ab=abs(bh(k))
      do 19 i=1,n1
      arg=ab*dfloat(i)
      if(arg .gt. 112.8d0)goto 99
   19 f(i)=dexp(-bh(k)*dfloat(i))
      a=dble(n1)
      b=0.d0
      d=0.d0
      e=0.d0
      g=0.d0
      do 21 i=1,n1
      b=b+dble(f(i))
      d=d+dble(z(i))
      e=e+dble(f(i))*dble(f(i))
   21 g=g+dble(z(i))*dble(f(i))
      if((b .gt. 1.d15 .or. e .gt. 1.d15) .or.
     +(b .lt. 1.d-15 .or. e .lt. 1.d-15))goto 99
      eh=(d*e-b*g)/(a*e-b*b)
      ah=(d-a*eh)/b
      rss(k)=0.d0
      do 25 i=1,n1
      zz=dble(z(i))-eh-ah*dble(f(i))
   25 rss(k)=rss(k)+zz*zz
   28 continue
      mu=1
      lo=0
      do 30 k=1,3,2
      if(rss(k) .lt. rss(2))then
      lo=-1
      bh(2)=bh(k)
      rss(2)=rss(k)
      endif
   30 continue
      if(lo .ge. 0)mo=1
      if(mo .le. 0)then
      dlt=dlt*2.d0
      else
      dlt=dlt*.5d0
      if(dlt .le. dble(dinc))goto 15
      endif
   13 continue
      write(*,'(''>> sbr curve: over 34 iterations'')')
      goto 99
   15 if(eh.gt.9999.d0 .or. ah.le.0.d0 .or. bh(2).lt.0.d0)bh(2)=0.d0
      eq(1)=sngl(ah)
      eq(2)=bh(2)
      eq(5)=sngl(eh)
      eq(6)=nit
      eq(7)=sngl(d)
*
* calculate curve values
      do i=1,n							!Hakan
        f(i)=sngl(ah*dexp(bh(2)*dfloat(i)*(-1.d0))+eh)
      enddo
      return
*
* flag values if coefficients not computed
   99 f(1)=-999.
      eq(2)=-999.
      return

      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr trend: fits trend line to series
*
*  programmed oct 1982 by
*
*     richard  l  holmes
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
*  modified by r l holmes 15 mar 1985
*  modified by e r cook 25 aug 1985 to double precision
*
********************************************************************
*
*  n:  number of values in series
*  y:  time series array
*  f:  trend line values calculated by this routine
*  sl: slope of trend line
*  yi: y-axis intercept
*
********************************************************************
*
      subroutine trend(n,n1,y,f,sl,yi)			!Hakan
      implicit real*8 (a-h,o-z)
      real*4 y(n),f(n),sl,yi
      an1=dfloat(n1)
      t=0.d0
      w=0.d0
      x=0.d0
      z=0.d0
      do i=1,n1
        ai=dfloat(i)
        z=z+ai
        t=t+ai*ai
        x=x+dble(y(i))*ai
        w=w+dble(y(i))
      enddo
      ymean=w/an1
      dsl=(x-w*z/an1)/(t-z*z/an1)
      dyi=ymean-dsl*z/an1
      do i=1,n						!Hakan
        ai=dfloat(i)
        f(i)=sngl(dsl*ai+dyi)
      enddo
      sl=sngl(dsl)
      yi=sngl(dyi)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr xmean
*
      subroutine xmean(x,f,n,n1)
      real*4 x(n),f(n)
      if(n1.le.0)then
        write(*,'(/1x,''error in xmean: n=0'')')
        pause
        stop
      endif
      rn1=n1
      xm=0.0
      do i=1,n1
        xm=xm+x(i)
      enddo
      xm=xm/rn1
      do i=1,n
        f(i)=xm
      enddo
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine supsmu (n,x,y,w,iper,span,alpha,smo,sc)
c
c------------------------------------------------------------------
c
c super-smoother.
c
c Friedman J.H. (1984). A variable span smoother. Department of Statistics,
c    Stanford University, Technical Report LCS5.
c
c version 10/10/84.
c
c coded  and copyright (c) 1984 by:
c
c                        Jerome H. Friedman
c                     Department of Statistics
c                               and
c                Stanford Linear Accelerator Center
c                        Stanford University
c
c all rights reserved.
c
c
c input:
c    n : number of observations (x,y - pairs).
c    x(n) : ordered abscissa values.
c    y(n) : corresponding ordinate (response) values.
c    w(n) : weight for each (x,y) observation.
c    iper : periodic variable flag.
c       iper=1 => x is ordered interval variable.
c       iper=2 => x is a periodic variable with values
c                 in the range (0.0,1.0) and peroid 1.0.
c    span : smoother span (fraction of observations in window).
c           span=0.0 => automatic (variable) span selection.
c    alpha : controles high frequency (small span) penality
c            used with automatic span selection (bass tone control).
c            (alpha.le.0.0 or alpha.gt.10.0 => no effect.)
c output:
c   smo(n) : smoothed ordinate (response) values.
c scratch:
c   sc(n,7) : internal working storage.
c
c note:
c    for small samples (n < 40) or if there are substantial serial
c    correlations between obserations close in x - value, then
c    a prespecified fixed span smoother (span > 0) should be
c    used. reasonable span values are 0.2 to 0.4.
c
c------------------------------------------------------------------
c
      real*4 x(n),y(n),w(n),smo(n),sc(n,7)
      common /spans/ spans(3) /consts/ big,sml,eps
      if (x(n).gt.x(1)) go to 30
      sy=0.0
      sw=sy
      do 10 j=1,n
      sy=sy+w(j)*y(j)
      sw=sw+w(j)
 10   continue
      a=0.0
      if (sw.gt.0.0) a=sy/sw
      do 20 j=1,n
      smo(j)=a
 20   continue
      return
 30   i=n/4
      j=3*i
      scale=x(j)-x(i)
 40   if (scale.gt.0.0) go to 50
      if (j.lt.n) j=j+1
      if (i.gt.1) i=i-1
      scale=x(j)-x(i)
      go to 40
 50   vsmlsq=(eps*scale)**2
      jper=iper
      if (iper.eq.2.and.(x(1).lt.0.0.or.x(n).gt.1.0)) jper=1
      if (jper.lt.1.or.jper.gt.2) jper=1
      if (span.le.0.0) go to 60
      call smooth (n,x,y,w,span,jper,vsmlsq,smo,sc)
      return
 60   do 70 i=1,3
      call smooth (n,x,y,w,spans(i),jper,vsmlsq,sc(1,2*i-1),sc(1,7))
      call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2*i),h)
 70   continue
      do 90 j=1,n
      resmin=big
      do 80 i=1,3
      if (sc(j,2*i).ge.resmin) go to 80
      resmin=sc(j,2*i)
      sc(j,7)=spans(i)
 80   continue
      if (alpha.gt.0.0.and.alpha.le.10.0.and.resmin.lt.sc(j,6).and.resmi
     1n.gt.0.0) sc(j,7)=sc(j,7)+(spans(3)-sc(j,7))*amax1(sml,resmin/sc(j
     2,6))**(10.0-alpha)
 90   continue
      call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2),h)
      do 110 j=1,n
      if (sc(j,2).le.spans(1)) sc(j,2)=spans(1)
      if (sc(j,2).ge.spans(3)) sc(j,2)=spans(3)
      f=sc(j,2)-spans(2)
      if (f.ge.0.0) go to 100
      f=-f/(spans(2)-spans(1))
      sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,1)
      go to 110
 100  f=f/(spans(3)-spans(2))
      sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,5)
 110  continue
      call smooth (n,x,sc(1,4),w,spans(1),-jper,vsmlsq,smo,h)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine smooth (n,x,y,w,span,iper,vsmlsq,smo,acvr)
      dimension x(n),y(n),w(n),smo(n),acvr(n)
      integer in,out
      double precision wt,fbo,fbw,xm,ym,tmp,var,cvar,a,h,sy
      xm=0.0
      ym=xm
      var=ym
      cvar=var
      fbw=cvar
      jper=iabs(iper)
      ibw=0.5*span*n+0.5
      if (ibw.lt.2) ibw=2
      it=2*ibw+1
      do 20 i=1,it
      j=i
      if (jper.eq.2) j=i-ibw-1
      xti=x(j)
      if (j.ge.1) go to 10
      j=n+j
      xti=x(j)-1.0
 10   wt=w(j)
      fbo=fbw
      fbw=fbw+wt
      if (fbw.gt.0.0) xm=(fbo*xm+wt*xti)/fbw
      if (fbw.gt.0.0) ym=(fbo*ym+wt*y(j))/fbw
      tmp=0.0
      if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo
      var=var+tmp*(xti-xm)
      cvar=cvar+tmp*(y(j)-ym)
 20   continue
      do 80 j=1,n
      out=j-ibw-1
      in=j+ibw
      if ((jper.ne.2).and.(out.lt.1.or.in.gt.n)) go to 60
      if (out.ge.1) go to 30
      out=n+out
      xto=x(out)-1.0
      xti=x(in)
      go to 50
 30   if (in.le.n) go to 40
      in=in-n
      xti=x(in)+1.0
      xto=x(out)
      go to 50
 40   xto=x(out)
      xti=x(in)
 50   wt=w(out)
      fbo=fbw
      fbw=fbw-wt
      tmp=0.0
      if (fbw.gt.0.0) tmp=fbo*wt*(xto-xm)/fbw
      var=var-tmp*(xto-xm)
      cvar=cvar-tmp*(y(out)-ym)
      if (fbw.gt.0.0) xm=(fbo*xm-wt*xto)/fbw
      if (fbw.gt.0.0) ym=(fbo*ym-wt*y(out))/fbw
      wt=w(in)
      fbo=fbw
      fbw=fbw+wt
      if (fbw.gt.0.0) xm=(fbo*xm+wt*xti)/fbw
      if (fbw.gt.0.0) ym=(fbo*ym+wt*y(in))/fbw
      tmp=0.0
      if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo
      var=var+tmp*(xti-xm)
      cvar=cvar+tmp*(y(in)-ym)
 60   a=0.0
      if (var.gt.vsmlsq) a=cvar/var
      smo(j)=a*(x(j)-xm)+ym
      if (iper.le.0) go to 80
      h=0.0
      if (fbw.gt.0.0) h=1.0/fbw
      if (var.gt.vsmlsq) h=h+(x(j)-xm)**2/var
      acvr(j)=0.0
      a=1.0-w(j)*h
      if (a.le.0.0) go to 70
      acvr(j)=abs(y(j)-smo(j))/a
      go to 80
 70   if (j.le.1) go to 80
      acvr(j)=acvr(j-1)
 80   continue
      j=1
 90   j0=j
      sy=smo(j)*w(j)
      fbw=w(j)
      if (j.ge.n) go to 110
 100  if (x(j+1).gt.x(j)) go to 110
      j=j+1
      sy=sy+w(j)*smo(j)
      fbw=fbw+w(j)
      if (j.lt.n) go to 100
 110  if (j.le.j0) go to 130
      a=0.0
      if (fbw.gt.0.0) a=sy/fbw
      do 120 i=j0,j
      smo(i)=a
 120  continue
 130  j=j+1
      if (j.le.n) go to 90
      return
      end
      block data
      common /spans/ spans(3) /consts/ big,sml,eps
c
c---------------------------------------------------------------
c
c this sets the compile time (default) values for various
c internal parameters :
c
c spans : span values for the three running linear smoothers.
c spans(1) : tweeter span.
c spans(2) : midrange span.
c spans(3) : woofer span.
c (these span values should be changed only with care.)
c big : a large representable floating point number.
c sml : a small number. should be set so that (sml)**(10.0) does
c       not cause floating point underflow.
c eps : used to numerically stabilize slope calculations for
c       running linear fits.
c
c these parameter values can be changed by declaring the
c relevant labeled common in the main program and resetting
c them with executable statements.
c
c-----------------------------------------------------------------
c
      data spans,big,sml,eps /0.05,0.2,0.5,1.0e20,1.0e-7,1.0e-3/
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr spline: fits cubic spline curve to time series
*
*  derived from imsl library routines by edward r cook,
*  lamont-doherty geological observatory, and modified by
*  richard l holmes, tree-ring laboratory, university of arizona.
*
*  modified by r l holmes 10 jun 1988
*  modified by e r cook to full double precision 4 apr 1991
*
********************************************************************
*
* calculates a cubic spline function to filter a time series.
* 'stiffness' of spline is specified by parameter 'ls'
*
* parameters:
*
* n:  number of values in time series
* y:  time series array to be modeled
* f:  array of cubic spline function values computed
* p:  value computed in this routine, used to calculate spline
* ls: stiffness (50% frequency response) of spline
* a:  working array of dimension (n,4)
*
********************************************************************
*
      subroutine spline(n,y,f,pp,ls)
      parameter(mxy=9000)
      implicit real*8 (a-h,o-z)
      dimension a(mxy,4),c1(4),c2(3)
      real*4 y(n),f(n),pp
      data c1 /1.d0,-4.d0,6.d0,-2.d0/
      data c2 /0.d0,.33333333333333d0,1.33333333333333d0/
      data pct,pi / .50d0, 3.1415926535897935d0 /
      if(n .lt. 4)then
      f(1)=-9998.
      return
      endif
      if(n.gt.mxy)then
        write(*,'(/t2,''*** series too long for spline subroutine ***''/
     *           t2,'' *** enlarge mxy parameter in subroutine ***''/)')
        stop
      endif
      nm2=n-2
      v=dble(ls)
      arg=(2.d0*pi)/v
      p=(6.d0*(dcos(arg)-1.d0)**2.d0)/(dcos(arg)+2.d0)
      pp=sngl(p)
      do 1 i=1,nm2
      do 1 j=1,3
      a(i,j)=c1(j)+p*c2(j)
    1 a(i,4)=dble(y(i))+c1(4)*dble(y(i+1))+dble(y(i+2))
      a(1,1)=c2(1)
      a(1,2)=c2(1)
      a(2,1)=c2(1)
      nc=2
* begin ludapb
      rn=dble(1.d0/(dfloat(nm2)*16.d0))
      d1=1.d0
      d2=0.d0
      ncp1=nc+1
      if(nc .ne. 0)then
* initialize zero elements
      do 5 i=1,nc
      do 5 j=i,nc
      k=ncp1-j
    5 a(i,k)=0.d0
* 'i' is row index of element being computed
* 'j' is column index of element being computed
* 'l' is row index of previously computed vector
*       being used to compute inner product
* 'm' is column index
      endif
      do 60 i=1,nm2
      imncp1=i-ncp1
      i1=max0(1,1-imncp1)
      do 60 j=i1,ncp1
      l=imncp1+j
      i2=ncp1-j
      sum=a(i,j)
      jm1=j-1
      if(jm1 .gt. 0)then
      do 25 k=1,jm1
      m=i2+k
   25 sum=sum-a(i,k)*a(l,m)
      endif
      if(j .eq. ncp1)then
      if(a(i,j)+sum*rn .le. a(i,j))then
      f(1)=-9999.
      write(*,'(''>> sbr spline: matrix not positive definite'')')
      return
      endif
      a(i,j)=1.d0/dsqrt(sum)
* update determinant
      d1=d1*sum
   35 if(dabs(d1) .gt. 1.d0)then
      d1=d1*.0625d0
      d2=d2+4.d0
      goto 35
      endif
   47 if(dabs(d1) .le. .0625d0)then
      d1=d1*16.d0
      d2=d2-4.d0
      goto 47
      else
      goto 60
      endif
      endif
      a(i,j)=sum*a(l,ncp1)
   60 continue
* end ludapb / begin luelpb
* solution ly = b
      nc1=nc+1
      iw=0
      l=0
      do 15 i=1,nm2
      sum=a(i,4)
      if(nc .gt. 0)then
      if(iw .ne. 0)then
      l=l+1
      if(l .gt. nc) l=nc
      k=nc1-l
      kl=i-l
      do 45 j=k,nc
      sum=sum-a(kl,4)*a(i,j)
   45 kl=kl+1
      else
      if(sum .ne. 0.d0)iw=1
      endif
      endif
   15 a(i,4)=sum*a(i,nc1)
* solution ux = y
      a(nm2,4)=a(nm2,4)*a(nm2,nc1)
      n1=nm2+1
      do 30 i=2,nm2
      k=n1-i
      sum=a(k,4)
      if(nc .gt. 0)then
      kl=k+1
      k1=min0(nm2,k+nc)
      l=1
      do 50 j=kl,k1
      sum=sum-a(j,4)*a(j,nc1-l)
   50 l=l+1
      endif
   30 a(k,4)=sum*a(k,nc1)
* end luelpb
      do 2 i=3,nm2
    2 f(i)=a(i-2,4)+c1(4)*a(i-1,4)+a(i,4)
      f(1)=a(1,4)
      f(2)=c1(4)*a(1,4)+a(2,4)
      f(n-1)=a(nm2-1,4)+c1(4)*a(nm2,4)
      f(n)=a(nm2,4)
      do 3 i=1,n
    3 f(i)=y(i)-f(i)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr spline1: fits cubic spline curve to time series
*
*  derived from imsl library routines by edward r cook,
*  lamont-doherty geological observatory, and modified by
*  richard l holmes, tree-ring laboratory, university of arizona.
*
*  modified by r l holmes 10 jun 1988
*  modified by e r cook to full double precision 4 apr 1991
*
********************************************************************
*
* calculates a cubic spline function to filter a time series.
* 'stiffness' of spline is specified by parameter 'ls'
*
* parameters:
*
* n:  number of values in time series
* y:  time series array to be modeled
* f:  array of cubic spline function values computed
* p:  value computed in this routine, used to calculate spline
* ls: stiffness (50% frequency response) of spline
* a:  working array of dimension (n,4)
*
********************************************************************
*
      subroutine spline1(n,y,f,ls)
      parameter(mxy=9000)
      implicit real*8 (a-h,o-z)
      dimension a(mxy,4),c1(4),c2(3),p(mxy)
      real*4 y(n),f(n)
      data c1 /1.d0,-4.d0,6.d0,-2.d0/
      data c2 /0.d0,.33333333333333d0,1.33333333333333d0/
      data pct,pi / .50d0, 3.1415926535897935d0 /
      if(n .lt. 4)then
      f(1)=-9998.
      return
      endif
      if(n.gt.mxy)then
        write(*,'(/t2,''*** series too long for spline subroutine ***''/
     *           t2,'' *** enlarge mxy parameter in subroutine ***''/)')
        stop
      endif
      
      nm2=n-2
c      if(ls.eq.9)then
      if(ls.eq.8)then   !pjk
        ls1=20
      else
        ls1=ls
      endif
      
ccc      rn23=dfloat(n)*2.d0/3.d0
      rn23=dfloat(n)
      do i=1,nm2
        if(ls.eq.9)then
          v=dfloat(ls1)+i-1
          if(v.gt.rn23)v=rn23
        else
          v=dfloat(ls1)
        endif
        arg=(2.d0*pi)/v
        p(i)=(6.d0*(dcos(arg)-1.d0)**2.d0)/(dcos(arg)+2.d0)
      enddo
      
      do 1 i=1,nm2
      do 1 j=1,3
      a(i,j)=c1(j)+p(i)*c2(j)
    1 a(i,4)=dble(y(i))+c1(4)*dble(y(i+1))+dble(y(i+2))
      a(1,1)=c2(1)
      a(1,2)=c2(1)
      a(2,1)=c2(1)
      nc=2
* begin ludapb
      rn=dble(1.d0/(dfloat(nm2)*16.d0))
      d1=1.d0
      d2=0.d0
      ncp1=nc+1
      if(nc .ne. 0)then
* initialize zero elements
      do 5 i=1,nc
      do 5 j=i,nc
      k=ncp1-j
    5 a(i,k)=0.d0
* 'i' is row index of element being computed
* 'j' is column index of element being computed
* 'l' is row index of previously computed vector
*       being used to compute inner product
* 'm' is column index
      endif
      do 60 i=1,nm2
      imncp1=i-ncp1
      i1=max0(1,1-imncp1)
      do 60 j=i1,ncp1
      l=imncp1+j
      i2=ncp1-j
      sum=a(i,j)
      jm1=j-1
      if(jm1 .gt. 0)then
      do 25 k=1,jm1
      m=i2+k
   25 sum=sum-a(i,k)*a(l,m)
      endif
      if(j .eq. ncp1)then
      if(a(i,j)+sum*rn .le. a(i,j))then
      f(1)=-9999.
      write(*,'(''>> sbr spline: matrix not positive definite'')')
      return
      endif
      a(i,j)=1.d0/dsqrt(sum)
* update determinant
      d1=d1*sum
   35 if(dabs(d1) .gt. 1.d0)then
      d1=d1*.0625d0
      d2=d2+4.d0
      goto 35
      endif
   47 if(dabs(d1) .le. .0625d0)then
      d1=d1*16.d0
      d2=d2-4.d0
      goto 47
      else
      goto 60
      endif
      endif
      a(i,j)=sum*a(l,ncp1)
   60 continue
* end ludapb / begin luelpb
* solution ly = b
      nc1=nc+1
      iw=0
      l=0
      do 15 i=1,nm2
      sum=a(i,4)
      if(nc .gt. 0)then
      if(iw .ne. 0)then
      l=l+1
      if(l .gt. nc) l=nc
      k=nc1-l
      kl=i-l
      do 45 j=k,nc
      sum=sum-a(kl,4)*a(i,j)
   45 kl=kl+1
      else
      if(sum .ne. 0.d0)iw=1
      endif
      endif
   15 a(i,4)=sum*a(i,nc1)
* solution ux = y
      a(nm2,4)=a(nm2,4)*a(nm2,nc1)
      n1=nm2+1
      do 30 i=2,nm2
      k=n1-i
      sum=a(k,4)
      if(nc .gt. 0)then
      kl=k+1
      k1=min0(nm2,k+nc)
      l=1
      do 50 j=kl,k1
      sum=sum-a(j,4)*a(j,nc1-l)
   50 l=l+1
      endif
   30 a(k,4)=sum*a(k,nc1)
* end luelpb
      do 2 i=3,nm2
    2 f(i)=a(i-2,4)+c1(4)*a(i-1,4)+a(i,4)
      f(1)=a(1,4)
      f(2)=c1(4)*a(1,4)+a(2,4)
      f(n-1)=a(nm2-1,4)+c1(4)*a(nm2,4)
      f(n)=a(nm2,4)
      do 3 i=1,n
    3 f(i)=y(i)-f(i)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr spline2: fits cubic spline curve to time series
*
*  derived from imsl library routines by edward r cook,
*  lamont-doherty geological observatory, and modified by
*  richard l holmes, tree-ring laboratory, university of arizona.
*
*  modified by r l holmes 10 jun 1988
*  modified by e r cook to full double precision 4 apr 1991
*
********************************************************************
*
* calculates a cubic spline function to filter a time series.
* 'stiffness' of spline is specified by parameter 'ls'
*
* parameters:
*
* n:  number of values in time series
* y:  time series array to be modeled
* f:  array of cubic spline function values computed
* p:  value computed in this routine, used to calculate spline
* ls: stiffness (50% frequency response) of spline
* a:  working array of dimension (n,4)
*
********************************************************************
*
      subroutine spline2(n,y,f,ls)
      parameter(mxy=9000)
      implicit real*8 (a-h,o-z)
      integer ls(mxy)
      dimension a(mxy,4),c1(4),c2(3),p(mxy)
      real*4 y(n),f(n)
      data c1 /1.d0,-4.d0,6.d0,-2.d0/
      data c2 /0.d0,.33333333333333d0,1.33333333333333d0/
      data pct,pi / .50d0, 3.1415926535897935d0 /
      if(n .lt. 4)then
      f(1)=-9998.
      return
      endif
      if(n.gt.mxy)then
        write(*,'(/t2,''*** series too long for spline subroutine ***''/
     *           t2,'' *** enlarge mxy parameter in subroutine ***''/)')
        stop
      endif
      
      nm2=n-2
      do i=1,nm2
        v=dfloat(ls(i))
        arg=(2.d0*pi)/v
        p(i)=(6.d0*(dcos(arg)-1.d0)**2.d0)/(dcos(arg)+2.d0)
      enddo
      
      do 1 i=1,nm2
      do 1 j=1,3
      a(i,j)=c1(j)+p(i)*c2(j)
    1 a(i,4)=dble(y(i))+c1(4)*dble(y(i+1))+dble(y(i+2))
      a(1,1)=c2(1)
      a(1,2)=c2(1)
      a(2,1)=c2(1)
      nc=2
* begin ludapb
      rn=dble(1.d0/(dfloat(nm2)*16.d0))
      d1=1.d0
      d2=0.d0
      ncp1=nc+1
      if(nc .ne. 0)then
* initialize zero elements
      do 5 i=1,nc
      do 5 j=i,nc
      k=ncp1-j
    5 a(i,k)=0.d0
* 'i' is row index of element being computed
* 'j' is column index of element being computed
* 'l' is row index of previously computed vector
*       being used to compute inner product
* 'm' is column index
      endif
      do 60 i=1,nm2
      imncp1=i-ncp1
      i1=max0(1,1-imncp1)
      do 60 j=i1,ncp1
      l=imncp1+j
      i2=ncp1-j
      sum=a(i,j)
      jm1=j-1
      if(jm1 .gt. 0)then
      do 25 k=1,jm1
      m=i2+k
   25 sum=sum-a(i,k)*a(l,m)
      endif
      if(j .eq. ncp1)then
      if(a(i,j)+sum*rn .le. a(i,j))then
      f(1)=-9999.
      write(*,'(''>> sbr spline: matrix not positive definite'')')
      return
      endif
      a(i,j)=1.d0/dsqrt(sum)
* update determinant
      d1=d1*sum
   35 if(dabs(d1) .gt. 1.d0)then
      d1=d1*.0625d0
      d2=d2+4.d0
      goto 35
      endif
   47 if(dabs(d1) .le. .0625d0)then
      d1=d1*16.d0
      d2=d2-4.d0
      goto 47
      else
      goto 60
      endif
      endif
      a(i,j)=sum*a(l,ncp1)
   60 continue
* end ludapb / begin luelpb
* solution ly = b
      nc1=nc+1
      iw=0
      l=0
      do 15 i=1,nm2
      sum=a(i,4)
      if(nc .gt. 0)then
      if(iw .ne. 0)then
      l=l+1
      if(l .gt. nc) l=nc
      k=nc1-l
      kl=i-l
      do 45 j=k,nc
      sum=sum-a(kl,4)*a(i,j)
   45 kl=kl+1
      else
      if(sum .ne. 0.d0)iw=1
      endif
      endif
   15 a(i,4)=sum*a(i,nc1)
* solution ux = y
      a(nm2,4)=a(nm2,4)*a(nm2,nc1)
      n1=nm2+1
      do 30 i=2,nm2
      k=n1-i
      sum=a(k,4)
      if(nc .gt. 0)then
      kl=k+1
      k1=min0(nm2,k+nc)
      l=1
      do 50 j=kl,k1
      sum=sum-a(j,4)*a(j,nc1-l)
   50 l=l+1
      endif
   30 a(k,4)=sum*a(k,nc1)
* end luelpb
      do 2 i=3,nm2
    2 f(i)=a(i-2,4)+c1(4)*a(i-1,4)+a(i,4)
      f(1)=a(1,4)
      f(2)=c1(4)*a(1,4)+a(2,4)
      f(n-1)=a(nm2-1,4)+c1(4)*a(nm2,4)
      f(n)=a(nm2,4)
      do 3 i=1,n
    3 f(i)=y(i)-f(i)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr robsum
*
      subroutine robsum(x,wgts,n,nc,crnmn,crnsd,eff,nss,iopt,mxy,mxs)
      parameter(maxnum=3000) !equal to mxs in main program
      real*4 x(mxy,mxs),wgts(mxy,mxs),crnmn(mxy),crnsd(mxy),eff(mxy)
      real*4 wrk(maxnum),wrk1(maxnum),wgt(maxnum)
      integer nss(mxy),iopt
      if(nc.gt.maxnum)then
        write(*,'(/1x,''Error in Sbr ROBSUM: Max number of series exceeded'')')
        write(*,'(1x,''Maximum allowed:'',i6,5x,''Number sent:'',i6)')maxnum,nc
        write(*,'(1x,''*** Enlarge parameter MAXNUM in Sbr ROBSUM and try again! ***'')')
        stop
      endif
      do i=1,n
        nc1=0
        do j=1,nc
          datum=x(i,j)
          if(datum.ne.-999.0)then
            nc1=nc1+1
            wrk(nc1)=datum
          endif
        enddo
        call biwgt(wrk,wrk1,nc1,iopt,bimn,bisg,bise,wgt,bieff,maxnum)
        crnmn(i)=bimn
        crnsd(i)=bisg
        eff(i)=bieff
        nss(i)=nc1
        if(nc1.lt.6)then
          wgts(i,1)=1.0
          wgts(i,2)=1.0
          wgts(i,3)=1.0
          wgts(i,4)=1.0
        else
          call mfs(wgt,nc1,xmed,hh,hl,fsd,rmn,rmx)
          wgts(i,1)=rmn
          wgts(i,2)=hl
          wgts(i,3)=xmed
          wgts(i,4)=hh
        endif
      enddo
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr mnsd
*
      subroutine mnsd(x,n,xm,sd)
      real*4 x(n),xm,sd,sq,sm,rn
      xm=0.0
      sd=0.0
c
c *** compute the mean and standard deviation of the data
c
      sq=0.0
      sm=0.0
      do 10 i=1,n
        sm=sm+x(i)
   10 continue
      rn=n
      xm=sm/rn
      do 15 i=1,n
        sq=sq+(x(i)-xm)**2
   15 continue
      sd=sqrt(sq/(rn-1.0))
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c-----------------------------------------------------------------------------
      SUBROUTINE XBIWT (XDATA,N,XLBIWT,XSBIWT,XLBIWT1,XSBIWT1,EFF)
c-----------------------------------------------------------------------------
c
c     The subroutine XBIWT provides an estimator of the location and
c     scale of the data set XDATA.  The scale uses the Biweight function
c     in the general formula of "A-estimators." This formula is given
c     on page of 416 in UREDA (formula 4). The BIWEIGHT scale estimate
c     is returned as the value XSBIWT. The BIWEIGHT function is given
c     by:
c
c          u((1-u*u)**2)     abs(u) <= 1
c          f(u) =
c                                  0                 abs(u) >  1
c
c     where u is defined by
c
c          u = (XDATA(I) - M) / c*MAD  .
c
c     M, MAD, and c are the median, the median absolute deviation from
c     the median, and the tuning constant respectively. The tuning
c     constant is a parameter which is chosen depending on the sample
c     size and the specific function being used for the scale estimate.
c     (See page 417 in UREDA).  Here we take c = 9.0.
c
c     The biweght location is found using the formula:
c
c          T = M + (sums)
c
c          where M is the sample median and sums are
c          as given on page 421 in UREDA
c
c          the tuning constant c is set to 6.0 for calculation
c          of the location as reccommended by Tukey ()
c
c     NOTE that the biweight is meant to be an iterated estimator, but one
c     commonly only takes the first step of the iteration.  Here we report
c     both the one-step estimators (XLBIWT1, XSBIWT1) and the preferred
c     fully iterated versions (XLBIWT, XSBIWT).
c
c****************************************************************************
      parameter(iii=3000)
      implicit real*4 (a-h,o-z)
      dimension xdata(n),u1(iii),u2(iii),xlb(11),xsb(11)
      data zero,d6,d1,d5,d9/0.0,6.0,1.0,5.0,9.0/
 
c---  sort the data and find the median
 
      call mdian1(xdata,n,xm)
 
c---  call xmad to find the median absolute deviation
 
      call xmad(xdata,n,xm,xmadm)
 
c---  must choose value of the tuning constant "c"
c     here c = 6.0 for the location estimator and
c     9.0 for the scale estimator
 
      c1 = d6
      c2 = d9
      
c      c1 = 7.5			!only for comparing with Tom's signal free
c      c2 = 7.5			!only for comparing with Tom's signal free
 
      if (n.le.5.or.xmadm.le..0001) then
        xlbiwt=xm
        xlbiwt1=xm
        xsbiwt=3.0*xmadm/2.0
        xsbiwt1=3.0*xmadm/2.0
        return
      endif
 
      do i = 1,n
        u1(i) = (xdata(i) - xm)/(c1*xmadm)
        u2(i) = (xdata(i) - xm)/(c2*xmadm)
      enddo
      s1 = zero
      s2 = zero
      s3 = zero
      s4 = zero
      do i = 1,n
        if (abs(u2(i)) .lt. d1) then
          s1 = s1+(((xdata(i)-xm)**2)*(d1-(u2(i)*u2(i)))**4)
          s2 = s2+((d1-u2(i)*u2(i))*(d1-(d5*u2(i)*u2(i))))
        endif
        if (abs(u1(i)) .lt. d1) then
          s3 = s3+(xdata(i)-xm)*(d1-u1(i)*u1(i))**2
          s4 = s4+(d1-u1(i)*u1(i))**2
        endif
      enddo 
c---  here are the one-step estimators
      xlbiwt1 = xm+s3/s4
      xsbiwt1 = float(n)/(float(n-1))**0.5*s1**0.5/abs(s2)
c---  now obtain the fully-iterated versions
c---  solve for new estimates of u1 and u2
      xlb(1) = xlbiwt1
      xsb(1) = xsbiwt1
      do j = 2,11   !assuming 10 iterations is sufficient
        xmm = xlb(j-1)
        do i = 1,n
          u1(i) = (xdata(i) - xmm)/(c1*xmadm)
          u2(i) = (xdata(i) - xmm)/(c2*xmadm)
        enddo
        s1 = zero
        s2 = zero
        s3 = zero
        s4 = zero
        do i = 1,n
          if (abs(u2(i)) .lt. d1) then
            s1 = s1+(((xdata(i)-xmm)**2)*(d1-(u2(i)*u2(i)))**4)
            s2 = s2+((d1-u2(i)*u2(i))*(d1-(d5*u2(i)*u2(i))))
          endif
          if (abs(u1(i)) .lt. d1) then
            s3 = s3+(xdata(i)-xmm)*(d1-u1(i)*u1(i))**2
            s4 = s4+(d1-u1(i)*u1(i))**2
          endif
        enddo
        xlb(j) = xlb(j-1)+s3/s4
        xsb(j) = float(n)/(float(n-1))**0.5*s1**0.5/abs(s2)
      enddo
      xlbiwt = xlb(11)
      xsbiwt = xsb(11)
   20 continue
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c-----------------------------------------------------------------------------
      SUBROUTINE XMAD (XDATA,N,XMED,XMADM)
c-----------------------------------------------------------------------------
c
c     The XMAD subroutine calculates the Median Absolute Deviation from
c     the sample median. The median, M , is subtracted from each
c     ORDERED statistic and then the absolute value is taken. This new
c     set of of statistics is then resorted so that they are ORDERED
c     statistics. The MAD is then defined to be the median of this
c     new set of statistics and is returned as XMADM. The MAD can
c     be defined:
c
c                   XMADM = median{ abs(x(i) - M) }
c
c     where the x(i) are the values passed in the array XDATA, and
c     the median, M, is passed in the array XLETTER. The set of stats
c     in the brackets is assumed to be resorted. For more information
c     see page 408 in UREDA.
c
c****************************************************************************
 
      parameter(iii=3000)  !equal to mxs in main program
      implicit real*4 (a-h,o-z)
      dimension xdata2(iii),xdata(n)
      data dhalf,n1,n2/0.5,1,2/
      do i = 1,n
        xdata2(i) = abs(xdata(i) - xmed)
      enddo
      call qcksrt(n,xdata2)
ccc      call sort(n,xdata2)
      if (float(n)/float(n2) - int(n/n2) .eq. 0) then
        i1 = n/n2
        i2 = n/n2 + n1
        xmadm = dhalf*(xdata2(i1) + xdata2(i2))
      else
        i1 = int(n/n2) + n1
        xmadm = xdata2(i1)
      endif
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c------------------------------------------------------------------------------
      SUBROUTINE MDIAN1 (X,N,XMED)
c------------------------------------------------------------------------------
c
c     Taken from Numerical Recipes, page 460.
c     Given an array X of N numbers, returns their median value XMED, and
c     the array is sorted low to high
c
c*******************************************************************************
      real*4 x(n)
      call qcksrt(n,x)
ccc      call sort(n,x)
      n2=n/2
      if (2*n2.eq.n) then
        xmed=0.5*(x(n2)+x(n2+1))
      else
        xmed=x(n2+1)
      endif
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr mfs
*
*     computes the median, hinges, and fourth-spread of n observations
*
*     inputs:
*
*     x    =  input series, returned in ranked form
*     n    =  number of observations in series x
*
*     outputs:
*
*     xmed =  median of series x
*     hh   =  high hinge
*     hl   =  low hinge
*     fsd  =  fourth-spread
*     rmn  =  minimum value
*     rmx  =  maximum value
*
*     subroutines required:  sort
*
      subroutine mfs(x,n,xmed,hh,hl,fsd,rmn,rmx)
      real*4 x(n)
      integer temp1,temp2,j,k   !pjk
*
* rank the observations
      call qcksrt(n,x)
      rmn=x(1)
      rmx=x(n)
      k=n
      j=(k/2)+1
      temp1=n+1-j
      xmed=(x(j)+x(temp1))/2.0
*
* calculate the high (hh) and low (hl) hinges 
* for computing the fourth-spread (fsd)
      k=(k+1)/2
      j=(k/2)+1
      temp1=k+1-j
      hl=(x(j)+x(temp1))/2.0
      temp1=n-k+j
      temp2=n+1-j
      hh=(x(temp1)+x(temp2))/2.0
*
* the fourth-spread
      fsd=hh-hl
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr qcksrt
*
      subroutine qcksrt(n,arr)
      parameter (m=7,nstack=10000,fm=7875.,fa=211.,fc=1663.,fmi=1.2698413e-4)
      dimension arr(n),istack(nstack)
      jstack=0
      l=1
      ir=n
      fx=0.
   10 if(ir-l.lt.m)then
        do 13 j=l+1,ir
          a=arr(j)
          do 11 i=j-1,1,-1
            if(arr(i).le.a)go to 12
            arr(i+1)=arr(i)
   11     continue
          i=0
   12     arr(i+1)=a
   13   continue
        if(jstack.eq.0)return
        ir=istack(jstack)
        l=istack(jstack-1)
        jstack=jstack-2
      else
        i=l
        j=ir
        fx=mod(fx*fa+fc,fm)
        iq=l+(ir-l+1)*(fx*fmi)
        a=arr(iq)
        arr(iq)=arr(l)
   20   continue
   21     if(j.gt.0)then
            if(a.lt.arr(j))then
              j=j-1
              go to 21
            endif
          endif
          if(j.le.i)then
            arr(i)=a
            go to 30
          endif
          arr(i)=arr(j)
          i=i+1
   22     if(i.le.n)then
            if(a.gt.arr(i))then
              i=i+1
              go to 22
            endif
          endif
          if(j.le.i)then
            arr(j)=a
            i=j
            go to 30
          endif
          arr(j)=arr(i)
          j=j-1
        go to 20
   30   jstack=jstack+2
        if(jstack.gt.nstack)pause 'nstack must be made larger.'
        if(ir-i.ge.i-l)then
          istack(jstack)=ir
          istack(jstack-1)=i+1
          ir=i-1
        else
          istack(jstack)=i-1
          istack(jstack-1)=l
          l=i+1
        endif
      endif
      go to 10
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr cenbyseg - censor by minimum segment length - mnsl
*
      subroutine cenbyseg(mnsl,x,nc,idate,ident,mxy,mxs)
      real*4 x(mxy,mxs)
      integer idate(mxs,3)
      character ident(mxs)*8
      maxn=idate(nc+1,2)-idate(nc+1,1)+1
      nc1=0
      ifmny1=9999
      ilmxy1=-9999
c
c *** find those series .ge. minimum segment legnth and save
c
      do j=1,nc
        nyrs=idate(j,3)
        if(nyrs.ge.mnsl)then
          nc1=nc1+1
          idate(nc1,1)=idate(j,1)
          idate(nc1,2)=idate(j,2)
          idate(nc1,3)=idate(j,3)
          ident(nc1)=ident(j)
          if(idate(nc1,1).lt.ifmny1)ifmny1=idate(nc1,1)
          if(idate(nc1,2).gt.ilmxy1)ilmxy1=idate(nc1,2)
          do i=1,maxn
            x(i,nc1)=x(i,j)
          enddo
        endif
      enddo
      maxn1=ilmxy1-ifmny1+1
      idate(nc1+1,1)=ifmny1
      idate(nc1+1,2)=ilmxy1
      idate(nc1+1,3)=maxn1
      if(maxn1.lt.maxn)then
        ndif=maxn-maxn1
        write(*,'(/1x,''Total chronology length shortened: '',i6,''  years'')')ndif
c        do i=1,maxn1
c          do j=1,nc
c            x(i,j)=x(i+ndif,j)
c          enddo
c        enddo
      endif
c
c *** dummy out the data matrix with missing values to account for removed series
c
      do j=nc1+1,nc
        do i=1,maxn
          x(i,j)=-999.0
        enddo
        call blank(ident(j))
      enddo
c
c *** final results
c
      write(*,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(*,'(1x,''Min segment length series:'',t30,4i6,''  Years total time span'')')
     *  nc1,ifmny1,ilmxy1,maxn1
      nc=nc1
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr cenayify - censor by minumum starting year - mnsy
*
      subroutine cenayify(mnsy,x,nc,idate,ident,mxy,mxs)
      real*4 x(mxy,mxs)
      integer idate(mxs,3),mnsy
      character ident(mxs)*8
c
      integer maxn,nc1,ifmny1,ilmxy1,i 
      maxn=idate(nc+1,2)-idate(nc+1,1)+1
      nc1=0
      ifmny1=9999
      ilmxy1=-9999
c
c *** Before changing the values in X check to see if there are any records that
c *** begin on or AFTER mnsy.  If not then return to the main program and prompt
c *** the user to try again. NOTE: mnsy is set to 0
c
      i=0
      do j=1,nc
        if(idate(j,1).ge.mnsy)i=i+1
      enddo
      if(i.eq.0)then
        mnsy=0
        return
      endif
c
c *** find those serie's with start years .ge. minimum starting year and save
c
      do j=1,nc
        ify=idate(j,1)
        if(ify.ge.mnsy)then
          nc1=nc1+1
          idate(nc1,1)=idate(j,1)
          idate(nc1,2)=idate(j,2)
          idate(nc1,3)=idate(j,3)
          ident(nc1)=ident(j)
          if(idate(nc1,1).lt.ifmny1)ifmny1=idate(nc1,1)
          if(idate(nc1,2).gt.ilmxy1)ilmxy1=idate(nc1,2)
          do i=1,maxn
            x(i,nc1)=x(i,j)
          enddo
        endif
      enddo
      maxn1=ilmxy1-ifmny1+1
      write(*,*)ilmxy1,ifmny1,maxn1
      idate(nc1+1,1)=ifmny1
      idate(nc1+1,2)=ilmxy1
      idate(nc1+1,3)=maxn1
      if(maxn1.lt.maxn)then
        ndif=maxn-maxn1
        write(*,'(/1x,''Total chronology length shortened: '',i6,''  years'')')ndif
c        do i=1,maxn1
c          do j=1,nc
c            x(i,j)=x(i+ndif,j)
c          enddo
c        enddo
      endif
c
c *** dummy out the data matrix with missing values to account for removed series
c
      do j=nc1+1,nc
        do i=1,maxn
          x(i,j)=-999.0
        enddo
        call blank(ident(j))
      enddo
c
c *** final results
c
      write(*,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(*,'(1x,''Min starting year series:'',t30,4i6,''  Years total time span'')')
     *  nc1,ifmny1,ilmxy1,maxn1
      nc=nc1
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr cenbyify - censor by maximum starting year - mxsy
*
      subroutine cenbyify(mxsy,x,nc,idate,ident,mxy,mxs)
      real*4 x(mxy,mxs)
      integer idate(mxs,3)
      character ident(mxs)*8
      maxn=idate(nc+1,2)-idate(nc+1,1)+1
      nc1=0
      ifmny1=9999
      ilmxy1=-9999
c
c *** Before changing the values in X check to see if there are any records that
c *** begin ON or BEFORE mxsy.  If not then return to the main program and prompt
c *** the user to try again. NOTE: mnsy is set to 0
c
      i=0
      do j=1,nc
        if(idate(j,1).lt.mxsy)i=i+1
      enddo
      if(i.eq.0)then
        mxsy=0
        return
      endif
c
c *** find those series .lt. minimum starting year and save
c
      do j=1,nc
        ify=idate(j,1)
        if(ify.lt.mxsy)then
          nc1=nc1+1
          idate(nc1,1)=idate(j,1)
          idate(nc1,2)=idate(j,2)
          idate(nc1,3)=idate(j,3)
          ident(nc1)=ident(j)
          if(idate(nc1,1).lt.ifmny1)ifmny1=idate(nc1,1)
          if(idate(nc1,2).gt.ilmxy1)ilmxy1=idate(nc1,2)
          do i=1,maxn
            x(i,nc1)=x(i,j)
          enddo
        endif
      enddo
      maxn1=ilmxy1-ifmny1+1
      idate(nc1+1,1)=ifmny1
      idate(nc1+1,2)=ilmxy1
      idate(nc1+1,3)=maxn1
      if(maxn1.lt.maxn)then
        ndif=maxn-maxn1
        write(*,'(/1x,''Total chronology length shortened: '',i6,''  years'')')ndif
c        do i=1,maxn1
c          do j=1,nc
c            x(i,j)=x(i+ndif,j)
c          enddo
c        enddo
      endif
c
c *** dummy out the data matrix with missing values to account for removed series
c
      do j=nc1+1,nc
        do i=1,maxn
          x(i,j)=-999.0
        enddo
        call blank(ident(j))
      enddo
c
c *** final results
c
      write(*,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(*,'(1x,''Max starting year series:'',t30,4i6,''  Years total time span'')')
     *  nc1,ifmny1,ilmxy1,maxn1
      nc=nc1
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr cenbycom - censor by common period - ifc, ilc
*
      subroutine cenbycom(ifc,ilc,x,nc,idate,ident,mxy,mxs)
      real*4 x(mxy,mxs)
      integer idate(mxs,3),ifc,ilc,nc
      character ident(mxs)*8
      maxn=idate(nc+1,2)-idate(nc+1,1)+1
      nc1=0
      nyc=ilc-ifc+1
      ifmny1=ifc
      ilmxy1=ilc
      maxn1=ilmxy1-ifmny1+1
c
c *** find those series with data in the common period - ifc, ilc
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        if(ify.le.ifc.and.ily.ge.ilc)then
          nc1=nc1+1
          idate(nc1,1)=idate(j,1)
          idate(nc1,2)=idate(j,2)
          idate(nc1,3)=idate(j,2)-idate(j,1)+1
          ident(nc1)=ident(j)
          do i=1,maxn
            x(i,nc1)=x(i,j)
          enddo
        endif
      enddo
      idate(nc1+1,1)=ifc
      idate(nc1+1,2)=ilc
      idate(nc1+1,3)=nyc
c
c *** shorten the length of retained series to the common interval only
c
      write(*,'(/1x,''Total chronology length shortened: '',i6,''  years'')')maxn-nyc
      do j=1,nc1
        ify=idate(j,1)
        ily=idate(j,2)
        ndif=ifc-ify
        do i=1,nyc
          x(i,j)=x(i+ndif,j)
        enddo
        do i=1,ndif
          x(i+nyc,j)=-999.0
        enddo
        idate(j,1)=ifc
        idate(j,2)=ilc
        idate(j,3)=nyc
      enddo
c
c *** dummy out the data matrix with missing values to account for removed series
c
      do j=nc1+1,nc
        do i=1,maxn
          x(i,j)=-999.0
        enddo
        call blank(ident(j))
      enddo
c
c *** final results
c
      write(*,'(/t30,''    NS   IFY   ILY   NYR'')')
      write(*,'(1x,''Max starting year series:'',t30,4i6,''  Years total time span'')')
     *  nc1,ifc,ilc,nyc
      nc=nc1
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr savcen - save the censored data in Tucson raw ringwidth format
*
      subroutine savcen(cproc,icen1,icen2,x,y,nc,idate,ident,itrdb,filnam,iu11,mxy,mxs)
      real*4 x(mxy,mxs),y(mxy)
      integer idate(mxs,3),icen1,icen2,nc
      character cproc,filnam*50,fil1*80,ident(mxs)*8,id*8,itrdb(3)*100,tag*6
c
c *** parse the input file name for creating the output file name
c
      ll=len(filnam)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(filnam(jj:jj).ne.' ')goto 1
      enddo
    1 ll=jj
      do j=1,ll
        jj=j
        if(filnam(j:j).eq.'.')then
          jj=j-1
          goto 2
        endif
      enddo
    2 ll=jj
c
c *** create the unique output file name for the censored data type
c
      call blank(fil1)
      fil1=filnam
      if(cproc.eq.'2')then
        if(icen1.lt.100)then
          fil1(ll+1:ll+12)='_mnsl=  .txt'
          write(fil1(ll+7:ll+8),'(i2)')icen1
        elseif(icen1.ge.100.and.icen1.lt.1000)then
          fil1(ll+1:ll+13)='_mnsl=   .txt'
          write(fil1(ll+7:ll+9),'(i3)')icen1
        elseif(icen1.ge.1000)then
          fil1(ll+1:ll+14)='_mnsl=    .txt'
          write(fil1(ll+7:ll+10),'(i4)')icen1
        endif
      elseif(cproc.eq.'3')then
        fil1(ll+1:ll+14)='_mxsy=    .txt'
        write(fil1(ll+7:ll+10),'(i4)')icen1
      elseif(cproc.eq.'4')then
        fil1(ll+1:ll+14)='_mnsy=    .txt'
        write(fil1(ll+7:ll+10),'(i4)')icen1
      elseif(cproc.eq.'5')then
        if(icen1.lt.100)then
          fil1(ll+1:ll+13)='_trunb=  .txt'
          write(fil1(ll+8:ll+9),'(i2)')icen1
        elseif(icen1.ge.100.and.icen1.le.999)then
          fil1(ll+1:ll+14)='_trunb=   .txt'
          write(fil1(ll+8:ll+10),'(i3)')icen1
        else
          fil1(ll+1:ll+15)='_trunb=    .txt'
          write(fil1(ll+8:ll+11),'(i4)')icen1
        endif
      elseif(cproc.eq.'6')then
        if(icen1.lt.100)then
          fil1(ll+1:ll+13)='_truna=  .txt'
          write(fil1(ll+8:ll+9),'(i2)')icen1
        elseif(icen1.ge.100.and.icen1.le.999)then
          fil1(ll+1:ll+14)='_truna=   .txt'
          write(fil1(ll+8:ll+10),'(i3)')icen1
        else
          fil1(ll+1:ll+15)='_truna=    .txt'
          write(fil1(ll+8:ll+11),'(i4)')icen1
        endif
      elseif(cproc.eq.'7')then
        fil1(ll+1:ll+19)='_comm=    -    .txt'
        write(fil1(ll+7:ll+10),'(i4)')icen1
        write(fil1(ll+12:ll+15),'(i4)')icen2
      endif
      call blank(tag)
      if(cproc.eq.'2')tag='mnsl'
      if(cproc.eq.'3')tag='mxsy'
      if(cproc.eq.'4')tag='mnsy'
      if(cproc.eq.'5')tag='trnb'
      if(cproc.eq.'6')tag='trna'
      if(cproc.eq.'7')tag='comm'
      open(iu11,file=fil1,status='unknown')
      write(*,'(/1x,''File for censored data created: '',a)')fil1
      do j=1,3
        if(cproc.eq.'2')itrdb(j)(85:88)='MNSL'
        if(cproc.eq.'3')itrdb(j)(85:88)='MXSY'
        if(cproc.eq.'4')itrdb(j)(85:88)='MNSY'
        if(cproc.eq.'5')itrdb(j)(85:88)='TRNB'
        if(cproc.eq.'6')itrdb(j)(85:88)='TRNA'
        if(cproc.eq.'7')itrdb(j)(85:88)='COMM'
        write(iu11,'(a)')itrdb(j)
      enddo
c
c *** write the censored data to the file in Tucson ring width format
c
      do j=1,nc
        call blank(id)
        id=ident(j)
        ify=idate(j,1)
        nyr=idate(j,3)
        do i=1,nyr
          y(i)=x(i,j)
        enddo
        call trrw(id,ify,nyr,y,nss,ifl,iu11,iuo,'mw',tit,tag,mxy,itrdb)
      enddo
      close(iu11)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr arpad
*
      subroutine arpad(x,n,y,np,ls,mxy)
      real*4 x(mxy),y(mxy)
      real*8 arps(500),wk1(9000),wk2(9000),wkm(500)
c
c *** extend the series off both ends with prediction error filter
c *** forecasts and hindcasts of length ls-1 (i.e. # of lags)
c
      lstest=0.67*n
      if(lstest.lt.ls)ls=lstest
      next=ls
      np=n+2*next
      do i=1,mxy
        y(i)=0.0
      enddo
      call mnsd(x,n,xm,sd)
      do i=1,n
        ii=i+next
        y(ii)=x(i)-xm
      enddo
      iopt=0
      ip=next
      call memcof(y(next+1),n,ip,pm,arps,wk1,wk2,wkm)
      call extend(y,n,next,arps,ip,iopt)
      do i=1,np
        y(i)=y(i)+xm
      enddo
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr memcof
*
      subroutine memcof(data,n,m,pm,cof,wk1,wk2,wkm)
      implicit real*8 (a-h,o-z)
      real*4 data(1)
      real*8 cof(1),wk1(1),wk2(1),wkm(1)
      data zero/0.0d0/,one/1.0d0/,two/2.0d0/
      rn=n
      p=zero
      do 11 j=1,n
        p=p+dble(data(j))*dble(data(j))
11    continue
      pm=p/rn
      wk1(1)=dble(data(1))
      wk2(n-1)=dble(data(n))
      do 12 j=2,n-1
        wk1(j)=dble(data(j))
        wk2(j-1)=dble(data(j))
12    continue
      do 17 k=1,m
        pneum=zero
        denom=zero
        do 13 j=1,n-k
          pneum=pneum+wk1(j)*wk2(j)
          denom=denom+wk1(j)**2+wk2(j)**2
13      continue
        cof(k)=two*pneum/denom
        pm=pm*(one-cof(k)**2)
        if(k.ne.1)then
          do 14 i=1,k-1
            cof(i)=wkm(i)-cof(k)*wkm(k-i)
14        continue
        endif
        if(k.eq.m)return
        do 15 i=1,k
          wkm(i)=cof(i)
15      continue
        do 16 j=1,n-k-1
          wk1(j)=wk1(j)-wkm(k)*wk2(j)
          wk2(j)=wk2(j+1)-wkm(k)*wk1(j+1)
16      continue
17    continue
      pause 'never get here'
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr extend
*
c
c *** uses prediction error filter or autogregressive coefficients
c *** to extrapolate a time series off either or both ends into
c *** never-never-land. are you listening, peter pan or tinkerbell?
c
c *** it can be used to pad the ends of time series before applying
c *** digital filters, provide starting values for autoregressive
c *** modeling or prewhitening, and simply forecast or hindcast a
c *** time series into the past for future for whatever purpose.
c
c       y    time series of length n
c       n    number of observations
c     ncast  number of forecasts and/or hindcasts
c      phi   prediction error filter coefficients
c      ip    order of prediction error filter
c     iopt   option for forecasts and hindcasts
c              -1 hindcasts only
c               0 forecasts and hindcasts
c               1 forecasts only
c
c *** a cautionary note:
c *** this routine assumes that room is available on either
c *** end of array y to put the forecasts and/or hindcasts.
c *** thus, if hindcasts are to be made, you must have moved
c *** the observations in y foreward to make room for the ncast
c *** hindcasts. if forecasts are to be made, array y must be
c *** dimensioned long enough to hold the ncast forecasts.
c *** thus, y must be dimensioned to hold n+ncast values and,
c *** perhaps, n+2*ncast elements long in the main program,
c *** depending on the way the subroutine is used.
c
      subroutine extend(y,n,ncast,arps,ip,iopt)
      real*4 y(1)
      real*8 arps(1),pf,pb,zero
      data zero/0.0d0/
ccc      write(2,'(10f8.4)')(arps(j),j=1,ip)			!debug
      do 15 i=1,ncast
        pf=zero
        pb=zero
        nf=ncast+n+i
        nb=ncast+1-i
        do 10 j=1,ip
          if(iopt.eq.0.or.iopt.eq.+1)pf=pf+arps(j)*dble(y(nf-j))
          if(iopt.eq.0.or.iopt.eq.-1)pb=pb+arps(j)*dble(y(nb+j))
   10   continue
        y(nf)=sngl(pf)
        y(nb)=sngl(pb)
ccc        write(2,'(1x,2i5,f9.5,i4,f9.5)')i,nb,y(nb),nf,y(nf)	!debug
   15 continue
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr runbar
*
      subroutine runbar(x,ybar,idate,nc,rxm,runr,ncnt,nsg,nlp,mxy,mxs,iu33,nocon)
c
c     x     -  input - real matrix of input series being averaged
c     ybar  -  input - real matrix containing a copy of the unstabilized series (*,1)
c             output - running rbar (runr) variance stabilized series, based on unsmoothed
c                     (*,2) and spline smoothed (*,3) runr series
c     idate - input - array of start and end years of input series
c     nc    - input - number of input series being averaged
c     runr  - output - real array containing sample sizes, running rbars, effective sample sizes
c     nsg   -  input - running rbar window length, must be odd - incremented by one if not
c     nlp   -  input - overlap of running rbar window
c     mxy  -  input - maximum number of observations - from calling program
c     mxs  -  input - maximum number of series - from calling program
c
      parameter(maxlen=10122750) !all possible pairs of correlations (N^2-N)/2 for max(4500) series
      real*4 x(mxy,mxs),ybar(mxy,3),rxm(mxy,7),runr(mxy,5),wrk1(maxlen)
      integer idate(mxs,3)
      nseg=0
      ncnt=0
      ifmn=idate(nc+1,1)
      ilmx=idate(nc+1,2)
      n=ilmx-ifmn+1   
      if(mod(nsg,2).eq.0)then
        nsg=nsg+1
        nlp=nsg-1
      endif
      nsgd2=nsg/2
      if(nocon.eq.0)write(*,'(/1x,''Running RBAR window length: '',t37,i5/
     *           1x,''Running RBAR window overlap: '',t37,i5)')nsg,nlp
      do i=1,n,nsg-nlp
        nseg=nseg+1
        iskp=(nseg-1)*nsg-(nseg-1)*nlp
        ifskp=ifmn+iskp
        ilskp=ifskp+nsg-1
        iyr=ifskp+nsg/2
        if(ilskp.le.ilmx)then
          call rrbar(x,wrk1,idate,nc,ifskp,ilskp,nr,ave,sdev,see,nsg,mxy,mxs,maxlen)
          if(ave.ne.-99.9)then
            ncnt=ncnt+1
            if(ncnt.eq.1)then
              ndif1=iyr-idate(nc+1,1)
            endif 
            rxm(ncnt,1)=iyr
            rxm(ncnt,2)=nr
            rxm(ncnt,3)=ave
            rxm(ncnt,4)=sdev
            rxm(ncnt,5)=see            
            runr(ncnt+ndif1,2)=ave            
            rncores=0.0
            do j=1,nsg
              j1=ifskp-idate(nc+1,1)+j
              do k=1,nc
                if(x(j1,k).ne.-9.99)rncores=rncores+1.0
              enddo
            enddo
            rncores=rncores/float(nsg)
            rxm(ncnt,6)=ave/(ave+(1.0-ave)/rncores)
            rxm(ncnt,7)=rncores
          endif
        endif
      enddo      
      if(nocon.eq.0)write(*,'(1x,''Running RBAR segments calculated: '',t37,i5)')ncnt
c
c *** pad the ends with values equal to the first and last running RBAR values
c
      do i=1,ndif1
          runr(i,2)=runr(ndif1+1,2)
      enddo
      ndif2=n-ncnt-ndif1
      do i=1,ndif2
          runr(i+ndif1+ncnt,2)=runr(ndif1+ncnt,2)
      enddo
c
c *** calculate the mean running RBARs for periods of constant sample size
c      
      icnt=1
      jcnt=0
      kcnt=0
      do i=2,n
        num1=runr(i-1,1)
        num2=runr(i,1)
        if(num2.eq.num1)then
          icnt=icnt+1
        else
          jcnt=jcnt+1
          kcnt=icnt
ccc          write(*,'(1x,''jcnt,kcnt: '',2i5)')jcnt,kcnt
          wrk1(jcnt)=kcnt
          icnt=icnt+1
        endif
        if(i.eq.n)then
          jcnt=jcnt+1
          kcnt=n
ccc          write(*,'(1x,''jcnt,kcnt: '',2i5)')jcnt,kcnt
          wrk1(jcnt)=kcnt
        endif
      enddo
      do i=1,jcnt
        sum=0.0
        if(i.eq.1)then
          kcnt1=1
        else
          kcnt1=wrk1(i-1)+1
        endif
        kcnt2=wrk1(i)
        rcnt=0.0
        do j=kcnt1,kcnt2
          rcnt=rcnt+1.0
          sum=sum+runr(j,2)
        enddo
        sum=sum/rcnt
        do j=kcnt1,kcnt2          
          runr(j,4)=sum
        enddo
      enddo      
c
c *** do the running rbar variance stabilization now
c
      call mnsd(ybar(1,1),n,xm,sd)
      do i=1,n
        runr(i,3)=runr(i,1)/(1.0+(runr(i,1)-1.0)*runr(i,2))
        runr(i,5)=runr(i,1)/(1.0+(runr(i,1)-1.0)*runr(i,4))
        iyr=ify+i-1
        datum=ybar(i,1)-xm
        ybar(i,2)=datum*sqrt(runr(i,2)*runr(i,3))+xm
        ybar(i,3)=datum*sqrt(runr(i,4)*runr(i,5))+xm
      enddo
      ifmn=idate(nc+1,1)
      write(iu33,'('' YEAR     NC   RBAR1    EPS1   NEFF1   RBAR2    EPS2   NEFF2'')')
      do i=1,n
        iyr=ifmn+i-1
        ncores=runr(i,1)
        rcores=runr(i,1)
        rbar1=runr(i,2)
        reff1=runr(i,3)
        eps1=(rcores*rbar1)/(rcores*rbar1+(1.0-rbar1))
        rbar2=runr(i,4)
        reff2=runr(i,5)
        eps2=(rcores*rbar2)/(rcores*rbar2+(1.0-rbar2))
        write(iu33,'(i5,i7,6f8.3)')iyr,ncores,rbar1,eps1,reff1,rbar2,eps2,reff2
      enddo
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr rrbar
*
      subroutine rrbar(x,wrk1,idate,nc,ifskp,ilskp,nr,ave,sdev,see,nsg,mxy,mxs,maxlen)
      real*4 x(mxy,mxs),wrk1(maxlen)
      real*8 x1,x2,dr,rn
      integer idate(mxs,3)
      ifyf=idate(nc+1,1)
      nr=0
      x1=0.d0
      x2=0.d0
      do 20 i=1,nc-1
        ify1=idate(i,1)
        ily1=idate(i,2)
        do 10 j=i+1,nc
          ify2=idate(j,1)
          ily2=idate(j,2)
          ifmx=max0(ify1,ify2)
          ilmn=min0(ily1,ily2)
          if(ifmx.gt.ifskp)then
            goto 10
          endif
          ist=ifskp-ifyf+1
          nmin=ilmn-ifskp+1
          if(nmin.gt.nsg)nmin=nsg
          if(nmin.eq.nsg)then
            call pearsn(x(ist,i),x(ist,j),nmin,r,a,b)
            if(r.gt.0)then
              nr=nr+1
              wrk1(nr)=r
              dr=r
              x1=x1+dr
              x2=x2+dr*dr
            endif
          endif
   10   continue
   20 continue
      if(nr.lt.3)then
        ave=-99.9
        sdev=-99.9
        see=-99.9
        return
ccc      elseif(nr.eq.1)then
ccc        ave=r
ccc        sdev=0.0
ccc        see=0.0
ccc        return
      else
        rn=dble(nr)
        ave=x1/rn
        sdev=dsqrt((x2-rn*ave*ave)/(rn-1.d0))
      endif
      rnr=nr
      see=sdev/sqrt(rnr)
      rnc=nc
      pap=(rnr/(rnc*(rnc-1.0)/2.0))*100.0
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr pearsn -- pearson product-moment correlation coefficient
*
      subroutine pearsn(x,y,n,r,a,b) !,,rho,int,slope
      real*4 x(n),y(n)
      ax=0.
      ay=0.
      do j=1,n
        ax=ax+x(j)
        ay=ay+y(j)
      enddo
      ax=ax/n
      ay=ay/n
      sxx=0.
      syy=0.
      sxy=0.
      do j=1,n
        xt=x(j)-ax
        yt=y(j)-ay
        sxx=sxx+xt**2
        syy=syy+yt**2
        sxy=sxy+xt*yt
      enddo
      sgy=sqrt(syy/(n-1.))
      sgx=sqrt(sxx/(n-1.))
      yxr=sgy/sgx
      r=sxy/sqrt(sxx*syy)
      b=yxr*r
      a=ay-b*ax
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr intfrm
*
      subroutine intfrm(datum,frm)
      character datum*(*),frm*(*)
      l=len(datum)
      ll=0
      nb=0
      do 5 i=1,l
        if(datum(i:i).ne.' ')then
          nb=i-1
          goto 10
        endif
    5 continue
   10 do 15 i=1,l
        if(datum(i:i).ne.' ')ll=ll+1
   15 continue
      if(nb.gt.0)then
        do 20 i=1,ll
          j=i+nb
          datum(i:i)=datum(j:j)
   20   continue
        do 25 i=ll+1,l
          datum(i:i)=' '
   25   continue
      endif
      call blank(frm)
      frm(1:2)='(i'
      if(ll.lt.10)then
        write(frm(3:3),'(i1)')ll
        frm(4:4)=')'
      else
        write(frm(3:4),'(i2)')ll
        frm(5:5)=')'
      endif        
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine stringclean(string,size)
c
c remove the blank spaces in string
c
	integer size
	character string
	integer p,k
c
10	do p=1,size-1
	  if(string(p:p).eq.char(32))then
	     do k=p,size-1
	       string(k:k)=string(k+1:k+1)
	     enddo
	  endif
	enddo
	do p=1,size-1
	  if(string(p:p).eq.char(32).and.string(p+1:p+1).ne.char(32))then
	    goto 10
	  endif
	enddo
c
	return
	end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr trrw: read/write indices/measurements
*
*  programmed jun 1984 by
*
*     richard  l  holmes
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
*  modified by r l holmes 22 aug 1988
*
************************************************************
*
*  this routine reads or writes tree-ring
*  indices or measurements in standard formats used
*  in the international tree-ring data bank (itrdb).
*
*     call trrw(id,iyr,n,y,nc,ifl,iu,iuo,q)
*               ==       = ==            =        (= see below)
*
* arguments (9):
*
* id:    series identification
*           6 characters for indices, 8 for measurements, string may be
*           longer.  when q = 'ir', if the first six characters of
*           id = '******' then nc need not be an array.
* iyr:   starting year of series
* n:     number of data values in series
*           returned as -999 if end-of-file
* y:     array of index or measurement values
*           when q = 'iw', if maximum value of series is over
*           9.989, entire series is divided by a factor of ten
*           in order to lower the maximum to 9.989 or lower.
* nc:    array of number of series included in index value for each year
*           when q = 'ir', see exception under 'id' above.
*           when q = 'iw', if nc(1) is zero or negative,
*           nc need not be an array)
* ifl:   count of number of series read, returned as -999 if end-of-file
* iu:    unit for reading or writing data
* iuo:   unit for printed output
* q:     character string *2 to indicate action desired:
*
*      indices,      read from file:   q = 'ir'
*      measurements, read from file:   q = 'mr'
*      indices,      write on file:    q = 'iw'
*      measurements, write on file:    q = 'mw'
*      cru data,     write on file:    q = 'cw'
*
************************************************************
*
      subroutine trrw(id,iyr,n,y,nc,ifl,iu,iuo,q,tit,tag,mxy,itrdb)
      character id*8,ida*8,line*100,q*2,tit*100,tag*6
      character itrdb(3)*100
      integer nc(mxy),iy(10),inc(10),flag
      real*4 y(mxy)
c
      flag=-9999
ccc      tag=tit(1:3)
      call blank(tit)
      ntit=min0(len(tit),100)
      if(q .eq. 'ir')then
        k=1
        if(id(1:6) .eq. '******')k=-1
      elseif(q .eq. 'mw' .or. q .eq. 'iw' .or. q .eq. 'cr')then
        goto 5
      endif
    2 n=0
      isw=0
      ier=0
      ifl=max0(ifl,0)
      ifl=ifl+1
      if(ifl.eq.1)then
        do j=1,3
          call blank(itrdb(j))
        enddo
      endif
      goto 1
   91 ier=ier+1
      if(ier .gt. 25)then
	  return
      endif
      if(ier.eq.1)then
        if(iuo .gt. 0)write(iuo,'(/t10,''title of data:''/1x,a)')line
        write(*,'(/1x,''title of data:''/1x,a)')line
ccc        tit(1:ntit)=line(1:ntit)
        tit(1:)=line(1:)
        itrdb(ier)(1:)=line(1:)
      else
        if(iuo .gt. 0)write(iuo,'(1x,a)')line
          if(ier.le.3)then
            itrdb(ier)(1:)=line(1:)
          endif
        write(*,'(1x,a)')line
      endif
    1 call blank(line)
      read(iu,'(a)',err=99,end=99)line
      if(n .eq. 0 .and. line(80:80) .eq. '#')then
        backspace iu
        call datar(line,n,y,iyr,iu,mxy)
        id=line(1:8)
        if(iuo .gt. 0)write(iuo,'(/t10,''title of data:  '',a/)')line
        return
      endif
      if(q .eq. 'ir')then
        if(line(7:10).eq.'    ')goto 1
        if(line(6:6).ne.'-'.and.line(5:5).ne.'-')then
          read(line,'(a6,t7,i4,10(i4,i3))',err=91,end=99)
     +      ida,iyr1,(iy(i),inc(i),i=1,10)
        elseif(line(6:6).eq.'-')then
          read(line,'(a5,t6,i5,10(i4,i3))',err=91,end=99)
     +      ida,iyr1,(iy(i),inc(i),i=1,10)
        elseif(line(5:5).eq.'-')then
          read(line,'(a4,t5,i6,10(i4,i3))',err=91,end=99)
     +      ida,iyr1,(iy(i),inc(i),i=1,10)
        endif
      ida(7:8)='  '
      elseif(q .eq. 'mr')then
        if(line(9:12).eq.'    ')goto 1
        if(line(8:8).ne.'-'.and.line(7:7).ne.'-')then
          read(line,'(a8,i4,10i6)',err=91,end=99)ida,iyr1,iy
        elseif(line(8:8).eq.'-')then
          read(line,'(a7,i5,10i6)',err=91,end=99)ida,iyr1,iy
        elseif(line(7:7).eq.'-')then
          read(line,'(a6,i6,10i6)',err=91,end=99)ida,iyr1,iy
        endif
      endif
ccc      write(*,'(1x,a,i8,10i6)')ida,iyr1,iy
      isw=isw+1
      l=10
      if(isw .eq. 1)then
      id=ida
      iyr=iyr1
      if(iyr .ge. 0)then
      l=10-mod(iyr,10)
      else
      l=abs(mod(iyr,10))
      if(l .eq. 0)l=10
      endif
      endif
      if(q .eq. 'mr')goto 3
      l=11-l
      do 10 i=l,10
      if(iy(i) .lt. 9990)then
      n=n+1
      y(n)=float(iy(i))*.001
      if(k .ge. 0)nc(n)=inc(i)
      else
      return
      endif
   10 continue
      goto 1
   99 n=-999
      ifl=-999
      return
    3 do 20 i=1,l
      if(iy(i) .eq. -9999)then
        flag=-9999
        do 6 j=1,n
          y(j)=y(j)*.1
    6   continue
        return
      endif
      if(iy(i) .eq. 999)then
        flag=-9999
        return
      endif
      n=n+1
      y(n)=float(iy(i))*.01
   20 continue
      goto 1
c
c *** write out tree-ring indices in tucson or cru format
c
    5 if(n.le.0)return
      ier=0
      j=0
      kyr=iyr
      if(q.eq.'iw'.or.q.eq.'cr')then
        if(q.eq.'cr')then
          ify=iyr
          ily=ify+n-1
          if(ify.le.-1000.or.ily.le.-1000)then
            write(iu,'(a6,2i5)')id(1:6),ify,ily
          else
            write(iu,'(a6,2i4)')id(1:6),ify,ily
          endif
        endif
        if(iyr.ge.0)then
          l=mod(iyr,10)+1
        else
          l=11-abs(mod(iyr,10))
          if(l.eq.11)l=1
        endif
   32   if(q.eq.'cr'.and.j.eq.n)return
        do i=1,10
          iy(i)=9990
          inc(i)=0
        enddo
        do i=l,10
          j=j+1
          if(j.gt.n)then
            j=-999
            goto 41
          endif
          if(nc(1).gt.0)then
            inc(i)=nc(j)
            else
            inc(i)=1
          endif
          iy(i)=nint(y(j)*1000.)
        enddo
   41   if(kyr.gt.-1000)then
          write(iu,'(a6,i4,10(i4,i3),2x,a)')
     +      id(1:6),kyr,(iy(k),inc(k),k=1,10),tag
        elseif(kyr.lt.-1000.and.kyr.gt.-10000)then
          write(iu,'(a5,i5,10(i4,i3),2x,a)')
     +      id(1:5),kyr,(iy(k),inc(k),k=1,10),tag
        else
          write(iu,'(a4,i6,10(i4,i3),2x,a)')
     +      id(1:5),kyr,(iy(k),inc(k),k=1,10),tag
        endif
        if(j.lt.0)return
        kyr=kyr-l+11
        l=1
        goto 32
      elseif(q .eq. 'mw')then
        goto 4
      endif
    4 if(iyr .ge. 0)then
      l=10-mod(iyr,10)
      else
      l=abs(mod(iyr,10))
      if(l .eq. 0)l=10
      endif
   42 do 50 i=1,l
      j=j+1
      if(j .gt. n)then
ccc      iy(i)=999
        iy(i)=flag
        l=i
        j=-999
        goto 51
      else
        if(flag.eq.999)then
          iy(i)=nint(y(j)*100.)
          if(iy(i) .eq. 999)iy(i)=1000
        elseif(flag.eq.-9999)then
          iy(i)=nint(y(j)*1000.)
          if(iy(i) .eq. 999)iy(i)=1000
        endif      
      endif
   50 continue
   51 if(kyr.gt.-1000)then
        if(l.eq.10)then
          write(iu,'(a8,i4,10i6,t75,a)')id,kyr,(iy(k),k=1,l),tag
        else
          write(iu,'(a8,i4,10i6)')id,kyr,(iy(k),k=1,l)
        endif
      elseif(kyr.lt.-1000.and.kyr.gt.-10000)then
        if(l.eq.10)then
          write(iu,'(a7,i5,10i6,t75,a)')id,kyr,(iy(k),k=1,l),tag
        else
          write(iu,'(a7,i5,10i6)')id,kyr,(iy(k),k=1,l)
        endif
      else
        if(l.eq.10)then
          write(iu,'(a6,i6,10i6,t75,a)')id,kyr,(iy(k),k=1,l),tag
        else
          write(iu,'(a6,i6,10i6)')id,kyr,(iy(k),k=1,l)
        endif
      endif
      if(j .lt. 0)return
      kyr=kyr+l
      l=10
      goto 42
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr datar: read data series preserving significant digits
*
*  programmed may 1986 by
*
*     richard  l  holmes
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
*  modified by r l holmes 19 sep 1988
*
*  call dataw (id,n,x,iyr,iu) write data series
*  call datar (id,n,x,iyr,iu) read data series
*
* parameters:
*
* id:  character string of flexible length to identify series
* n:   number of data values
*        (note: in calling datar, if 'n' is returned as a negative
*         value, an end-of-file has been reached.)
* x:   array of data values
* iyr: year of first data value
* iu:  unit to write or read series
*
      subroutine datar(id,n,x,iyr,iu,mxy)
      character line*80,frm*8,s*2,id*(*)
      real*4 x(mxy)
      s='rd'
      lz=min(len(id),80)
    2 read(iu,'(a)',err=99,end=99)line
      if(line(1:3) .ne.'n  ')then
      id(1:lz)=line(1:lz)
      endif
      read(line,'(2(2x,i8),t23,a)',err=2,end=99)n,iyr,frm
      if(index(frm,'(') .eq. 0 .or. index(frm,')') .eq. 0)goto 2
      read(iu,frm,err=97,end=98)(x(i),i=1,n)
      return
   97 write(*,'(''>> sbr datar:  error reading data'')')
      return
   98 write(*,'(''>> sbr datar:  unexpected end reading data'')')
      return
   99 n=-999
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr blank: blanks character string
*
*  programmed dec 1986 by
*
*     richard  l  holmes
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
*  modified by r l holmes  9 dec 1986
*
      subroutine blank(l)
      character l*(*)
      ll=len(l)
      do 10 i=1,ll
   10 l(i:i)=' '
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
ccccccccccccccccccccc  New Subroutines for RCS Detrending  cccccccccccccccccccccccccccccccc
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine rcurve(mxy,mxs,nc,x,xrc,f,idate,pith,flag,mxage,eq,iopt,alpha,ndt,poff,rcmax,
     *   mnpoff,istrtls)
c compute a simple age aligned population mean curve
c argument decs
	integer mxy,mxs,nc,mxage,iopt,ndt,rcmax,mnpoff
	real*4 alpha
	integer pith(mxs),idate(mxs,3)
	real*4 x(mxy,mxs),xrc(mxy),f(mxy),flag,eq(7)
	logical poff
c locals decs
	integer mxd, p,j,k,age,n1
	parameter (mxd=9000)    !must equal mxy
	real*4  num(mxd),sum(mxd),txrc(mxd),tf(mxd)
c	
	mxage=-9999
	do j=1,mxd
	  sum(j)=0.0;num(j)=0.0;xrc(j)=flag;f(j)=flag
	enddo
c
       mnpoff=0
       if(poff)then
         p=pith(1)
         do j=2,nc
            if(pith(j).lt.p)p=pith(j)
         enddo
         mnpoff=p
       endif
c	
	do j=1,nc
	  p=pith(j)+1
	  age=(idate(j,2)-idate(j,1))+1;
	  do k=1,age
	     sum(p)=sum(p)+x(k,j)
	     num(p)=num(p)+1.
	     p=p+1
	  enddo
	  if(p-1.gt.mxage)mxage=p-1
	enddo
c	
	do p=1,mxage
	  if(num(p).ne.0)then
	    txrc(p)=sum(p)/num(p)
	  else
	    txrc(p)=flag
	  endif
	enddo
	p=1
	do j=1,mxage
	   txrc(j)=txrc(p+mnpoff)
	   p=p+1
	enddo
	mxage=mxage-mnpoff
c
	if(rcmax.eq.0)then
	    n1=mxage
	else
	    n1=rcmax
	endif
c
       call detrend2(txrc,tf,mxage,n1,eq,iopt,9000,ndt,alpha,istrtls)			!Hakan
          do j=1,mxage
              xrc(j+mnpoff)=txrc(j); f(j+mnpoff)=tf(j)
              if( (j.gt.rcmax).and. (rcmax.ne.0) )f(j+mnpoff)=tf(rcmax)  !truncate regional curve  new 3/2012 pjk
          enddo
          mxage=mxage+mnpoff
c
	return
	end	
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr detrend2
* Use in conjunction with subroutine rcurve.f to perform quick and dirty regional curve
* standardization 
* Writen by ERC and only slighly modified by pjk.
*
* jdt detrending option
* alpha freidman smoother, lowess smoother
*
      subroutine detrend2(x,f,n1,n,eq,jdt,mxy,ndt,alpha,istrtls)			!Hakan
c
      integer n1,n,jdt,mxy,ndt
      real*4  x(mxy),f(mxy),eq(7)
      parameter (i1=1,i2=2,i3=3,i4=4,i5=5,i6=6,i10=10,i21=21,iu11=11)
      parameter (nemax=9000,ndmax=i5,ndmaxp1=i6,r0=0e0,r1=1e0,nmax=9000)
      real*4 pam(ndmaxp1,ndmax),yam(ndmaxp1),v(ndmax)
      real*4 span,alpha,w(nmax),sc(nmax,7)
      real*4 wk2(nmax),wk3(nmax)    !dimention must equal mxy
      real*4 rdt
      integer ls2(nmax)   !new pjk age dependent spline2
c      
c
      do i=1,7
        eq(i)=0.0
      enddo
      ls=0
      ndif=0
      if(jdt.eq.-5)then
        do i=1,n
          wk2(i)=float(i)
          wk3(i)=x(i)
          w(i)=1.0
        enddo
        span=0.0
        if(n.lt.40)span=0.3
        iper=1
c        alpha=float(ndt)   !pjk
        call supsmu(n,wk2,wk3,w,iper,span,alpha,f,sc)
      elseif(jdt.eq.-4)then
        do i=1,n
          wk2(i)=x(i)
        enddo
         alpha=float(ndt)/100.  
c        rdt=float(ndt)
         call lowess(mxy,wk2,f,n,alpha)   !pjk
      elseif(jdt.eq.-3)then
        do i=1,n
          wk2(i)=x(i)
        enddo
	 ndt=int(alpha)
        call msmoor(wk2,f,wk3,n,ndt,iter2,ier,mxy)
      elseif(jdt.eq.-2)then    !age dependent spline  pjk
ccc        istrtls=10				!starting ls now expressed as a variable
        call lsmake(nmax,n,istrtls,ls2)
        call spline2(n,x,f,ls2)
        do i=1,n				!ERC add for non-increasing end to age dependent spline
          wk2(i)=f(i)
        enddo
        nxx=0      
        do i=1,n
          ii=n-i
          iii=n-i+1
          datum1=wk2(ii)
          datum2=wk2(iii)
          if(datum2.gt.datum1)then
            nxx=nxx+1
          else
            nx=n-nxx
            rpad=wk2(nx)
            iext=nxx
            goto 10
          endif
        enddo
   10   continue
        if(nx.lt.n)then
          do i=1,iext
            wk2(i+nx)=rpad
          enddo
          call lsmake(mxlen,n,istrtls,ls2)
          call spline2(n,wk2,f,ls2)
        endif          
          
      elseif(jdt.eq.-1)then
        do i=2,n
          wk2(i-1)=x(i)
        enddo
        call xmean2(x(2),n-1,xm1)
        do i=2,n
          wk3(i-1)=x(i)-x(i-1)						                !first-difference
        enddo
        x(1)=-999.0
        n=n-1
        do i=1,n
          x(i+1)=wk3(i)
        enddo
        ls=n/3
        call spline(n,wk2,f,p,ls)
        do i=1,n
          wk2(i)=wk2(i)/f(i)
        enddo
        call moment(x(2),n,ave1,adev,sdev1,var,skew,curt,sens,ac)
        call moment(wk2,n,ave2,adev,sdev2,var,skew,curt,sens,ac)
        do i=1,n
          x(i+1)=(x(i+1)-ave1)/sdev1
          x(i+1)=x(i+1)*sdev2+ave2
        enddo
      elseif(jdt.eq.1.or.jdt.eq.2)then
        do i=1,7
          eq(i)=0.0
        enddo
c        call curve(n,x,f,eq)				!negative exponential curve
        call curve(n1,n,x,f,eq)				!Hakan
        if(eq(2).le.0.or.eq(5).lt.0)then
          do i=1,7
            eq(i)=0.0
          enddo
c          call trend(n,x,f,eq(3),eq(5))
          call trend(n1,n,x,f,eq(3),eq(5))		!Hakan
          if(jdt.eq.1)then
            jdt=4
          elseif(jdt.eq.2.and.eq(3).le.0)then
            jdt=5
          else
            do i=1,7
              eq(i)=0.0
            enddo
            jdt=5
            call xmean2(x,n,eq(5))
c            do i=1,n
            do i=1,n1
              f(i)=eq(5)					!Hakan
            enddo
          endif
        endif
      elseif(jdt.eq.3)then
        iopt=1
        do i=1,n
          wk2(i)=i
        enddo
	       nd=iopt+i2
        pam(1,1)=0.0
        pam(1,2)=0.0
        pam(1,3)=0.0
        pam(1,4)=0.0
        pam(1,5)=0.0
c        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n,wk2,x,f,sumsq)
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n1,n,wk2,x,f,sumsq)		!Hakan
        slop=pam(i1,i2)
        eq(1)=pam(i1,i1)
        eq(2)=abs(pam(i1,i2))
        eq(3)=r0
        eq(5)=pam(i1,i3)
        eq(6)=r0
        if(slop.ge.0)then
          jdt=4
          do i=1,7
            eq(i)=0.0
          enddo
c          call trend(n,x,f,eq(3),eq(5))
          call trend(n1,n,x,f,eq(3),eq(5))				!Hakan
        endif
      elseif(jdt.eq.4.or.jdt.eq.5)then
c        call trend(n,x,f,eq(3),eq(5))				        !linear regression
        call trend(n1,n,x,f,eq(3),eq(5))				 	!Hakan
        if(jdt.eq.5.and.eq(3).gt.0)then
          jdt=6
          eq(3)=0.0
          eq(5)=0.0
          call xmean2(x,n,eq(5))						            !arithmetic mean
c          do i=1,n
          do i=1,n1								!Hakan
            f(i)=eq(5)
          enddo 
        endif       
      elseif(jdt.eq.6)then
        call xmean2(x,n,eq(5))						              !arithmetic mean
c        do i=1,n
        do i=1,n1								!Hakan
          f(i)=eq(5)
        enddo
      elseif(jdt.eq.7)then
        do i=1,n
          wk2(i)=i
        enddo
c        call hughdi(wk2,x,n,f,eq,flag)           !hugershoff growth curve
        call hughdi(wk2,x,n1,n,f,eq,flag)         !Hakan
        do i=1,n
          wk2(i)=i
          wk3(i)=f(i)
        enddo
        iopt=3
	       nd=iopt+i2
        pam(1,1)=eq(1)
        pam(1,2)=eq(2)
        pam(1,3)=eq(3)
        pam(1,4)=0.0
        pam(1,5)=0.0
c        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n,wk2,x,f,sumsq)
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n1,n,wk2,x,f,sumsq)		!Hakan
        eq(1)=pam(i1,i1)
        eq(2)=pam(i1,i2)
        eq(3)=abs(pam(i1,i3))
        eq(5)=pam(i1,i5)
        eq(6)=pam(i1,i4)
c        if(eq(2).le.0)then
c          jdt=3
c          do i=1,7
c            eq(i)=0.0
c          enddo
c          call trend(n,x,f,eq(3),eq(5))
c        endif
        eq(7)=jdt
      elseif(jdt.eq.8)then
c        call gexp(x,n,f,wk2,wk3,eq,flag)         !general exponential curve
        call gexp(x,n1,n,f,wk2,wk3,eq,flag)       !Hakan
        do i=1,n
          wk2(i)=i
          wk3(i)=f(i)
        enddo
        iopt=2
	       nd=iopt+i2
        pam(1,1)=eq(1)
        pam(1,2)=eq(2)
        pam(1,3)=0.0
        pam(1,4)=0.0
        pam(1,5)=0.0
c        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n,wk2,x,f,sumsq)
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n1,n,wk2,x,f,sumsq)		!Hakan
        eq(1)=pam(i1,i1)
        eq(2)=r1
        eq(3)=abs(pam(i1,i2))
        eq(5)=pam(i1,i4)
        eq(6)=pam(i1,i3)
        if(eq(2).le.0)then
          jdt=3
          do i=1,7
            eq(i)=0.0
          enddo
c          call trend(n,x,f,eq(3),eq(5))
          call trend(n1,n,x,f,eq(3),eq(5))			!Hakan
        endif
        eq(7)=jdt
      else
        if(jdt.gt.9)then
          ls=jdt											                      !fixed 50% frequency response
        elseif(jdt.lt.-9)then
          ls=ifix(abs((float(jdt)/100.0)*float(n)))			!%n frequency response
        endif
        do i=1,n
          wk2(i)=1.0
        enddo
ccc        call spl2w(x,n,f,wk2,p,ls,mxy)
ccc        call spl2w(mxy,n,x,wrk2,pp,f,ls)
        call spline(n,x,f,p,ls)						            !cubic spline filter
      endif
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	     subroutine pithy(mxs,iu,pith,poff,filnam)
c
c argument declarations.
	     integer iu,mxy,pith(mxs)
	     logical poff
	     character filnam*50,tf
c local declarations
	     integer p,j
	     integer ifmt
	     character junk*80,rfmt*40,infl*50,key*1
	     logical fok
c
c begin
c
            tf=' '
	     write(*,'(/1x,''Use a pith offset file? [T]rue or <[F]>alse'',t50,''==> '',$)')
	     read(*,'(a)')tf
            if(tf.eq.' ')tf='F'
            if(tf.eq.'F'.or.tf.eq.'f')poff=.false.
	     if(poff)then
   10	  call blank(infl)
	       write(*,'(/1x,''NOTE: the order of pith offsets must follow the order'')')
	       write(*,'(1x,''of the file raw ring width records: '',a)')filnam
	       write(*,'(/1x,''Okay? So enter pith offset file name here'',t50,''==> '',$)')
	       read(*,'(a)')infl
        if(infl(1:1).eq.'/')stop
        inquire(file=infl,exist=fok)
        if(.not.fok)then
	         write(*,'(//10x,''File > '',a25,'' < not found'')')infl
	         pause'          Hit return to enter a new file name or / to quit program.'
	         goto 10
        endif
   20	  write(*,'(//1x,''Select method to read the offset information:'')')
     	  write(*,'(1x,''Single column offset i.e.  <i4>   [1]'')')
	       write(*,'(1x,''User defined fortran format       [2]'')')
	       write(*,'(1x,''Enter option number'',t50,''==> '',$)')
	       read(*,*)ifmt
	       write(*,'(/1x,''Enter number of header lines to skip [none=0]'',t50,''==> '',$)')
	       read(*,*)p
	       select case(ifmt)
  	       case(1)
	         rfmt='(i4)'
	         case(2)
		        write(*,'(/1x,''Enter format to read just the '')')
		        write(*,'(1x,''offset values (within parentheses)'')')
  		      write(*,'(1x,''[e.g.,(2x,i3)]'',t50,''==> '',$)')
		        read(*,'(a)')rfmt
	         case default
		        write(*,'(/10x,''Please enter 1 or 2 '')')
          pause'          Hit RETURN and try again.'
  		      goto 20
	       end select
	       open(unit=iu,file=infl,status='old')
	       write(*,'(/1x,''Reading offset file: '',a)')infl
	       do j=1,p
    	     read(iu,'(a)')junk
	         write(*,'(1x,i2,''Title Line: '',a)')j,junk
	       enddo
	       poff=.true.
	       j=1	     
   30	  read(iu,rfmt,end=40,err=900)pith(j)   
	       j=j+1
	       if(j.gt.mxs)goto 901
	       goto 30
	     else  !no pith offset information, set all to 0
	       do j=1,mxs
	         pith(j)=0
	       enddo
	       poff=.false.
	       return
	     endif
   40	close(iu)
c
	     return
c
c error msgs
  900	write(*,'(/10x,''There was an error reading the pith offset '')')
	     write(*,'(10x,''values in file  : '',a)')infl
	     write(*,'(10x,''Do you want to try again? or quit?'')')
	     write(*,'(10x,''enter [\] to quit  : '',$)')
	     read(*,*)key
	     close(iu)
	     if(key.ne.char(92))then
	       goto 20
	     else
	       goto 1000
	     endif
	     goto 999
  901	write(*,'(/10x,''The number of pith offset values read exceeds the'')')
	     write(*,'(10x,''the dimensions of the array in which they are stored'')')

  999	write(*,'(/10x,''This is a fatal error, there is no recovery '')')
 1000	write(*,'(10x,''Program Terminating '')')
     	stop
     	end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c      subroutine gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,ne,x,y,yfit,sumsq)
c uses the nr subroutine amoeba to find useful values for the time and
c ringwidth offsets t and k in y = a*exp(b*ln(x+t)-c*(x+t)) + k as well
c as a, b, and c.
c
c nd is the number of amoeba dimensions. it must be ² ndmax.
c pam contains the nd+1 vectors of vertex coordinants of the amoeba.
c   they are initialized below to order of magnitude and usual sign.
c yam contains the rss for each vertex.
c iter is the number of steps the amoeba needed to find the solution.
c   itmax in amoeba is currently set to ????.
c if iopt = 1, an offset gamma with b=0 will be fit.
c  "   "  " 2,  "    "     "    "   b=1   "  "   " .
c           3,  "    "     "              "  "   " .
c ne is the number of (x,y) data pairs. it must be ² nemax.
c y is the (ringwidth) data to be fit.
c x is a vector of the same length as y. it will be loaded with the
c   numbers 1 thru ne below. not the years!
c yfit is the fitted function,
c sumsq it's residual sum of squares (rss).
c
c
       subroutine gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter2,iopt,nemax,n1,ne,x,y,yfit,sumsq)	!Hakan

	parameter (i1=1,i2=2,i3=3,i4=4,i5=5,i6=6)
      
      integer ndmaxp1,ndmax,nd,iter2,iopt,nemax,ne
      
      real*4    pam(ndmaxp1,ndmax),yam(ndmaxp1),v(ndmax)
	     real*4    pami(i3,i6,i5)
	     parameter (r0=0e0,rh=-1e-2,rt=1e-1,r1=1e0)
      parameter (ftol=1e-5)
	     real*4    x(nemax),y(nemax),yfit(nemax)
c234567890         0         0         0         0         0         012
	     data pami/r0,r0,r0,r1,r1,r1,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,
     *          r0,r0,r0,r0,r0,r0,rh,rh,r1,r0,r0,r0,r0,r0,r0,r0,r0,r0,
     *          r0,r0,r0,r0,r0,r0,r0,r0,r0,rt,r1,rh,r0,r0,r0,r0,r0,r0,
     *          r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,rt,r1,r0,r0,r0,
     *          r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,r0,rt/
c
c initialize pam and yam.
c the first vertex has been passed in pam as input.
c replace the original(0) vertex with this linearized solution.
      do ic=i1,i5
	       v(ic)=pam(i1,ic)
	     enddo
	     yam(i1)=gamoff(v,ndmax,nemax,ne,x,y,iopt)
      do ir=i2,nd+i1
	       do ic=i1,nd
		        pamu=pami(iopt,ir,ic)
		        pam(ir,ic)=pamu
		        v(ic)=pamu
		      enddo
	       yam(ir)=gamoff(v,ndmax,nemax,ne,x,y,iopt)
	     enddo
c
c call amoeba.
    2 call amoeba(pam,yam,ndmaxp1,ndmax,nd,iter2,ftol,
     *            iopt,nemax,ne,x,y)
	     sumsq=yam(i1)
c
c get the fitted function.
	     go to (21,22,23) iopt
   21 a=pam(i1,i1)
	     b=r0
      c=pam(i1,i2)
      t=r0
      rk=pam(i1,i3)
	     go to 9
   22 a=pam(i1,i1)
	     b=r1
	     c=pam(i1,i2)
	     t=pam(i1,i3)
	     rk=pam(i1,i4)
	     go to 9
   23 a=pam(i1,i1)
   	  b=pam(i1,i2)
   	  c=pam(i1,i3)
   	  t=pam(i1,i4)
   	  rk=pam(i1,i5)
c    9 do ie=i1,ne
    9 do ie=i1,n1						!Hakan
	       time=float(ie)+t
	       yfit(ie)=a*exp(b*alog(time)+c*time)+rk
	     enddo
	     return
	     end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	function gamoff(v,ndmax,nemax,ne,x,y,iopt)
c will compute y = a*exp(b*ln(x+t)-c*(x+t)) + k for x=1,ne.
c
      parameter (i1=1,i2=2,i3=3,i4=4,i5=5)
	     real*4    v(ndmax),x(nemax),y(nemax)
	     real*8    ad,bd,cd,td,rkd,sumsq,xd,tmd,d0,d1,yd,difd
	     parameter (d0=0d0,d1=1d0)
c
c dimensions...
      if(ne.gt.nemax) then
	       write(*,'(/1x,''in gamoff ne > nemax: '',2i10)') ne,nemax
		      pause'bye.'
		      stop
	     endif
c
c compute the residuals.
	     if(iopt.eq.i1) then
	       ad=dble(v(i1))
	       bd=d0
		      cd=dble(v(i2))
		      td=d0
		      rkd=dble(v(i3))
	       go to 8
	     endif
	     if(iopt.eq.i2) then
	       ad=dble(v(i1))
	       bd=d1
		      cd=dble(v(i2))
		      td=dble(v(i3))
		      rkd=dble(v(i4))
	       go to 8
	     endif
	     if(iopt.eq.i3) then
	       ad=dble(v(i1))
	       bd=dble(v(i2))
		      cd=dble(v(i3))
		      td=dble(v(i4))
		      rkd=dble(v(i5))
	       go to 8
	     endif
    8 sumsq=d0
	     do ie=i1,ne
	       xd=dble(x(ie))
		      tmd=xd+td
		      if(tmd.lt.d0) then
		        write(*,'(/1x,''in gamoff tmd ² 0 at xd.'',2d17.10)') tmd,xd
c23456789012345678901234567890123456789012345678901234567890123456789012
          pause'this is a fatal condition.'
		        stop
		      endif
		      yd=ad*dexp(bd*dlog(tmd)+cd*tmd)+rkd
		      difd=yd-dble(y(ie))
		      sumsq=sumsq+difd*difd
	     enddo
	     gamoff=sngl(sumsq)
	     return
	     end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine amoeba(p,y,mp,np,ndim,iter2,ftol,iopt,
     *                 nemax,ne,x,ye)
      integer iter2,mp,ndim,np,nmax,itmax
      real*4 ftol,p(mp,np),y(mp)
	     real*4    x(nemax),ye(nemax)
      parameter (nmax=5,itmax=2000)
cu    uses ametry,gamoff
      integer i,ihi,ilo,inhi,j,m,n
      real*4 rtol,sum,swap,ysave,ytry,psum(nmax)
      iter2=0
1     do 12 n=1,ndim
        sum=0.
        do 11 m=1,ndim+1
          sum=sum+p(m,n)
11      continue
        psum(n)=sum
12    continue
2     ilo=1
      if (y(1).gt.y(2)) then
        ihi=1
        inhi=2
      else
        ihi=2
        inhi=1
      endif
      do 13 i=1,ndim+1
        if(y(i).le.y(ilo)) ilo=i
        if(y(i).gt.y(ihi)) then
          inhi=ihi
          ihi=i
        else if(y(i).gt.y(inhi)) then
          if(i.ne.ihi) inhi=i
        endif
13    continue
      rtol=2.*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo)))
      if (rtol.lt.ftol) then
        swap=y(1)
        y(1)=y(ilo)
        y(ilo)=swap
        do 14 n=1,ndim
          swap=p(1,n)
          p(1,n)=p(ilo,n)
          p(ilo,n)=swap
14      continue
        return
      endif
      if (iter2.ge.itmax) then
        pause 'itmax exceeded in amoeba'
        return
      endif
      iter2=iter2+2
c	  write(*,'(1x,''iter2,y: '',i5,3e14.7)') iter2,(y(iy),iy=1,3)
c	  write(*,'(1x,''p: '')')
c	  do iv=1,3
c	    write(*,'(1x,2e14.7)') (p(iv,itk),itk=1,2)
c	  enddo
c	  write(*,'(1x,''a,b,c: '',3e14.7)') cc(1),cc(2),cc(3)
c234567890         0         0         0         0         0         012
      ytry=ametry(p,y,psum,mp,np,ndim,ihi,-1.0,iopt,
     *            nemax,ne,x,ye)
      if (ytry.le.y(ilo)) then
        ytry=ametry(p,y,psum,mp,np,ndim,ihi,2.0,iopt,
     *              nemax,ne,x,ye)
      else if (ytry.ge.y(inhi)) then
        ysave=y(ihi)
        ytry=ametry(p,y,psum,mp,np,ndim,ihi,0.5,iopt,
     *              nemax,ne,x,ye)
        if (ytry.ge.ysave) then
          do 16 i=1,ndim+1
            if(i.ne.ilo)then
              do 15 j=1,ndim
                psum(j)=0.5*(p(i,j)+p(ilo,j))
                p(i,j)=psum(j)
15            continue
			  itag=8
c234567890         0         0         0         0         0         012
              y(i)=gamoff(psum,np,nemax,ne,x,ye,iopt)
            endif
16        continue
          iter2=iter2+ndim
          goto 1
        endif
      else
        iter2=iter2-1
      endif
      goto 2
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      function ametry(p,y,psum,mp,np,ndim,ihi,fac,iopt,
     *                nemax,ne,xe,ye)
      integer ihi,mp,ndim,np,nmax
      real*4 fac,p(mp,np),psum(np),y(mp)
	     real*4    xe(nemax),ye(nemax)
      parameter (nmax=5)
cu    uses gamoff
      integer j
      real*4 fac1,fac2,ytry,ptry(nmax)
      fac1=(1.-fac)/ndim
      fac2=fac1-fac
      do 11 j=1,ndim
        ptry(j)=psum(j)*fac1-p(ihi,j)*fac2
11    continue
      i1=1
	     ndimm1=ndim-i1
	     r0=0e0
      if(iopt.gt.i1) then
		      if(ptry(ndimm1).le.r0) ptry(ndimm1)=r0
	     endif
	     itag=9
      ytry = gamoff(ptry,np,nemax,ne,xe,ye,iopt)
      if (ytry.lt.y(ihi)) then
        y(ihi)=ytry
        do 12 j=1,ndim
          psum(j)=psum(j)-p(ihi,j)+ptry(j)
          p(ihi,j)=ptry(j)
12      continue
      endif
      ametry=ytry
      return
      end

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr hughdi
*
c      subroutine hughdi(x,y,ntot,xy,coef,flag)
      subroutine hughdi(x,y,n1,ntot,xy,coef,flag)		!Hakan
c
c     x     --  predictor variable -- time t=1,ntot
c     y     --  tree-ring series
c     ntot  --  number of years
c     xy    --  hugershoff growth curve estimates
c     coef  --  vector of hugershoff coefficients
c     flag  --  missing value flag
c
c     ausgleich mit hugershoff-funktion
c     schaetzen der parameter mit direkter berechnung (h.p. holzhauser)
c     a, cm, ck    im modell 
c     y(i) = a * t(i)**cm * exp(ck*t(i))   fuer i=1....ntot
c     fuer die berechnung muessen folgender summenregister vom 
c     logarithmierten x und y und unlogarithmierten x (t) vorbereitet werden.
c     sumt, sumt2, sumx, sumx2, sumy, sumyt, sumxy und sumxt.
c     regression ueber hilfsfunktion 
c     z = ln(y) = ln(a) + m*ln(t) - k*t 
c     umgesetzt in z = a' + m*t' - k*t
c     nrow entsprechend dimensionierung hauptprogramm
c     ncoef muss 3 sein
c
c     september 1989 / nos/ve /  braeker/nogler
c     pc-version 2.1 / juni 1992 / p. nogler
c     modified by e.r. cook oct 23, 1996
c
      implicit real*8 (a-h,o-z)
      real*4 x(ntot),y(ntot),xy(ntot),coef(7),flag
      real*8 a,ck,cm,se,sf,cc,dcoef(3)
      integer ntot,ncoef,nred
      logical lber
      lber=.true.
      cc = -999.0d0
c
c     beginn hughdi
c
      if(.not.lber) goto 500 
      nred  = 0 
      sumt  = 0.0d0
      sumx  = 0.0d0
      sumx2 = 0.0d0
      sumt2 = 0.0d0
      sumxt = 0.0d0
      sumy  = 0.0d0
      sumxy = 0.0d0
      sumyt = 0.0d0
c
      do 200 k = 1,ntot
        xk=dble(x(k))
        yk=dble(y(k))
        if(yk.eq.flag) goto 200
        if(yk.le.0.0d0) goto 200
        if(xk.le.0.0d0) goto 200
        nred = nred+1 
        xl = dlog(xk)
        yl = dlog(yk)
        sumt  = sumt  + xk
        sumt2 = sumt2 + xk*xk
        sumx  = sumx  + xl
        sumx2 = sumx2 + xl*xl
        sumxt = sumxt + xl*xk
        sumy  = sumy  + yl
        sumxy = sumxy + xl*yl
        sumyt = sumyt + yl*xk
  200 continue
c 
      rn1 = (sumx2 * sumt2 - sumxt**2) 
      rn2 = (sumt * sumxt - sumx * sumt2) 
      rn3 = (sumx * sumxt - sumt * sumx2)
      rn  = nred * rn1 + sumx * rn2 + sumt * rn3
      rza = sumy * rn1 + sumxy * rn2 + sumyt * rn3
      a   = rza / rn
      rz2 = (sumx * sumt - nred * sumxt)
      rzm = sumy * rn2 + sumxy * (nred * sumt2 - sumt**2) + sumyt * rz2
      cm  = rzm / rn
      rz1 = (sumt * sumx2 - sumx * sumxt)
      rz2 = (nred * sumxt - sumx * sumt)
      rzk = sumy * rz1 + sumxy * rz2 + sumyt * (sumx**2 - nred * sumx2)
      ck  = rzk / rn
c
      ncoef = 3
      dcoef(1) = dexp(a)
      dcoef(2) = cm
      dcoef(3) = -ck
      coef(1) = sngl(dexp(a))
      coef(2) = sngl(cm)  
      coef(3) = sngl(-ck) 
ccc      if(coef(2).le.0.0)then
ccc        coef(2)=-999.0
ccc        xy(1)=-999.0
ccc        goto 700
ccc      endif
c 
c     coef-korrekturfaktor berechnen ueber abweichungen
c
      se = 0.0d0
      sf = 0.0d0
c      do k = 1,ntot 
      do k = 1,n1							!Hakan 
        xk = dble(x(k))
        yk = dble(y(k))
        dxy = dcoef(1) * xk**dcoef(2) * dexp(dcoef(3)*xk)
        xy(k) = sngl(dxy)
        if(yk.ne.flag)then 
          se = se+(yk-dxy) 
          sf = sf+dxy 
        endif
      enddo
      cc = se/sf+1.0d0
      if(cc.eq.0.0d0) goto 700 
      dcoef(1) = dcoef(1)*cc
      coef(1) = sngl(dcoef(1))
c      do k = 1,ntot 
      do k = 1,n1							!Hakan 
        xy(k) = xy(k)*cc 
      enddo
      goto 700
  500 continue
c     berechnen der ausgleichskurve und xy in kolonne 1 setzen
c      do k = 1,ntot 
      do k = 1,n1							!Hakan
        xk = dble(x(k))
        dxy = dcoef(1) * xk**dcoef(2) * dexp(dcoef(3)*xk)
        xy(k) = sngl(dxy) 
      enddo
  700 return
      end 
*sbr gexp
*
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine gexp(y,nt,n,f,wk1,wk2,coef,flag)		!Hakan
c
c     y     --  tree-ring series
c     n     --  number of years
c     f     --  general exponential curve estimates
c     wk1   --  work vector
c     wk2   --  work vector
c     coef  --  vector of hugershoff coefficients
c     flag  --  missing value flag
c
      real*4 y(n),f(n),wk1(n),wk2(n),coef(7),flag
      real*8 a,b,r,ax,ay,dn1,xt,yt,sxx,syy,sxy,sgy,sgx,yxr,ri
      if(n.le.0)then
        write(*,'(/1x,''*** n .le. 0 in sbr gexp ***''/)')
        pause
        stop
      endif
      a=0.0d0
      b=0.0d0
      n1=0
c
c *** linearize the problem
c
      do i=1,n
        if(y(i).gt.0.and.y(i).ne.flag)then
          n1=n1+1
          wk1(n1)=float(i)
          wk2(n1)=alog(y(i))-alog(wk1(i))
        endif
      enddo
      if(n1.le.0)then
        write(*,'(/1x,''*** n1 .le. 0 in sbr gexp ***''/)')
        pause
        stop
      endif
c
c *** now compute simple linear regression
c
      dn1=dfloat(n1)
      ax=0.0d0
      ay=0.0d0
      do j=1,n1
        ax=ax+dble(wk1(j))
        ay=ay+dble(wk2(j))
      enddo
      ax=ax/dn1
      ay=ay/dn1
      sxx=0.0d0
      syy=0.0d0
      sxy=0.0d0
      do j=1,n1
        xt=dble(wk1(j))-ax
        yt=dble(wk2(j))-ay
        sxx=sxx+xt**2
        syy=syy+yt**2
        sxy=sxy+xt*yt
      enddo
      sgy=dsqrt(syy/(dn1-1.0d0))
      sgx=dsqrt(sxx/(dn1-1.0d0))
      yxr=sgy/sgx
      r=sxy/dsqrt(sxx*syy)
      b=yxr*r
      a=ay-b*ax
c
c *** unlinearize the fitted model and calculate growth curve values
c
      a=dexp(a)
c      do i=1,n
      do i=1,nt					!Hakan
        ri=dble(i)
        f(i)=sngl(a*ri*dexp(b*ri))
      enddo
      coef(1)=sngl(a)
      coef(2)=-sngl(b)
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr moment
*
      subroutine moment(data,n,ave,adev,sdev,var,skew,curt,sens,ac)
      real*4 data(n)
      if(n.eq.0)then
        ave=-99.0
        adev=-99.0
        sdev=-99.0
        var=-99.0
        skew=-99.0
        curt=-99.0
        sens=-99.0
        ac=-99.0
        return
      endif
      rn=n
      s=0.0
      do j=1,n
        s=s+data(j)
      enddo
      ave=s/rn
      if(n.eq.1)then
        adev=-99.0
        sdev=-99.0
        var=-99.0
        skew=-99.0
        curt=-99.0
        sens=-99.0
        ac=-99.0
        return
      endif
      adev=0.0
      var=0.0
      skew=0.0
      curt=0.0
      sens=0.0
      do j=1,n
        s=data(j)-ave
        adev=adev+abs(s)
        p=s*s
        var=var+p
        p=p*s
        skew=skew+p
        p=p*s
        curt=curt+p
        if(j.lt.n)then
          rnum=data(j+1)-data(j)
          dnum=(data(j+1)+data(j))/2.0
          if(dnum.gt.0)then
            sens=sens+abs(rnum/dnum)
          endif
        endif
      enddo
      sens=sens/(rn-1.0)
      adev=adev/rn
      var=var/(rn-1.0)
      bvar=var*(rn-1.0)/rn
      if(var.gt.0.0)then
        sdev=sqrt(var)
        bsdev=sqrt(bvar)
        skew=skew/(rn*sdev**3)
        curt=curt/(rn*var**2)
        if(n.lt.3)then
          bfs=1.0
        else
          bfs=(sqrt(abs((rn*(rn-1.0))))/(rn-2.0))*(1.0+8.5/rn)
        endif
        if(n.lt.4)then
          bfk=1.0
        else
          bfk=(rn*rn*(rn+1.0))/((rn-1.0)*(rn-2.0)*(rn-3.0))
        endif
        skew=skew*bfs
        curt=curt*bfk
        do i=1,n
	         data(i)=(data(i)-ave)/bsdev
        enddo
        cxx=0.0
        do i=2,n
          cxx=cxx+data(i)*data(i-1)
        enddo
        ac=cxx/rn
        do i=1,n
          data(i)=data(i)*bsdev+ave
        enddo
      else
        sdev=-99.0
        skew=-99.0
        curt=-99.0
        ac=-99.0
      endif
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr xmean2
*
      subroutine xmean2(x,n,xm)
      real*4 x(n)
      if(n.le.0)then
        write(*,'(/1x,''error in xmean2: n=0'')')
        pause
        stop
      endif
      rn=n
      xm=0.0
      do i=1,n
        xm=xm+x(i)
      enddo
      xm=xm/rn
      return
      end

cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr lowess
*
*  argument description:
* 
*       x = input; abscissas of the points on the scatterplot; 
*           the values in x must be ordered from smallest to largest.
*       y = input; ordinates of the points on the scatterplot.
*       n = input; dimension of x,y,ys,rw, and res.
*       f = input; specifies the amount of smoothing; f is
*           the fraction of points used to compute each
*           fitted value; as f increases the smoothed values
*           become smoother; choosing f in the range .2 to .8
*           usually results in a good fit; if you have no
*           idea which value to use, try f = .5.
*  nsteps = input; the number of iterations in the robust
*           fit; if nsteps = 0, the nonrobust fit is
*           returned; setting nsteps equal to 2 should serve
*           most purposes.
*   delta = input; nonnegative parameter which may be used
*           to save computations; if n is less than 100, set
*           delta equal to 0.0; if n is greater than 100 you
*           should find out how delta works by reading the
*           additional instructions section.
*      ys = output; fitted values; ys(i) is the fitted value
*           at x(i); to summarize the scatterplot, ys(i)
*           should be plotted against x(i).
*      rw = output; robustness weights; rw(i) is the weight
*           given to the point (x(i),y(i)); if nsteps = 0,
*           rw is not used.
*     res = output; residuals; res(i) = y(i)-ys(i).
* 
ccc      subroutine lowess(x,y,n,f,nsteps,delta,ys,rw,res)
      subroutine lowess(mxy,y,ys,n,f)
      
      integer mxy,n
      real y(mxy), ys(mxy), f
      
      parameter(mxd=9000)
      integer nsteps
ccc      real x(n), y(n),  delta, ys(n), rw(n)
ccc      real res(n)
      real x(mxd),  delta, rw(mxd)
      real res(mxd)
      integer nright, min0, max0, i, j, ifix
      integer iter, last, m1, m2, ns, nleft
      real abs, cut, cmad, r, d1, d2
      real*4 c1, c9, alpha, denom, float
      logical ok
c
c *** ed's add in stuff
c
      nsteps=2
c	     if(n.le.100)then
        delta=0.0
c      else
c        range=x(n)-x(1)
c        delta=range/50.0
c      endif
      do i=1,n
        ri=i
        x(i)=ri
      enddo
c
c ***
c
      if (n .ge. 2) goto 1
         ys(1) = y(1)
         return
c at least two, at most n points
   1  ns = max(min(int(f*float(n)), n), 2)   !pjk
c   1  ns = max0(min0(ifix(f*float(n)), n), 2)
      iter = 1
         goto  3
   2     iter = iter+1
   3     if (iter .gt. nsteps+1) goto  22
c robustness iterations
         nleft = 1
         nright = ns
c index of prev estimated point
         last = 0
c index of current point
         i = 1
   4        if (nright .ge. n) goto  5
c move nleft, nright to right if radius decreases
               d1 = x(i)-x(nleft)
c if d1<=d2 with x(nright+1)==x(nright), lowest fixes
               d2 = x(nright+1)-x(i)
               if (d1 .le. d2) goto  5
c radius will not decrease by move right
               nleft = nleft+1
               nright = nright+1
               goto  4
c fitted value at x(i)
   5        call lowest(x, y, n, x(i), ys(i), nleft, nright, res, iter
     +     .gt. 1, rw, ok)
            if (.not. ok) ys(i) = y(i)
c all weights zero - copy over value (all rw==0)
            if (last .ge. i-1) goto 9
               denom = x(i)-x(last)
c skipped points -- interpolate
c non-zero - proof?
               j = last+1
                  goto  7
   6              j = j+1
   7              if (j .ge. i) goto  8
                  alpha = (x(j)-x(last))/denom
                  ys(j) = alpha*ys(i)+(1.0-alpha)*ys(last)
                  goto  6
   8           continue
c last point actually estimated
   9        last = i
c x coord of close points
            cut = x(last)+delta
            i = last+1
               goto  11
  10           i = i+1
  11           if (i .gt. n) goto  13
c find close points
               if (x(i) .gt. cut) goto  13
c i one beyond last pt within cut
               if (x(i) .ne. x(last)) goto 12
                  ys(i) = ys(last)
c exact match in x
                  last = i
  12           continue
               goto  10
c back 1 point so interpolation within delta, but always go forward
  13        i = max(last+1, i-1)
c  13        i = max0(last+1, i-1)
  14        if (last .lt. n) goto  4
c residuals
         do  15 i = 1, n
            res(i) = y(i)-ys(i)
  15        continue
         if (iter .gt. nsteps) goto  22
c compute robustness weights except last time
         do  16 i = 1, n
            rw(i) = abs(res(i))
  16        continue
         call sort(n,rw)
         m1 = n/2+1
         m2 = n-m1+1
c 6 median abs resid
         cmad = 3.0*(rw(m1)+rw(m2))
         c9 = .999*cmad
         c1 = .001*cmad
         do  21 i = 1, n
            r = abs(res(i))
            if (r .gt. c1) goto 17
               rw(i) = 1.
c near 0, avoid underflow
               goto  20
  17           if (r .le. c9) goto 18
                  rw(i) = 0.
c near 1, avoid underflow
                  goto  19
  18              rw(i) = (1.0-(r/cmad)**2)**2
  19        continue
  20        continue
  21        continue
         goto  2
  22  return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine lowest(x,y,n,xs,ys,nleft,nright,w,userw,rw,ok)
      parameter(mxy=9000)
      integer n
      integer nleft, nright
ccc      real*4 x(n), y(n), xs, ys, w(n), rw(n)
      real*4 x(mxy), y(n), xs, ys, w(n), rw(n)
      logical userw, ok
      integer nrt, j
      real*4 abs, a, b, c, h, r
      real*4 h1, sqrt, h9, range   !, amax1   -pjk
      range = x(n)-x(1)
      h = max(xs-x(nleft), x(nright)-xs)    !pjk
c      h = amax1(xs-x(nleft), x(nright)-xs)
      h9 = .999*h
      h1 = .001*h
c sum of weights
      a = 0.0
      j = nleft
         goto  2
   1     j = j+1
   2     if (j .gt. n) goto  7
c compute weights (pick up all ties on right)
         w(j) = 0.
         r = abs(x(j)-xs)
         if (r .gt. h9) goto 5
            if (r .le. h1) goto 3
               w(j) = (1.0-(r/h)**3)**3
c small enough for non-zero weight
               goto  4
   3           w(j) = 1.
   4        if (userw) w(j) = rw(j)*w(j)
            a = a+w(j)
            goto  6
   5        if (x(j) .gt. xs) goto  7
c get out at first zero wt on right
   6     continue
      
ccc         if(y(j).eq.-999.0)w(j)=0.0               !ed's bodge

         goto  1
c rightmost pt (may be greater than nright because of ties)
   7  nrt = j-1
      if (a .gt. 0.0) goto 8
         ok = .false.
         goto  16
   8     ok = .true.
c weighted least squares
         do  9 j = nleft, nrt
c make sum of w(j) == 1
            w(j) = w(j)/a
   9        continue
         if (h .le. 0.) goto 14
            a = 0.0
c use linear fit
            do  10 j = nleft, nrt
c weighted center of x values
               a = a+w(j)*x(j)
  10           continue
            b = xs-a
            c = 0.0
            do  11 j = nleft, nrt
               c = c+w(j)*(x(j)-a)**2
  11           continue
            if (sqrt(c) .le. .001*range) goto 13
               b = b/c
c points are spread out enough to compute slope
               do  12 j = nleft, nrt
                  w(j) = w(j)*(b*(x(j)-a)+1.0)
  12              continue
  13        continue
  14     ys = 0.0
         do  15 j = nleft, nrt
            ys = ys+w(j)*y(j)
  15        continue
  16  return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr msmoor
*
      subroutine msmoor(x,y,z,n,m,iter2,ier,mxy)
c     repeatedly calls msmoo until either absum < small or iter2 > itmax.
c
      parameter (i0=0,i1=1,i2=2,i3=3)
      parameter (itmax=10,small=1e-6)                                                                               
      real*4  x(mxy),y(mxy),z(mxy)
c
c input error checks
      ier=i0
      if(n.lt.m.or.n.gt.mxy)ier=i1
      if(m.lt.i1.or.m.gt.mxy)ier=i2
      if(mod(m,i2).ne.i1)m=m-1
      if(mod(m,i2).ne.i1)ier=i3
      if(ier.ne.i0) then
        write(*,'(/1x,''input error '',i1,'' in msmoor.'')') ier
        pause
        return
      endif
c pass.
      iter2=i0
   10 iter2=iter2+i1
      if(iter2.gt.itmax) then
        ier=20
		      write(*,'(/1x,''*** maximum iterations reached in '',
     *    ''msmoor ***'')')
        return
      endif
      call msmoo(x,y,z,n,m,iter2,ier,mxy)
      if(ier.ne.i0) then
        ier=ier+10
        return
      endif
      absum=0e0
      do i=i1,n                                                              
        absum = absum + abs(x(i) - y(i))
      enddo
c      write(*,'(/1x,i5,f10.7)') iter2,absum
c      write(11,'(/1x,i5,f10.7)') iter2,absum
      if(absum.lt.small) return
      do i=i1,n
        x(i)=y(i)
      enddo
      go to 10
      end 
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr msmoo
*                                                                      
      subroutine msmoo(x,y,z,n,m,iter2,ier,mxy)
c     will do median smoothing of a time series. n is the number of
c     data in the series, i.e. the series length. m is the filter
c     length which must be odd. x comes in,
c                               y goes out, and
c                               z is a little work vector.
c                               oh la di da!
c     at the ends medians of 1, 3, 5,..., m-2 data points are taken.
c
      parameter (i0=0,i1=1,i2=2)
      parameter (r0=0e0)
      real*4 x(mxy),y(mxy),z(mxy)
c
c
c input error checks
      ier=i0
      if(n.lt.m.or.n.gt.mxy) ier=i1
      if(m.lt.i1.or.m.gt.mxy) ier=i2
      if(mod(m,i2).ne.i1) ier=3
      if(ier.ne.i0) then
        write(*,'(/1x,''input error '',i1,'' in msmoo.'')') ier
        pause
        return
      endif
      if(m.eq.i1) then
        do i=i1,n
          y(i)=x(i)
        enddo
        return
      endif
      mm = (m-i1)/i2
c
c save the first point.
ccc      y(i1)=x(i1+1)
      y(i1)=x(i1)
c
c do from 2 thru mm.
      if(mm.gt.i1) then
        do i=i2,mm
          im=i2*i-i1
          do j=i1,im
            z(j) = x(j)
          enddo
ccc          call rank(z,im,mmax)
          call sort(im,z)
          y(i) = z(i)
        enddo
      endif
c
c do the middle.
      do i=mm+i1,n-mm
        jj=i-mm-i1
        do j=i-mm,i+mm
          z(j-jj) = x(j)
        enddo
ccc        call rank(z,m,mmax)
        call sort(m,z)
        y(i) = z(mm+i1)
      enddo
c
c do from n-mm+1 thru n-1.
      if(mm.gt.i1) then
        np1=n+i1
        do i=i2,mm
          im=i2*i-i1
          do j=i1,im
            z(j) = x(np1-j)
          enddo
ccc          call rank(z,im,mxy)
          call sort(im,z)
          y(np1-i)=z(i)
        enddo
      endif
c
c save the last point.
ccc      y(n)=x(n-1)
      y(n)=x(n)
c
      do i=i1,mm
        j=n-i+1
        y(i)=y(mm+1)
        y(j)=y(n-mm)
      enddo
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr sort
*
*      heapsort algorithm from numerical recipes
*
*      n   =  number of observations in ra to be sorted
*      ra  =  input series to be sorted. ra is returned
*             with its observations ranked in ascending
*             numerical order.
*
      subroutine sort(n,ra)
      real*4 ra(n)
      l=n/2+1
      ir=n
   10 continue
        if(l.gt.1)then
          l=l-1
          rra=ra(l)
        else
          rra=ra(ir)
          ra(ir)=ra(1)
          ir=ir-1
          if(ir.eq.1)then
            ra(1)=rra
            return
          endif
        endif
        i=l
        j=l+l
   20   if(j.le.ir)then
          if(j.lt.ir)then
            if(ra(j).lt.ra(j+1))j=j+1
          endif
          if(rra.lt.ra(j))then
            ra(i)=ra(j)
            i=j
            j=j+j
          else
            j=ir+1
          endif
        go to 20
        endif
        ra(i)=rra
      go to 10
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c function to find the maximum value
	function minimum(iarray, nsize)
	dimension iarray(nsize)
	minimum=iarray(1)
	do 10 j=2,nsize
	   if (minimum.gt.iarray(j)) minimum=iarray(j)
10     continue
	return
	end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c function to find the maximum value
	function maximum(iarray, nsize)
	dimension iarray(nsize)
	maximum=iarray(1)
	do 10 j=2,nsize
	   if (maximum.lt.iarray(j)) maximum=iarray(j)
10     continue
	return
	end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr comint: determines optimum common interval
*
*  programmed apr 1986 by
*
*     richard  l  holmes
*     tree-ring laboratory
*     university of arizona
*     tucson, arizona  85721  usa
*
*  modified by r l holmes 22 aug 1988
*  modified by pjk 2/2006
*
      subroutine comint(mxs,iyr,id,n,ns)
      integer mxs,ns
      integer n(mxs),iyr(mxs)
      character*8 id(mxs)
c
c local decs
	integer mxs2,i,l,m,j,k,ifl,icy,lcy,nly
	integer lyr,iz,lly,is,ici,nyc,ny,nci,nsci,nrci
	parameter (mxs2=3000)   !must = mxrec
       integer l20(mxs2,20)
	character sqc(mxs2)*40,sa*40,sb*40
c
*
      if(ns.gt.mxs2)goto 100
      ifl=0
c
      icy= 32000
      lcy=-32000
*
* here is where you would dump your 
* file data into the character array sqc 
      do 10 m=1,ns
          lyr=iyr(m)+n(m)-1
          icy=min(iyr(m),icy)
          lcy=max(lyr,lcy)
          iz=9000-iyr(m)
c          write(sqc(ns),'(5i5,2x,a8,5x)')lyr,iz,n(m),iyr(m),ns,id(m)
          write(sqc(m),'(5i5,2x,a8,5x)')lyr,iz,n(m),iyr(m),ns,id(m)
c          write(*,'(5i5,2x,a8,5x)')lyr,iz,n(m),iyr(m),ns,id(m)
c          pause '5'
10 	continue
c
       do 20 i=1,ns
          sa=sqc(i)
          sb=sqc(i)
          k=i
          do 30 j=i,ns
             if(sqc(j) .gt. sa)then
                sa=sqc(j)
                k=j
             endif
   30     continue
          sqc(k)=sb
20     sqc(i)=sa
*
* make array of starting and ending years of series
       nly=1
       read(sqc(1),'(i5,t1,i5,t16,i5)')l20(1,3),l20(1,2),l20(1,1)
       lly=l20(nly,3)
       do 60 i=2,ns
          read(sqc(i),'(i5,t1,i5,t16,i5)',err=1000)l20(mxs,3),l20(i,2),l20(i,1)
          if(lly .ne. l20(mxs,3))then
             nly=nly+1
             l20(nly,3)=l20(mxs,3)
             lly=l20(nly,3)
          endif
60     continue
c	write(*,*)nly
c	pause '2-commint'
       nrci=0
       do 40 l=1,nly
          do 50 i=1,ns
             nc=0
             ny=l20(l,3)-l20(i,1)+1
             do 70 is=1,ns
                 if(l20(is,1) .le. l20(i,1) .and. l20(is,2) .ge. l20(l,3))then
                    nc=nc+1
                 endif
70           continue
             nyc=nc*ny
             if(nyc .gt. nrci)then
                 nrci=nyc
                 ici=l20(i,1)
                 lci=l20(l,3)
                 nci=ny
                 nsci=nc
             endif
50        continue
c	   write(*,*)l,nly,i,ns
c	   pause '3-commint'
40     continue
c	pause '4-commint'
*
* print results on screen
       write(*,'(/t21,42(''*''))')
       write(*,'(t20,'' **  Time span of chronology: '',i5,'' to'',i5)')
     +        icy,lcy
       write(*,'(t20,'' **  length =               : '',i13)')
     +        lcy-icy+1
       write(*,'(t20,'' **  Number of series in chronology: '',i6)')ns
       write(*,'(t20,'' **  Optimum common interval: '',i5,'' to'',i5)')
     +        ici,lci
       write(*,'(t20,'' **  Number of years included: '',i12)')nci
       write(*,'(t20,'' **  Number of Series included:     '',i7,/,
     + t20,'' **  Number of rings:               '',i7)')nsci,nrci
       write(*,'(t20,'' **  Length of longest Series: '',i12)')maximum(n,ns)
       write(*,'(t20,'' **  Length of shortest Series: '',i11)')minimum(n,ns)

       write(*,'(t21,42(''*''))')
       return
100    write(*,'(/t20'' >> file contains more than program limit of'',i4,
     +'' series'')')mxs2-1
       stop' too many series for subroutine Commint'
1000   write(*,*)sqc(i)
	write(*,'(1x,''error reading sqc)'')')
	return
       end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine slpt1(mxy,mxs,x,idate,nc,ptmean,nocon)
c
c *** performs adaptive power transformation on matrix x alla cook and peters 1997, holocene
c *** pjk 2011, SU
c *** erc 2011, LDEO
c *** argument decs
c
      integer mxy,mxs,nc
      real*4 x(mxy,mxs)
      integer idate(mxs,3)
c local declarations
      integer p,j,k,i,n
      integer maxdat,maxser
      parameter(maxdat=9000,maxser=3000)!dimension must equal mxy
      integer num(maxser)
      real*4 level(maxdat,maxser),sprd(maxdat,maxser) 
      real*4 slope(maxser),yint(maxser),lv,sp,wk1(maxdat)
      real*4 xtmp(maxdat*maxser),ytmp(maxdat*maxser),rho,inter,slp
c
      j=1
      ptmean=0.0
      do k=1,nc
        n=(idate(k,2)-idate(k,1))+1
        do p=1,n
          wk1(p)=x(p,k)
        enddo
        call qcksrt(n,wk1)
        rmin=wk1(1)
        rmax=wk1(n)
        range=rmax-rmin
        i=1
        do p=1,n-1
          lv=x(p+1,k)
          sp=abs(x(p+1,k)-x(p,k))
          if(lv.gt.0. .and. sp.gt.0.)then
            level(i,k)=alog(lv); sprd(i,k)=alog(sp)
            xtmp(j)=level(i,k);ytmp(j)=sprd(i,k)
            i=i+1; j=j+1
          endif
        enddo
        num(k)=i-1
        call trend2(num(k),level(1,k),sprd(1,k),slope(k),yint(k))
        pt=1.0-slope(k)
        if(pt.lt.0.05)pt=0
        if(pt.gt.1.0)pt=1.0
        ptmean=ptmean+pt
        do p=1,n
          datum=x(p,k)
          if(pt.gt.0)then
            if(datum.lt.0.01)datum=0.01
            datum=datum**pt
          else
            if(datum.gt.0)then
              datum=alog(datum)
            else
              datum=alog(0.05)
            endif
          endif
          x(p,k)=datum
          wk1(p)=datum
        enddo
        call qcksrt(n,wk1)
        rminp=wk1(1)
        rmaxp=wk1(n)
        rangep=rmaxp-rminp
        do p=1,n
          datum=x(p,k)
          datum=(datum-rminp)*range/rangep+rmin
          x(p,k)=datum
        enddo
      enddo
      j=j-1
      ptmean=ptmean/float(nc)
      call pearsn(xtmp,ytmp,j,rho,inter,slp)
      if(nocon.eq.0)call scatplt(maxdat,maxser,level,sprd,slope,yint,num,nc,j,xtmp,rho,inter,slp)
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*rtn trend2: fits linear regression line to data pairs
*
* programmed (c) may 1987 from trend by
* richard l holmes, holzbiologie - bfh, universitaet hamburg - germany
* modified (c) 04 aug 1990
*
*  n:  number of values in each array
*  x:  array of horizontal coordinates
*  y:  array of vertical coordinates
*  sl: slope of regression
*  yi: y-axis intercept
*
*  equation:  y = sl * x + yi
*
      subroutine trend2(n,x,y,sl,yi)
      real*4 x(1),y(1),sl,yi
      integer n
c      
      integer i
      real*4 t,w,v,z
c
      an=float(n)
      t=0.
      w=0.
      v=0.
      z=0.
      do 10 i=1,n
         z=z+x(i)
         t=t+x(i)*x(i)
         v=v+y(i)*x(i)
   10 w=w+y(i)
      ymean=w/an
      if((t-z*z/an) .ne. 0.)then
         sl=(v-w*z/an)/(t-z*z/an)
      else
         sl=0.
      endif
      yi=ymean-sl*z/an
      end ! trend2
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	     subroutine lsmake(nmax,n,strtls,ls2)
	     integer n,j,strtls,nmax,ls2(nmax)
c
c *** makes an age dependent spline smoothing parameter arry
c
	     ls2(1)=strtls
	     do j=2,n
     	  ls2(j)=ls2(j-1)+1
     	enddo
     	return
     	end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr tabit
*
      subroutine tabit(x,nr,nc,ify,mxr,mxc,iux)
      dimension x(mxr,mxc)
      character tab,iout*1007,head*1007
      tab=char(9)
      mxt=10*nc+7
      call blank(head)
      head(1:5)=' ncnt'
      head(6:6)=tab
      head(7:15)='     freq'
      head(16:16)=tab
      do j=2,nc,4
        ij=(j-1)*10+7
        ik=ij+9
        head(ij:ik-1)=' power#  '
        write(head(ik-2:ik-1),'(i2)')j/4+1
        head(ik:ik)=tab
        head(ij+10:ik+9)='  dens#  '
        write(head(ik+8:ik+9),'(i2)')j/4+1
        head(ik+10:ik+10)=tab
        head(ij+20:ik+19)='  null#  '
        write(head(ik+18:ik+19),'(i2)')j/4+1
        head(ik+20:ik+20)=tab
        head(ij+30:ik+29)='95% cl#  '
        write(head(ik+28:ik+29),'(i2)')j/4+1
        head(ik+30:ik+30)=tab
      enddo
      write(iux,'(a)')head(1:ik+30)
      do 10 i=1,nr
        do 11 j=1,mxt
          iout(j:j)=' '
   11   continue
        write(iout(1:5),'(i5)')ify+i-1
        iout(6:6)=tab
        do 12 j=1,nc
          ij=(j-1)*10+7
          ik=ij+9
          write(iout(ij:ik-1),'(f9.5)')x(i,j)
          iout(ik:ik)=tab
   12   continue
        write(iux,'(a)')iout(1:ik)
   10 continue
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*     subroutine ftfreq (x,ind,xind,xymv,acv,freq,ps,xcov,xspect,
*    *                   amphas,xfer,coher,ier)
*-spect--------s-------library 1---------------------------------------
*
*   function            - multichannel time series analysis in the
*                           time and frequency domains
*   usage               - call spect (x,ind,xind,xymv,acv,freq,ps,
*                           xcov,xspect,amphas,xfer,coher,ier)
*   parameters   x      - input vector of length 2*ind(2). the first
*                           ind(2) locations contain a base time series
*                           x, and the second ind(2) locations contain
*                           a time series y to be crossed with x.
*                ind    - input vector of length 6. ind(i) contains
*                           when
*                           i=1, a control parameter.  ind(1) = 0
*                             implies calculations for x series only.
*                             nonzero ind(1) implies calculations for
*                             y series and cross-calculations only -
*                             assumes x calculations done and
*                             left in x, xymv, acv, and ps.
*                           i=2, the length of time series x and y.
*                           i=3, control parameter.  if ind(3) is
*                             negative -- xymv,acv,xcov
*                             zero     -- and freq,ps,xspect
*                             positive -- and amphas,xfer,coher
*                             are calculated. (xspect, not if ind(1)=0).
*                           i=4, the number of lags.
*                             (call ind(4) m, and let mp1 = m+1)
*                           i=5. option parameter. nonzero ind(5)
*                             implies prewhitening is desired.
*                             otherwise, set ind(5)=0.
*                           i=6. option parameter. nonzero ind(6)
*                             implies detrending is desired.
*                             otherwise, set ind(6)=0.
*                xind   - input vector of length 2. xind(i) contains
*                           when
*                           i=1, constant time interval (decimal) in
*                             some unit.
*                           i=2, constant in exclusive interval (-1,1)
*                             used for prewhitening when ind(5)
*                             is nonzero.
*                xymv   - output vector of length 6.
*                         xymv(i) contains when
*                           i=1, the mean of time series x
*                           i=2, the variance of series x
*                           i=3, the mean of time series y
*                           i=4, the variance of series y
*                           i=5 and 6, work area
*                acv    - output vector of length 2*m. acv(i) and
*                           acv(i+m) contain the autocovariances of
*                           series x and y, respectively, at time
*                           lag i, i=1,2,..,m.  xymv(2) and xymv(4)
*                           contain the autocovariances at lag 0.
*                freq   - output vector of length mp1 containing the
*                           frequencies at which the spectral quantities
*                           are calculated in cycles per unit of time.
*                ps     - output vector of length 2*mp1. ps(i) and
*                           ps(i+mp1) contain the power spectrum
*                           estimates of x and y, respectively, at
*                           frequencies freq(i), i=1,..,mp1.
*                xcov   - output vector of length m+mp1. xcov(i)
*                           contains the cross-covariance between series
*                           x and y at time lag i-mp1, i=1,2,..,m+mp1.
*                           thus, (i-mp1) = -m,..,0,..,m .
*                xspect - output vector of length 2*mp1, the cross-
*                           spectrum. xspect(i) and xspect(i+mp1)
*                           contain the cospectrum (real part) and
*                           quadrature spectrum (imaginary part),
*                           respectively, at freq(i), i=1,2,..,mp1 .
*                amphas - output vector of length 2*mp1. amphas(i) and
*                           amphas(i+mp1) contain the amplitude and
*                           phase, respectively, of the cross-spectrum
*                           at freq(i),i=1,2,..,mp1. the phase is given
*                           in fractions of a circle, between 0 and 1.
*                xfer   - output vector of length 2*mp1. xfer(i) and
*                           xfer(i+mp1) contain the amplitude of the
*                           transfer functions from x to y and y to x,
*                           respectively, at freq(i), i=1,2,...,mp1.
*                           not defined if ier = 67.
*                coher  - output vector of length mp1. coher(i) contains
*                           the coherence square at freq(i),
*                           i=1,2,...,mp1.  not defined if ier = 67.
*                ier    - error parameter.  ier = 0 implies no error.
*                         terminal error = 128+n
*                           n = 1 indicates one of ind out of range.
*                           n = 2 indicates one of xind out of range.
*                         warning (with fix) = 64+n
*                           n = 3 indicates a power spectral estimate
*                             was not positive - it is set to zero.
*                             xfer and coher cannot be calculated.
*                           n = 4 indicates a coherence estimate was
*                             greater than 1.0 -- it is set to 1.0.
*   precision           - single
*   reqd. imsl routines - ftauto,uertst
*   language            - fortran
*-----------------------------------------------------------------------
*   latest revision     - january 21, 1975
*
      subroutine ftfreq  (x,ind,xind,xymv,acv,freq,ps,xcov,xspect,
     &                    amphas,xfer,coher,ier)
      dimension          x(1),ind(1),xind(1),xymv(1),acv(1),freq(1),
     &                   ps(1),xcov(1),xspect(1),amphas(1),xfer(1),
     &                   coher(1)
      double precision   x54,x46,x23,sve,svex,hemp,hempx,ambda,
     &                   c,f,g,c1,c2,c3,temp,temp1,temp2,x1s8,xp5
      data               i0/0/,i1/1/,i2/2/,x1s8/.8333333333333333d-01/,
     &                   xp5/.5d0/,x54/.54d0/,x46/.46d0/,x23/.23d0/,
     &                   pi/3.1415927/
*                                  error checks
      nshift=0
      ier = 0
      if (ind(2).ge.4.and.ind(4).lt.ind(2).and.ind(4).ge.3) go to 10
    5 ier = 129
      go to 9000
   10 if (xind(1).gt.0.0) go to 20
   15 ier = 130
      go to 9000
   20 if (ind(5).eq.0) go to 25
      if (xind(2).le.-1.0.or.xind(2).ge.1.0) go to 15
      if (ind(1).ne.0.and.ind(3).ge.0) go to 5
*                                  useful constants
   25 n = ind(2)
      xn = n
      ml = ind(4)
      xml = ml
      mlp1 = ml+1
      if (ind(1).eq.0) ierx = 0
      mlm1 = ml-1
      if (ind(1).ne.0) go to 30
      itm = 0
      itn = 0
      itmp = 0
      it1 = 0
      go to 35
   30 itm = ind(4)
      itn = ind(2)
      itmp = itm+1
      it1 = 2
*                                  prewhitening
   35 if (ind(5).eq.0) go to 45
      nm1 = n-1
      itnp1 = itn+1
      sve = xind(2)
      wk = sve*dble(x(n+itn))-dble(x(1+itn))
      do 40 i=1,nm1
         x(i+itn) = dble(x(i+itnp1))-sve*dble(x(i+itn))
   40 continue
      x(n+itn) = wk
*                                  calculate mean and variance
   45 call ftauto (x(1+itn),n,i0,i0,i1,xymv(1+it1),xymv(2+it1),z,z,z,z)
      if (ind(6).ne.0) xymv(2+it1) = xymv(2+it1)+xymv(1+it1)*xymv(1+it1)
      if (ind(6).ne.0) go to 55
      xbar = xymv(it1+1)
      do 50 i=1,n
         x(i+itn) = x(i+itn)-xbar
   50 continue
*                                  covariances
   55 z = 0.0
      call ftauto (x(1+itn),n,ml,i0,i2,z,z,acv(1+itm),wk,wk,wk)
*                                  scale cov
      sve = n
      do 60 i=1,ml
         temp = sve/(sve-dble(float(i)))
         acv(i+itm) = dble(acv(i+itm))*temp
   60 continue
*                                  detrending
      if (ind(6).eq.0) go to 75
      k = (n+2)/3
      itnp1 = itn+n-k
      temp = 0.0d0
      do 65 i=1,k
         temp = temp+dble(x(i+itnp1))-dble(x(i+itn))
   65 continue
      itemp = 5 + it1/2
      xymv(itemp) = temp/(dble(xind(1))*dble(float(k*(n-k))))
      xymv(2+it1) = dble(xymv(2+it1))-dble(xymv(1+it1))**2-(dble(xn)*
     &dble(xind(1)))**2*dble(xymv(itemp))**2*x1s8
      hemp = n
      temp = dble(xind(1))**2
      temp1 = dble(xymv(1+it1))**2
      temp2 = dble(xymv(itemp))**2*x1s8
      do 70 i=1,ml
         sve = i
         ambda = temp*(hemp*(hemp-sve-sve)-2.d0*sve**2)
         acv(i+itm) = dble(acv(i+itm))-temp1-ambda*temp2
   70 continue
   75 if (ind(3).lt.0) go to 120
      if (ind(1).ne.0) go to 85
      den = 1.0/((xml+xml)*xind(1))
      do 80 i=1,mlp1
         freq(i) = float(i-1)*den
   80 continue
*                                  spectrum  - double
   85 c = (xind(1)+xind(1))/pi
      d = pi/xml
      temp1 = dble(xymv(2+it1))*xp5
      temp2 = dble(acv(ml+itm))*xp5
      do 95 i=1,mlp1
         xi = i-1
         xj = d*xi
         temp = temp1
         do 90 j=1,mlm1
            e = xj*float(j)
            temp = temp+dble(acv(j+itm))*dble(cos(e))
   90    continue
         temp = temp+temp2*dble(cos(xi*pi))
         ps(i+itmp) = temp*c
   95 continue
*                                  smooth spectrum
      sve = ps(1+itmp)
      ps(1+itmp) = x54*sve+x46*dble(ps(2+itmp))
      itmpp1 = itmp+1
      do 100 i=2,ml
         hemp = ps(i+itmp)
         ps(i+itmp) = x23*(sve+dble(ps(i+itmpp1))) + x54*hemp
         sve = hemp
  100 continue
      k = mlp1+itmp
      ps(k) = x54*dble(ps(k))+x46*sve
*                                  recoloring
*     if (ind(5).eq.0) go to 110
      if (ind(5).eq.0) go to 120
      sve = xind(2)
      pisxml = pi/xml
      do 105 i=1,mlp1
         xi = i-1
         c = 1.d0+sve*(sve-2.d0*dble(cos(xi*pisxml)))
         ps(i+itmp) = dble(ps(i+itmp))/c
  105 continue
*                                  check sign of spectral estimate
* 110 do 115 i=1,mlp1
*        if (ps(i+itmp).gt.0.0) go to 115
*        ps(i+itmp) = 0.0
*        if (ind(1).eq.0) ierx = 1
*        ier = 67
* 115 continue
  120 if (ind(1).eq.0) go to 185
*                                  multichannel calculations
*                                  cross-covariance
*                                  negative tau
      mlp = ml + nshift
      mlpp=mlp+1
*     do 130 i=1,mlp1
      do 130 i=1,mlpp
*        k = mlp1-i
         k = mlpp-i
         l = n-k
         temp = 0.0d0
         do 125 j=1,l
            temp = temp+dble(x(j+k))*dble(x(j+n))
  125    continue
         xcov(i) = temp/dble(float(n-k))
  130 continue
*                                  positive tau
*     do 140 i=1,ml
      do 140 i=1,mlp
         k = n+i
         l = n-i
         temp = 0.0d0
         do 135 j=1,l
            temp = temp+dble(x(j))*dble(x(j+k))
  135    continue
*        xcov(i+mlp1) = temp/dble(float(l))
         xcov(i+mlpp) = temp/dble(float(l))
  140 continue
      if(nshift.eq.0) go to 8000
      ntlag=mlp1+ml
      do 7000 i=1,ntlag
 7000 xcov(i)=xcov(i+nshift)
*                                  detrend
 8000 if (ind(6).eq.0) go to 150
      sve = xymv(1)
      svex = xymv(2)
      hemp = xymv(3)
      hempx = xymv(4)
      f = xymv(5)
      g = xymv(6)
      c1 = sve*hemp
      c2 = (sve*g-svex*f)*xp5
      c3 = f*g*x1s8
      hemp = n
      temp2 = dble(xind(1))**2
      do 145 i=1,ml
         sve = i
         ambda = temp2*(hemp*(hemp-sve-sve)-2.d0*sve**2)
         k = mlp1+i
         m = mlp1-i
         temp = -c1 - ambda*c3
         temp1 = sve * c2
         xcov(k) = dble(xcov(k)) + temp - temp1
         xcov(m) = dble(xcov(m)) + temp + temp1
  145 continue
      xcov(mlp1) = dble(xcov(mlp1))-c1-c3*(dble(xind(1))*hemp)**2
*                                  cross-spectrum
  150 if (ind(3).lt.0) go to 185
      c = xind(1)/pi
      d = pi/xml
      do 160 i=1,mlp1
         xi = i-1
         xj = d*xi
         temp1 = xcov(mlp1)
         temp2 = 0.0d0
         do 155 j=1,mlm1
            k = mlp1+j
            m = mlp1-j
            e = xj*float(j)
            f = dble(xcov(k))
            g = dble(xcov(m))
            temp1 = temp1+(f+g)*dble(cos(e))
            temp2 = temp2+(f-g)*dble(sin(e))
  155    continue
         e = xi*pi
         f = dble(xcov(ml+mlp1))
         g = dble(xcov(1))
         xspect(i) = c*(temp1+(f+g)*dble(cos(e))*xp5)
         xspect(i+mlp1) = c*(temp2+(f-g)*dble(sin(e))*xp5)
  160 continue
*                                  smooth x-spectrum
      sve = xspect(1)
      svex = xspect(1+itmp)
      xspect(1) = x54*sve+x46*dble(xspect(2))
      xspect(1+itmp) = x54*svex+x46*dble(xspect(2+itmp))
      do 165 i=2,ml
         k = i+itmp
         hemp = xspect(i)
         hempx = xspect(k)
         xspect(i) = x23*sve+x54*hemp+x23*dble(xspect(i+1))
         xspect(k) = x23*svex+x54*hempx+x23*dble(xspect(k+1))
         sve = hemp
         svex = hempx
  165 continue
      xspect(mlp1) = x54*dble(xspect(mlp1))+x46*sve
      xspect(mlp1+itmp) = x54*dble(xspect(mlp1+itmp))+x46*svex
      if (ind(3).eq.0) go to 185
*                                  amplitude & phase
      pippi = pi+pi
      do 175 i=1,mlp1
         k = i+itmp
         amphas(i) = dsqrt(dble(xspect(i))**2+dble(xspect(k))**2)
         if (xspect(i).ne.0.0) go to 170
         if (xspect(k).ge.0.0) amphas(k) = 0.25
         if (xspect(k).lt.0.0) amphas(k) = 0.75
         go to 175
  170    amphas(k) = atan(xspect(k)/xspect(i))
         if (xspect(i).lt.0.0) amphas(k) = amphas(k)+pi
         amphas(k) = amphas(k)/pippi
         if (amphas(k).lt.0.0) amphas(k) = 1.0+amphas(k)
  175 continue
*                                  transfer function
*     if (ierx.eq.1) ier = 67
*     if (ier.eq.67) go to 9000
      do 180 i=1,mlp1
         k = i+itmp
         xfer(i) = amphas(i)/ps(i)
         xfer(k) = amphas(i)/ps(k)
      if(xfer(i).lt.0.0) xfer(i)=0.0
      if(xfer(k).lt.0.0) xfer(k)=0.0
         coher(i) = amphas(i)*amphas(i)/(ps(i)*ps(k))
*        if (coher(i).le.1.0) go to 180
         if (coher(i).le.1.0) go to 179
         ier = 68
         coher(i) = 1.0
      go to 180
  179 if(coher(i).lt.0.0) coher(i)=0.0
  180 continue
  185 if (ier.eq.0) go to 9005
 9000 continue
*     call uertst (ier,6hspect)
 9005 return
      end
*     subroutine ftauto (w,lw,k,l,isw,amean,var,acv,ac,pacv,wkarea)
*
*-ftauto--------s/d-----library 1---------------------------------------
*
*   function            - given a time series, compute
*                           1. the mean and variance,
*                           2. the autocovariances,
*                           3. the autocovariances and autocorrelations,
*                           4. the partial autocorrelations.
*   usage               - call ftauto(w,lw,k,l,isw,amean,var,acv,ac,
*                           pacv,wkarea)
*   parameters   w      - input vector of length lw containing the time
*                           series.
*                lw     - input. length of w.
*                k      - input. number of autocovariances and
*                           autocorrelations to be computed.
*                l      - input. number of partial autocorrelations to
*                           be computed.  l must be less than or equal
*                           to k.
*                isw    - input. control parameter for determining task
*                           to be performed. if
*                             isw = 1  find mean and variance.
*                             isw = 2  find autocovariance.
*                             isw = 3  find mean, variance, and
*                                        autocovariances.
*                             isw = 4  find autocovariances and
*                                        autocorrelations.
*                             isw = 5  find mean, variance, auto-
*                                        covariances, and autocorrelat-
*                                        ions.
*                             isw = 6  find autocovariances, autocorrel-
*                                        ations, and partial autoco-
*                                        rrelations.
*                             isw = 7  find mean, variance, autocovar-
*                                        iances, autocorrelations, and
*                                        partial autocorrelations.
*                amean  - output for isw = 1,3,5, and 7.
*                           input for isw = 2,4, and 6. mean value of
*                           the time series w.
*                var    - output for isw = 1,3,5, and 7.
*                           input for isw = 2,4, and 6. variance of
*                           time series w.
*                acv(k) - output for isw = 2,3,4,5,6 and 7.
*                           autocovariances for time series w.  acv(i)
*                           corresponds to a time lag of i time units.
*                ac(k)  - output for isw = 4,5,6, and 7.
*                           autocorrelations for time series w.  ac(i)
*                           corresponds to a time lag of i time units.
*                pacv(l)- output for isw = 6 and 7.
*                           partial autocorrelations of time series w.
*                           pacv(1) = ac(1).
*                wkarea - work area vector of length l.
*   precision           - single/double
*   reqd. imsl routines - double/vxpadd
*   language            - fortran
*-----------------------------------------------------------------------
*   latest revision     - april 13,1973
*
      subroutine ftauto  (w,lw,k,l,isw,amean,var,acv,ac,pacv,wkarea)
*
      dimension          w(1),acv(1),ac(1),pacv(1),wkarea(1)
**    double precision   w,acv,ac,pacv,temp2,amean,var,wkarea
      double precision   temp,temp1
      im = (isw/2)*2 - isw
*                                  compute the mean
      if (im .eq. 0) go to 15
*1    call vxpzro
      temp = 0.0d0
      do 5 i=1,lw
*1  5 call vxpadd(w(i))
    5 temp = temp + dble(w(i))
**    call vxpsto(temp)
      amean = temp/lw
*                                  compute the variance
*1    call vxpzro
      temp = 0.0d0
      do 10 i=1,lw
**       temp = w(i)-amean
*1 10 call vxpmul(temp,temp)
   10 temp = temp + (dble(w(i)-amean)*dble(w(i)-amean))
**    call vxpsto(temp)
      var = temp/lw
      if (isw .eq. 1) go to 9005
*                                  compute autocovariances
   15 do 25 j=1,k
         kend = lw-j
*1       call vxpzro
         temp = 0.0d0
         do 20 i=1,kend
**          temp = w(i)-amean
**          temp1 = w(i+j)-amean
*1 20    call vxpmul(temp,temp1)
   20    temp = temp+(dble(w(i)-amean)*dble(w(i+j)-amean))
**       call vxpsto(temp)
         acv(j) = temp/lw
   25 continue
      if (isw .lt. 4) go to 9005
*                                  compute autocorrelations
      do 30 j=1,k
   30 ac(j) = acv(j)/var
      if (isw .lt. 6) go to 9005
*                                  compute partial autocovariance
      pacv(1) = ac(1)
       do 55 j=2,l
         j1 = j-1
         wkarea(j1) = pacv(j1)
         j2 = (j1)/2
         if(j .eq. 2) go to 40
         do 35 k0=1,j2
            j1mk = j1-k0
**          call vxpzro
**          call vxpadd(wkarea(k0))
**          call vxpmul(pacv(j1),-wkarea(j1mk))
**          call vxpsto(temp2)
**          call vxpzro
**          call vxpadd(wkarea(j1mk))
**          call vxpmul(pacv(j1),-wkarea(k0))
*2          call vxpsto(wkarea(j1mk))
            temp2 = wkarea(k0)-pacv(j1)*wkarea(j1mk)
            wkarea(j1mk) = wkarea(j1mk)-pacv(j1)*wkarea(k0)
   35    wkarea(k0) = temp2
*2 40    call vxpzro
   40    temp = 0.0d0
         temp1 = 0.0d0
         do 45 i=1,j1
*2 45    call vxpmul(ac(j-i),wkarea(i))
            temp = temp + (dble(ac(j-i)) * dble(wkarea(i)))
   45    temp1 = temp1 + (dble(ac(i)) * dble(wkarea(i)))
**       call vxpsto(temp)
**       call vxpzro
**       do 50 i=1,j1
** 50    call vxpmul(ac(i),wkarea(i))
**       call vxpsto(temp1)
         pacv(j) = (ac(j)-temp)/(1.0d0-temp1)
   55 continue
 9005 return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr sftest
c
c *** four tests of convergence based on mean and median absolute differences
c *** differences between successive signal free chronologies, both unweighted 
c *** and weighted by the square root of the changing sample count - meant to 
c *** discount weakly replicated portions of the chronology. Maybe it will work!
c
      subroutine sftest(f,g,nss,maxn,test1,test2,test3,test4,mxy,mxlen)
      real*4 f(mxy),g(mxlen),test1,test2,test3,test4
      integer nss(mxy)
c
c *** calculate the mean absolute difference
c
      test1=0.0
      maxn1=0
      do i=1,maxn
        if(nss(i).gt.0)then
          maxn1=maxn1+1
          g(maxn1)=f(i)
          test1=test1+f(i)
        endif
      enddo
      test1=test1/float(maxn1)
c
c *** calculate the median absolute difference
c
      call mfs(g,maxn1,xmed,hh,hl,fsd,rmn,rmx)
      test2=xmed
c
c *** calculate the maximum sample count for normalizing the sample count weights
c
      maxns=0
      do i=1,maxn
        if(nss(i).gt.maxns)then
          maxns=nss(i)
        endif
      enddo
      rmaxns=float(maxns)
c
c *** calculate the mean absolute differences weighted by the normalized sqrt(sample count)
c
      test3=0.0
      maxn1=0
      do i=1,maxn
        if(nss(i).gt.0)then
          maxn1=maxn1+1
          rnss=float(nss(i))
          g(maxn1)=f(i)*(sqrt(rnss)/sqrt(rmaxns))
          test3=test3+g(maxn1)
        endif
      enddo
      test3=test3/float(maxn1)
c
c *** calculate the median absolute differences weighted by the normalized sqrt(sample count)
c
      call mfs(g,maxn1,xmed,hh,hl,fsd,rmn,rmx)
      test4=xmed
c
c *** return the four test statistics to the calling program
c
      return
      end
*sbr biwgt: biweight robust mean estimation
*
*  programmed by:
*
*     edward r cook
*     tree-ring laboratory
*     lamont-doherty geological observatory
*     palisades, new york  10964
*
*       x  - input  - data vector of length n
*      wrk - input  - work vector of length n
*       n  - input  - number of observations in data vector x
*     iopt - input  - the measure of location to be estimated
*                   <0 = quantile (acceptible range -1 to -99,
*                        so -50 = median, -25 = lower hinge, -1 = minimum, etc.)
*                    1 = arithmetic mean
*                    2 = biweight robust mean
*     bimn - output - gaussian, biweight robust mean, or quantile
*     bisg - output - gaussian or biweight standard deviation - none for quantile 
*     bise - output - gaussian or biweight mean standard error - none for quantile
*      eff - output - efficiency of biweight mean relative to the gaussian mean
*      wgt - output - vector of biweights - only for iopt 2
*
*     subroutines called - mfs and qcksrt
*  
      subroutine biwgt(x,wrk,n,iopt,bimn,bisg,bise,wgt,eff,mxy)
      parameter(iii=3000)
      real*4 x(mxy),wrk(mxy),med,mad,wgt(mxy)
      real*8 xlb(11),xsb(11),u1(iii),u2(iii)
      real*8 c1,c2,d1,d5,dx,s1,s2,s3,s4,zero,xm,xmm,xmadm,drn,sq,var
c
      if(n.le.0)then						!fatal error test for n<=0
        bimn=-999.					
        pause'fatal error in biwgt: n is zero or negative'
        stop
      endif
c
      if(n.eq.1)then						!if n=1, just return
        bimn=x(1)	
        bisg=0.0
        bise=0.0
        eff=0.0
        return
      endif
c
      xm=0.d0							!compute gaussian mean and variance
      do i=1,n						!also used for later efficiency test (eff)
        xm=xm+dble(x(i))					!if biweight robust mean is calculated
      enddo
      drn=dfloat(n)
      xm=xm/drn
      gmean=sngl(xm)						!gaussian mean (gmean)
      sq=0.d0					
      do i=1,n		
        sq=sq+(dble(x(i))-xm)**2
      enddo
      var=sq/(drn-1.d0)
      gvar=sngl(var)						!gaussian variance (gvar)
      if(iopt.eq.1)then
        bimn=gmean
        bisg=sqrt(gvar)					!gaussian standard deviation
        bise=bisg/sqrt(rn)					!guassian standard error of the mean
        eff=1.0
        return
      endif
      call mfs(x,n,smed,shh,shl,sfsd,smn,smx)
      if(iopt.lt.0)then					!calculate quantiles if iopt<0
        iqt=iabs(iopt)
        if(iqt.eq.1)then					!minimum value quantile
          bimn=x(1)
        elseif(iqt.eq.25)then				!lower hinge quantile
          bimn=shl
        elseif(iqt.eq.50)then				!median
          bimn=smed
        elseif(iqt.eq.75)then				!upper hinge quantile
          bimn=shh
        elseif(iqt.eq.100)then				!maximum value quantile
          bimn=x(n)
        else							!other user-defined quantiles
          rqt=float(n)*float(iqt)/100.0
          iqt1=rqt
          iqt2=rqt+.5
          bimn=(x(iqt1)+x(iqt2))/2.0
        endif
        bisg=0.0
        bise=0.0
        eff=0.0
        return
      endif
      m=(n+1)/2		
      mm=n-m+1
      med=smed		     				!median (med) of data vector x
      bimn=smed
      do i=1,n
        wrk(i)=abs(x(i)-med)				!absolute departures from med
      enddo
      call qcksrt(n,wrk)
      mad=(wrk(m)+wrk(mm))/2.				!median absolute deviation (mad)
      smad=mad
*
      if(mad.lt.0.0001.and.n.gt.5)then			!mad too small for calculating
        bimn=med						!the biweight robust mean
        bisg=mad
        bise=mad/sqrt(rn)
        return
      endif
*
      if(n.le.5)then
        mad=3.*mad/2.					!if n.le.5, use median and
        bisg=mad						!scaled mad as robust estimates
        bise=mad/sqrt(rn) 					!of location, scale, and std error
        eff=1.0
        return
      endif
c
c *** compute bisquare mean using the median as the initial estimate -- this code from ROSTAT
c
      c1=7.5d0						!for comparison with ARSTAN
      c2=7.5d0						!for comparison with ARSTAN
c      c1=6.d0
c      c2=9.d0
      d1=1.d0
      d5=5.d0
      zero=0.d0
      xm=dble(med)
      xmadm=dble(mad)  
      do i=1,n
        dx=dble(x(i))
        u1(i)=(dx-xm)/(c1*xmadm)
        u2(i)=(dx-xm)/(c2*xmadm)
      enddo 
      s1=zero
      s2=zero
      s3=zero
      s4=zero 
      do i=1,n
        dx=dble(x(i))
        if(dabs(u2(i)).lt.d1)then
          s1=s1+(((dx-xm)**2.0d0)*(d1-(u2(i)*u2(i)))**4.0d0)
          s2=s2+((d1-u2(i)*u2(i))*(d1-(d5*u2(i)*u2(i))))
        endif
        if(dabs(u1(i)).lt.d1)then
          s3=s3+(dx-xm)*(d1-u1(i)*u1(i))**2.0d0
          s4=s4+(d1-u1(i)*u1(i))**2.0d0
        endif
      enddo
      xlb(1)=xm+s3/s4					!one-step biweight mean
      xsb(1)=drn/(drn-1.d0)**0.5d0*s1**0.5d0/dabs(s2) 	!one-step biweight std dev
c
c *** now obtain the fully-iterated versions solving for new estimates of u1 and u2 
c
      do j=2,4   						!assume 3 iterations is sufficient 
        xmm=xlb(j-1)
        do i=1,n
          dx=dble(x(i))
          u1(i)=(dx-xmm)/(c1*xmadm)
          u2(i)=(dx-xmm)/(c2*xmadm)
        enddo 
        s1=zero
        s2=zero
        s3=zero
        s4=zero 
        wgt(i)=1.0
        do i=1,n
          dx=dble(x(i))
          if(dabs(u2(i)).lt.d1)then
            s1=s1+(((dx-xmm)**2.0d0)*(d1-(u2(i)*u2(i)))**4.0d0)
            s2=s2+((d1-u2(i)*u2(i))*(d1-(d5*u2(i)*u2(i))))
          endif
          if(dabs(u1(i)).lt.d1)then
            s3=s3+(dx-xmm)*(d1-u1(i)*u1(i))**2.0d0
            s4=s4+(d1-u1(i)*u1(i))**2.0d0
            wgt(i)=sngl((d1-u1(i)*u1(i))**2.0d0)     	!Ed's code for biweights
          endif
        enddo
        xlb(j)=xlb(j-1)+s3/s4
        xsb(j)=drn/(drn-1.d0)**0.5d0*s1**0.5d0/dabs(s2)
      enddo
      bimn=sngl(xlb(4))					!return the iterated biweight mean
      bisg=sngl(xsb(4))					!return the iterated biweight std dev
      iter=3
      bise=bisg/sqrt(rn)					!return the iterated biweight std err
      if (bisg.gt.0) then					!return the relative biweight efficieny
        eff=gvar/bisg**2
c        if(eff.lt.1.0)then
c          bimn=gmean
c          bisg=sqrt(gvar)
c          bise=bisg/sqrt(rn)
c        endif
      else
        eff=1.0
      endif 
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr stabit: stabilize variance of a series using age-dependent spline smoothing
*
      subroutine stabit(tr,cv,sb,nc,n,mxy)
      parameter(mxlen=9000)
      real*4 tr(mxy),cv(mxy),sb(mxy)
      real*4 w(mxlen),wrk(mxlen),sc(mxlen,7)		!internal work vectors
      integer nc(mxy),ls2(mxlen)
      character isign(mxlen)
c
c *** calculate input series mean and sigma for all years and sample sizes (less stable?)
c
      call mnsd(tr,n,xbar,sig)
c
c *** calculate input series mean and sigma over only years with nc .ge. 5 (more stable?)
c
      n1=0
      n2=0
      do i=1,n
        if(nc(i).lt.5)then
          n2=n2+1
        elseif(nc(i).ge.5)then
          n1=n1+1
          wrk(n1)=tr(i)
        endif
      enddo
      call mnsd(wrk,n1,xbar1,sig1)
c
c *** if n1 (for nc .ge. 5) is .le. n/3, use mean and sigma for full length
c
      if(n1.le.n/3)then
        xbar1=xbar
        sig1=sig
      endif
c
c *** subtract appropriate mean to create chronology anomalies for signs
c
      do i=1,n
        tr(i)=tr(i)-xbar1
      enddo
c
c *** collect anomaly signs and absolute values of anomalies for detrending
c
      do i=1,n
        if(tr(i).lt.0.0)then
          isign(i)='-'
        else
          isign(i)='+'
        endif
        tr(i)=abs(tr(i))
      enddo
c
c *** use the supersmoother to detrend the absolute values of the anomalies
c
      do i=1,n
        wrk(i)=float(i)
        w(i)=1.0
      enddo
      span=0.0
      if(n1.lt.40)span=0.3
      iper=1
      alpha=3
      call supsmu(n,wrk,tr,w,iper,span,alpha,cv,sc)
      do i=1,n
        wrk(i)=cv(i)
      enddo
ccc      istrtls=n2
      istrtls=20
      call lsmake(mxlen,n,istrtls,ls2)
ccc      call spline2(n,tr,cv,ls2)  
      call spline2(n,wrk,cv,ls2)  
      do i=1,n				!ERC add for non-increasing end to age dependent spline
        wrk(i)=cv(i)
      enddo
      nxx=0      
      do i=1,n
        ii=n-i
        iii=n-i+1
        datum1=wrk(ii)
        datum2=wrk(iii)
        if(datum2.gt.datum1)then
          nxx=nxx+1
        else
          nx=n-nxx
          rpad=wrk(nx)
          iext=nxx
          goto 10
        endif
      enddo
   10 continue
      if(nx.lt.n)then
        do i=1,iext
          wrk(i+nx)=rpad
        enddo
      endif
      call lsmake(mxlen,n,istrtls,ls2)
      call spline2(n,wrk,cv,ls2)
c
c *** detrend abs anomalies and add back the appropriate signs of the detrended values
c
      do i=1,n
        sb(i)=tr(i)/cv(i)
        if(isign(i).eq.'-')sb(i)=-sb(i)
      enddo
c
c *** calculate the appropriate means and standard deviations for denormalizing
c
      call mnsd(sb,n,xbar,sig)
      nx=0
      do i=1,n
        if(nc(i).ge.5)then
          nx=nx+1
          wrk(nx)=sb(i)
        endif
      enddo
      call mnsd(wrk,nx,xbar2,sig2)
      if(nx.gt.n/3)then
        xbar=xbar2
        sig=sig2
      endif
c
c *** rescale the variance stabilized series and return
c
      do i=1,n
        dep=(sb(i)-xbar)/sig
        sb(i)=dep*sig1+xbar1
        if(sb(i).lt.0.0)sb(i)=0.0
      enddo   
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr stabit1: stabilize variance of a series
*
      subroutine stabit1(tr,cv,sb,ns,n,ls,mxy)
      real*4 tr(mxy),cv(mxy),sb(mxy)
      integer ns(mxy)
      real*8 p
      character isign(9000)
      call moment1(tr,ns,n,xbar1,adev,sig1,var,skew,curt,sens,ac)
      do i=1,n
        if(ns(i).gt.0)then
          tr(i)=tr(i)-xbar1
        endif
      enddo
      do i=1,n
        if(ns(i).gt.0)then
          if(tr(i).lt.0.0)then
            isign(i)='-'
          else
            isign(i)='+'
          endif
          tr(i)=abs(tr(i))
        endif
      enddo
      if(ls.lt.-9)then
        ls=abs((float(ls)/100.0)*float(n))
      endif
      call spline(n,tr,cv,p,ls)
      do i=1,n
        if(ns(i).gt.0)then
          sb(i)=tr(i)/cv(i)
          if(isign(i).eq.'-')sb(i)=-sb(i)
        endif
      enddo
      call moment1(sb,ns,n,xbar,adev,sig,var,skew,curt,sens,ac)
      do i=1,n
        if(ns(i).gt.0)then
          dep=(sb(i)-xbar)/sig
          sb(i)=dep*sig1+xbar1
          if(sb(i).lt.0.0)sb(i)=0.0
        endif
      enddo   
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr moment1
*
      subroutine moment1(data,ns,n,ave,adev,sdev,var,skew,curt,sens,ac)
      real*4 data(n)
      integer ns(n)
      if(n.eq.0)then
        ave=-99.0
        adev=-99.0
        sdev=-99.0
        var=-99.0
        skew=-99.0
        curt=-99.0
        sens=-99.0
        ac=-99.0
        return
      endif
      s=0.0
      n1=0
      ify=1680
      do j=1,n
        iyr=ify+j-1
        if(ns(j).gt.0)then
          n1=n1+1
          s=s+data(j)
ccc          write(*,'(2i5,2f8.3)')iyr,ns(j),data(j),s
ccc        else
ccc          write(*,'(2i5)')iyr,ns(j)
        endif
      enddo
      rn1=n1
      ave=s/rn1
      if(n1.eq.1)then
        adev=-99.0
        sdev=-99.0
        var=-99.0
        skew=-99.0
        curt=-99.0
        sens=-99.0
        ac=-99.0
        return
      endif
      adev=0.0
      var=0.0
      skew=0.0
      curt=0.0
      sens=0.0
      n2=0
      do j=1,n
        if(ns(j).gt.0)then
          s=data(j)-ave
          adev=adev+abs(s)
          p=s*s
          var=var+p
          p=p*s
          skew=skew+p
          p=p*s
          curt=curt+p
          if(j.lt.n)then
            if(ns(j+1).gt.0)then
              n2=n2+1
              rnum=data(j+1)-data(j)
              dnum=(data(j+1)+data(j))/2.0
              if(dnum.gt.0)then
                sens=sens+abs(rnum/dnum)
              endif
            endif
          endif
        endif
      enddo
ccc      write(*,*)n,n1,n2
      rn2=n2
      sens=sens/(rn2-1.0)
      adev=adev/rn1
      var1=var
      var=var/(rn1-1.0)
      bvar=var*(rn1-1.0)/rn1
ccc      write(*,'(1x,''var: '',3f12.4)')rn1,var1,var
      if(var.gt.0)then
        sdev=sqrt(var)
        bsdev=sqrt(bvar)
        skew=skew/(rn1*sdev**3)
        curt=curt/(rn1*var**2)
        if(n1.lt.3)then
          bfs=1.0
        else
          bfs=(sqrt(abs((rn1*(rn1-1.0))))/(rn1-2.0))*(1.0+8.5/rn1)
        endif
        if(n1.lt.4)then
          bfk=1.0
        else
          bfk=(rn1*rn1*(rn1+1.0))/((rn1-1.0)*(rn1-2.0)*(rn1-3.0))
        endif
        skew=skew*bfs
        curt=curt*bfk
ccc        write(*,*)ave,var,sdev,skew,curt
ccc        pause
        do i=1,n
          if(ns(i).gt.0)then
	           data(i)=(data(i)-ave)/bsdev
          endif
        enddo
        cxx=0.0
        n2=0
        do i=2,n
          if(ns(i).gt.0.and.ns(i-1).gt.0)then
            n2=n2+1
            cxx=cxx+data(i)*data(i-1)
          endif
        enddo
        rn2=n2
        ac=cxx/rn2
        do i=1,n
          if(ns(i).gt.0)then
            data(i)=data(i)*bsdev+ave
          endif
        enddo
      else
        sdev=-99.0
        skew=-99.0
        curt=-99.0
        ac=-99.0
      endif
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine loaddat(mxy,mxs,x,idate,ident,iu,nc,itrdb,ferr)
c	
      integer mxy,mxs,iu,nc
	     real*4 x(mxy,mxs)
	     integer idate(mxs,3)
	     character ident(mxs)*8
	     logical ferr
c
	     integer p,k,ifmny,ilmxy,maxn
	     real*4  y1(9000)  !must = mxy
	     integer ns(9000)  !must = mxy
	     integer dattype,ifl,ou1,age,iyr
	     character infl1,q*2,id*8,tit*100,tag*6,itrdb(3)*100 
	     logical eof
c
	     ferr=.false.
    5	write(*,'(/t19,''__ Input Data Format Menu __'')')
	     write(*,'(t19,''_____________________________''/)')
     	write(*,'(t19,''Raw ring-widths (Decade)  [1]'')')
	     write(*,'(t19,''Chronologies (Index)      [2]'')')
	     write(*,'(t19,''Single Column             [3]'')')
	     write(*,'(t19,''Multiple Columns          [4]'')')
	     write(*,'(t19,''Enter zer0 for HELP       [0]'')')
	     write(*,'(t19,''_____________________________'')')
	     write(*,'(/1x,''Enter a value between [0-4] or [Q]uit'',t50,''==> '',$)')
	     read(*,*,err=110)dattype
	     goto 6
  110 return
c
    6	if(dattype.ne.0.and.dattype.gt.2)then
        write(*,'(/1x,''Enter number of file header lines to skip'')')
        write(*,'(1x,''before reading data or columns. If none then'')')
        write(*,'(1x,''enter a zer[0] for none'',t50,''==> '',$)')
        read(*,*)p
        if(p.gt.0)then
          do k=1,p
            read(iu,*)
          enddo
        endif
      endif
c
c read in all the raw data into 
      ifmny=9999; ilmxy=-9999; maxn=-999; ifl=0
	     select case (dattype)
c
	     case(0)
	     call dathlp(iu,infl1)
	     goto 5
c
	     case(1)          ! rrw - decade format
		    q='mr' ; nc=0
   10	if(ifl.ne.-999)then
		      nc=nc+1;age=0
		      call trrw(id,iyr,age,y1,ns,ifl,iu,ou1,q,tit,tag,mxy,itrdb)
		   
        if(itrdb(1)(1:6).eq.'      ')then
          itrdb(1)(1:22)='1st itrdb line missing'
          itrdb(1)(59:80)='1st itrdb line missing'
        endif
        if(itrdb(2)(1:6).eq.'      ')then
          itrdb(2)(1:22)='2nd itrdb line missing'
          itrdb(2)(59:80)='2nd itrdb line missing'
        endif
        if(itrdb(3)(1:6).eq.'      ')then
          itrdb(3)(1:22)='3rd itrdb line missing'
          itrdb(3)(59:80)='3rd itrdb line missing'
        endif		   
		   
		      if(age.le.0.and.ifl.ne.-999)then
  		      write(*,'(/1x,''WARNING: Fatal error reading data from input file.'')')
		        write(*,'(1x,''         Suggest checking file format and/or file type'')')
		        write(*,'(1x,''         Unix/Dos/Mac?'')')
		        pause' Hit Return to Continue'
		        ferr=.true.
  		      return
		      endif
		      do k=1,age
		        x(k,nc)=y1(k)
		      end do
		      idate(nc,2)=(iyr+age)-1; idate(nc,1)=iyr; idate(nc,3)=age; ident(nc)=id
        ifmny=min0(idate(nc,1),ifmny)
        ilmxy=max0(idate(nc,2),ilmxy)
		      goto 10
		    else
   		   eof=.true.
	       nc=nc-1
        idate(nc+1,1)=ifmny
    	   idate(nc+1,2)=ilmxy
        maxn=ilmxy-ifmny+1
        idate(nc+1,3)=maxn
	       if(eof)then
	         write(*,'(/1x,''Input data read successfully'')')
	       else
	         write(*,'(/1x,''Input data not read in successfully'')')
	         pause'             Hit RETURN to Continue'
	         goto 105
	       endif
		    endif
c
	     case(2)
	     q='ir'
		    nc=0
   20	if(ifl.ne.-999)then
		      nc=nc+1
   		   call trrw(id,iyr,age,y1,ns,ifl,iu,ou1,q,tit,tag,mxy,itrdb)
		      ident(nc)=id
   		   do k=1,age
		        x(k,nc)=y1(k)
   		   end do
		      idate(nc,2)=(iyr+age)-1; idate(nc,1)=iyr; idate(nc,3)=age; ident(nc)=id
        ifmny=min0(idate(nc,1),ifmny)
    	   ilmxy=max0(idate(nc,2),ilmxy)
		      goto 20
		    else
	       nc=nc-1
		      eof=.true.
        idate(nc+1,1)=ifmny
    	   idate(nc+1,2)=ilmxy
        maxn=ilmxy-ifmny+1
    	   idate(nc+1,3)=maxn
	       if(eof)then
	         write(*,'(/1x,''Input data read successfully'')')
	       else
	         write(*,'(/1x,''Input data not read in successfully'')')
	         pause'             Hit RETURN to Continue'
	         goto 105
	       endif
		    endif
c
	     case(3)
	     call rd1col(mxy,mxs,iu,x,ident,idate,nc,eof)
	     if(eof)then
	       write(*,'(/1x,''Input data read successfully'')')
	     else
	       write(*,'(/1x,''Input data not read in successfully'')')
	       pause'             Hit RETURN to Continue'
	       goto 105
	     endif
c
	     case(4)
	     call rdmcol(mxy,mxs,iu,x,ident,idate,nc,eof)
	     if(eof)then
	       write(*,'(/1x,''Input data read successfully'')')
	     else
	       write(*,'(/1x,''Input data not read in successfully'')')
	       pause'             Hit RETURN to Continue'
	       goto 105
	     endif
c
	     case default
	     write(*,'(/1x,''WARNING: You must enter a value between 0 and 7'')')
	     pause'             Hit RETURN to Continue'
	     goto 5
c
	     end select
c
	     return
c
  105 ferr=.true.
c
	     return
	     end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Subroutine rdmcol ******************************************************************
	subroutine rdmcol(mxy,mxs,iu,x,ident,idate,ns,eof)
c reads a column format time series file.  Expects title for each column
c with the first column being the X axis variable followed by as many Y 
c columns as needed.
c The routine expects to find a user defined sentinal in positions of X
c for which there is no corresponding Y.
c Assumes the time step is 1.
c
c Input format:
c X_axis	Series_ID_1	Series_ID_2	Series_ID_3	Series_ID_4 .....   (character)
c yr1		val_yr1	sentinal	sentinal	val_yr1 ....	      (real)
c yr2		val_yr2	val_yr2	sentinal	val_yr2 ....		"
c yr3		val_yr3	val_yr3	val_yr3	sentinal ....		"
c yr4		sentinal	val_yr4	val_yr4	sentinal ....		"
c (eof)
c
c argument declearations
c
	integer mxy,mxs,ns,iu
	integer idate(mxs,3)
	real*4    x(mxy,mxs)
	character*8 ident(mxs)
	logical eof
c local declarations
c
	integer maxdat,maxrec
	parameter(maxrec=3000,maxdat=9000) !must equal mxs and mxy in main
	integer p,j,k,nrows,ifmny,ilmxy,maxn
	character*8 tmp(maxrec,maxdat),pad,id2
c
c begin subroutine
c
	write(*,'(/1x,''Enter the total number of columns in your file'')')
	write(*,'(1x,''[Program assumes Col_1 contains the X values] : '',$)')
	read(*,'(i4)')ns
	ns=ns
	write(*,'(/1x,''Enter the sentinal value or character used to '')')
	write(*,'(1x,''pad the records [can not be spaces, if ******* enter *] : '',$)')
	read(*,'(a)')pad
c	
	k=1; ifmny=9999; ilmxy=-9999; maxn=-999
	read(iu,*)id2,(ident(p),p=1,ns-1)
10	read(iu,*,end=20)(tmp(p,k),p=1,ns)
	    k=k+1
	goto 10
c
20	eof=.true.
	nrows=k-1
	j=1
	do p=2,ns  
	  idate(j,3)=1
c	  write(*,*)ident(p-1)
	  do k=1,nrows
	    if(tmp(p,k).ne.pad)then
c	      write(*,*)tmp(p,k)
	      read(tmp(p,k),*,err=50)x(idate(j,3),j)
c	          write(*,*)j,idate(j,3),x(idate(j,3),j)
	      if(idate(j,3).eq.1)then
	        read(tmp(1,k),*,err=60)idate(j,1)
	      endif
	      idate(j,3)=idate(j,3)+1
	    endif
	  end do
	  idate(j,3)=idate(j,3)-1
	  idate(j,2)=(idate(j,1)+idate(j,3))-1
         ifmny=min0(idate(j,1),ifmny)
         ilmxy=max0(idate(j,2),ilmxy)
c         write(*,*)idate(j,3),idate(j,2),idate(j,1),ifmny,ilmxy,j
	  j=j+1
	enddo
	ns=j-1
c
       idate(ns+1,1)=ifmny
       idate(ns+1,2)=ilmxy
       maxn=ilmxy-ifmny+1
       idate(ns+1,3)=maxn
c       write(*,*)idate(ns+1,1),idate(ns+1,2),idate(ns+1,3)

 	return
c
50	write(*,'(/1x,''Error reading y values check sentinel if ******* enter *'')')
	eof=.false.
	return
60	write(*,'(/1x,''Error reading time steps'')')
	eof=.false.
	return
 	end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Subroutine rd1col ******************************************************************
	subroutine rd1col(mxy,mxs,iu,x,ident,idate,nc,eof)
c reads a single column time series.  Expects an id and iyr for each record.
c Assumes time step is 1 and there are no gaps.
c
c Input format:
c Series_ID   (character)
c Series_iyr (integer)
c val1_(iyr)
c val2_(iyr+1)
c val2_(iyr+2)
c
c argument declearations
	integer mxy,mxs,nc,iu
	integer idate(mxs,3)
	real*4    x(mxy,mxs)
	character*8 ident(mxs)
	logical eof
c local declarations
	integer i,p,k,ifmny,ilmxy,maxn
c
c begin subroutine
	eof=.false.
	nc=1; ifmny=9999; ilmxy=-9999; maxn=-999
10	read(iu,*,err=80,end=100)ident(nc)
20	  read(iu,*,err=70)idate(nc,1)
c	    write(*,*)ident(nc),idate(nc,1)
c	    pause'1'
	    k=1
30	    read(iu,*,err=40,end=40)x(k,nc)
	      k=k+1
	    goto 30
40	    idate(nc,3)=k-1
	    idate(nc,2)=(idate(nc,1)+idate(nc,3))-1
           ifmny=min0(idate(nc,1),ifmny)
           ilmxy=max0(idate(nc,2),ilmxy)
	    nc=nc+1
	    backspace(iu)
	goto 10
	    
70	write(*,'(1x,''Rd1col: Error reading series IYR value'')')
	write(*,'(8x,''Series: '',a,'' Number: '',i5)')ident(ns),ns
	pause' Hit return to continue '
	eof=.false.
	return
80	write(*,'(1x,''Rd1col: Error reading series ID'')')
	write(*,'(8x,''Series: '',a,'' Number: '',i5)')ident(ns),ns
	pause' Hit return to continue '
	eof=.false.
	return
c	    
100	eof=.true.
	nc=nc-1
       idate(nc+1,1)=ifmny
       idate(nc+1,2)=ilmxy
       maxn=ilmxy-ifmny+1
       idate(nc+1,3)=maxn
c	write(*,*)nc,((idate(i,p),i=1,nc),p=1,3)
	return
	end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine dathlp(iu,infl1)
c
	integer iu
	character*40 infl1
c
c displays samples of various input file formats
c
c local arguments
c
	integer dattype
c
	write(*,'(/1x,''Select a file type to see an example.'')')
5	write(*,'(/1x,''_____   Input Format Help Menu    _____'')')
	write(*,'(1x,''Raw ring-widths (mm-decade)          [1] '')')
	write(*,'(1x,''Chronologies (index-decade)          [2] '')')
	write(*,'(1x,''Single Column                        [3]'')')
	write(*,'(1x,''Multiple Columns                     [4]'')')
	write(*,'(1x,''Enter zero when finished             [0]'')')
	write(*,'(1x,''Enter H for further help'')')
	write(*,'(1x,''________________________________________'')')
	write(*,'(1x,''Enter a value between  [0-4]       : '',$)')
	read(*,'(i1)',err=100)dattype
	select case (dattype)
	   case(0)
	       return
c
	   case(1)
	   	write(*,'(/1x,''rrw - decade format'')')
	   	write(*,'(/1x,''Example:'')')
		write(*,'(/1x,''HBM01A  1940   176   198   164   188   214   148   188    66   150    88'')')
		write(*,'(1x,''HBM01A  1950    94   156    96     2   232   150   208    84   216   136'')')
		write(*,'(1x,''HBM01A  1960   150   386   126    96    86   204   132   314   112   106'')')
		write(*,'(1x,''HBM01A  1970   206    66   180   190    82   100   110   154    76   238'')')
		write(*,'(1x,''HBM01A  1980   138   206    90   218   144   150   198   176    36   158'')')
		write(*,'(1x,''HBM01A  1990   118   116    78   116   198   108   320   108   116   198'')')
		write(*,'(1x,''HBM01A  2000   178    62   236 -9999'')')
		write(*,'(1x,''HBM01B  1740   220   248   272   110    58    46    50    92   104    32'')')
		write(*,'(1x,''HBM01B  1750   198   282   200   128   144   132   190   152   146   206'')')
		write(*,'(1x,''HBM01B  1760   192   130    70   188   154   174     0   180   112   188'')')
		write(*,'(1x,''HBM01B  1770   208   398   164   252   182   298     0   192    56    58'')')
		write(*,'(1x,''HBM01B  1780    20    64   230    42    24    74    14    52    92   220'')')
		write(*,'(1x,''HBM01B  1790   156 -9999'')')
		write(*,'(1x,''und so veite, und so veite, ... '')')
		pause ' <Hit Return to continue>'
	     goto 5
c
	   case(2)
	   	write(*,'(/1x,''chronology - index format'')')
	   	write(*,'(/1x,''Example:'')')
		write(*,'(/1x,''tst1a.raw -- no data title --                             1st itrdb line missing  raw'')')
		write(*,'(1x,''tst1a.raw -- no data title --                             2nd itrdb line missing  raw'')')
		write(*,'(1x,''tst1a.raw -- no data title --                             3rd itrdb line missing  raw'')')
		write(*,'(1x,''tst1a.1950 356 38 439 38 276 38 132 38 424 38 423 38 258 38 295 38 379 38 382 38  raw'')')
		write(*,'(1x,''tst1a.1960 274 38 396 38 330 38 285 38 324 38 348 38 299 38 361 38 261 38 316 38  raw'')')
		write(*,'(1x,''tst1a.1970 372 38 211 37 418 37 271 37 417 37 398 37 299 37 296 36 205 36 261 36  raw'')')
		write(*,'(1x,''tst1a.1980 344 36 349 36 327 36 367 36 418 36 412 36 463 36 448 36 391 36 530 35  raw'')')
		write(*,'(1x,''tst1a.1990 486 35 507 33 365 33 468 33 387 33 190 33 536 32 533 32 483 32 536 32  raw'')')
		write(*,'(1x,''tst1a.2000 507 32 295 32 505 329990  09990  09990  09990  09990  09990  09990  0  raw'')')
		write(*,'(1x,''tst1a.raw -- no data title --                             1st itrdb line missing  std'')')
		write(*,'(1x,''tst1a.raw -- no data title --                             2nd itrdb line missing  std'')')
		write(*,'(1x,''tst1a.raw -- no data title --                             3rd itrdb line missing  std'')')
		write(*,'(1x,''tst1a.19501120 381264 38 903 38 306 381269 381307 38 806 38 812 381183 381229 38  std'')')
		write(*,'(1x,''tst1a.1960 847 381261 381108 38 930 381109 381172 38 879 381125 38 902 38 939 38  std'')')
		write(*,'(1x,''tst1a.19701200 38 593 371472 37 923 371318 371226 37 946 371002 36 645 36 787 36  std'')')
		write(*,'(1x,''tst1a.19801042 361095 361140 361306 361231 361252 361461 361422 361213 361831 35  std'')')
		write(*,'(1x,''tst1a.19901540 351597 331296 331498 331295 33 710 331770 321642 321462 321682 32  std'')')
		write(*,'(1x,''tst1a.20001606 32 970 321608 329990  09990  09990  09990  09990  09990  09990  0  std'')')
		write(*,'(1x,''und so veite, und so veite, ... '')')
		pause ' <Hit Return to continue>'
	     goto 5
c
	   case(3)
		write(*,'(/1x,''Single Column'')')
	   	write(*,'(/1x,''Example:'')')
		write(*,'(/1x,''abscdef'')')
		write(*,'(1x,''1771'')')
		write(*,'(1x,''0.1'')')
		write(*,'(1x,''0.2'')')
		write(*,'(1x,''0.3'')')
		write(*,'(1x,''...'')')
		write(*,'(1x,''..'')')
		write(*,'(1x,''bbscdef'')')
		write(*,'(1x,''1772'')')
		write(*,'(1x,''0.2'')')
		write(*,'(1x,''0.2'')')
		write(*,'(1x,''0.4'')')
		write(*,'(1x,''0.5'')')
		write(*,'(1x,''0.6'')')
		write(*,'(1x,''...'')')
		write(*,'(1x,''..'')')
		write(*,'(1x,''cbscdef'')')
		write(*,'(1x,''1773'')')
		write(*,'(1x,''0.3'')')
		write(*,'(1x,''0.2'')')
		write(*,'(1x,''0.5'')')
		write(*,'(1x,''0.6'')')
		write(*,'(1x,''...'')')
		write(*,'(1x,''..'')')
		write(*,'(1x,''und so veite, und so veite, ... '')')
		pause ' <Hit Return to continue>'
	     goto 5
c
	   case(4)
		write(*,'(/1x,''Multiple Columns'')')
		write(*,'(1x,''This format requires you to provide the total number '')')
		write(*,'(1x,''of columns in your file (e.g., 6 in the examples below)'')')
		write(*,'(1x,''along with the sentinel value or character string used '')')
		write(*,'(1x,''as a spacer to keep the rows correctly aligned by year. '')')
	   	write(*,'(/1x,''Example 1:  Sentinel = ******* '')')
		write(*,'(/1x,'' YEAR   HKTC01A  HKTC01B  HKTC01C  HKTC01D  HKTC25A '')')
		write(*,'(1x,'' 1944  *******  *******   3.2260   6.0800  *******   '')')
		write(*,'(1x,'' 1945   2.0860   3.2820   1.8860   2.8020  *******   '')')
		write(*,'(1x,'' 1946   6.0860   6.0120   4.8920   6.6880  *******   '')')
		write(*,'(1x,'' 1947   2.7720   3.1300   3.6180   5.1740  *******   '')')
		write(*,'(1x,'' 1948   5.7480   3.5940   4.2900   4.2400  *******   '')')
		write(*,'(1x,'' 1949   5.2300   2.1320   6.0520   5.4160  *******   '')')
		write(*,'(1x,'' 1950   5.0280   4.2560   5.3640   4.2280  *******   '')')
		write(*,'(1x,'' 1951  10.6580   6.7120   9.3440   7.4140  *******   '')')
		write(*,'(1x,'' 1952   6.5420   5.0500   4.7300   4.4300  *******   '')')
		write(*,'(1x,'' 1953   0.9300   0.8760   0.5200   0.5780   1.0140  '')')
		write(*,'(1x,'' 1954   0.7320   0.4080  *******   0.4940   0.3020  '')')
		write(*,'(1x,'' 1955   1.4780   0.7380  *******   2.0320   0.7840  '')')
		write(*,'(1x,'' 1956   1.5100   1.4740  *******   0.9880   0.9040  '')')
		write(*,'(1x,'' 1957   0.5700   0.9640  *******   2.0440   0.9040  '')')
		write(*,'(1x,'' ....   ......  .......  .......  .......  .......  '')')
		write(*,'(1x,''und so veite, und so veite, ... '')')
		pause '  <Hit Return to continue>'
	   	write(*,'(/1x,''Example 2:  Sentinel = -9.9 '')')
		write(*,'(/1x,''  year   HKTC01A  HKTC01B  HKTC01C  HKTC01D  HKTC25A '')') 
		write(*,'(1x,''  1941  -9.9     -9.9      2.8200   3.3580  -9.9  '')')     
		write(*,'(1x,''  1942  -9.9     -9.9      2.0740   2.1740  -9.9  '')')     
		write(*,'(1x,''  1943  -9.9     -9.9      1.9020   1.7040  -9.9  '')')     
		write(*,'(1x,''  1944  -9.9     -9.9      3.2260   6.0800  -9.9  '')')     
		write(*,'(1x,''  1945   2.0860   3.2820   1.8860   2.8020  -9.9  '')')     
		write(*,'(1x,''  1946   6.0860   6.0120   4.8920   6.6880  -9.9  '')')     
		write(*,'(1x,''  1947   2.7720   3.1300   3.6180   5.1740  -9.9  '')')     
		write(*,'(1x,''  1948   5.7480   3.5940   4.2900   4.2400  -9.9  '')')     
		write(*,'(1x,''  1949   5.2300   2.1320   6.0520   5.4160  -9.9  '')')     
		write(*,'(1x,''  1950   5.0280   4.2560   5.3640   4.2280  -9.9  '')')     
		write(*,'(1x,''  1951  10.6580   6.7120   9.3440   7.4140  -9.9  '')')     
		write(*,'(1x,''  1952   6.5420   5.0500   4.7300   4.4300  -9.9  '')')     
		write(*,'(1x,''  1953   2.5240   1.2340   4.4140   6.6740  -9.9  '')')     
		write(*,'(1x,'' ....   ......  .......  .......  .......  .....   '')')
		write(*,'(1x,''und so veite, und so veite, ... '')')
		pause ' <Hit Return to continue>'
	     goto 5
c
	   case default
	     write(*,'(/1x,''You must enter a value between 0 and 4'',/)')
	     goto 5
c
	end select
	return
c
100    call snoop(iu)
	goto 5
c	
	end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr snoop
*
      subroutine snoop(iu4)
      character line*100,more
      logical tab
      tab=.false.
      rewind iu4
      write(*,'(/1x,''snooping in the data file '',
     *		    ''(first 100 characters/line):'')')
      write(*,'(5x,''.........1.........2.........3.........4.....'',
     *             ''....5.........6.........7.........8.........9.........10'')')
    9 i=0
   10 more=' '
   11 read(iu4,'(a)',end=20)line
      i=i+1
      if(tab)goto 13
      do 12 j=1,100
        if(line(j:j).eq.char(9))then
          tab=.true.
          goto 13
        endif
   12 continue
   13 if(more.eq.'e'.or.more.eq.'e')goto 11
      if(tab)then
        do 14 j=1,100
          if(line(j:j).eq.char(9))line(j:j)=' '
   14   continue
      endif
      write(*,'(1x,i3,1x,a)')i,line
      if(mod(i,5).eq.0)then
        write(*,'(/1x,''more <ret>, read to end <e>, '',
     *      ''return to main program <m> '',$)')
        read(*,'(a)')more
        if(more.eq.'e'.or.more.eq.'e')goto 11
        if(more.eq.'m'.or.more.eq.'m')then
          rewind iu4
          write(*,'(/1x,''end-of-snoop: '', i5,'' lines read'')')i
          return
        endif
        write(*,'(5x,''.........1.........2.........3.........4....'',
     *             ''....5.........6.........7.........8.........9.........10'')')
      endif
      goto 10
   20 if(more.ne.'e'.and.more.ne.'e')goto 35
      do 25 j=1,5
        backspace iu4
   25 continue
      write(*,'(/1x,''last 5 lines in file (first 80 characters):'')')
      write(*,'(5x,''.........1.........2.........3.........4....'',
     *             ''....5.........6.........7.........8.........9.........10'')')
      do 30 j=1,5
        read(iu4,'(a)',end=20)line
        if(tab)then
          do 27 k=1,100
            if(line(k:k).eq.char(9))line(k:k)=' '
   27     continue
        endif
        write(*,'(1x,i3,1x,a)')i-5+j,line
   30 continue        
   35 rewind iu4
      write(*,'(/1x,''end-of-snoop: '', i5,'' lines read''/)')i
      write(*,'(1x,''more <ret> or return to main program <m> '',$)')
      read(*,'(a)')more
      if(more.ne.'m'.and.more.ne.'m')goto 9
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr calind
c
c *** calculate tree-ring indices as ratios or differences ***
c
c      y   --  series to be converted to indices
c      f   --  growth trend used for detrending
c      z   --  tree-ring indices returned
c     nyr  --  number of years in y
c     ind  --  method of index calculation (ratio: 1, resid: 2)
c     mxy  --  maximum length series, from calling program
c
c     subroutines called:  moment
c
      subroutine calind(y,f,z,nyr,ind,mxy)
      real*4 y(mxy),f(mxy),z(mxy)
      integer nyr,ind
c
c *** calculate indices as ratios and return if that is all
c
      do i=1,nyr
        z(i)=y(i)/f(i)
      enddo
      if(ind.eq.1)return
c
c *** calculate and scale the residuals to be like indices
c
      if(ind.eq.2)then
        call moment(z,nyr,ave1,adev,sdev1,var,skew,curt,sens,ac)
        do i=1,nyr
          z(i)=z(i)*f(i)
          z(i)=z(i)-f(i)
        enddo
        call moment(z,nyr,ave,adev,sdev,var,skew,curt,sens,ac)
        do i=1,nyr
          z(i)=(z(i)-ave)/sdev
          z(i)=z(i)*sdev1+ave1
          if(z(i).lt.0)z(i)=0.0
        enddo
      endif
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr plot1
*
      subroutine plot1(nmax,wrk,sp,ny,iy,xlab,ylab,tit,rline,annot1,annot2,iw1,iw2,iw3)
c
c     write(winu9,'(/13x,''COLOR TABLE ______________________________________________'')')
c     write(winu9,'(13x,''White(0) Red(1)  Yellow(2)  Green(3)  Aquamarine(4) Pink(5) '')')
c     write(winu9,'(13x,''Wheat(6)  Grey(7)  Browm(8)  Blue(9)  BlueViolet(10)'')')
c     write(winu9,'(13x,''Cyan(11)  Turquoise(12)  Magenta(13)  Salmon(14)  Black(15)'')')
c     write(winu9,'(13x,''___________________________________________________________'',/)')
c
c
c     argument
      integer nmax,ny,iy,iw1,iw2,iw3
      dimension sp(nmax),wrk(nmax),rline(nmax)
      character tit*60,xlab*20,ylab*20,annot1*36,annot2*36
c     local
      integer p,red,green,blue
      real*4 x(9000),mny,mxy,mx,mnx,mny1,mxy1	
      
      character dev*80,filename*60,ans*2
      logical bg,ok
c
      mny=100000.0;mxy=-100000.0
      red=255;green=255;blue=255
      bg=.false.
      ok=.true.;dev='Mac1'
c
      do p=1,ny
        if(wrk(p).gt.mxy)mxy=wrk(p)
        if(sp(p).gt.mxy)mxy=sp(p)
        if(wrk(p).lt.mny)mny=wrk(p)
        if(sp(p).lt.mny)mny=sp(p)
        x(p)=iy+p-1
      enddo
      if(rline(1).eq.0.85)mxy=1.0
      irange=mxy-mny
      mxy=mxy+irange/10
      mny=mny-irange/10
c      
      mnx=iy;mx=iy+ny-1
ccc      write(*,*)mxy,mny
ccc      write(*,*)mx,mnx
ccc	write(*,'(/1x,''from plot1'')')
	if(iw3.eq.0)mny=0.
c      
10      if(ok)call plsdev('Mac1')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c
c     initialize plplot
      call plinit()
c     define the viewport one column by one rows
      call plssub(1,1)
c     set lable color
      call plcol0(15)   !color box and lables
      call plenv(mnx,mx,mny,mxy,0,0)
      if(rline(1).ne.-999.9)then
c     set curve width
        call plwid(iw3)
        if(rline(1).eq.0.85)call pllsty(3)
        call plline(ny,x,rline)            !plot rline
      endif
      call plfont(1)      
      call plwid(1)
      call pllab(xlab,ylab,' ')
      if(annot1(1:5).eq.'     '.and.annot2(1:5).eq.'     ')then
        call plmtex('b',-35.5,.5,0.5,tit)
      else
        call plmtex('b',-35.5,.5,0.5,tit)
      endif
      
c     set line style
      call pllsty(1)
      call plcol0(9)  !color lines
      call plwid(iw1)
      call plline(ny,x,wrk)            !plot wrk
      call plwid(1)
      if(annot1(1:5).ne.'     ')call plmtex('b',-33.75,0.06,0.0,annot1)
      call plcol0(1)  !color lines
      call plwid(iw2)
      call plline(ny,x,sp)           !plot spline curve
      call plwid(1)
      if(annot2(1:5).ne.'     ')call plmtex('b',-33.75,0.55,0.0,annot2)
c     
      call plend()
c  
       ans='C '
       dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;
         filename=tit
         call stringclean(filename,60)
         do p=1,60
           if(filename(p:p).eq.' ')goto 69
         enddo
69       write(filename(p:p+2),'(a3)')'.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
      return
      end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine plt1(mxsl,rmax,mey,ycal,fycaly,lycaly,flag,string,mnpoff)
c
c	argument
	integer mxsl,rmax,mnpoff
	integer fycaly,lycaly
	real*4 mey(mxsl),ycal(mxsl)
	character string*30
c	local
	integer p,k
	integer red,blue,green
	real*4 miny, maxy
	real*4 wrk1(9000),wrk2(9000),wrk3(9000)
	character ans*1,filename*9,dev*80
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
ccc	write(*,'(/1x,''from plt1'')')
c
10	if(ok)call plsdev(dev)
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	miny=9999.;maxy=-9999.;p=1
	do k=fycaly,lycaly
	    if(mey(k).ne.flag.and.mey(k).gt.maxy)maxy=mey(k)
	    if(mey(k).ne.flag.and.mey(k).lt.miny)miny=mey(k)
	    if(ycal(k).ne.flag.and.ycal(k).lt.miny)miny=ycal(k)
	    if(ycal(k).ne.flag.and.ycal(k).gt.maxy)maxy=ycal(k)
	    wrk1(k)=real(k+mnpoff)   !x axis data 
	    wrk2(k)=ycal(k+mnpoff)  !rc
	    wrk3(k)=mey(k+mnpoff)    !input series
	    if(wrk2(k).ne.flag)p=p+1
	enddo
ccc	if(miny.ge.0.)miny=0.
	p=p-1
c
c initialize plplot
	call plinit()
c set lable color
	call plcol0(15)   !color box and lables
c define the viewport one column by one rows
	call plssub(1,1)
       call plwid(1)
	call plenv(real(0),real(lycaly+mnpoff),miny,maxy,0,2)
	call pllab('Biological Year','Y',string)
	call plcol0(1)   !color box and lables
	call plline(p,wrk1,wrk3)
	call plcol0(9)   !color box and lables
	call plwid(2)
	call plline(p,wrk1,wrk2)
	call plend()
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig11.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
	return
	end
c

ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine plt2(mxy,mxs,pltdata,nc,idate,flag,string)
c
c	argument
	integer mxy,mxs,nc
	integer idate(mxs,3)
	real*4 pltdata(mxy,mxs),flag
	character string*30
c	local
	integer p,j,k, minx, maxx
	integer red,blue,green
	real*4 miny, maxy
	real*4 wrk1(9000),wrk2(9000),wrk3(9000),wrk4(9000)
	character ans*1,filename*9,dev*80
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
ccc	write(*,'(/1x,''from plt2'')')
c
10	if(ok)call plsdev(dev)
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	miny=9999.;maxy=-9999.;minx=9999;maxx=-9999
	do p=1,nc
	  j=1
	  do k=idate(p,1),idate(p,2)
	      if(pltdata(j,p).ne.flag.and.pltdata(j,p).gt.maxy)maxy=pltdata(j,p)
	      if(pltdata(j,p).ne.flag.and.pltdata(j,p).lt.miny)miny=pltdata(j,p)
	      j=j+1
	  enddo
	  if(idate(p,1).lt.minx)minx=idate(p,1)
	  if(idate(p,2).gt.maxx)maxx=idate(p,2)
	enddo
c
c initialize plplot
	call plinit()
c set lable color
	call plcol0(15)   !color box and lables
c define the viewport one column by one rows
	call plssub(1,2)
       call plwid(1)
	call plenv(real(minx),real(maxx),miny,maxy,0,2)
	call pllab('Calendar Year','Y','First Detrending')
	call plcol0(1)   !color box and lables
	do p=1,nc
	   k=1
	   do j=idate(p,1),idate(p,2)
	     wrk1(k)=real(j);wrk2(k)=pltdata(k,p)
	     k=k+1
	   enddo
	   k=k-1
	    call plline(k,wrk1,wrk2)
	enddo
c
c set lable color
	call plcol0(15)   !color box and lables
       call plwid(1)
	call plenv(real(minx),real(maxx),miny,maxy,0,2)
	call pllab('Calendar Year','Y','Average Indices')
	do p=1,mxy
	   wrk1(p)=0.;wrk2(p)=0.;wrk3(p)=0
	enddo
	do p=1,nc
	   k=1
      ny=idate(p,2)-idate(p,1)+1
ccc	   do j=idate(p,1),idate(p,2)
	   do j=1,ny
      j1=minx+j-1
	     wrk2(j1)=wrk2(j1)+pltdata(k,p)
	     wrk3(j1)=wrk3(j1)+1.
	     k=k+1
	   enddo
	   k=k-1
	enddo
	k=1
	do j=minx,maxx
	   if(wrk3(j).ne.0)wrk1(k)=wrk2(j)/wrk3(j)
	   wrk4(k)=real(j)
	   k=k+1
	enddo
      	k=k-1
	call plcol0(1)   !color box and lables
	call plline(k,wrk4,wrk1)
	call plend()
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig11.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
	return
	end
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine plt3(mxy,mxs,indx,xrc,f,idate,flag,nmax,sernum,n,ident,string,plotall,pith,mnpoff)
c
c	argument
	integer mxy,mxs,nmax,sernum,n,mnpoff
	integer idate(mxs,3),pith(mxs)
	real*4 indx(mxy),flag,f(mxy),xrc(mxy)
	character ident(mxs)*8
	character string*30
	logical plotall
c	local
	integer p,j,k, minx, maxx
	integer red,blue,green
	real*4 miny, maxy
	real*4 wrk1(9000),wrk2(9000),wrk3(9000)
	character dev*80
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
c
10	if(ok)call plsdev(dev)
ccc	write(*,'(/1x,''from plt3'')')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	miny=9999.;maxy=-9999.;minx=9999;maxx=-9999; k=1
	do p=1,nmax
	   if(xrc(p).ne.flag.and.xrc(p).gt.maxy)maxy=xrc(p)
	   if(f(p).ne.flag.and.f(p).gt.maxy)maxy=f(p)
	   wrk1(p)=real(p+pith(sernum))   !x axis series
	   wrk2(p)=real(p+mnpoff)         !xaxis rcf
	   wrk3(p)=f(p+mnpoff)
	   if(wrk3(p).ne.flag)k=k+1
	enddo
	k=k-1
c
c initialize plplot
	call plinit()
c set lable color
	call plcol0(15)   !color box and lables
c define the viewport one column by one rows
	call plssub(1,2)
       call plwid(1)
	call plenv(real(0),real(nmax+mnpoff),0.,maxy,0,2)
	call pllab('Biological Year','Y',string)
	call plcol0(1)   !color box and lables
	call plline(n,wrk1,xrc)
	call plcol0(9)   !color box and lables
	call plwid(2)
	call plline(k,wrk2,wrk3)
c
c bottom plot
	miny=9999.; maxy=-9999.; minx=9999; maxx=-9999; j=idate(sernum,1)
	do p=1,n
	      if(indx(p).ne.flag.and.indx(p).gt.maxy)maxy=indx(p)
	      if(indx(p).ne.flag.and.indx(p).lt.miny)miny=indx(p)
	      wrk1(p)=real(j)
	      j=j+1
	enddo
c
c set lable color
	call plcol0(15)   !color box and lables
       call plwid(1)
	call plenv(real(idate(sernum,1)),real(idate(sernum,2)),miny,maxy,0,2)
	call pllab('Calendar Year','Y',ident(sernum))
	call plcol0(1)   !color box and lables
	call plline(n,wrk1,indx)
	call plend()
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''| [s]ave  [c]ontinue  [r]eplot  [n]o more plots |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig11.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
       elseif((ans.eq.'N').or.(ans.eq.'n'))then
         plotall=.false.
         return
	endif
c
	return
	end
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine plt4(mxlen,maxit,rcscrv,nmax,rcnt,mnpoff,flag)
c plot all regional curves and their solutions
	integer mxlen,maxit,rcnt,mnpoff
	real*4 rcscrv(mxlen,2,maxit),flag
c	local
	integer i,p,j,k,nrows,ncols,nplts
	integer red,blue,green
	real*4 miny, maxy, minx, maxx
	real*4 x(9000),y1(9000),y2(9000)
	character string*16,dev*3
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
c
10	if(ok)call plsdev(dev)
ccc	write(*,'(/1x,''from plt4'')')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	miny=9999.;maxy=-9999.
	minx=0.;maxx=float(nmax)
	do k=1,rcnt
	  do j=1,2
	    do p=1,mxlen
	      if(rcscrv(p,j,k).ne.flag.and.rcscrv(p,j,k).gt.maxy)maxy=rcscrv(p,j,k)
	      if( (rcscrv(p,j,k).ne.flag) .and. (rcscrv(p,j,k).lt.miny) .and. 
     *                               (rcscrv(p,j,k).ne.0.0) )miny=rcscrv(p,j,k)
	    enddo
	  enddo
	enddo
c
	if(rcnt.le.8)then
	   nrows=2;ncols=4
	elseif(rcnt.gt.8.and.rcnt.le.10)then
	   nrows=2;ncols=5
	elseif(rcnt.gt.10.and.rcnt.le.15)then
	   nrows=3;ncols=5
	elseif(rnct.gt.15.and.rcnt.le.20)then
	   nrows=4;ncols=5
	else
	   write(*,'(/1x,''Too many Regional curves to plot. Try '')')
	   write(*,'(1x,''plotting them outside this program.'')')
	   write(*,'(1x,''Hit RETURN to Continue'')')
	   pause
	   return
	endif
c	
	string='Iteration #     '
	nplts=nrows*ncols
c
c initialize plplot
	call plinit()
	call plssub(nrows,ncols)
	do i=1,rcnt
	         j=1
	    	  do p=1,nmax
	    	      if(rcscrv(p+mnpoff,1,i).ne.flag)then
	    	         y1(j)=rcscrv(p+mnpoff,1,i)
	                y2(j)=rcscrv(p+mnpoff,2,i)
	                if(i.eq.1)x(j)=real(p+mnpoff)
	                j=j+1
	             endif
	         enddo
	         j=j-1
	         call plcol0(15)   !color box and lables
       	  call plwid(1)
	         call plenv(real(0),real(j+mnpoff),miny,maxy,0,2)
	         if(i.eq.1)then
	             call pllab('Biological Year','Y','Initial RC and Fit')
	         else
	            write(string(14:16),'(i3)')i-1
	            call pllab('Biological Year','Y',string)
	         endif
	         call plcol0(9)
	         call plwid(1)	     
	         call plline(j,x,y1)
	         call plcol0(1)   !color box and lables
	         call plwid(2)	     
	         call plline(j,x,y2)
	enddo
c
	if(rcnt.lt.nplts)goto 20
c
20	call plend()	    	    
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig11.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
	return
	end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	     subroutine plt5(mxlen,maxit,rcscrv,nmax,rcnt,mnpoff,flag)
c plot all regional curves in a stacked plot.

	     integer mxlen,maxit,rcnt,mnpoff
	     real*4 rcscrv(mxlen,2,maxit),flag
c	local
	     integer i,p,j,k,nrows,ncols,nplts
	     integer red,blue,green
	     real*4 miny, maxy, minx, maxx, step
	     real*4 x(9000),y1(9000),y2(9000)
	     character string*16,dev*3
	     logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
c
   10	if(ok)call plsdev(dev)
ccc	write(*,'(/1x,''from plt5'')')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	     miny=9999.;maxy=-9999.
	     minx=0.;maxx=float(nmax);n1=1
	     do k=1,rcnt
	       do j=1,2
	         do p=1,mxlen
	           if(rcscrv(p,j,k).ne.flag)then
	             if(rcscrv(p,j,k).gt.maxy)maxy=rcscrv(p,j,k)
	             if(rcscrv(p,j,k).lt.miny.and.rcscrv(p,j,k).ne.0.0)miny=rcscrv(p,j,k)
	           endif
	         enddo
	       enddo
	     enddo
c	
	     string='Iteration #     '
	     nplts=nrows*ncols
c
c initialize plplot
	     call plinit()
	     call plssub(1,1)
	     call plcol0(15)   !color box and lables
	     call plwid(1)
	     call plenv(real(0),maxx+10.,miny,maxy,0,2)
	     call pllab('Biological Year','Y','Regional Curves')
	     call plcol0(9)   !color box and lables
	     step=-38.4
	     call plmtex('rv',step,1.065,0.0,'Initial')
	     step=step+4.;call plcol0(1)
	     call plmtex('rv',step,1.065,0.0,'/Final')
	     call plcol0(15)
	     do i=1,rcnt
	         k=1
	    	  do p=1,nmax
	    	    if(rcscrv(p,1,i).ne.flag.or.rcscrv(p,1,i).ne.0.)then
	    	      y1(k)=rcscrv(p+mnpoff,1,i)
	             y2(k)=rcscrv(p+mnpoff,2,i)
	             if(i.eq.1)x(k)=real(p+mnpoff)
	             k=k+1
	           endif
	       enddo
	       k=k-1
	       call plcol0(15)
	       if(i.eq.1)call plcol0(9)
	       if(i.eq.rcnt)call plcol0(1)   !color box and lables
	       call plline(k,x,y1)
	     enddo
c
   20	call plend()	    	    
c	
      ans='C '
	     dev='Mac1'
      write(*,'(/1x,''|************* plot options menu ***************|'')')
      write(*,'(1x,''|-----------------------------------------------|'')')
      write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
      write(*,'(1x,''|_______________________________________________|'')')
      write(*,'(/1x,'' enter option number > '',$)')
      read(*,'(a1)')ans
      if((ans.eq.'S').or.(ans.eq.'s'))then
        dev='psc';ok=.false.;filename='fig11.ps'
	       call plsdev(dev)
        call plsfnam(filename)
        goto 10
      elseif((ans.eq.'R').or.(ans.eq.'r'))then
        ok=.true.
        goto 10
      elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
        return
	     endif
c
	     return
	     end
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine plt6(mxl,mxs,nc,n,btout2,string1,string2)
c plot power spectrum of std and SSF chronologies in Log10
c argument decs
	integer mxl,mxs,nc,n
	real*4 btout2(mxl,3)
	character*18 string1,string2
c local decs
	integer red,blue,green
	integer p,j,k
	real*4 minx,maxx,miny,maxy,step
	real*4 wrk1(9000),wrk2(9000),wrk3(9000)
	character ans*1,filename*9,dev*80
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
ccc	write(*,'(/1x,''from plt6'')')
c
	miny=999.;maxy=-999.;minx=miny;maxx=maxy
	do p=1,nc
	  do j=1,n
	     if(p.eq.1)then
	       if(btout2(j,p).gt.maxx)maxx=btout2(j,p)
	       if(btout2(j,p).lt.minx)minx=btout2(j,p)
	       wrk1(j)=btout2(j,p)
	     else
	       if(log10(btout2(j,p)).gt.maxy)maxy=log10(btout2(j,p))
	       if(log10(btout2(j,p)).lt.miny)miny=log10(btout2(j,p))
	       if(p.eq.2)wrk2(j)=log10(btout2(j,p))
	       if(p.eq.3)wrk3(j)=log10(btout2(j,p))
	     endif
	  enddo
	enddo
c
10	if(ok)call plsdev(dev)
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)             !change default color map white>black
        call plscol0(0,0,0,0)                    !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
c initialize plplot
	call plinit()
	call plssub(1,1)
       call plwid(1)
	call plcol0(15)   !color box and lables
	call plenv(minx,maxx,miny,maxy,0,20)
	call pllab('Frequency (cycles/yr.)','log10 Power',' ')
	call plcol0(9)
	step=-43.25
	call plmtex('rv',step,1.065,0.0,string1)
	call plline(n,wrk1,wrk2)
	step=step+24.;call plcol0(1)
	call plmtex('rv',step,1.065,0.0,string2)
	call plline(n,wrk1,wrk3)
c		
20	call plend()	    	    
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig1b.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
	return
	end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr spaghetti
*
      subroutine spaghetti(xy,rline,ny,ns,ify,xlab,ylab,tit,annot1,annot2,mxy,mxs)
c
c     write(winu9,'(/13x,''COLOR TABLE ______________________________________________'')')
c     write(winu9,'(13x,''White(0) Red(1)  Yellow(2)  Green(3)  Aquamarine(4) Pink(5) '')')
c     write(winu9,'(13x,''Wheat(6)  Grey(7)  Browm(8)  Blue(9)  BlueViolet(10)'')')
c     write(winu9,'(13x,''Cyan(11)  Turquoise(12)  Magenta(13)  Salmon(14)  Black(15)'')')
c     write(winu9,'(13x,''___________________________________________________________'',/)')
c
      parameter(mxlen=9000)
c     argument
      real*4 xy(mxy,mxs),rline(mxy)
      integer ny,ns,ify,mxy,mxs
      character tit*60,xlab*20,ylab*20,annot1*36,annot2*36
c     local
      integer red,green,blue
      real*4 x(mxlen),wrk(mxlen),miny,maxy,maxx,minx,range	
      integer p
c      
      character dev*80,filename*60,ans*2
      logical bg,ok
c
      mny=100000.0;mxy=-100000.0
      red=255;green=255;blue=255
      bg=.false.;ok=.true.;dev='Mac1'
c
      minx=ify
      maxx=ify+ny-1
      maxy=-100000.0
      miny=100000.0
      do i=1,ny
        do j=1,ns
          datum=xy(i,j)
          if(datum.ne.-999.0)then
            if(datum.gt.maxy)maxy=datum
            if(datum.lt.miny)miny=datum
          endif
        enddo
        x(i)=ify+i-1
      enddo
      range=maxy-miny
      maxy=maxy+range/20.
      miny=miny-range/20.
c      
   10 if(ok)call plsdev('Mac1')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c
c *** initialize plplot
      call plinit()
c *** set lable color
      call plcol0(15)   !color box and lables
c *** set curve width
      call plwid(1)
c *** define the viewport one column by one rows
      call plssub(1,1)
      call plenv(minx,maxx,miny,maxy,0,0)
      call plfont(1)
      call pllab(xlab,ylab,' ')
      call plmtex('b',-35.5,.5,0.5,tit)
c *** set line style
      call pllsty(1)
c *** set line color
      call plcol0(15)  !color lines
c *** do plots
      if(rline(1).ne.-999.9)then
        do i=1,ny
          x(i)=minx+i-1
        enddo
        call plline(ny,x,rline)            !plot rline
      endif
      do j=1,ns
        do i=1,ny
          wrk(i)=xy(i,j)
        enddo
        call plcol0(15)
        if(j.eq.1)then
          call plcol0(9)
          if(ylab.eq.'Biweights')call plwid(1)
        elseif(j.eq.ns)then
          call plcol0(1)
          if(ylab.eq.'Biweights')call plwid(1)
        endif
        call plline(ny,x,wrk)
      enddo
      call plcol0(9)
      call plmtex('b',-33.75,0.19,0.0,annot1)
      call plcol0(1)   !red
      call plmtex('b',-33.75,0.55,0.0,annot2)
c
c *** end plotting
c
      call plend()   
c  
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;
         filename=tit
         call stringclean(filename,60)
         do p=1,60
           if(filename(p:p).eq.' ')goto 69
         enddo
69       write(filename(p:p+2),'(a3)')'.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
	subroutine scatplt(mxy,mxs,x1,y1,slope,int1,num,nc,n2,xtmp,rho,int2,slp)
c create a scatter plot of x vs y and thier ols solution
	integer mxy,mxs,num(mxs),nc,n2
	real*4 x1(mxy,mxs),y1(mxy,mxs),slope(mxs),int1(mxs),xtmp(mxy*mxs),rho,int2,slp
c	local
	integer p,j,k
	integer red,blue,green
	real*4 miny, maxy, minx, maxx
	real*4 x2(9000),y2(9000),y3(9000)
	character string*55,dev*3,filename
	logical ok,bg
c
       dev='Mac1';ok=.true.
       red=255;green=255;blue=255
       bg=.false.
ccc	write(*,'(/1x,''from scatplt'')')       
c
10	if(ok)call plsdev(dev)
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)             !change default color map white>black
        call plscol0(0,0,0,0)                    !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c	
	miny=9999.;maxy=-9999.
	minx=miny ;maxx=maxy 
	do k=1,nc
	   do p=1,num(k)
	      if(y1(p,k).gt.maxy)maxy=y1(p,k)
	      if(y1(p,k).lt.miny)miny=y1(p,k)
	      if(x1(p,k).gt.maxx)maxx=x1(p,k)
	      if(x1(p,k).lt.minx)minx=x1(p,k)
	      j=j+1
	  enddo
	enddo
c
c initialize plplot
	call plinit()
	call plssub(1,1)
       call plwid(1)
	call plcol0(15)   !color box and lables
	call plenv(minx,maxx,miny-1.,maxy+1.5,0,2)
       string='Y=       +       x  Rho=             '
       write(string,*)'Y=',int2,' + ',slp,'(x)  Rho= ',rho
	call pllab('log(LEVEL)','log(SPREAD)',string)
	do k=1,nc
	    call plcol0(9)
	    do p=1,num(k)
	       x2(p)=x1(p,k)
	       y2(p)=y1(p,k)
	    enddo
           call plwid(2)
	    call plpoin(num(k),x2,y2,1)
	    call plcol0(1)
	    do p=1,num(k)
	      y3(p)=x2(p)*slope(k)+int1(k)
	    enddo
ccc           call plwid(1)
	    call plline(num(k),x2,y3)
	enddo
c	
	
20	call plend()	    	    
c	
       ans='C '
	dev='Mac1'
       write(*,'(/1x,''|************* plot options menu ***************|'')')
       write(*,'(1x,''|-----------------------------------------------|'')')
       write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
       write(*,'(1x,''|_______________________________________________|'')')
       write(*,'(/1x,'' enter option number > '',$)')
       read(*,'(a1)')ans
       if((ans.eq.'S').or.(ans.eq.'s'))then
         dev='psc';ok=.false.;filename='fig1b.ps'
	  call plsdev(dev)
         call plsfnam(filename)
         goto 10
       elseif((ans.eq.'R').or.(ans.eq.'r'))then
         ok=.true.
         goto 10
       elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
         return
	endif
c
	return
	end
c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
*sbr linguine2
*
      subroutine linguine2(x1,x2,rline,ns,idate,xlab,ylab,tit,annot1,annot2,mxy1,mxs1,mxs)
c
c     write(winu9,'(/13x,''COLOR TABLE ______________________________________________'')')
c     write(winu9,'(13x,''White(0) Red(1)  Yellow(2)  Green(3)  Aquamarine(4) Pink(5) '')')
c     write(winu9,'(13x,''Wheat(6)  Grey(7)  Browm(8)  Blue(9)  BlueViolet(10)'')')
c     write(winu9,'(13x,''Cyan(11)  Turquoise(12)  Magenta(13)  Salmon(14)  Black(15)'')')
c     write(winu9,'(13x,''___________________________________________________________'',/)')
c
      parameter(mxlen=9000)
c     argument
      real*4 x1(mxy1,mxs1),x2(mxy1,mxs1),rline(mxy1)
      integer ny,ns,ify,mxy,mxs,idate(mxs,3)
      character tit*60,xlab*20,ylab*20,annot1*36,annot2*36
c     local
      integer red,green,blue
      real*4 x(mxlen),wrk(mxlen),miny,maxy,maxx,minx,range,miny1,maxy1,miny2,maxy2	
      integer p
c      
      character dev*80,filename*60,ans*2
      logical bg,ok
c
      mny=100000.0;mxy=-100000.0
      red=255;green=255;blue=255
      bg=.false.;ok=.true.;dev='Mac1'
ccc      write(*,*)'from linguine2'
c
      minx=100000.0
      maxx=-100000.0
      miny1=100000.0
      maxy1=-100000.0
      do j=1,ns
        ify=idate(j,1)
        ily=idate(j,2)
        ny=ily-ify+1
        if(ify.lt.minx)minx=ify
        if(ily.gt.maxx)maxx=ily
        do i=1,ny
          datum=x1(i,j)
          if(datum.ne.-999.0)then
            if(datum.gt.maxy1)maxy1=datum
            if(datum.lt.miny1)miny1=datum
          endif
        enddo
      enddo
      miny2=100000.0
      maxy2=-100000.0
      do j=1,ns
        ify=idate(j,1)
        ily=idate(j,2)
        ny=ily-ify+1
        do i=1,ny
          datum=x2(i,j)
          if(datum.ne.-999.0)then
            if(datum.gt.maxy2)maxy2=datum
            if(datum.lt.miny2)miny2=datum
          endif
        enddo
      enddo
      miny=amin1(miny1,miny2)
      maxy=amax1(maxy1,maxy2)
ccc      write(*,'(1x,''miny1,maxy1,miny2,maxy2,miny,maxy: '',6f8.3)')miny1,maxy1,miny2,maxy2,miny,maxy
      range=maxy-miny
      maxy=maxy+range/10.
      miny=miny-range/10.
      if(miny.lt.0)miny=0.0
c      miny=0.0
c      
   10 if(ok)call plsdev('Mac1')
c
c set background color
c
      if(.not.bg)then
        call plscol0(0,255,255,255)              !change default color map black>white 
        call plscol0(15,0,0,0)                   !change default color map white>black
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      elseif(bg)then
        call plscol0(15,255,255,255)              !change default color map white>black
        call plscol0(0,0,0,0)                   !change default color map black>white
        call plscolbg(red,green,blue)            !change background color if other than white is desired
      endif  
c
c *** initialize plplot
      call plinit()
c *** set lable color
      call plcol0(15)   !color box and lables
c *** set curve width
      call plwid(1)
c *** define the viewport one column by one rows
      call plssub(1,1)
      call plenv(minx,maxx,miny,maxy,0,0)
      call plfont(1)
      call pllab(xlab,ylab,' ')
      call plmtex('b',-35.5,.5,0.5,tit)
c *** set line style
      call pllsty(1)
c *** do plots
      call plcol0(9)
      do j=1,ns
        ify=idate(j,1)
        ily=idate(j,2)
        ny=ily-ify+1
        do i=1,ny
          wrk(i)=x1(i,j)
          x(i)=ify+i-1
        enddo
        call plline(ny,x,wrk)
      enddo
      call plcol0(1)
      do j=1,ns
        ify=idate(j,1)
        ily=idate(j,2)
        ny=ily-ify+1
        do i=1,ny
          wrk(i)=x2(i,j)
          x(i)=ify+i-1
        enddo
        call plline(ny,x,wrk)
      enddo
      call plwid(2)
      call plcol0(15)
      if(rline(1).ne.-999.9)then
        maxn=idate(ns+1,2)-idate(ns+1,1)+1
        do i=1,maxn
          x(i)=idate(ns+1,1)+i-1
        enddo
        call plline(maxn,x,rline)            !plot rline
      endif
      call plcol0(9)  !color lines
      call plwid(1)
      call plmtex('b',-33.75,0.05,0.0,annot1)
      call plcol0(1)
      call plmtex('b',-33.75,0.72,0.0,annot2)
c
c *** end plotting
c
      call plend()   
c  
c      ans='C '
c      dev='Mac1'
c      write(*,'(/1x,''|************* plot options menu ***************|'')')
c      write(*,'(1x,''|-----------------------------------------------|'')')
c      write(*,'(1x,''|       [s]ave   <[c]ontinue>   [r]eplot        |'')') 
c      write(*,'(1x,''|_______________________________________________|'')')
c      write(*,'(/1x,'' enter option number > '',$)')
c      read(*,'(a1)')ans
c      if((ans.eq.'S').or.(ans.eq.'s'))then
c        dev='psc';ok=.false.;
c        filename=tit
c        call stringclean(filename,60)
c        do p=1,60
c          if(filename(p:p).eq.' ')goto 69
c        enddo
69      write(filename(p:p+2),'(a3)')'.ps'
c        call plsdev(dev)
c        call plsfnam(filename)
c        goto 10
c      elseif((ans.eq.'R').or.(ans.eq.'r'))then
c        ok=.true.
c        goto 10
c      elseif((ans.eq.'C').or.(ans.eq.'c').or.(ans.eq.' ').or.
c     *                             (ans.eq.'Y').or.(ans.eq.'y'))then
c        return
c      endif
c
      return
      end
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc