      program turbo
c MODIFICATIONS - 12/2006
c      subr. robsum, fixed bug when dealing with chronologies containing large gaps. ERC
c      subr. scale,  calculates optimum plot limits and tic interval
C                    ALGORITHM AS 96  APPL. STATIST. (1976) VOL.25, NO.1
c
c NOTES:
c
c ***  mxy = maximum number of chronology years  ***
c ***  mxs = maximum number of tree-ring series  ***
c      !!! Before recompiling for different platforms !!!
c ***  The character variable (dev) must be set to "win3" for plotting on Macs
c      and "win3" for plotting on pc's. The value of dev is case sensitive.
c *** change these parameters to suit your needs ***
c
c  This version 41dx expanded to handle 3000 series. -pjk
c
      parameter(mxy=5000,mxs=3000,mxplts=20)  !msx=500
      real*4 x(mxy,mxs),y(mxy,16),f(mxy),stats(mxs,12),crn(mxy),corr(mxs,mxs)
      real*4 wrk1(mxy),wrk2(mxy),wrk3(mxy),wrk4(mxy),wrk5(mxy),wrk6(mxy)
      real*4 phi(12),cof(12,mxs),rxm(mxy,7,4),rxm1(mxy,7),eq(7)
      real*4 bierr(mxy),acr(12),pac(12),seac(12),shl(mxy),shh(mxy)
      real*4 a(mxs,mxs),b(mxs,mxs),c(mxs,mxs)
      integer idate(mxs+2,10),ns(mxy),nss(mxy),mask(mxs)
      integer nshft(mxs),keep(mxs)
      character fil*40,fil2*40,tit*85,line*50,line1*60
      character id*8,ident(mxs)*8,id1(mxs)*8,tab,crc,bif,ans
      character fil4*40,title*80,datum1*6,datum2*6,datum3*6,frm*20
      character tit1*85,tag*3,md,jtrdb(3)*85
c
c *** common block variables
c
      integer jems(30,5),ndd                    
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	  common/icommands/jems,ndd            !new pjk
      common/tsi1/x,crn,idate,ident,nc
      common/tsi2/y
c
c *** set logical unit numbers
c
      data iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,iu17,iu18,
     *    iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,iu35,iu36,
     *    iu37,iu38,iu39/9,10,11,12,13,14,15,16,17,18,19,20,
     *    21,30,31,32,33,34,35,36,37,38,39/
c
c February 7,2008 -pjk
c New in version ARS41d is the addition of a call to PLPLOT_fonts2.c to set an environment 
c vairable to include path to /Applications/Absoft/EXAMPLES/PLPlot/examples the folder that 
c contains those six pesty font files for plplot graphics. NOT YET REQUIRED 
c for Windows.
c
c      call PLPLOT_fonts2( )    !new for Absoft10.1 OS X 10.5 Intel
c
      tab=char(9)
      cvp='n'
      call blank(cpm1)
c
      pixels='2'
c
c *** for saving sorted chronologies in separate files
c
      open(iu30,file='crns.raw',status='unknown')
      close(iu30,status='delete')
      open(iu30,file='crns.raw',status='unknown')
      open(iu31,file='crns.std',status='unknown')
      close(iu31,status='delete')
      open(iu31,file='crns.std',status='unknown')
      open(iu32,file='crns.res',status='unknown')
      close(iu32,status='delete')
      open(iu32,file='crns.res',status='unknown')
      open(iu33,file='crns.ars',status='unknown')
      close(iu33,status='delete')
      open(iu33,file='crns.ars',status='unknown')
      open(iu34,file='crns.rcs',status='unknown')
      close(iu34,status='delete')
      open(iu34,file='crns.rcs',status='unknown')
      open(iu35,file='crns.raw_err',status='unknown')
      close(iu35,status='delete')
      open(iu35,file='crns.raw_err',status='unknown')
      open(iu36,file='crns.std_err',status='unknown')
      close(iu36,status='delete')
      open(iu36,file='crns.std_err',status='unknown')
      open(iu37,file='crns.res_err',status='unknown')
      close(iu37,status='delete')
      open(iu37,file='crns.res_err',status='unknown')
      open(iu38,file='crns.ars_err',status='unknown')
      close(iu38,status='delete')
      open(iu38,file='crns.ars_err',status='unknown')
      open(iu39,file='crns.rcs_err',status='unknown')
      close(iu39,status='delete')
      open(iu39,file='crns.rcs_err',status='unknown')
c
      write(*,'(/t26,''**********************************''/
     *           t26,''**********************************''/
     *           t26,''***                            ***''/
     *           t26,''***     Program ARSTAN_41dx    ***''/
     *           t26,''***                            ***''/
     *           t26,''***       Creation Date:       ***''/
     *           t26,''***          04/16/08          ***''/
     *           t26,''***                            ***''/
     *           t26,''***       Programmed by:       ***''/
     *           t26,''***     Dr. Edward R. Cook     ***''/
     *           t26,''***       Paul J. Krusic       ***''/
     *           t26,''***    Tree-Ring Laboratory    ***''/
     *           t26,''***  Lamont-Doherty Earth Obs. ***''/
     *           t26,''***    Palisades, N.Y. 10964   ***''/
     *           t26,''*** drdendro@ldeo.columbia.edu ***''/
     *           t26,''***    pjk@ldeo.columbia.edu   ***''/
     *           t26,''***  www.ldeo.columbia.edu/trl ***''/
     *           t26,''***                            ***''/
     *           t26,''**********************************''/
     *           t26,''**********************************'')')
c
      write(*,'(/17x,''MAXIMUM tree-ring chronology length: '',
     *  t65,i5)')mxy
      write(*,'(17x,''MAXIMUM number of tree-ring series:  '',
     *  t65,i5)')mxs
    1 md=' '
      write(*,'(/20x,''<ret> to run, / to exit, '',
     *  ''h for more info: '',$)')
      read(*,'(a)')md
      if(md.eq.' ')then
        goto 2
      elseif(md.eq.'/')then
        close(iu30,status='delete')
        close(iu31,status='delete')
        close(iu32,status='delete')
        close(iu33,status='delete')
        close(iu34,status='delete')
        close(iu35,status='delete')
        close(iu36,status='delete')
        close(iu37,status='delete')
        close(iu38,status='delete')
        close(iu39,status='delete')
        stop' <=== bailout ===>'
      endif
      if(md.eq.'h'.or.md.eq.'H')then
        call info(1)
      endif
      md=' '
      write(*,'(/1x,''<ret> to run, / to exit, '',
     *  ''h for more info: '',$)')
      read(*,'(a)')md
      if(md.eq.' ')then
        goto 2
      elseif(md.eq.'/')then
        stop' <=== bailout ===>'
      endif
      call info(2)
      md=' '
      write(*,'(/1x,''<ret> to run, / to exit, '',
     *  ''h for more info: '',$)')
      read(*,'(a)')md
      if(md.eq.' ')then
        goto 2
      elseif(md.eq.'/')then
        stop' <=== bailout ===>'
      endif
      call info(3)
    2 md='n'
    3 call blank(fil1)
      write(*,'(/1x,''open the file listing the data file names''/
     *  1x,''type h for help or <ret> to enter them'',
     *  t45,''==> '',$)')
      read(*,'(a)')fil1
      if(fil1(1:1).eq.'/')stop' <=== bailout ===>'
      if(fil1(1:5).eq.'b    '.or.fil1(1:5).eq.'B    ')goto 1
      if(fil1(1:5).eq.'h    '.or.fil1(1:5).eq.'H    ')then
        call helpm(2)
        goto 3
      endif
      if(fil1(1:5).eq.'     ')then
        fil1(1:12)='arstan.files'
        open(iu9,file=fil1,status='unknown',err=3)
        close(iu9,status='delete')
        open(iu9,file=fil1,status='unknown',err=3)
        write(*,'(/1x,''okay, so enter your data file name(s)'')')
        write(*,'(1x,''which will be stored in the new file: '',a)')
     *    fil1
        write(*,'(1x,''when done, hit <ret> to process the '',
     *    ''data file(s).''/)')
        nfil=0
    4   call blank(fil)
        write(*,'(1x,''file name #'',i2,'': '',$)')nfil+1
        read(*,'(a)')fil
        if(fil(1:5).eq.'b    '.or.fil(1:5).eq.'B    ')then
          if(nfil.eq.0)then
            close(iu9,status='delete')
            goto 3
          else
            backspace(iu9)
            nfil=nfil-1
            goto 4
          endif
        endif
        if(fil(1:5).eq.'     ')then
          if(nfil.eq.0)then
            write(*,'(/1x,''*** no data file names entered ***'')')
            close(iu9,status='delete')
            goto 3
          else
            goto 5
          endif
        endif
        write(iu9,'(a)')fil
        nfil=nfil+1
        goto 4
      else
        open(iu9,file=fil1,status='old',err=3)
        write(*,'(/1x,a,'' opened'')')fil1
        nfil=0
        do i=1, 5000
          call blank(fil)
          read(iu9,'(a)',end=5)fil
          if(fil(1:5).eq.'     '.and.nfil.gt.0)then
            goto 5
          elseif(fil(1:5).eq.'     '.and.nfil.eq.0)then
            write(*,'(/1x,''*** no data file names found ***'')')
            goto 3
          endif
          nfil=nfil+1
          write(*,'(1x,i5,2x,a)')nfil,fil
        enddo
      endif
    5 rewind(iu9)
      write(*,'(/1x,''number of files to be processed: '',i5)')nfil
      call blank(title)
      write(*,'(/1x,''okay, enter your overall run title:''/
     *  1x,''==> '',$)')
      read(*,'(a)')title
      if(title(1:5).eq.'b    '.or.title(1:5).eq.'B    ')then
        close(iu9)
        goto 3
      endif
      if(title(1:5).eq.'h    '.or.title(1:5).eq.'H    ')then
        call helpm(3)
        goto 5
      endif
      call blank(fil)
      fil=fil1
    6 bf=' '
      write(*,'(/1x,''run in batch mode from log file? y/<n>/h'',
     *  t45,''==> '',$)')
      read(*,'(a)')bf
      if(bf.eq.'/')stop
      if(bf.eq.' ')then
        bf='n'
        goto 7
      endif
      if(bf.eq.'b'.or.bf.eq.'B')then
        goto 5
      endif
      if(bf.eq.'h'.or.bf.eq.'H')then
        call helpm(4)
        goto 6
      endif
      if((bf.ne.'y'.and.bf.ne.'Y').and.(bf.ne.'n'.and.bf.ne.'N'))
     *  goto 6
c
c *** create log files for batch mode processing
c
    7 if(bf.eq.'n'.or.bf.eq.'N')then
        go=' '
        if(nfil.gt.1)then
          write(*,'(1x,''use same commands for all runs? <y>/n/h '',
     *	  	  t45,''==> '',$)')
          read(*,'(a)')go
          if(go.eq.' ')go='y'
        else
          go='y'
        endif
        if(go.eq.'/')stop
        if(go.eq.'b'.or.go.eq.'B')goto 6
        if(go.eq.'h'.or.go.eq.'H')then
          call helpm(5)
          goto 7
        endif
        if((go.ne.'y'.and.go.ne.'Y').and.(go.ne.'n'.and.go.ne.'N'))
     *    goto 7
        call mlf
        rewind(iu9)
    8   bd=' '
        write(*,'(/
     *    1x,''the log files have been created now.''/
     *    1x,''continue with run? <y>/n/h'',t45,''==> '',$)')
        read(*,'(a)')bd
        if(bd.eq.' ')bd='y'
        if(bd.eq.'/')stop
        if(bd.eq.'b'.or.bd.eq.'B')goto 7
        if(bd.eq.'h'.or.bd.eq.'H')then
          call helpm(6)
          goto 8
        endif
        if((bd.ne.'y'.and.bd.ne.'Y').and.(bd.ne.'n'.and.bd.ne.'N'))
     *    goto 8
        if(bd.eq.'n'.or.bd.eq.'N')then
          close(iu30,status='delete')
          close(iu31,status='delete')
          close(iu32,status='delete')
          close(iu33,status='delete')
          close(iu34,status='delete')
          close(iu35,status='delete')
          close(iu36,status='delete')
          close(iu37,status='delete')
          close(iu38,status='delete')
          close(iu39,status='delete')
          stop
        endif
      endif
c
c *** now proceed to process data sets -- implied do loop 10
c
      nfil=0
   10 call blank(fil1)
      read(iu9,'(a)',end=100)fil1
      if(fil1(1:10).eq.'          ')goto 100
      ll=len(fil1)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(fil1(jj:jj).ne.' ')goto 11
      enddo
   11 ll=jj
      call blank(fil2)
      fil2=fil1
      fil2(ll+1:ll+10)='_out      '
      open(iu11,file=fil2,status='unknown')
      close(iu11,status='delete')
      open(iu11,file=fil2,status='unknown')
      write(iu11,'(/t25,''**********************************''/
     *           t25,''**********************************''/
     *           t25,''***                            ***''/
     *           t25,''***      program ARSTAN40c     ***''/
     *           t25,''***                            ***''/
     *           t25,''***       creation date:       ***''/
     *           t25,''***           3/6/06           ***''/
     *           t25,''***                            ***''/
     *           t25,''***       programmed by:       ***''/
     *           t25,''***     Dr. Edward R. Cook     ***''/
     *           t25,''***       Paul J. Krusic       ***''/
     *           t25,''***    tree-ring laboratory    ***''/
     *           t25,''***  lamont-doherty earth obs  ***''/
     *           t25,''***    palisades, n.y. 10964   ***''/
     *           t25,''*** drdendro@ldeo.columbia.edu ***''/
     *           t25,''***    pjk@ldeo.columbia.edu   ***''/
     *           t25,''***                            ***''/
     *           t25,''**********************************''/
     *           t25,''**********************************'')')
      write(iu11,'(/t2,''|=================================='',
     *  ''============================================|'')')
      write(iu11,'(/1x,''overall run title: '',a)')title
      write(iu11,'(/t2,''file names file processed: '',
     *  t35,a)')fil
      fil2(ll+1:ll+10)='_tabs     '
      open(iu12,file=fil2,status='unknown')
      close(iu12,status='delete')
      open(iu12,file=fil2,status='unknown')
      fil2(ll+1:ll+10)='_crns     '
      open(iu13,file=fil2,status='unknown')
      close(iu13,status='delete')
      open(iu13,file=fil2,status='unknown')
      fil2(ll+1:ll+10)='_errs     '
      open(iu17,file=fil2,status='unknown')
      close(iu17,status='delete')
      open(iu17,file=fil2,status='unknown')
c
c *** now open data and log files, and read log files
c
      fil2(ll+1:ll+10)='_log      '
      open(iu10,file=fil1,status='old',err=14)    !open data file
      write(iu11,'(t2,''data file processed: '',
     *  t35,a)')fil1
      goto 15
   14 write(*,'(/1x,''data file not found:  '',a)')fil1
      write(*,'(/1x,''check file names in:  '',a)')fil
      goto 100
   15 open(iu21,file=fil2,status='old',err=16)    !open log file
      write(iu11,'(t2,''log file processed: '',
     *  t35,a/)')fil2
      goto 17
   16 write(*,'(/1x,''*** log file not found:  ''a)')fil2
      write(*,'(1x,''*** re-run program in interactive mode''/
     *          1x,''*** to create the proper log file.'')')
      close(iu11,status='delete')
      close(iu12,status='delete')
      close(iu13,status='delete')
      close(iu17,status='delete')
      goto 100
   17 call batch(ier,nfil,fil1)
      if(ier.gt.0)goto 100
      call blank(cpm)
      cpm=cpm1
      nfil=nfil+1
c
c *** set up default batch detail and pith offset arrays
c
      do i=1,mxs
        do j=1,10
          idate(i,j)=0
        enddo
        idate(i,4)=jems(3,1)
        idate(i,8)=1
        idate(i,9)=1
ccc        if(jems(13,1).ne.0.and.jems(14,1).ne.0)then
          idate(i,10)=i
ccc        endif
        nshft(i)=0
        call blank(ident(i))
      enddo
c
c *** open and read batch detail file
c
      if(bf.eq.'y'.or.bf.eq.'Y')then
        bd='y'
        fil2(ll+1:ll+10)='_detail   '
        fil4=fil2
        open(iu14,file=fil4,status='old',err=21)
        write(*,'(/1x,''batch detail file opened:  '',a)')fil4
        write(iu11,'(t2,''batch detail file processed: '',t35,a/)')fil4
        call blank(line)
        do i=1,8
          read(iu14,'(a)')line
        enddo
        nl=1
   20   read(iu14,'(i4,2x,a8,10i6)',err=21,end=22)j,ident(nl),
     *    (idate(nl,k),k=1,10)
        if(j.eq.0)goto 22
        nl=nl+1
        goto 20
   21   write(*,'(/
     *    1x,''*** batch detail data file either not found or''/
     *    1x,''*** error in reading in data. defaults are used.'')')
        bd='n'
        goto 23
   22   close(iu14)
      endif
c
c *** miscellaneous bullshit
c
   23 if(jems(1,1).eq.1)then
        q='mr'
        qq='iw'
      elseif(jems(1,1).eq.2)then
        q='cr'
        qq='cr'
      elseif(jems(1,1).eq.3)then
        q='ir'
        qq='iw'
      elseif(jems(1,1).eq.4)then
        q='cd'
        qq='iw'
      endif
      q3=q
c
c *** more of the same
c
      ifg1=jems(2,1)	      !missing data flag
      ifg2=jems(2,2)	      !plot estimated missing data
      itn1=jems(3,1)	      !data transformation option
      itn2=jems(3,2)          !plot transformed data
      idt=jems(4,1)           !first detrending option
      ndt1=jems(4,2)	      !smoothing for lowess or median
      idt1=jems(4,3)          !plot data and curve fits
      id2=jems(5,1)           !second detrending option
      ndt1=jems(5,2)	      !smoothing for lowess or median
      id3=jems(5,3)           !plot data and curve fits
      irb=jems(6,1)           !robust detrending option
      ido=jems(7,1)           !interactive detrending option
      ind=jems(8,1)	          !index calculation option
      jrb1=jems(9,1)          !autoregressive modeling option
      jrb2=jems(9,2)          !plot autoregressive outliers
      ipp=jems(10,1)          !pooled ar order selection
      ip2=jems(10,2)          !pooled ar plot option
      ips=jems(11,1)          !individual series ar order
      krb1=jems(12,1)         !mean chronology option
      krb2=jems(12,2)         !plot bootstrap
      krb3=jems(12,3)         !bootstrap chronology
      krb4=jems(12,4)         !splined bootstrap limits
      isb=jems(13,1)          !variance stabilization option
      ifc=jems(14,1)          !first year of common period
      ilc=jems(14,2)          !last year of common period
      nsg=jems(16,1)	      !running rbar segment length
      nlp=jems(16,2)          !running rbar segment overlap
      npl=jems(16,3)          !running rbar/eps plots
      ipo=jems(17,1)	      !print out option
      ics=jems(18,1)          !individual series save option
      ird=jems(19,1)          !high-resolution display option
      isd1=jems(20,1)         !stand dynamics stuff
      nww=jems(20,2)          !running mean window width
      ipg=jems(20,3)          !percent growth change threshold
      nse=jems(20,4)          !standard error threshold
      isd2=jems(20,5)         !plot it
      jrd=ird
c
c *** header output
c
      write(iu11,'(''                       opt          plt'')')
      call gmh(1,jems(1,1),line)
      write(iu11,'(t2,''tree-ring data type'',t21,i5,t42,a)')
     *		jems(1,1),line
      call gmh(2,jems(2,2),line)
      write(iu11,'(t2,''missing data in gaps'',t21,i5,i13,t42,a)')
     *		jems(2,1),jems(2,2),line
      if(itn2.eq.0)then
        itns=itn1
      else
        itns=-itn1
      endif
      call gmh(3,itns,line)
      write(iu11,'(t2,''data transformation'',t21,i5,i13,t42,a)')
     *		jems(3,1),jems(3,2),line
      call gmh(4,jems(4,1),line)
      line(2:5)='1st-'
ccc      if(jems(4,1).ne.-3.and.jems(4,1).ne.-4)then
ccc        write(iu11,'(t2,''first detrending'',t21,i5,i13,t42,a)')
ccc     *		jems(4,1),jems(4,3),line
ccc      else
        write(iu11,'(t2,''first detrending'',t21,i5,i7,i6,t42,a)')
     *		  jems(4,1),jems(4,2),jems(4,3),line
ccc      endif
      call gmh(5,jems(5,1),line)
      if(jems(4,1).eq.-2)then
        line(2:5)='rcs-'
      else
        line(2:5)='2nd-'
      endif
ccc      if(jems(5,1).ne.-3.and.jems(4,1).ne.-4)then
ccc        write(iu11,'(t2,''second detrending'',t21,i5,i13,t42,a)')
ccc     *		jems(5,1),jems(5,3),line
ccc      else
        write(iu11,'(t2,''second detrending'',t21,i5,i7,i6,t42,a)')
     *		  jems(5,1),jems(5,2),jems(5,3),line
ccc      endif
      call gmh(6,jems(6,1),line)
      write(iu11,'(t2,''robust detrending'',t21,i5,t42,a)')
     *		jems(6,1),line
      call gmh(7,jems(7,1),line)
      write(iu11,'(t2,''interactive detrend'',t21,i5,t42,a)')
     *		jems(7,1),line
      call gmh(8,jems(8,1),line)
      write(iu11,'(t2,''index calculation'',t21,i5,t42,a)')
     *		jems(8,1),line
      if(jrb2.eq.0)then
        jrbs=jrb1
      else
        jrbs=-jrb1
      endif
      call gmh(9,jrbs,line)
      write(iu11,'(t2,''ar modeling method'',t21,i5,i13,t42,a)')
     *		jems(9,1),jems(9,2),line
      if(ip2.eq.0)then
        ips=ip2
      else
        ips=-ipp-1
      endif
      call gmh(10,ips,line)
      write(iu11,'(t2,''pooled ar order'',t21,i5,i13,t42,a39)')
     *		jems(10,1),jems(10,2),line
      call gmh(11,jems(11,1),line)
      write(iu11,'(t2,''series ar order'',t21,i5,t42,a)')
     *		jems(11,1),line
      if(krb1.eq.0)then
        krb12=1
      elseif(krb1.eq.1.and.krb3.eq.0)then
        krb12=2
      elseif(krb1.eq.1.and.krb3.eq.1)then
        krb12=6
      elseif(krb1.eq.2.and.krb3.eq.0)then
        krb12=3
      elseif(krb1.eq.2.and.krb3.eq.1)then
        krb12=7
      elseif(krb1.lt.0.and.krb3.eq.0)then
        krb12=5
      elseif(krb1.lt.0.and.krb3.eq.1)then
        krb12=8
      endif   
      call gmh(12,krb12,line)
      write(iu11,'(t2,''mean chronology'',t22,2i4,i5,i4,t42,a)')
     *		jems(12,1),jems(12,3),jems(12,4),jems(12,2),line
      call gmh(13,jems(13,1),line)
      write(iu11,'(t2,''stabilize variance'',t21,i5,t42,a)')
     *		jems(13,1),line
      call blank(datum1)
      call intfrm1(jems(14,1),frm)
      write(datum1,frm)jems(14,1)
      call blank(datum2)
      call intfrm1(jems(14,2),frm)
      write(datum2,frm)jems(14,2)
      call gmh(14,jems(14,1),line)
      write(iu11,'(t2,''common period years'',t25,2i5,t42,a)')
     *  jems(14,1),jems(14,2),line
ccc     *	 datum1,datum2,line
      call gmh(15,jems(15,1),line)
      write(iu11,'(t2,''site-tree-core mask'',t24,4x,a,t42,a)')
     *  cpm,line
      call blank(datum1)
      call intfrm1(jems(16,1),frm)
      write(datum1,frm)jems(16,1)
      call blank(datum2)
      call intfrm1(jems(16,2),frm)
      write(datum2,frm)jems(16,2)
      call blank(datum3)
      call intfrm1(jems(16,3),frm)
      write(datum3,frm)jems(16,3)
      jemsum=jems(16,1)
      if(jems(16,3).eq.1)jemsum=-jemsum
      call gmh(16,jemsum,line)
      write(iu11,'(t2,''running rbar'',t25,2i5,i4,t42,a)')
     *  jems(16,1),jems(16,2),jems(16,3),line
      call gmh(17,jems(17,1),line)
      write(iu11,'(t2,''printout option'',t21,i5,t42,a)')
     *		jems(17,1),line
      call gmh(18,jems(18,1),line)
      write(iu11,'(t2,''core series save'',t21,i5,t42,a)')
     *		jems(18,1),line
      call gmh(19,jems(19,1),line)
      write(iu11,'(t2,''summary plot displays'',t24,i2,t42,a)')
     *		jems(19,1),line
      call gmh(20,jems(20,1),line)
      write(iu11,'(/t2,''stand dynamics stuff'',t21,i5,i13,t42,a)')
     *		jems(20,1),jems(20,5),line
      call gmh(21,jems(20,2),line)
      write(iu11,'(t2,''running mean window'',t21,i5,t42,a)')
     *		jems(20,2),line
      call gmh(22,jems(20,3),line)
      write(iu11,'(t2,''percent growth change'',t24,i2,t42,a)')
     *		jems(20,3),line
      call gmh(23,jems(20,4),line)
      write(iu11,'(t2,''std error threshold'',t21,i5,t42,a)')
     *		jems(20,4),line
c
c *** read in the data
c
c      start=secnds(0.0)
      write(iu11,'(/t2,''|======================== raw data '',
     *  ''statistical analyses =======================|'')')
      call trread(x,wrk1,nss,nc,idate,id,ident,mxy,mxs,tit,gmn,
     *  stats,mgap)
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
      do i=1,maxn
        do j=1,12
          y(i,j)=-9.99
        enddo
      enddo
c
c *** properly align the series by date in the array and dummy the missing values
c
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ish=ify-idate(nc+1,1)
        do i=1,n
          ii=n-i+1
          x(ii+ish,j)=x(ii,j)
        enddo
        do i=1,ish
          x(i,j)=-9.99
        enddo
      enddo
c
c *** save original individual series if ics > 0
c
      id(1:6)=fil2(1:6)
      if(tit(1:6).eq.'      ')then
        call blank(tit)
        tit(1:ll)=fil1(1:ll)
        tit(ll+1:ll+34)=' -- no data title -- '
      endif
      if(itrdb(1)(1:6).eq.'      ')then
        itrdb(1)(1:80)=tit(1:80)
        itrdb(1)(59:80)='1st itrdb line missing'
      endif
      if(itrdb(2)(1:6).eq.'      ')then
        itrdb(2)(1:58)=itrdb(1)(1:58)
        itrdb(2)(59:80)='2nd itrdb line missing'
      endif
      if(itrdb(3)(1:6).eq.'      ')then
        itrdb(3)(1:58)=itrdb(1)(1:58)
        itrdb(3)(59:80)='3rd itrdb line missing'
      endif
      do j=1,3
        call blank(jtrdb(j))
        jtrdb(j)=itrdb(j)
      enddo
      if(ics.gt.0)then
        fil2(ll+1:ll+10)='_raw      '
        open(iu14,file=fil2,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil2,status='unknown')
        if(ics.le.3)then
          do j=1,3
            jtrdb(j)(81:85)='  raw'
            write(iu14,'(a)')jtrdb(j)
          enddo
        endif
        call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'raw')
        close(iu14)
      endif
c
c *** fill in missing data gaps if necessary (mgap.gt.0)
c
      if(mgap.gt.0)then
        write(*,'(/1x,''fill in missing data gaps now'')')
        call fillin(x,nss,wrk1,wrk2,wrk3,nc,idate,ident,mxy,mxs)
        if(ics.gt.0)then
          id(1:6)=fil2(1:6)
          fil2(ll+1:ll+10)='_gap      '
          open(iu14,file=fil2,status='unknown')
          close(iu14,status='delete')
          open(iu14,file=fil2,status='unknown')
          if(ics.le.3)then
            do j=1,3
              jtrdb(j)(81:85)='  gap'
              write(iu14,'(a)')jtrdb(j)
            enddo
          endif
          call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'gap')
          close(iu14)
        endif
      endif
c
c *** do lorimer/nowacki/abrams/cook release analyses if desired
c
      if(isd1.gt.1)then
        iplt=isd2
        do j=1,nc
          nww1=nww
          ipg1=ipg
          nse1=nse
          ify=idate(j,1)
          ily=idate(j,2)
          nyr=ily-ify+1
          ish=ify-idate(nc+1,1)
          call blank(id)
          bif='N'
   30     do i=1,nyr
            wrk1(i)=x(i+ish,j)
          enddo
c	    write(*,'(1x,''Before call to nowacki ify= '',i4)')ify
          call nowacki(wrk1,ident(j),ify,nyr,nww1,ipg1,nse1,bif,wrk2,wrk3,wrk4,mxy,iplt)
          if(iplt.gt.0)then
            bif=' '
            crc=' '
            write(*,'(/1x,''change release detection settings? y/<n>'',t45,''==> '',$)')
            read(*,'(a)')crc
            if(crc.eq.' ')crc='N'
            if(crc.eq.'y'.or.crc.eq.'Y')then
   31         write(*,'(1x,''running mean window width (5-50)'',t45,''==> '',$)')
              read(*,*,err=31)nww1
              if(nww1.le.5.or.nww1.gt.50)goto 31
   32         write(*,'(1x,''percent growth change threshold (5-200)'',t45,''==> '',$)')
              read(*,*,err=32)ipg1
              if(ipg1.lt.5.or.ipg1.gt.200)goto 32
   33         write(*,'(1x,''standard error threshold (0-5)'',t45,''==> '',$)')
              read(*,*,err=33)nse1
              if(nse1.lt.0.or.nse1.gt.5)goto 33
   34         write(*,'(1x,''prefilter with 3-point binomial? y/<n>'',t45,''==> '',$)')
              read(*,'(a)')bif
              if(bif.eq.' ')bif='N'
              if(bif.eq.'n')bif='N'
              if(bif.eq.'y')bif='Y'
              if((bif.ne.'y'.and.bif.ne.'Y').and.(bif.ne.'n'.and.bif.ne.'N'))then
                bif=' '
                goto 34
              endif
              ify=idate(j,1)
              goto 30
            endif
          endif
        enddo
      endif
c
c *** plot out the raw data spaghetti
c
      if((ird.eq.1.or.ird.eq.3).and.krb1.eq.0)then
        crn(1)=-9.99
        call crnplt3('tree ring measurements','years',
     *    'measurements (y)',1)
      endif
c
c *** raw data rbar stuff
c
      if(nc.gt.1)then
        call rbar(x,idate,ident,nc,mxy,mxs,iu11,rbr)
        if(ifc.ne.0.and.ilc.ne.0)then
          cpm1=cpm
          call stc(ident,idate,nc,cpm1,mxs)
          ntest=1.00*(ilc-ifc+1)
          do j=1,nc
            ify=idate(j,1)
            ily=idate(j,2)
            n=min0(ilc,ily)-max0(ifc,ify)+1
            if(n.lt.ntest)idate(j,10)=0
          enddo
          write(iu11,'(/t2,''|======================= raw data '',
     *      ''common period analyses ======================|'')')
          itp=1
          call comper(x,corr,a,b,c,wrk1,idate,ident,id1,nc,mxy,mxs,stats,rbc,rbs,eps,itp)
        endif
        if(nsg.gt.0.and.maxn.gt.nsg*2)then
          write(*,'(/1x,''calculate raw data chronology running '',
     *      ''rbar'')')
          call runr(x,idate,maxn,nc,rxm1,ncnt,mxy,mxs)
          do i=1,ncnt
            do j=1,7
              rxm(i,j,1)=rxm1(i,j)
            enddo
          enddo
ccc          if(ics.gt.0)then
            fil2(ll+1:ll+10)='_raw_rbar '
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            write(iu14,'(''year'',a,''corrs'',a,''rbar'',a,''sdev'',
     *        a,''serr'',a,''eps '',a,''cores'')')tab,tab,tab,tab,
     *        tab,tab
            do i=1,ncnt
              write(iu14,'(f7.0,a,f7.0,4(a,f8.4),a,f7.2)')rxm(i,1,1),
     *          tab,rxm(i,2,1),tab,rxm(i,3,1),tab,rxm(i,4,1),tab,
     *          rxm(i,5,1),tab,rxm(i,6,1),tab,rxm(i,7,1)
            enddo
            close(iu14)
ccc          endif
        else
          write(iu11,'(/14x,''no running rbar segments calculated: total chronology''/
     *      15x,''length less then 2x the running window width: '',i4)')nsg
          write(*,'(/1x,''no running rbar segments calculated: total chronology''/
     *      2x,''length less then 2x the running window width: '',i4)')nsg
        endif
      endif
c
c *** optionally transform the data
c
      if(itn1.gt.0)then
        write(iu11,'(/t2,''|==================== transformed '',
     *    ''data statistical analyses ===================|'')')	                                   
        call trnfrm(x,wrk1,wrk2,wrk3,wrk4,wrk5,wrk6,idate,ident,nc,stats)
c
c *** save transformed individual series if ics > 0
c
        if(ics.gt.0)then
          fil2(ll+1:ll+10)='_trn      '
          open(iu14,file=fil2,status='unknown')
          close(iu14,status='delete')
          open(iu14,file=fil2,status='unknown')
          if(ics.le.3)then
            do j=1,3
              jtrdb(j)(81:85)='  trn'
              write(iu14,'(a)')jtrdb(j)
            enddo
          endif
          call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'trn')
          close(iu14)
        endif
c
c *** plot out the raw data spaghetti
c
        if((ird.eq.1.or.ird.eq.3).and.krb1.eq.0)then
          crn(1)=-9.99
          call crnplt3('transformed measurements','years',
     *      'measurements (y)',2)
        endif
c
c *** transformed data rbar stuff
c
        if(nc.gt.1)then
          call rbar(x,idate,ident,nc,mxy,mxs,iu11,rbr)
          if(ifc.ne.0.and.ilc.ne.0)then
            cpm1=cpm
            call stc(ident,idate,nc,cpm1,mxs)
            ntest=1.00*(ilc-ifc+1)
            do j=1,nc
              ify=idate(j,1)
              ily=idate(j,2)
              n=min0(ilc,ily)-max0(ifc,ify)+1
              if(n.lt.ntest)idate(j,10)=0
            enddo
            write(iu11,'(/t2,''|================= transformed raw '',
     *        ''data common period analyses ================|'')')
            itp=2
            call comper(x,corr,a,b,c,wrk1,idate,ident,id1,nc,mxy,mxs,stats,rbc,rbs,eps,itp)
          endif
          if(nsg.gt.0.and.maxn.gt.nsg*2)then
            write(*,'(/1x,''calculate transformed data running rbar'')')
            call runr(x,idate,maxn,nc,rxm(1,1,2),ncnt,mxy,mxs)
ccc            if(ics.gt.0)then
              fil2(ll+1:ll+10)='_trn_rbar '
              open(iu14,file=fil2,status='unknown')
              close(iu14,status='delete')
              open(iu14,file=fil2,status='unknown')
              write(iu14,'(''year'',a,''corrs'',a,''rbar'',a,''sdev'',
     *          a,''serr'',a,''eps '',a,''cores'')')tab,tab,tab,tab,
     *          tab,tab
              do i=1,ncnt
                write(iu14,'(f7.0,a,f7.0,4(a,f8.4),a,f7.2)')rxm(i,1,2),
     *            tab,rxm(i,2,2),tab,rxm(i,3,2),tab,rxm(i,4,2),tab,
     *            rxm(i,5,2),tab,rxm(i,6,2),tab,rxm(i,7,2)
              enddo
              close(iu14)
ccc            endif
          else
            write(iu11,'(/14x,''no running rbar segments calculated: total chronology''/
     *        15x,''length less then 2x the running window width: '',i4)')nsg
            write(*,'(/1x,''no running rbar segments calculated: total chronology''/
     *        2x,''length less then 2x the running window width: '',i4)')nsg
          endif
        endif
      endif
c
c *** calculate mean raw ring-width chronology
c
      if(krb1.ne.0)then
        q='n '
        do j=1,3
          call blank(itrdb(j))
          itrdb(j)=jtrdb(j)
        enddo
        write(iu11,'(/t2,''|======================== raw data '',
     *    ''chronology statistics ======================|'')')	                                   
        call robsum(ns,y(1,2),y(1,3),y(1,4),wrk1,wrk2,wrk3,wrk4,
     *    wrk5,gmn,rbr,'n',bierr,shl,shh)
        do i=1,maxn
          y(i,1)=ns(i)
          crn(i)=y(i,4)
        enddo
        if(krb3.eq.1)then
c
c *** save raw chronology with bootstrap 95% confidence limits
c
          iskp=0
          nozed=0
          do i=1,maxn
            if(shl(i).eq.0)then
              iskp=iskp+1
            else
              goto 35
            endif
          enddo
   35     maxskp=maxn-iskp
          ifmskp=ifmny+iskp
          do i=1,maxn
            ii=maxn-i+1
            if(shl(ii).eq.0)then
              maxskp=maxskp-1
            else
              goto 39
            endif
          enddo
   39     do i=1,maxn
            wrk2(i)=0.0
            wrk3(i)=0.0
          enddo
   36     call spline(maxn,crn,wrk1,p,krb4)
          call spline(maxskp,shl(iskp+1),wrk2(iskp+1),p,krb4)
          call spline(maxskp,shh(iskp+1),wrk3(iskp+1),p,krb4)
          do i=1,maxn
            if(shl(i).eq.0)then
              shl(i)=crn(i)
              shh(i)=crn(i)
              wrk2(i)=wrk1(i)
              wrk3(i)=wrk1(i)
            endif
            ns(i)=ifix(y(i,1))
          enddo
c
          if(krb2.gt.0)then
            call crnplt1(crn(iskp+1),shl(iskp+1),shh(iskp+1),wrk1(iskp+1),
     *        wrk2(iskp+1),wrk3(iskp+1),ns(iskp+1),maxskp,ifmskp,1,fil1,
     *        ' raw ring width bootstrap',' splined raw bootstrap',
     *        'years','measurements (y)','years','measurements (z)',9,pixels,jrd,mxy,eq,jdt)
   37       ans=' '     
            write(*,'(/1x,''change the spline? y/<n>'',t45,''==> '',$)')
            read(*,'(a)')ans
            if(ans.eq.' ')ans='n'
            if((ans.ne.'y'.and.ans.ne.'Y').and.(ans.ne.'n'.and.ans.ne.'N'))goto 37
            if(ans.eq.'y'.or.ans.eq.'Y')then
   38         write(*,'(1x,''enter the new spline smoothing in years'',t45,''==> '',$)')
              read(*,*,err=38)krb4
              if(krb4.lt.5)then
                write(*,'(/1x,''--> spline cutoff must be .ge. 5 years''/)')
                goto 38
              endif
              jems(12,4)=krb4
              goto 36
            endif
          endif
c
          fil2(ll+1:ll+10)='_raw_95%cl'
          call blank(line1)
          line1(1:60)='  year    nc     raw    2.5%   97.5%     spl    2.5%   97.5%'
          write(line1(37:41),'(i5)')krb4
          open(iu14,file=fil2,status='unknown')
          close(iu14,status='delete')
          open(iu14,file=fil2,status='unknown')
          write(iu14,'(a60)')line1
          do i=1,maxn
            write(iu14,'(2i6,6f8.3)')i+ifmny-1,ifix(y(i,1)),crn(i),shl(i),shh(i),
     *        wrk1(i),wrk2(i),wrk3(i)
          enddo
          close(iu14)
        endif
c
        if(ird.eq.1.or.ird.eq.3)then
          if(itn1.eq.0)then
            call crnplt3('tree ring measurements with mean',
     *        'years','measurements (y)',1)
          else
            call crnplt3('transformed measurements with mean',
     *        'years','measurements (y)',2)
          endif
        endif
        id(1:6)=fil2(1:6)
        if(tit(1:6).eq.'      ')then
          call blank(tit)
          tit(1:ll)=fil1(1:ll)
c          tit(ll+1:ll+34)=' -- no data title -- '
        endif
        if(itrdb(1)(1:6).eq.'      ')then
          itrdb(1)(1:80)=tit(1:80)
          itrdb(1)(59:80)='1st itrdb line missing'
        endif
        if(itrdb(2)(1:6).eq.'      ')then
          itrdb(2)(1:58)=itrdb(1)(1:58)
          itrdb(2)(59:80)='2nd itrdb line missing'
        endif
        if(itrdb(3)(1:6).eq.'      ')then
          itrdb(3)(1:58)=itrdb(1)(1:58)
          itrdb(3)(59:80)='3rd itrdb line missing'
        endif
        tit(78:85)=' raw crn'
        if(qq.ne.'cr')then
          do j=1,3
            itrdb(j)(81:85)='  raw'
            write(iu13,'(a)')itrdb(j)
            write(iu17,'(a)')itrdb(j)
            write(iu30,'(a)')itrdb(j)
            write(iu35,'(a)')itrdb(j)
          enddo
        endif
        if(itn1.eq.0)then
          tag='raw'
        elseif(itn1.gt.0)then
          tag='trn'
        endif
        call trrw(id,ifmny,maxn,y(1,4),ns,ifl,iu13,0,qq,tit1,
     *  		tag,mxy,itrdb)
        call trrw(id,ifmny,maxn,y(1,4),ns,ifl,iu30,0,qq,tit1,
     *  		tag,mxy,itrdb)
        tag='err'
        call trrw(id,ifmny,maxn,bierr,ns,ifl,iu17,0,qq,tit1,
     *  		tag,mxy,itrdb)
        call trrw(id,ifmny,maxn,bierr,ns,ifl,iu35,0,qq,tit1,
     *  		tag,mxy,itrdb)
      endif
c
c *** optionally detrend and index the data
c
      ndd=0
      if(idt.ne.0)then
        write(iu11,'(/t2,''|================== detrended data '',
     *    ''curve fits and statistics ==================|'')')
        if(idt.eq.-2)then
          do j=1,3
            call blank(itrdb(j))
            itrdb(j)=jtrdb(j)
          enddo
          call rcs(y,f,ns,stats,wrk1,wrk2,wrk3,wrk4,wrk5,gmn,
     *      nshft,tit,bierr,shl,shh)
          do i=1,maxn
            ns(i)=y(i,1)
          enddo
          if(ics.gt.0)then
            fil2(ll+1:ll+10)='_rcs_ind2 '
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            tit(73:85)='             '
            if(ics.le.3)then
              do j=1,3
                if(ndd.eq.1)jtrdb(j)(81:85)=' rcs'
                write(iu14,'(a)')jtrdb(j)
              enddo
            endif
            call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'ind')
            close(iu14)
          endif
        else
          ndd=1
   50     if(ndd.eq.1)then
            idtt=idt
            write(iu11,'(/t2,''|------------------------ results '',
     *        ''of first detrending -------------------------|'')')
          elseif(ndd.eq.2)then
            idtt=id2
            write(iu11,'(/t2,''|------------------------ results '',
     *        ''of second detrending ------------------------|'')')
          endif
          do j=1,3
            call blank(itrdb(j))
            itrdb(j)=jtrdb(j)
          enddo
          call detrend(f,wrk1,wrk2,wrk3,wrk4,eq,nss,stats)
          if(idtt.eq.-1)then
            ifmny=ifmny+1
            idate(nc+1,1)=ifmny
            maxn=maxn-1
            do i=1,maxn
              y(i,4)=y(i+1,4)
            enddo
          endif
          if((ird.eq.1.or.ird.eq.3).and.krb1.eq.0)then
            crn(1)=-9.99
            call crnplt3('tree ring indices','years','indices (y)',3)
          endif
c
c *** save single-series tree-ring indices
c
          if(ics.gt.0)then
            if(ndd.eq.1)fil2(ll+1:ll+10)='_ind1     '
            if(ndd.eq.2)fil2(ll+1:ll+10)='_ind2     '
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            tit(73:85)='             '
            if(ics.le.3)then
              do j=1,3
                if(ndd.eq.1)jtrdb(j)(80:85)=' ind1'
                if(ndd.eq.2)jtrdb(j)(80:85)=' ind2'
                write(iu14,'(a)')jtrdb(j)
              enddo
            endif
            call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'ind')
            close(iu14)
          endif
          ndd=ndd+1
          if(ndd.eq.2.and.id2.ne.0)goto 50
        endif
c
c *** detrended data rbar stuff
c
        if(nc.gt.1)then
          call rbar(x,idate,ident,nc,mxy,mxs,iu11,rbr)
          if(ifc.ne.0.and.ilc.ne.0)then
            cpm1=cpm
            call stc(ident,idate,nc,cpm1,mxs)
            ntest=1.00*(ilc-ifc+1)
            do j=1,nc
              ify=idate(j,1)
              ily=idate(j,2)
              n=min0(ilc,ily)-max0(ifc,ify)+1
              if(n.lt.ntest)idate(j,10)=0
            enddo
            write(iu11,'(/t2,''|==================== detrended data '',
     *        ''common period analyses ===================|'')')
            itp=3
            call comper(x,corr,a,b,c,wrk1,idate,ident,id1,nc,mxy,mxs,stats,rbc,rbs,eps,itp)
          endif
          if(nsg.gt.0.and.maxn.gt.nsg*2)then
            write(*,
     *        '(/1x,''calculate standard chronology running rbar'')')
            call runr(x,idate,maxn,nc,rxm(1,1,3),ncnt,mxy,mxs)
ccc            if(ics.gt.0)then
              fil2(ll+1:ll+10)='_ind_rbar '
              open(iu14,file=fil2,status='unknown')
              close(iu14,status='delete')
              open(iu14,file=fil2,status='unknown')
              write(iu14,'(''year'',a,''corrs'',a,''rbar'',a,''sdev'',
     *          a,''serr'',a,''eps '',a,''cores'')')tab,tab,tab,tab,
     *          tab,tab
              do i=1,ncnt
                write(iu14,'(f7.0,a,f7.0,4(a,f8.4),a,f7.2)')rxm(i,1,3),
     *            tab,rxm(i,2,3),tab,rxm(i,3,3),tab,rxm(i,4,3),tab,
     *            rxm(i,5,3),tab,rxm(i,6,3),tab,rxm(i,7,3)
              enddo
              close(iu14)
ccc            endif
          else
            write(iu11,'(/14x,''no running rbar segments calculated: total chronology''/
     *        15x,''length less then 2x the running window width: '',i4)')nsg
            write(*,'(/1x,''no running rbar segments calculated: total chronology''/
     *        2x,''length less then 2x the running window width: '',i4)')nsg
          endif
        endif
c
c *** calculate robust mean standard chronology
c
        if(krb1.ne.0)then
          q='s '
          do j=1,3
            call blank(itrdb(j))
            itrdb(j)=jtrdb(j)
          enddo
          write(iu11,'(/t2,''|======================== standard '',
     *      ''chronology statistics ======================|'')')	                                   
          call robsum(ns,y(1,2),y(1,3),y(1,5),wrk1,wrk2,wrk3,wrk4,
     *      wrk5,gmn,rbr,'s',bierr,shl,shh)
          do i=1,maxn
            y(i,1)=ns(i)
            if(ns(i).eq.0)then
              y(i,5)=1.0
            endif
            crn(i)=y(i,5)
          enddo
          if(itn1.eq.4)then
            call symmetry(y(1,5),wrk1,wrk2,wrk3,wrk4,maxn,ns)
            call moment1(y(1,5),ns,maxn,ave2,adev2,sdev2,var2,skew2,
     *        curt2,sens2,ac2)
            write(iu11,'(/t2,''|-------------------- final adjusted '',
     *        ''chronology statistics --------------------|'')')
            write(iu11,'(/t3,
     *        ''first    last    total    mean    stdrd    skew    '',
     *        ''kurtosis    mean    serial''/t4,
     *        ''year    year    years   index     dev     coeff     '',
     *        ''coeff     sens     corr'')')
            if(maxn.lt.1000)then
              write(iu11,'(i7,i8,i8,1x,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *          ifmny,ilmxy,maxn,ave2,sdev2,skew2,curt2,sens2,ac2
            else
              write(iu11,'(i7,i8,i9,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *          ifmny,ilmxy,maxn,ave2,sdev2,skew2,curt2,sens2,ac2
            endif
          endif
          if(krb3.eq.1)then
c
c *** save standard chronology with bootstrap 95% confidence limits
c
            do i=1,maxn
              wrk2(i)=0.0
              wrk3(i)=0.0
            enddo
            call spline(maxn,crn,wrk1,p,krb4)
            call spline(maxskp,shl(iskp+1),wrk2(iskp+1),p,krb4)
            call spline(maxskp,shh(iskp+1),wrk3(iskp+1),p,krb4)
            do i=1,maxn
              if(shl(i).eq.0)then
                shl(i)=crn(i)
                shh(i)=crn(i)
                wrk2(i)=wrk1(i)
                wrk3(i)=wrk1(i)
              endif
            enddo
c
            if(krb2.gt.0)then
              call crnplt1(crn(iskp+1),shl(iskp+1),shh(iskp+1),wrk1(iskp+1),
     *          wrk2(iskp+1),wrk3(iskp+1),ns(iskp+1),maxskp,ifmskp,2,fil1,
     *          ' std ring width bootstrap',' splined std bootstrap',
     *          'years','indices (y)','years','indices (z)',9,pixels,jrd,mxy,eq,jdt)
            endif
c
            fil2(ll+1:ll+10)='_std_95%cl'
            line1(1:60)='  year    nc     std    2.5%   97.5%     spl    2.5%   97.5%'
            write(line1(37:41),'(i5)')krb4
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            write(iu14,'(a60)')line1
            do i=1,maxn
              write(iu14,'(2i6,6f8.3)')i+ifmny-1,ifix(y(i,1)),crn(i),shl(i),shh(i),
     *          wrk1(i),wrk2(i),wrk3(i)
            enddo
            close(iu14)
          endif
c
          if(ird.eq.1.or.ird.eq.3)then
            call crnplt3('tree ring indices with mean','years','indices (y)',2)
          endif
          if(isb.eq.0)then
            tit(78:85)=' std crn'
          else
            tit(73:85)=' stab std crn'
          endif
          if(qq.ne.'cr')then
            do j=1,3
              itrdb(j)(81:85)='  std'
              write(iu13,'(a)')itrdb(j)
              write(iu17,'(a)')itrdb(j)
              write(iu31,'(a)')itrdb(j)
              write(iu36,'(a)')itrdb(j)
            enddo
          endif
          tag='std'
          call trrw(id,ifmny,maxn,y(1,5),ns,ifl,iu13,0,qq,tit1,
     *	    	tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,y(1,5),ns,ifl,iu31,0,qq,tit1,
     *    		tag,mxy,itrdb)
          tag='err'
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu17,0,qq,tit1,
     *  		  tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu36,0,qq,tit1,
     *  		  tag,mxy,itrdb)
        endif
      endif
c
c *** calculate pooled autoregression and do jacknife if cvp = 'y'
c
      if(jrb1.gt.0)then
        write(iu11,'(/t2,''|======================= pooled '',
     *    ''autoregression analysis =======================|'')')
        do j=1,nc
          mask(j)=1
        enddo                                  
        cvp='n'
        call pool(x,nc,maxn,ipr,phi,rsq,mxy,mxs,idate,mask,vif)
        if(ipr.eq.0)rsq=0.0
        do j=1,nc
          n=idate(j,2)-idate(j,1)+1
          ist=idate(j,1)-idate(nc+1,1)+1
c         call albino(x(ist,j),wrk1,n,ipr,phi)
        enddo
        if(cvp.eq.'y'.or.cvp.eq.'Y')then
          iopt1=ipr
          do j=1,nc
            mask(j)=0
            call pool(x,nc,maxn,ipr,phi,rsq,mxy,mxs,idate,mask,vif)
            write(*,'(1x,2i3,f7.3,10f7.3)')j,ipr,rsq,
     *        (phi(k),k=1,ipr)
            mask(j)=1
          enddo
          iopt1=0
          do j=1,nc
            mask(j)=1
          enddo
          npsp=100
          do i=1,maxn,10
            j=i+npsp-1
            if(j.le.maxn)then
              call pool(x(i,1),nc,npsp,ipr,phi,rsq,mxy,mxs,idate,
     *          mask,vif)
              write(*,'(1x,2i6,i3,f7.3,10f7.3)')i,j,ipr,rsq,
     *          (phi(k),k=1,ipr)
            endif
          enddo 
          pause
        endif
c
c *** calculate individual series autoregressions
c
        iopt2=ips
        write(iu11,'(/t2,''|================== individual '',
     *    ''series autoregression analyses =================|'')')	                                   
        call armod(y,wrk1,wrk2,wrk3,wrk4,wrk5,wrk6,cof,ipr,stats)
c
c *** save individual residuals if ics > 0
c
        if(ics.gt.0)then
          fil2(ll+1:ll+10)='_res      '
          open(iu14,file=fil2,status='unknown')
          close(iu14,status='delete')
          open(iu14,file=fil2,status='unknown')
          tit(73:85)='             '
          if(ics.le.3)then
            do j=1,3
              jtrdb(j)(81:85)='  res'
              write(iu14,'(a)')jtrdb(j)
            enddo
          endif
          call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'res')
          close(iu14)
        endif
c
c *** plot out residual spaghetti
c
        if((ird.eq.1.or.ird.eq.3).and.krb1.eq.0)then
          crn(1)=-9.99
          call crnplt3('tree ring residuals','years','indices (y)',4)
        endif
c
c *** calculate all possible residuals rbar and (optionally) running rbar
c
        if(nc.gt.1)then
          call rbar(x,idate,ident,nc,mxy,mxs,iu11,rbr)
          if(ifc.ne.0.and.ilc.ne.0)then
            write(iu11,'(/t2,''|=================== prewhitened data '',
     *        ''common period analyses ==================|'')')
            itp=4
            call comper(x,corr,a,b,c,wrk1,idate,ident,id1,nc,mxy,mxs,stats,rbc,rbs,eps,itp)
          endif
          if(nsg.gt.0.and.maxn.gt.nsg*2)then
            write(*,'(/1x,''calculate residual chronology running '',
     *        ''rbar'')')
            call runr(x,idate,maxn,nc,rxm(1,1,4),ncnt,mxy,mxs)
ccc            if(ics.gt.0)then
              fil2(ll+1:ll+10)='_res_rbar '
              open(iu14,file=fil2,status='unknown')
              close(iu14,status='delete')
              open(iu14,file=fil2,status='unknown')
              write(iu14,'(''year'',a,''corrs'',a,''rbar'',a,''sdev'',
     *          a,''serr'',a,''eps '',a,''cores'')')tab,tab,tab,tab,
     *          tab,tab
              do i=1,ncnt
                write(iu14,'(f7.0,a,f7.0,4(a,f8.4),a,f7.2)')rxm(i,1,4),
     *            tab,rxm(i,2,4),tab,rxm(i,3,4),tab,rxm(i,4,4),tab,
     *            rxm(i,5,4),tab,rxm(i,6,4),tab,rxm(i,7,4)
              enddo
              close(iu14)
ccc            endif
          else
            write(iu11,'(/14x,''no running rbar segments calculated: total chronology''/
     *        15x,''length less then 2x the running window width: '',i4)')nsg
            write(*,'(/1x,''no running rbar segments calculated: total chronology''/
     *        2x,''length less then 2x the running window width: '',i4)')nsg
          endif
        endif
c
c *** calculate robust mean white noise chronology and rewhiten
c
        if(krb1.ne.0)then
          q='r '
          do j=1,3
            call blank(itrdb(j))
            itrdb(j)=jtrdb(j)
          enddo
          write(iu11,'(/t2,''|======================== residual '',
     *      ''chronology statistics ======================|'')')	                                   
          call robsum(ns,y(1,2),y(1,3),y(1,6),wrk1,wrk2,wrk3,wrk4,
     *      wrk5,gmn,rbr,'r',bierr,shl,shh)
          do i=1,maxn
            if(ns(i).eq.0)then
              y(i,6)=1.0
            endif
            crn(i)=y(i,6)
          enddo
          if(itn1.eq.4)then
            call symmetry(y(1,6),wrk1,wrk2,wrk3,wrk4,maxn,ns)
            call moment1(y(1,6),ns,maxn,ave2,adev2,sdev2,var2,skew2,
     *        curt2,sens2,ac2)
            write(iu11,'(/t2,''|-------------------- final adjusted '',
     *        ''chronology statistics --------------------|'')')
            write(iu11,'(/t3,
     *        ''first    last    total    mean    stdrd    skew    '',
     *        ''kurtosis    mean    serial''/t4,
     *        ''year    year    years   index     dev     coeff     '',
     *        ''coeff     sens     corr'')')
            if(maxn.lt.2000)then
              write(iu11,'(i7,i8,i8,1x,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *          ifmny,ilmxy,maxn,ave2,sdev2,skew2,curt2,sens2,ac2
            else
              write(iu11,'(i7,i8,i9,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *          ifmny,ilmxy,maxn,ave2,sdev2,skew2,curt2,sens2,ac2
            endif
          endif
          if(krb3.eq.1)then
c
c *** save residual chronology with bootstrap 95% confidence limits
c
            do i=1,maxn
              wrk2(i)=0.0
              wrk3(i)=0.0
            enddo
            call spline(maxn,crn,wrk1,p,krb4)
            call spline(maxskp,shl(iskp+1),wrk2(iskp+1),p,krb4)
            call spline(maxskp,shh(iskp+1),wrk3(iskp+1),p,krb4)
            do i=1,maxn
              if(shl(i).eq.0)then
                shl(i)=crn(i)
                shh(i)=crn(i)
                wrk2(i)=wrk1(i)
                wrk3(i)=wrk1(i)
              endif
            enddo
c
            if(krb2.gt.0)then
              call crnplt1(crn(iskp+1),shl(iskp+1),shh(iskp+1),wrk1(iskp+1),
     *          wrk2(iskp+1),wrk3(iskp+1),ns(iskp+1),maxskp,ifmskp,2,fil1,
     *          ' res ring width bootstrap',' splined res bootstrap',
     *          'years','indices (y)','years','indices (z)',9,pixels,jrd,mxy,eq,jdt)
            endif
c
            fil2(ll+1:ll+10)='_res_95%cl'
            line1(1:60)='  year    nc     res    2.5%   97.5%     spl    2.5%   97.5%'
            write(line1(37:41),'(i5)')krb4
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            write(iu14,'(a60)')line1
            do i=1,maxn
              write(iu14,'(2i6,6f8.3)')i+ifmny-1,ifix(y(i,1)),crn(i),shl(i),shh(i),
     *          wrk1(i),wrk2(i),wrk3(i)
c              if(i.le.iskp)then
c                shl(i)=0.0
c                shh(i)=0.0
c              endif
c              if(i.gt.(maxskp+iskp))then
c                shl(i)=0.0
c                shh(i)=0.0
c              endif
            enddo
            close(iu14)
          endif
c
          call memcof1(y(1,6),ns,maxn,ipr+1,ip,pm,wrk4,1,wrk1,wrk2,wrk5)
          if(ip.gt.0)then
            call albino1(y(1,6),ns,wrk1,maxn,ip,wrk4,mxy)
            do i=1,maxn
              if(ns(i).eq.0)then
                y(i,6)=1.0
              endif
              crn(i)=y(i,6)
            enddo
            if(ird.eq.1.or.ird.eq.3)then
              call crnplt3('tree ring residuals with mean','years',
     *          'indices (y)',4)
            endif
            call moment1(y(1,6),ns,maxn,ave2,adev2,sdev2,var2,skew2,
     *        curt2,sens2,ac2)
            call acf1(y(1,6),ns,maxn,10,acr,pac,seac)
            write(iu11,'(/t2,''|---------- rewhitened chronology '',
     *        ''auto and partial autocorrelations -----------|'')')
            write(iu11,'(/t2,''lag'',t16,''t-1    t-2    t-3    '',
     *        ''t-4    t-5    t-6    t-7    t-8    t-9   t-10'')')
            write(iu11,'(t2,''acf'',t12,10f7.3)')(acr(j),j=1,10)
            write(iu11,'(t2,''pacf'',t12,10f7.3)')(pac(j),j=1,10)
            write(iu11,'(t2,''95% c.l.'',t12,10f7.3)')
     *        (seac(j),j=1,10)
            call memcof1(y(1,6),ns,maxn,ipr+1,ip,pm,wrk4,1,wrk1,
     *        wrk2,wrk5)
            write(iu11,'(/t2,''|----------------- rewhitened '',
     *        ''chronology autoregressive model -----------------|'')')
            write(iu11,'(/t2,''ord    rsq    t-1    t-2    t-3    '',
     *        ''t-4    t-5    t-6    t-7    t-8    t-9   t-10'')')
            write(iu11,'(t2,i2,1x,11f7.3)')ip,pm,(wrk4(j),j=1,ip)
          endif
          if(isb.eq.0)then
            tit(78:85)=' res crn'
          else
            tit(73:85)=' stab res crn'
          endif
          if(qq.ne.'cr')then
            do j=1,3
              itrdb(j)(81:85)='  res'
              write(iu13,'(a)')itrdb(j)
              write(iu17,'(a)')itrdb(j)
              write(iu32,'(a)')itrdb(j)
              write(iu37,'(a)')itrdb(j)
            enddo
          endif
          tag='res'
          call trrw(id,ifmny,maxn,y(1,6),ns,ifl,iu13,0,qq,tit1,
     *      tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,y(1,6),ns,ifl,iu32,0,qq,tit1,
     *      tag,mxy,itrdb)
          tag='err'
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu17,0,qq,tit1,
     *    		tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu37,0,qq,tit1,
     *    		tag,mxy,itrdb)
c
c *** do endogenous disturbance stuff
c
          if(isd1.gt.0)then
            iplt=isd2
            do j=1,nc
              ify=idate(j,1)
              ily=idate(j,2)
              nyr=ily-ify+1
              ist=ify-ifmny+1
              call blank(id)
              id=ident(j)
              do i=1,nyr
                wrk1(i)=x(i+ist-1,j)
                wrk2(i)=1.0
                x(i+ist-1,j)=(x(i+ist-1,j)-crn(i+ist-1))+1.0
                wrk3(i)=x(i+ist-1,j)
              enddo
              call biwgt(wrk3,wrk4,7.5,nyr,bimn,bisg,bise,eff,iter,wrk5)
              do i=1,nyr
                dep=(x(i+ist-1,j)-bimn)/bisg
                if(abs(dep).le.3.5)x(i+ist-1,j)=1.0
                wrk2(i)=x(i+ist-1,j)
              enddo
              if(iplt.gt.0)then
                call commie2(wrk2,wrk3,nyr,phi,ipr,mxy)
ccc                do i=1,nyr
ccc                  write(*,'(i5,2f8.4)')ify+i-1,wrk2(i),wrk3(i)
ccc                enddo
ccc                pause
                call crnplt1(wrk1,crn(ist),wrk4,wrk2,wrk3,wrk4,ns,
ccc                call crnplt1(wrk1,crn(ist),wrk3,x(ist,j),wrk2,wrk4,ns,
     *            nyr,ify,2,id,' residuals with mean',
     *            ' endogenous outliers (>3.5 sd) with impulse response','years',
     *            'measurements (y)','years','indices (z)',8,pixels,iplt,mxy,eq,jdt)
              endif
            enddo
            if(isd2.gt.0)then
              do i=1,maxn
                wrk1(i)=0.0
                wrk2(i)=0.0
                wrk3(i)=0.0
                wrk4(i)=0.0
                do j=1,nc
                  if(x(i,j).lt.1.0.and.x(i,j).ne.-9.99)then
                    wrk1(i)=wrk1(i)-1
                  elseif(x(i,j).gt.1.0)then
                    wrk2(i)=wrk2(i)+1
                  endif
                enddo
                wrk3(i)=wrk1(i)/y(i,1)
                wrk4(i)=wrk2(i)/y(i,1)
              enddo
              crn(1)=-9.99
              call crnplt3('endogenous outliers (>3.5 sd)','years','index units (y)',13)
              call crnplt1(wrk1,wrk2,wrk5,wrk3,wrk4,wrk6,ns,maxn,ifmny,2,fil1,
     *          ' number of endogenous outliers (>3.5 sd)',
     *          ' fraction of endogenous outliers (>3.5 sd)',
     *          'years','number (y)','years','fraction (z)',7,pixels,jrd,mxy,eq,jdt)
            endif
            if(ics.gt.0)then
              ll=len(fil1)
              jj=0
              do j=1,ll
                jj=ll-j+1
                if(fil1(jj:jj).ne.' ')goto 77
              enddo
   77         ll=jj
              call blank(fil)
              fil=fil1
              fil(ll+1:ll+11)='_endo_outs '
              tag='out'
              open(iu14,file=fil,status='unknown')
              close(iu14,status='delete')
              open(iu14,file=fil,status='unknown')
              tit(73:85)='             '
              if(ics.le.3)then
                do j=1,3
                  jtrdb(j)(82:85)=' eout'
                  write(iu14,'(a)')jtrdb(j)
                enddo
              endif
              call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'out')
              close(iu14)
            endif
          endif
c
c *** add red noise back in for arstan chronology
c
          do i=1,maxn
            y(i,7)=y(i,6)
          enddo
          write(iu11,'(/t2,''|========================= arstan '',
     *      ''chronology statistics =======================|'')')	                                   
          call commie1(y(1,7),ns,wrk1,maxn,phi,ipr,mxy)
          do i=1,maxn
            if(ns(i).eq.0)then
              y(i,7)=1.0
            endif
            crn(i)=y(i,7)
          enddo
          if(itn1.eq.4)then
            call symmetry(y(1,7),wrk1,wrk2,wrk3,wrk4,maxn,ns)
          endif
          vif1=1.0+sqrt(vif-1.0)
ccc          write(*,'(2f8.4)')vif,vif1
ccc          pause
          if(krb3.eq.1)then
c
c *** save arstan chronology with bootstrap 95% confidence limits
c
ccc            call commie3(shl,ns,wrk1,maxn,phi,ipr,mxy)
ccc            call commie3(shh,ns,wrk1,maxn,phi,ipr,mxy)
            do i=iskp+1,maxn
              shl(i)=crn(i)-((y(i,6)-shl(i))*vif1)
              shh(i)=crn(i)+((shh(i)-y(i,6))*vif1)
            enddo
            do i=1,maxn
              wrk2(i)=0.0
              wrk3(i)=0.0
            enddo
            call spline(maxn,crn,wrk1,p,krb4)
            call spline(maxskp,shl(iskp+1),wrk2(iskp+1),p,krb4)
            call spline(maxskp,shh(iskp+1),wrk3(iskp+1),p,krb4)
            do i=1,maxn
              if(wrk2(i).eq.0)then
                shl(i)=crn(i)
                shh(i)=crn(i)
                wrk2(i)=wrk1(i)
                wrk3(i)=wrk1(i)
              endif
            enddo
c
            if(krb2.gt.0)then
              call crnplt1(crn(iskp+1),shl(iskp+1),shh(iskp+1),wrk1(iskp+1),
     *          wrk2(iskp+1),wrk3(iskp+1),ns(iskp+1),maxskp,ifmskp,2,fil1,
     *          ' ars ring width bootstrap',' splined ars bootstrap',
     *          'years','indices (y)','years','indices (z)',9,pixels,jrd,mxy,eq,jdt)
            endif
c
            fil2(ll+1:ll+10)='_ars_95%cl'
            line1(1:60)='  year    nc     ars    2.5%   97.5%     spl    2.5%   97.5%'
            write(line1(37:41),'(i5)')krb4
            open(iu14,file=fil2,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil2,status='unknown')
            write(iu14,'(a60)')line1
            do i=1,maxn
              write(iu14,'(2i6,6f8.3)')i+ifmny-1,ifix(y(i,1)),crn(i),shl(i),shh(i),
     *          wrk1(i),wrk2(i),wrk3(i)
            enddo
            close(iu14)
          endif
c
          call moment1(y(1,7),ns,maxn,ave,adev,sdev,var,skew,curt,
     *      sens,ac)
          if(krb1.eq.1)then
            write(iu11,'(/t2,''|---------------- gaussian mean arstan chronology '',
     *        ''statistics ------------------|'')')
          else
            write(iu11,'(/t2,''|----------------- robust mean arstan chronology '',
     *        ''statistics -------------------|'')')
          endif
          write(iu11,'(//t3,
     *      ''first    last    total    mean    stdrd    skew    '',
     *      ''kurtosis    mean    serial''/t4,
     *      ''year    year    years   index     dev     coeff     '',
     *      ''coeff     sens     corr'')')
          write(iu11,'(i7,i8,i9,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *      ifmny,ilmxy,maxn,ave,sdev,skew,curt,sens,ac
          call acf1(y(1,7),ns,maxn,10,acr,pac,seac)
          write(iu11,'(/t2,''|------------ arstan chronology '',
     *      ''auto and partial autocorrelations -------------|'')')
          write(iu11,'(/t2,''lag'',t16,''t-1    t-2    t-3    t-4    '',
     *      ''t-5    t-6    t-7    t-8    t-9   t-10'')')
          write(iu11,'(t2,''acf'',t12,10f7.3)')(acr(j),j=1,10)
          write(iu11,'(t2,''pacf'',t12,10f7.3)')(pac(j),j=1,10)
          write(iu11,'(t2,''95% c.l.'',t12,10f7.3)')(seac(j),j=1,10)
          call memcof1(y(1,7),ns,maxn,11,ip,pm,wrk4,0,wrk1,wrk2,wrk5)
          write(iu11,'(/t2,''|------------------- arstan chronology '',
     *      ''autoregressive model -------------------|'')')
          write(iu11,'(/t2,''ord    rsq    t-1    t-2    t-3    '',
     *      ''t-4    t-5    t-6    t-7    t-8    t-9   t-10'')')
          write(iu11,'(t2,i2,1x,11f7.3)')ip,pm,(wrk4(j),j=1,ip)
          if(isb.eq.0)then
            tit(78:85)=' ars crn'
          else
            tit(73:85)=' stab ars crn'
          endif
          if(qq.ne.'cr')then
            do j=1,3
              itrdb(j)(81:85)='  ars'
              write(iu13,'(a)')itrdb(j)
              write(iu17,'(a)')itrdb(j)
              write(iu33,'(a)')itrdb(j)
              write(iu38,'(a)')itrdb(j)
            enddo
          endif
          tag='ars'
          do i=1,maxn
            ns(i)=y(i,1)
          enddo
          call trrw(id,ifmny,maxn,y(1,7),ns,ifl,iu13,0,qq,tit1,
     *    		tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,y(1,7),ns,ifl,iu33,0,qq,tit1,
     *     	tag,mxy,itrdb)
          tag='err'
          do i=1,maxn
            serr=bierr(i)
            bierr(i)=serr/sqrt(vif)
          enddo
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu17,0,qq,tit1,
     *    		tag,mxy,itrdb)
          call trrw(id,ifmny,maxn,bierr,ns,ifl,iu38,0,qq,tit1,
     *    		tag,mxy,itrdb)
        endif
      endif
c
c *** end of data set run
c
c      duration=secnds(start)
c      write(*,'(/1x,''elapsed time: '',f9.2,''  minutes'')')
c     *  duration/60.
      write(iu11,'(/t2,''|================ as jim morrison '',
     *  ''would say, "this is the end" ================|'')')                                 
c      write(iu11,'(/t16,''elapsed time of turbo arstan run: '',f9.2,
c     *  ''  minutes'')')duration/60.
c
c *** store away the chronology data in tab-delimited column format
c
      if(krb1.ne.0)then
        if(idt.ne.-2)then
          if(jrb1.gt.1)then
            write(iu12,'(''year'',a,''num'',a,''seg'',a,''age'',a,
     *        ''raw'',a,''std'',a,''res'',a,''ars'',a,''nabs'',a,
     *        ''pabs'',a,''npct'',a,''ppct'')')tab,tab,tab,tab,tab,tab,
     *        tab,tab,tab,tab,tab
          elseif(jrb1.eq.1)then
            write(iu12,'(''year'',a,''num'',a,''seg'',a,''age'',a,
     *        ''raw'',a,''std'',a,''res'',a,''ars'')')tab,tab,tab,tab,
     *        tab,tab,tab
          endif
        else
          if(jrb1.gt.1)then
            write(iu12,'(''year'',a,''num'',a,''seg'',a,''age'',a,
     *        ''raw'',a,''std'',a,''res'',a,''ars'',a,''rcs yr'',a,
     *        ''num'',a,''rcs'',a,''sig'',a,''crv'',a,''nabs'',a,
     *        ''pabs'',a,''npct'',a,''ppct'')')tab,tab,tab,tab,tab,tab,
     *          tab,tab,tab,tab,tab,tab,tab,tab,tab,tab
          elseif(jrb1.eq.1)then
            write(iu12,'(''year'',a,''num'',a,''seg'',a,''age'',a,
     *        ''raw'',a,''std'',a,''res'',a,''ars'',a,''rcs yr'',a,
     *        ''num'',a,''rcs'',a,''sig'',a,''crv'')')tab,tab,tab,tab,
     *          tab,tab,tab,tab,tab,tab,tab,tab
          endif
        endif
        do i=1,maxn
          if(idt.ne.-2)then
            if(jrb1.gt.1)then
              write(iu12,'(1x,i6,a,f5.0,10(a,f8.3))')ifmny+i-1,
     *          tab,y(i,1),tab,y(i,2),tab,y(i,3),tab,y(i,4),
     *          tab,y(i,5),tab,y(i,6),tab,y(i,7),tab,y(i,13),
     *          tab,y(i,14),tab,y(i,15),tab,y(i,16)
            elseif(jrb1.eq.1)then
              write(iu12,'(1x,i6,a,f5.0,6(a,f8.3))')ifmny+i-1,
     *          tab,y(i,1),tab,y(i,2),tab,y(i,3),tab,y(i,4),
     *          tab,y(i,5),tab,y(i,6),tab,y(i,7)
            endif
          else
            if(jrb1.gt.1)then
              write(iu12,'(1x,i6,a,f5.0,15(a,f8.3))')ifmny+i-1,
     *          tab,y(i,1),tab,y(i,2),tab,y(i,3),tab,y(i,4),
     *          tab,y(i,5),tab,y(i,6),tab,y(i,7),tab,y(i,8),
     *          tab,y(i,9),tab,y(i,10),tab,y(i,11),tab,y(i,12),
     *          tab,y(i,13),tab,y(i,14),tab,y(i,15),tab,y(i,16)
            elseif(jrb1.eq.1)then
              write(iu12,'(1x,i6,a,f5.0,11(a,f8.3))')ifmny+i-1,
     *          tab,y(i,1),tab,y(i,2),tab,y(i,3),tab,y(i,4),
     *          tab,y(i,5),tab,y(i,6),tab,y(i,7),tab,y(i,8),
     *          tab,y(i,9),tab,y(i,10),tab,y(i,11),tab,y(i,12)
            endif
          endif
        enddo
      endif
c
c *** begin tsi summary plots
c
      jrd=ird
      if((jrd.eq.2.or.jrd.eq.3).and.krb1.gt.0)then
        call spline(maxn,y(1,4),wrk1,p,maxn/10)
        call spline(maxn,y(1,5),wrk2,p,maxn/10)
c        pause 'ars before crnplt itype=3'
        call crnplt1(y(1,4),wrk1,wrk3,y(1,5),wrk2,wrk4,ns,maxn,ifmny,1,fil1,
     *    ' raw ring width chronology',' standard chronology',
     *    'years','measurements (y)','years','indices (z)',3,pixels,jrd,mxy,eq,jdt)
      endif
      if(idt.ne.0.and.krb1.ne.0)then
        if(jrb1.ne.0)then
          if(jrd.lt.ird)jrd=0
          if(jrd.eq.2.or.jrd.eq.3)then
            call spline(maxn,y(1,6),wrk1,p,maxn/10)
            call spline(maxn,y(1,7),wrk2,p,maxn/10)
c            pause 'ars before crnplt itype=3'
            call crnplt1(y(1,6),wrk1,wrk3,y(1,7),wrk2,wrk4,ns,maxn,ifmny,2,fil1,
     *        ' residual chronology',' arstan chronology',
     *        'years','indices (y)','years','indices (z)',3,pixels,jrd,mxy,eq,jdt)
        
          endif
        endif
      endif
      if(jrd.lt.ird)jrd=0
      if((jrd.eq.2.or.jrd.eq.3).and.krb1.gt.0)then
        if(nc.gt.1.and.ncnt.gt.0)then
          call spline(maxn,y(1,2),wrk1,p,maxn/3)
          call spline(maxn,y(1,3),wrk2,p,maxn/3)
c            pause 'ars before crnplt itype=4'
          call crnplt1(y(1,2),wrk1,wrk3,y(1,3),wrk2,wrk4,ns,maxn,ifmny,1,fil1,
     *      ' mean segment length',' mean tree age','years',
     *      'segment length (y)','years','tree age (z)',4,pixels,jrd,mxy,eq,jdt)
        endif
      endif
      if(jrd.lt.ird)jrd=0
ccc      if(jrb1.gt.1.and.(jrd.eq.2.or.jrd.eq.3))then
ccc        call crnplt1(y(1,13),y(1,14),y(1,15),y(1,16),ns,maxn,ifmny,1,fil1,
ccc     *    ' number of autoregressive outliers',' fraction of autoregressive outliers',
ccc     *    'years','number','years','fraction',7,pixels,jrd,mxy,eq)
ccc      endif
      if(jrd.lt.2.and.npl.gt.0)jrd=2
      if((jrd.eq.2.or.jrd.eq.3).and.(nc.eq.1.or.ncnt.lt.2))then
        write(*,'(/1x,''*** no running rbar plotted ***'')')
        if(nc.eq.1)then
          write(*,'(1x,''*** only 1 series processed ***'')')
        elseif(ncnt.lt.2)then
          write(*,'(1x,''*** number of segments is 1 ***'')')
        endif
      else
        if(jrd.lt.ird)jrd=0
        if(jrd.eq.2.or.jrd.eq.3)then
          ify=rxm(1,1,1)
          call blank(tit1)
          tit1(1:18)=' raw running rbar,'
          write(tit1(20:27),'(2i4)')nsg,nlp
c           pause 'ars before crnplt itype=5'
          call crnplt1(rxm(1,3,1),rxm(1,1,1),wrk1,rxm(1,6,1),rxm(1,5,1),wrk2,ns,
     *      ncnt,ify,3,fil1,tit1,' raw running eps','years','rbar (y)',
     *      'years','eps (z)',5,pixels,jrd,mxy,eq,jdt)
          if(itn1.gt.0)then
            call blank(tit1)
            tit1(1:24)=' transform running rbar,'
            write(tit1(26:33),'(2i4)')nsg,nlp
c            pause 'ars before crnplt itype=5'
            call crnplt1(rxm(1,3,2),rxm(1,1,2),wrk1,rxm(1,6,2),rxm(1,5,2),wrk2,ns,ncnt,
     *        ify,4,fil1,tit1,' transform running eps','years','rbar (y)',
     *        'years','eps (z)',5,pixels,jrd,mxy,eq,jdt)
          endif
          if(idt.ne.0)then
            call blank(tit1)
            tit1(1:22)=' detrend running rbar,'
            write(tit1(24:31),'(2i4)')nsg,nlp
c            pause 'ars before crnplt itype=5'
            call crnplt1(rxm(1,3,3),rxm(1,1,3),wrk1,rxm(1,6,3),rxm(1,5,3),wrk2,ns,ncnt,
     *        ify,5,fil1,tit1,' detrend running eps','years','rbar (y)',
     *        'years','eps (z)',5,pixels,jrd,mxy,eq,jdt)
            if(jrb1.ne.0)then
              call blank(tit1)
              tit1(1:23)=' residual running rbar,'
              write(tit1(25:32),'(2i4)')nsg,nlp
c            pause 'ars before crnplt itype=5'
              call crnplt1(rxm(1,3,4),rxm(1,1,4),wrk1,rxm(1,6,4),rxm(1,5,4),wrk2,ns,
     *          ncnt,ify,6,fil1,tit1,' residual series running eps',
     *          'years','rbar (y)','years','eps (z)',5,pixels,jrd,mxy,eq,jdt)
            endif
          endif
        endif
      endif
c
c *** print out batch detail file info
c
      fil2(ll+1:ll+10)='_detail   '
      open(iu15,file=fil2,status='unknown')
      close(iu15,status='delete')
      open(iu15,file=fil2,status='unknown')
      write(iu15,
     *  '(1x,''num = number of series'',
     *   t37,''ident = series identification''/
     *    1x,''ify = first year of time series'',
     *   t39,''ily = last year of time series''/
     *    1x,''yfp = years from pith for rcs'',
     *   t39,''itn = transform (>3 = power*1000)''/
     *    1x,''idt = series detrending options'',
     *   t39,''ips = series ar model order options''/
     *    1x,''isb = stabilize variance options'',
     *   t39,''icu = use (1) or do not use (0)''/
     *    1x,''ics = save (1) or do not save (0)'',
     *   t39,''cpa = common period analysis series''/
     *   19x,''-- do not delete these lines --'')')
      write(iu15,'('' num  ident      ify   ily   yfp   itn   '',
     *  ''idt   ips   isb   icu   ics   cpa'')')
      do j=1,nc
        if(idt.eq.-1)idate(j,1)=idate(j,1)-1
        write(iu15,'(i4,2x,a8,10i6)')j,ident(j),(idate(j,k),k=1,10)
      enddo
      write(*,'(/1x,''batch detail file saved: '',a)')fil2
      close(iu15)
c
      goto 10                 !implied do-loop continue
c
c *** all done, so close the files and quit
c
  100 call blank(fil)
      close(iu9)
      close(iu10)
      close(iu11)
      close(iu20)
      close(iu21)
      if(krb1.ne.0.and.ier.eq.0)then
        close(iu12)
        close(iu13)
        close(iu17)
      endif
      if(nfil.gt.1)then
        close(iu30)
        close(iu31)
        close(iu32)
        close(iu33)
        close(iu34)
        close(iu35)
        close(iu36)
        close(iu37)
        close(iu38)
        close(iu39)
      else
        close(iu30,status='delete')
        close(iu31,status='delete')
        close(iu32,status='delete')
        close(iu33,status='delete')
        close(iu34,status='delete')
        close(iu35,status='delete')
        close(iu36,status='delete')
        close(iu37,status='delete')
        close(iu38,status='delete')
        close(iu39,status='delete')
      endif
      write(*,'(/1x,''|====== as jim morrison '',
     *  ''would say, "this is the end." ======|''/)')                                 
      pause' hit return to quit'
      stop
      end
*sbr info -- general program information
*
      subroutine info(n)
      goto(1,2,3),n
    1 write(*,'(/
     *  1x,''************ welcome to turbo arstan ************''/
     *  1x,''this program requires that you create a file that''/
     *  1x,''lists the name(s) of the file(s) of tree-ring data''/
     *  1x,''that you want to process. this enables the program''/
     *  1x,''to efficiently process many data sets sequentially''/
     *  1x,''if so desired. if you have not created this file''/
     *  1x,''before hand, just hit return at the next prompt for''/
     *  1x,''the file name and the program will allow you to enter''/
     *  1x,''your data file name(s) interactively. capeche?'')')
      goto 100
    2 write(*,'(/
     *  1x,''the output files from turbo arstan are all labeled''/
     *  1x,''with prefixes that come from the data file names being''/
     *  1x,''processed by the program. this more or less guarantees''/
     *  1x,''that each series of output file names will be unique.''/
     *  1x,''so, for a data file named myfile, the standard output''/
     *  1x,''files produced by the program are:''//
     *  1x,''  myfile_out    -- the general output file''/
     *  1x,''  myfile_crns   -- chronologies in decadal format''/
     *  1x,''  myfile_tabs   -- column tab-delimited chronologies''/
     *  1x,''  myfile_log    -- log file of interactive commands''/
     *  1x,''  myfile_detail -- batch details for series''//
     *  1x,''in addition, generic files with the names crns.raw,''/
     *  1x,''crns.std, crns.res, crns.ars, and crns.rcs (only if''/
     *  1x,''regional curve standardization is done) are produced''/
     *  1x,''to save the chronologies in files sorted by kind.''/
     *  1x,''this is done for convenient use of the chronologies''/
     *  1x,''by kind, if many data sets are processed sequentially''/
     *  1x,''by the program. the myfile_tabs file also contains''/
     *  1x,''sample size, mean tree age, and mean segment length''/
     *  1x,''series. and, if done, the negative and positive auto-''/
     *  1x,''regressive outliers are also included as absolute''/
     *  1x,''numbers and relative frequencies.'')')
      pause
      write(*,'(/
     *  1x,''the following files are also created if the running''/
     *  1x,''rbar option is used and individual series are saved:''//
     *  1x,''  myfile_raw_rbar -- for raw data series''/
     *  1x,''  myfile_ind_rbar -- for standard indices''/
     *  1x,''  myfile_res_rbar -- for ar modeled residuals''//
     *  1x,''finally, if the individual series are saved, then the''/
     *  1x,''following files are created and saved:''//
     *  1x,''  myfile_raw  -- original raw series''/
     *  1x,''  myfile_trn  -- transformed series (if done)''/
     *  1x,''  myfile_ind  -- tree-ring indices''/
     *  1x,''  myfile_crv1 -- 1st growth trend values''/
     *  1x,''  myfile_crv2 -- 2nd growth trend values (if done)''/
     *  1x,''  myfile_res  -- ar modeled residuals''//
     *  1x,''of course, none of the "_res" files will be saved if''/
     *  1x,''no ar modeling is performed on the data. i hope that''/
     *  1x,''this information helps you. if not, well ...'')')
      goto 100
    3 write(*,'(/
     *  1x,''running arstan in interactive mode automatically''/
     *  1x,''produces a log file and batch detail file named''/
     *  1x,''for each data set. the log file is a list of control''/
     *  1x,''parameters that apply equally to all series in the''/
     *  1x,''given data set file. the batch detail file lists''/
     *  1x,''the control parameters applied to each series in the ''/
     *  1x,''given data set. when these files are created in the''/
     *  1x,''interactive mode run, the batch detail file parameters''/
     *  1x,''reflect exactly the commands in the log file. you''/
     *  1x,''may then run the program again in batch mode using''/
     *  1x,''these log and batch detail files, either as is or in''/
     *  1x,''edited form to alter the way that the data files are''/
     *  1x,''processed. by editing the batch detail file, it is''/
     *  1x,''possible to customize the processing of individual''/
     *  1x,''series, or even delete certain series from the''/
     *  1x,''analysis. in batch mode, the batch detail parameters''/
     *  1x,''override certain controls in the log file, like the''/
     *  1x,''data transformation option and the detrending option.''/
     *  1x,''keep this in mind when modifying either for a new''/
     *  1x,''run in batch mode. good luck, mr. phelps.'')')
      goto 100
  100 return
      end
*sbr helpm -- miscellaneous help
*
      subroutine helpm(n)
      goto(1,2,3,4,5,6,7,8),n
    1 write(*,'(/
     *  1x,''this query is for those poor souls on ms-dos''/
     *  1x,''machines who still have strict file name''/
     *  1x,''limits. if you answer "y", the output file''/
     *  1x,''names will be truncated accordingly. i am not''/
     *  1x,''a dos user (thank god!), so if i do not get''/
     *  1x,''this right, complain to megalomaniac bill''/
     *  1x,''gates, who took years to almost get it right.'')')
      goto 100
    2 write(*,'(/
     *  1x,''this may seem like a strange query. afterall,''/
     *  1x,''what is the point of putting a list of data file''/
     *  1x,''names in a file. here is the scoop. this enables''/
     *  1x,''the program to cycle back after processing the''/
     *  1x,''first data set and open up the next data set file''/
     *  1x,''automatically. so, it is possible to process as''/
     *  1x,''many data sets as desired without the operator''/
     *  1x,''having to sit there and tell the program to do''/
     *  1x,''so. if you have not created this file before hand''/
     *  1x,''just hit return at the next prompt for the file''/
     *  1x,''name and the program will allow you to enter your''/
     *  1x,''data file name(s) interactively.'')')
      goto 100
    3 write(*,'(/
     *  1x,''you can enter in a general run title here. it''/
     *  1x,''will be applied identically to all data sets.'')')
      goto 100
    4 write(*,'(/
     *  1x,''this option allows the program to be run in''/
     *  1x,''batch mode rather than interactive mode if the''/
     *  1x,''answer to this query is "y". it basically means''/
     *  1x,''running the program once in interactive mode to''/
     *  1x,''create log files of batch mode commands. these''/
     *  1x,''log files can be used to run the same data set''/
     *  1x,''over again with identical settings and can also''/
     *  1x,''be used on additional data sets. the log file''/
     *  1x,''commands can also be changed to alter the way''/
     *  1x,''the data sets are processed in later runs.'')')
      goto 100
    5 write(*,'(/
     *  1x,''the same batch commands can be used to process''/
     *  1x,''any number of data sets identically if the answer''/
     *  1x,''to this query is "y". if the answer is "n", then''/
     *  1x,''a new set of commands is read in to process each ''/
     *  1x,''data set in the file of data set names.''/)')
      goto 100
    6 write(*,'(/
     *  1x,''if you only want to create a new set of log files''/
     *  1x,''for editing or posterity, you may stop now without''/
     *  1x,''running the program further.'')')
      goto 100
    7 write(*,'(/
     *  1x,''the batch detail file is a listing of options''/
     *  1x,''for each individual core series. when the program''/
     *  1x,''is run in interactive mode, this file is created''/
     *  1x,''automatically, with a suffix of _detail for real,''/
     *  1x,''normal computers and .det for stupid dos machines.''/
     *  1x,''when the program is run in batch mode using the''/
     *  1x,''log file commands, the program automatically tries''/
     *  1x,''to open a detail file having the name of the input''/
     *  1x,''data file plus the above suffix. if it can not''/
     *  1x,''find this file, you get the above query. if you''/
     *  1x,''do not have this file, you may abort and run''/
     *  1x,''the program in interactive mode to create one. so''/
     *  1x,''why do this? well, if you run the program in batch''/
     *  1x,''mode, you can customize the detail file for any of''/
     *  1x,''the core series prior to the run to process them''/
     *  1x,''individually from the rest. you can also specify''/
     *  1x,''a subset of series to be used in the analysis and''/
     *  1x,''save that subset of series only. groovy, huh?'')')
      goto 100
    8 write(*,'(/
     *  1x,''the rcs pith offset file is an optional file for''/
     *  1x,''reading in the number of years between the pith''/
     *  1x,''and the first year of data when the regional curve''/
     *  1x,''standardization (rcs) option -2 is used to detrend''/
     *  1x,''the individual core series. this information is''/
     *  1x,''necessary to estimate rcs curve most precisely.''/
     *  1x,''if no pith offset file is opened, the program''/
     *  1x,''assumes a zero offset for all series. if this file''/
     *  1x,''of information is available, the pith offset data ''/
     *  1x,''are saved in the batch detail file for using the''/
     *  1x,''rcs option in batch mode. groovy, huh?'')')
      goto 100
  100 return
      end
*sbr mlf -- make log files for running program in batch mode
*
      subroutine mlf
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk

c
c *** internal stuff
c
      character fil2*40,fil3*40
c
c *** create log files now
c
      nfil=0
    1 call blank(fil2)
      call blank(fil3)
      read(iu9,'(a)',end=100)fil2
      if(fil2(1:10).eq.'          ')goto 100
      fil3=fil2
      nfil=nfil+1
      ll=len(fil2)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(fil2(jj:jj).ne.' ')goto 2
      enddo
    2 ll=jj
      fil2(ll+1:ll+10)='_log      '
      open(iu21,file=fil2,status='unknown')
      close(iu21,status='delete')
      open(iu21,file=fil2,status='unknown')
c
c *** do menu stuff now
c
      if(go.eq.'n'.or.go.eq.'N')then
        call menu(jems,cpm1)
      elseif((go.eq.'y'.or.go.eq.'Y').and.nfil.eq.1)then
        call menu(jems,cpm1)
      endif
c
c *** write out batch commands now
c
      if(nfil.eq.1)write(*,'('' '')')
      write(*,'(1x,''==> writing batch commands for: '',a)')
     *  fil3
      write(iu21,'(''data file #'',i3,''  --  '',a)')nfil,fil3
      call wlf(jems,cpm1,iu21)
      close(iu21)
      goto 1
  100 write(*,'(/1x,i4,''  batch command files created'')')nfil
      return
      end
*sbr menu
*
      subroutine menu(jems,cpm1)
      integer jems(30,5)
      character cpm1*8
c
c *** internal stuff
c
      character line*50,datum*8,frm*20,datum1*8,datum2*8,datum3*8
c
c *** set up defaults
c
      jems(1,1)=1           !tree-ring data type
      jems(2,1)=-9          !missing data flag
      jems(3,1)=0	        !data transformation option
      jems(3,2)=0           !plot transformed data (0=no, 1=yes)
      jems(4,1)=1           !first detrending option
      jems(4,2)=0           !smoothing parameter for median and lowess
      jems(4,3)=0           !plot data with first curve fits
      jems(5,1)=0           !second detrending option
      jems(5,2)=0           !smoothing parameter for median, lowess, friedman
      jems(5,3)=0           !plot data with 2nd curve fits
      jems(6,1)=1           !robust detrending option
      jems(7,1)=0           !interactive detrending
      jems(8,1)=1	        !index calculation option
      jems(9,1)=1           !autoregressive modeling option
      jems(9,2)=0           !plot autoregressive outliers
      jems(10,1)=0          !pooled ar order selection
      jems(10,2)=0          !pooled ar order plots
      jems(11,1)=0          !individual series ar order
      jems(12,1)=2          !mean chronology option
      jems(12,2)=0          !plot bootstrap results (0=no, 1=yes)
      jems(12,3)=0          !bootstrap the mean chronologies
      jems(12,4)=0          !splined bootstrap limits
      jems(13,1)=0          !variance stabilization option
      jems(14,1)=0          !first year of common period
      jems(14,2)=0          !last year of common period
      cpm1='SSSTTCC '       !mask for common period analysis 
      jems(16,1)=50         !running rbar segment length
      jems(16,2)=25         !running rbar segment overlap
      jems(16,3)=0          !plot running rbar and eps
      jems(17,1)=2	        !print out option
      jems(18,1)=0          !individual series save option
      jems(19,1)=0          !high resolution display
      jems(20,1)=0          !stand dynamics stuff
      jems(20,2)=0          !running mean window width
      jems(20,3)=0          !percent growth change theshold
      jems(20,4)=0          !standard error threshold
c
c *** header output
c
    1 write(*,'(/1x,''|************** arstan run time menu and '',
     *  ''current options settings **************|''/)')
      write(*,'(28x,''opt          plt'')')
      call gmh(1,jems(1,1),line)
      write(*,'(t2,'' [1] tree-ring data type'',t26,i5,t47,a)')
     *		jems(1,1),line
      call gmh(2,jems(2,2),line)
      write(*,'(t2,'' [2] missing data in gaps'',t26,i5,i13,t47,a)')
     *		jems(2,1),jems(2,2),line
      if(jems(3,2).eq.0)then
        jemsum=jems(3,1)
      else
        jemsum=-jems(3,1)
      endif
      call gmh(3,jemsum,line)
      write(*,'(t2,'' [3] data transformation'',t26,i5,i13,t47,a)')
     *		jems(3,1),jems(3,2),line
      call gmh(4,jems(4,1),line)
      line(2:5)='1st-'
      write(*,'(t2,'' [4] first detrending'',t26,i5,i7,i6,t47,a)')
     *	jems(4,1),jems(4,2),jems(4,3),line
      call gmh(5,jems(5,1),line)
      if(jems(4,1).ne.-2)then
        line(2:5)='2nd-'
        write(*,'(t2,'' [5] second detrending'',t26,i5,i7,i6,t47,a)')
     *    jems(5,1),jems(5,2),jems(5,3),line
      else
        line(2:5)='rcs-'
        write(*,'(t2,'' [5] rcs detrending'',t26,i5,i13,t47,a)')
     *		  jems(5,1),jems(5,2),line
      endif
      call gmh(6,jems(6,1),line)
      write(*,'(t2,'' [6] robust detrending'',t26,i5,t47,a)')
     *		jems(6,1),line
      call gmh(7,jems(7,1),line)
      write(*,'(t2,'' [7] interactive detrend'',t26,i5,t47,a)')
     *		jems(7,1),line
c      if(jems(3,1).eq.0)then
c        jems(8,1)=1
c      else
c        jems(8,1)=2
c      endif
      call gmh(8,jems(8,1),line)
      write(*,'(t2,'' [8] index calculation'',t26,i5,t47,a)')
     *		jems(8,1),line
      if(jems(9,2).eq.0)then
        jemsum=jems(9,1)
      else
        jemsum=-jems(9,1)
      endif
      call gmh(9,jemsum,line)
      write(*,'(t2,'' [9] ar modeling method'',t26,i5,i13,t47,a)')
     *		jems(9,1),jems(9,2),line
      if(jems(10,2).eq.0)then
        jemsum=jems(10,1)
      else
        jemsum=-jems(10,1)-1
      endif
      call gmh(10,jemsum,line)
      write(*,'(t2,''[10] pooled ar order'',t26,i5,i13,t47,a39)')
     *		jems(10,1),jems(10,2),line
      call gmh(11,jems(11,1),line)
      write(*,'(t2,''[11] series ar order'',t26,i5,t47,a)')
     *		jems(11,1),line
      if(jems(12,1).eq.0)then
        jemsum=1
      elseif(jems(12,1).eq.1)then
        if(jems(12,3).eq.0)then
          jemsum=2
        elseif(jems(12,3).eq.1)then
          jemsum=6
        endif
      elseif(jems(12,1).eq.2)then
        if(jems(12,3).eq.0)then
          jemsum=3
        elseif(jems(12,3).eq.1)then
          jemsum=7
        endif
      elseif(jems(12,1).lt.0)then
        if(jems(12,3).eq.0)then
          jemsum=5
        elseif(jems(12,3).eq.1)then
          jemsum=8
        endif
      endif
c      write(*,'(1x,''jemsum:'',i5)')jemsum
c      pause
      call gmh(12,jemsum,line)
      write(*,'(t2,''[12] mean chronology'',t27,2i4,i5,i4,t47,a)')
     *		jems(12,1),jems(12,3),jems(12,4),jems(12,2),line
      call gmh(13,jems(13,1),line)
      write(*,'(t2,''[13] stabilize variance'',t26,i5,t47,a)')
     *		jems(13,1),line
      call gmh(14,jems(14,1),line)
      write(*,'(t2,''[14] common period years'',t27,3x,2i5,t47,a)')
     *  jems(14,1),jems(14,2),line
      call gmh(15,jems(15,1),line)
      write(*,'(t2,''[15] site-tree-core mask'',t27,6x,a,t47,a)')
     *  cpm1,line
      call blank(datum1)
      call intfrm1(jems(16,1),frm)
      write(datum1,frm)jems(16,1)
      call blank(datum2)
      call intfrm1(jems(16,2),frm)
      write(datum2,frm)jems(16,2)
      call blank(datum3)
      call intfrm1(jems(16,3),frm)
      write(datum3,frm)jems(16,3)
      jemsum=jems(16,1)
      if(jems(16,3).eq.1)jemsum=-jemsum
      call gmh(16,jemsum,line)
ccc      if(jems(16,2).lt.10)then
      write(*,'(t2,''[16] running rbar'',t26,4x,2i5,i4,t47,a)')
     *  jems(16,1),jems(16,2),jems(16,3),line
ccc      elseif(jems(16,2).ge.10.and.jems(16,2).lt.100)then
ccc        write(*,'(t2,''[16] running rbar window/overlap'',t34,i6,''/'',i2,i4,
ccc     *    t50,a)')jems(16,1),jems(16,2),jems(16,3),line
ccc      else
ccc        write(*,'(t2,''[16] running rbar window/overlap'',t34,i6,''/'',i3,i3,
ccc     *    t50,a)')jems(16,1),jems(16,2),jems(16,3),line
ccc      endif
      call gmh(17,jems(17,1),line)
      write(*,'(t2,''[17] printout option'',t26,i5,t47,a)')
     *		jems(17,1),line
      call gmh(18,jems(18,1),line)
      write(*,'(t2,''[18] core series save'',t26,i5,t47,a)')
     *		jems(18,1),line
      call gmh(19,jems(19,1),line)
      write(*,'(t2,''[19] summary plots'',t26,i5,t47,a)')
     *		jems(19,1),line
c      if(jems(20,5).eq.0)then
c        jemsum=jems(20,1)
c      else
c        jemsum=-jems(20,1)
c      endif
c      call gmh(20,jemsum,line)
      call gmh(20,jems(20,1),line)
      write(*,'(t2,''[20] stand dynamics stuff'',t28,i3,i13,t47,a)')
     *		jems(20,1),jems(20,5),line
      call gmh(21,jems(20,2),line)
      write(*,'(t7,''running mean window'',t28,i3,t47,a)')
     *		jems(20,2),line
      call gmh(22,jems(20,3),line)
      write(*,'(t7,''percent growth change'',t28,i3,t47,a)')
     *		jems(20,3),line
      call gmh(23,jems(20,4),line)
      write(*,'(t7,''std error threshold'',t28,i3,t47,a)')
     *		jems(20,4),line
    2 call blank(datum)
      write(*,'(/1x,''enter the option to change (<ret> = go)'',t45,
     *  ''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.' ')return
      if(datum(1:1).eq.'/')stop
      call intfrm(datum,frm)
      read(datum,frm,err=2)iopt
      if(iopt.gt.0)then
        call query(iopt)
        goto 1
      elseif(iopt.lt.0)then
        goto 2
      else
        return
      endif
      return
	     end
*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
*sbr query
*
      subroutine query(ier)
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** internal stuff
c
      character datum*10,frm*20,yn
c
      jer=ier
      if(jer.le.0)jer=1
      write(*,'(/1x,''input control parameters from keyboard''/
     *  1x,''hit <ret> for any specified default <parameters>'')')
      goto(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20),jer
    1 call blank(datum)
      write(*,'(/
     *  1x,''tree-ring measurement types (/ to exit, h for help):''/
     *	 1x,''raw measurements  (tucson format)'',t38,''<1>''/
     *		1x,''tree-ring series (uea cru format)'',t38,'' 2''/
     *	 1x,''tree-ring indices (tucson format)'',t38,'' 3''/
     *	 1x,''tree-ring series in compact format'',t38,'' 4''/
c     *	 1x,''user-defined data format'',t38,'' 5'',
c     * t53,''(*** not enabled yet ***)''/
     *	 1x,''enter your data format type'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 1
      endif
      if(datum(1:1).eq.' ')datum(1:1)='1'
      call intfrm(datum,frm)
      read(datum,frm,err=1)jems(jer,1)
      if(jems(jer,1).le.0.or.jems(jer,1).gt.4)goto 1
      return
    2 call blank(datum)
      write(*,'(/
     *  1x,''missing data fill-in capability is automatic.''/
     *  1x,''any number .lt. 0, except -9999, is regarded''/
     *  1x,''as a missing datum. if your missing data flag''/
     *  1x,''is not negative, or it equals -9999, quit the''/
     *  1x,''program and change your missing data flag!''/
     *  1x,''enter <ret> to continue or / to quit'',
     *	t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.' ')datum(1:2)='-9'
      call intfrm(datum,frm)
      read(datum,frm,err=2)jems(jer,1)
   21 yn=' '
      jems(jer,2)=0
      write(*,'(/
     *  1x,''plot the in-filled data? y/<n>'',t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.' ')yn='n'
      if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *  goto 21
      if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,2)=1
      return
    3 call blank(datum)
      write(*,'(/
     *  1x,''data transformation options (/ to exit, h for help):''/
     *		1x,''no data transformation'',t38,''<0>''/
     *		1x,''natural log (rt)'',t38,'' 1''/
     *		1x,''natural log (rt+1/6)'',t38,'' 2''/
     *		1x,''inverse hypersine (rt)'',t38,'' 3''/
     *  1x,''adaptive power transform (rt^p)'',t38,'' 4'',
     * t53,''(*** experimental!!! ***)''/
     *	 1x,''enter transformation method'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 3
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=3)jems(jer,1)
      if(jems(jer,1).eq.0)then
        jems(8,1)=1
      else
        jems(8,1)=2
      endif
      if(jems(jer,1).lt.0.or.jems(jer,1).gt.5)goto 3
      if(jems(jer,1).gt.0)then
   31   yn=' '
        jems(jer,2)=0
        write(*,'(/
     *    1x,''plot the transformed data? y/<n>'',t45,''==> '',$)')
        read(*,'(a)')yn
        if(yn.eq.' ')yn='n'
        if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *    goto 31
        if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,2)=1
      endif
      return
    4 call blank(datum)
      write(*,'(/
     *  1x,''first tree-ring detrending option:''/
     *  1x,''the detrending options (/ to exit, h for help):''/
     *  1X,''friedman variable span smoother'',T38,''-5''/
     *  1X,''lowess robust smoothing method'',T38,''-4''/
     *  1X,''median filter sharpening/smoothing'',T38,''-3''/
     *  1x,''regional curve (rcs) detrending'',t38,''-2''/
     *	1x,''first differences'',t38,''-1''/
     *	1x,''no detrending applied'',t38,'' 0''/
     *  1x,''neg expon curve (k>0), no = opt 4'',t38,'' 1''/
     *  1x,''neg expon curve (k>0), no = opt 5'',t38,'' 2''/
     *  1x,''neg expon curve (any k)'',t38,'' 3''/
     *	1x,''linear regression (any slope)'',t38,'' 4''/
     *	1x,''linear regression (neg slope)'',t38,'' 5''/
     *	1x,''horizontal line (arithmetic mean)'',t38,'' 6''/
     *  1x,''hugershoff growth curve'',t38,'' 7''/
     *  1x,''general negative exponential curve'',t38,'' 8''/
     *		1x,''smoothing spline (fixed n cutoff)'',t38,''>9''/
     *		1x,''smoothing spline (pct n cutoff)'',t37,''<-9'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 4
      endif
      if(datum(1:1).eq.' ')goto 4
      call intfrm(datum,frm)
      read(datum,frm,err=4)jems(jer,1)
      if(jems(jer,1).eq.-2.and.jems(jer+1,1).eq.0)then
        jems(jer+1,1)=-67
      endif
      if(jems(jer,1).lt.-5.and.jems(jer,1).gt.-10)goto 4
      if(jems(jer,1).eq.-5)then
   41   ndt1=5
        call blank(datum)
        write(*,'(/1x,''enter variable span tweeter sensitivity.''/
     *    1x,''it ranges from 0 to 9, from most sensitive''/
     *    1x,''to least sensitive: suggested default is 5,''/
     *    1x,''but you will probably want to experiment.''/
     *    1x,''so enter your tweeter sensitivity now'', t45,''==> '',$)')
        read(*,'(a)')datum
        if(datum(1:1).eq.'/')stop
        if(datum(1:1).eq.' ')goto 4
        call intfrm(datum,frm)
        read(datum,frm,err=41)ndt1
        if(ndt1.gt.9)goto 41
        if(ndt1.lt.0)goto 41
        jems(jer,2)=ndt1
      elseif(jems(jer,1).eq.-4)then
   42   ndt1=0
        call blank(datum)
        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(*,'(a)')datum
        if(datum(1:1).eq.'/')stop
        if(datum(1:1).eq.' ')goto 4
        call intfrm(datum,frm)
        read(datum,frm,err=42)ndt1
        if(ndt1.ge.0)then
          if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)goto 42
        else
          if(ndt1.gt.-1)goto 42
          if(ndt1.lt.-100)goto 42
        endif
        jems(jer,2)=ndt1
      elseif(jems(jer,1).eq.-3)then
   43   ndt1=0
        call blank(datum)
        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(*,'(a)')datum
        if(datum(1:1).eq.'/')stop
        if(datum(1:1).eq.' ')goto 4
        call intfrm(datum,frm)
        read(datum,frm,err=43)ndt1
        if(ndt1.ge.0)then
          if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)goto 43
          if(mod(ndt1,2).eq.0)goto 43
        else
          if(ndt1.gt.-1)goto 43
          if(ndt1.lt.-100)goto 43
        endif
        jems(jer,2)=ndt1
      endif
   44 yn=' '
      jems(jer,3)=0
      write(*,'(/
     *  1x,''plot data with curve fits? y/<n>'',t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.' ')yn='n'
      if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *  goto 44
      if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,3)=1
      return
    5 call blank(datum)
      if(jems(jer-1,1).ne.-2)then
        write(*,'(/
     *    1x,''second detrending option (/ to exit, '',
     *    ''h for help):'')')
      else
        write(*,'(/
     *    1x,''rcs growth curve option (/ to exit, '',
     *    ''h for help):'')')
      endif
      write(*,'(/
     *  1x,''the detrending options (/ to exit, h for help):''/
     *  1X,''friedman variable span smoother'',T38,''-5''/
     *  1X,''lowess robust smoothing method'',T38,''-4''/
     *  1X,''median filter sharpening/smoothing'',T38,''-3''/
     *	1x,''no detrending applied'',t38,'' 0''/
     *  1x,''neg expon curve (k>0), no = opt 4'',t38,'' 1''/
     *  1x,''neg expon curve (k>0), no = opt 5'',t38,'' 2''/
     *  1x,''neg expon curve (any k)'',t38,'' 3''/
     *	1x,''linear regression (any slope)'',t38,'' 4''/
     *	1x,''linear regression (neg slope)'',t38,'' 5''/
     *	1x,''horizontal line (arithmetic mean)'',t38,'' 6''/
     *  1x,''hugershoff growth curve'',t38,'' 7''/
     *  1x,''general negative exponential curve'',t38,'' 8''/
     *	1x,''smoothing spline (fixed n cutoff)'',t38,''>9''/
     *	1x,''smoothing spline (pct n cutoff)'',t37,''<-9'',
     *	t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 5
      endif
      if(datum(1:1).eq.' ')goto 5
      call intfrm(datum,frm)
      read(datum,frm,err=5)jems(jer,1)
      if(jems(jer,1).eq.-2)then
        write(*,'(/1x,''*** rcs option not allowed for 2nd ''
     *    ''detrending ***'')')
        goto 5
      endif
      if(jems(jer,1).lt.-5.and.jems(jer,1).gt.-10)goto 5
      if(jems(jer,1).eq.-5)then
        ndt1=0
      elseif(jems(jer,1).eq.-4)then
   51   ndt1=0
        call blank(datum)
        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(*,'(a)')datum
        if(datum(1:1).eq.'/')stop
        if(datum(1:1).eq.' ')goto 4
        call intfrm(datum,frm)
        read(datum,frm,err=51)ndt1
        if(ndt1.ge.0)then
          if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)goto 51
        else
          if(ndt1.gt.-1)goto 51
          if(ndt1.lt.-100)goto 51
        endif
        jems(jer,2)=ndt1
      endif
   52 if(jems(jer,1).eq.-3)then
        ndt1=0
        call blank(datum)
        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(*,'(a)')datum
        if(datum(1:1).eq.'/')stop
        if(datum(1:1).eq.' ')goto 5
        call intfrm(datum,frm)
        read(datum,frm,err=52)ndt1
        if(ndt1.ge.0)then
          if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)goto 52
          if(mod(ndt1,2).eq.0)goto 52
        else
          if(ndt1.gt.-1)goto 52
          if(ndt1.lt.-100)goto 52
        endif
        jems(jer,2)=ndt1
      endif
   53 yn=' '
      jems(jer,3)=0
      write(*,'(/
     *  1x,''plot data with curve fits? y/<n>'',t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.' ')yn='n'
      if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *  goto 53
      if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,3)=1
      return
    6 call blank(datum)
      write(*,'(/
     *  1x,''general detrending options (/ to exit, h for help):''/
     *	 1x,''non-robust (lsq) methods'',t38,''<1>''/
     *	 1x,''robust detrending methods'',t38,'' 2'',
     * t53,''(*** not yet enabled ***)''/
     *	 1x,''enter detrending method'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 6
      endif
      if(datum(1:1).eq.' ')datum(1:1)='1'
      call intfrm(datum,frm)
      read(datum,frm,err=6)jems(jer,1)
      if(jems(jer,1).le.0.or.jems(jer,1).ge.2)goto 6
      return
    7 call blank(datum)
      write(*,'(/
     *  1x,''interactive detrending (/ to exit, h for help):''/
     *  1x,''no interactive detrending'',t38,''<0>''/
     *  1x,''interactive gap filling'',t38,'' 1''/
     *  1x,''interactive detrending'',t38,'' 2''/
     *  1x,''interactive gap and detrend'',t38,'' 3'',t45,
     *  ''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 7
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=7)jems(jer,1)
      if(jems(jer,1).lt.0.or.jems(jer,1).gt.3)goto 7
      return
    8 call blank(datum)
      write(*,'(/
     *  1x,''compute detrended tree rings (/ to exit, h for help):'')')
      if(jems(3,1).eq.0)then
        write(*,'(
     *	  	1x,''indices or ratios (rt/gt)'',t38,''<1>''/
     *    1x,''residuals or differences (rt-gt)'',t38,'' 2'',
     *   t45,''==> '',$)')
      else
        write(*,'(
     *	  	1x,''indices or ratios (rt/gt)'',t38,'' 1''/
     *    1x,''residuals or differences (rt-gt)'',t38,''<2>'',
     *   t45,''==> '',$)')
      endif
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 8
      endif
      if(datum(1:1).eq.' ')datum(1:1)='1'
      call intfrm(datum,frm)
      read(datum,frm,err=8)jems(jer,1)
      if(jems(jer,1).lt.1.or.jems(jer,1).gt.2)goto 8
      return
    9 call blank(datum)
      write(*,'(/
     *  1x,''ar prewhitening options (/ to exit, h for help):''/
     *  1x,''no autoregressive modeling'',t38,'' 0''/
     *	 1x,''non-robust autoregressive modeling'',t38,''<1>''/
     *	 1x,''robust autoregressive modeling'',t38,'' 2''/
     *	 1x,''robust ar modeling + outlier removal'',t38,'' 3'',
     * t53,''(*** experimental!!! ***)''/
     *	 1x,''enter prewhitening type'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 9
      endif
      if(datum(1:1).eq.' ')datum(1:1)='1'
      call intfrm(datum,frm)
      read(datum,frm,err=9)jems(jer,1)
      if(jems(jer,1).lt.0.or.jems(jer,1).gt.3)goto 9
      if(jems(jer,1).gt.1)then
   91   yn=' '
        jems(jer,2)=0
        write(*,'(/
     *    1x,''plot the autoregressive outliers? y/<n>'',t45,''==> '',$)')
          read(*,'(a)')yn
          if(yn.eq.' ')yn='n'
          if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *      goto 91
          if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,2)=1
      endif
      return
   10 call blank(datum)
      write(*,'(/
     *  1x,''pooled ar model order options (/ to exit, h for help):''/
     *		1x,''minimum aic order selection'',t38,''<0>''/
     *		1x,''user-fixed ar order (max=10)'',t38,''ip'',
     *	t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 10
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=10)jems(jer,1)
      if(jems(jer,1).lt.0.or.jems(jer,1).gt.10)goto 10
  101 yn=' '
      jems(jer,2)=0
      write(*,'(/
     *  1x,''plot pooled ar modelling results? y/<n>'',t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.' ')yn='n'
      if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *  goto 101
      if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,2)=1
      return
   11 call blank(datum)
      write(*,'(/
     *  1x,''series ar model order options (/ to exit, h for help):''/
     *  1x,''same order as pooled ar model'',t38,''<0>''/
     *		1x,''minimum aic order selection'',t38,''-1''/
     *		1x,''user-fixed ar order (max=10)'',t38,''ip'',
     *	t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 11
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=11)jems(jer,1)
      if(jems(jer,1).lt.-1.or.jems(jer,1).gt.10)goto 11
      return   
   12 call blank(datum)
      jems(jer,1)=0
      jems(jer,2)=0
      jems(jer,3)=0
      jems(jer,4)=0
      write(*,'(/
     *  1x,''mean chronology options (/ to exit, h for help):''/
     *  1x,''no mean chronologies computed'',t38,'' 0''/
     *  1x,''non-robust (arithmetic) mean'',t38,'' 1''/
     *  1x,''robust (biweight) mean'',t38,''<2>''/
     *  1x,''quantile (min -1 to max -100)'',t38,''<0'',
     *  t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 12
      endif
      if(datum(1:1).eq.' ')datum(1:1)='2'
      call intfrm(datum,frm)
      read(datum,frm,err=12)jems(jer,1)
      if(jems(jer,1).lt.-100.or.jems(jer,1).gt.2)goto 12
      if(jems(jer,1).eq.0)then
        return
      endif
c      if(jems(jer,1).eq.2)then
c  124   yn=' '
c        jems(jer,2)=0
c        write(*,'(/
c     *    1x,''plot the robust biweights? y/<n>'',t45,''==> '',$)')
c        read(*,'(a)')yn
c        if(yn.eq.' ')yn='n'
c        if((yn.ne.'y'.and.yn.ne.'y').and.(yn.ne.'n'.and.yn.ne.'n'))
c     *    goto 124
c        if(yn.eq.'y'.or.yn.eq.'y')jems(jer,2)=1
c      endif
c      write(*,'(/
c     *  1x,''compute chronology bootstrap confidence''/
c     *  1x,''limits? currently, this is only done for''/
c     *  1x,''arithmetic mean or quantile chronologies.'')')
ccc      if(jems(jer,1).ne.2)then
  122   yn=' '
        jems(jer,3)=0
        write(*,'(/
     *  1x,''compute bootstrap confidence limits?''/
     *  1x,''be advised that no mean chronology''/
     *  1x,''variance stabilization is allowed if''/
     *  1x,''bootstrop limits are computed . . so''/
     *  1x,''compute bootstrap confidence limits? y/<n>'',t45,''==> '',$)')
        read(*,'(a)')yn
        if(yn.eq.' ')yn='n'
        if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *    goto 122
        if(yn.eq.'y'.or.yn.eq.'Y')then
          jems(jer,3)=1
          jems(jer,4)=20
          jems(jer+1,1)=0
ccc  123     call blank(datum)
ccc          write(*,'(/
ccc     *      1x,''spline the bootstrap confidence limits as''/
ccc     *      1x,''well. enter the spline filter cutoff in''/
ccc     *      1x,''years. the default is 20 years.'',t45,''==> '',$)')
ccc          read(*,'(a)')datum
ccc          if(datum(1:1).eq.'/')stop
ccc          if(datum(1:1).eq.'h'.or.datum(1:1).eq.'h')then
ccc            call helpq(jer)
ccc            goto 123
ccc          endif
ccc          if(datum(1:1).eq.' ')datum(1:2)='20'
ccc          call intfrm(datum,frm)
ccc          read(datum,frm,err=10)jems(jer,4)
ccc          if(jems(jer,4).lt.5)then
ccc            write(*,'(/1x,''==> spline cutoff must be .ge. 5 years'')')
ccc            goto 123
ccc          endif
  121     yn=' '
          jems(jer,2)=0
          write(*,'(/
     *      1x,''plot the bootstrap results? y/<n>'',t45,''==> '',$)')
          read(*,'(a)')yn
          if(yn.eq.' ')yn='n'
          if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *      goto 121
          if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,2)=1
        endif
ccc      else
ccc  125   yn=' '
ccc        write(*,'(/1x,''currently, no bootstrapping''/
ccc     *    1x,''can be done using the robust mean.''/
ccc     *    1x,''so, change the mean? y/<n>'',t45,''==> '',$)')
ccc        read(*,'(a)')yn
ccc        if(yn.eq.' ')yn='n'
ccc        if((yn.ne.'y'.and.yn.ne.'y').and.(yn.ne.'n'.and.yn.ne.'n'))
ccc     *    goto 125
ccc        if(yn.eq.'y'.or.yn.eq.'y')then
ccc          goto 12
ccc        else
ccc          jems(jer,2)=0
ccc          jems(jer,3)=0
ccc          jems(jer,4)=0
ccc          return
ccc        endif
ccc      endif
      return
   13 call blank(datum)
      write(*,'(/
     *  1x,''variance stabilization (/ to exit, h for help):''/
     *  1x,''no variance stabilization'',t38,''<0>''/
     *  1x,''keith briffa rbar-weighted method'',t38,'' 1''/
     *  1x,''both briffa & 67%n spline methods'',t38,'' 2''/
     *  1x,''smoothing spline (fixed n cutoff)'',t38,''>9''/
     *  1x,''smoothing spline (pct n cutoff)'',t37,''<-9'',
     *  t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 13
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=13)jems(jer,1)
      if(jems(jer,1).ne.0.and.jems(jer-1,3).eq.1)then
        write(*,'(/
     *    1x,''bootstrap limits will be calculated.''/
     *    1x,''no variance stabilization is allowed.'')')
        jems(jer,1)=0
      endif
      return   
   14 call blank(datum)
c     call comint()
c     need to know where the raw data is
      write(*,'(/1x,''common period analysis (/ to exit, h for help):''/
     *		1x,''first year (<ret> for none)'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 14
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=14)jems(jer,1)
  141 call blank(datum)
      write(*,'(1x,''last year (<ret> for none)'',t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 141
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=141)jems(jer,2)
      return
   15 call blank(cpm1)
      write(*,'(/1x,''enter the 8-character site-tree-core mask as''/
     *  1x,''something like ssstttcc, whatever the consistent''/
     *  1x,''separation of the site, tree, and core ids may be''/
     *  1x,''for the series ids (/ to exit, h for help):''//
     *		1x,''site-tree-core mask'',t45,''==> '',$)')
      read(*,'(a)')cpm1
      jems(jer,1)=0
      if(cpm1(1:1).eq.'/')stop
      if(cpm1(1:1).eq.'h'.or.cpm1(1:1).eq.'H')then
        call helpq(jer)
        goto 15
      endif
      return   
   16 call blank(datum)
      write(*,'(/1x,''running rbar options (/ to exit, h for help):''/
     *		 1x,''enter rbar window length, <ret> for none'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 16
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=16)jems(jer,1)
  161 call blank(datum)
      write(*,'(1x,''enter the running rbar window overlap'',
     *	 t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 161
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=161)jems(jer,2)
  162 yn=' '
      jems(jer,3)=0
      write(*,'(/
     *  1x,''plot running rbar and eps? y/<n>'',t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.' ')yn='n'
      if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *  goto 162
      if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,3)=1
      return
   17 call blank(datum)
      write(*,'(/1x,''output options (/ to exit, h for help):''/
     *		1x,''summary statistics of all series'',t38,'' 1''/
     *		1x,''+ individual series statistics'',t38,''<2>''/
     *		1x,''+ long list of mean chronology'',t38,'' 3''/
     *  1x,''+ plots of series curve fits'',t38,'' 4'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 17
      endif
      if(datum(1:1).eq.' ')datum(1:1)='2'
      call intfrm(datum,frm)
      read(datum,frm,err=17)jems(jer,1)
	     if(jems(jer,1).lt.1.or.jems(jer,1).gt.4)goto 17
      return
   18 call blank(datum)
      write(*,'(/1x,''save core series (/ to exit, h for help):''/
     *		1x,''no core series saved'',t38,''<0>''/
     *		1x,''save in tucson raw data format'',t38,'' 1''/
     *		1x,''save in tucson index format'',t38,'' 2''/
     *		1x,''save in uea cru index format'',t38,'' 3''/
     *		1x,''save in rlh compact data format'',t38,'' 4''/
     *  1x,''save in sas space-delimited columns'',t38,'' 5''/
     *  1x,''save in tab-delimited columns'',t38,'' 6''/
     *  1x,''save in comma-delimited columns'',t38,'' 7'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 18
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=18)jems(jer,1)
	     if(jems(jer,1).lt.0.or.jems(jer,1).gt.7)goto 18
      return
   19 call blank(datum)
      write(*,'(/1x,''summary hi-res plot options'',
     *  1x,''(/ to exit, h for help):''/
     *		1x,''no summary hi-res plots'',t38,''<0>''/
     *  1x,''spaghetti plots of all series'',t38,'' 1''/
     *		1x,''various summary plots (try it!)'',t38,'' 2''/
     *		1x,''all of the above (lots!!!)'',t38,'' 3'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 19
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=19)jems(jer,1)
	     if(jems(jer,1).lt.0.or.jems(jer,1).gt.3)goto 19
      return
   20 call blank(datum)
      write(*,'(/1x,''stand dynamics analysis'',
     *  1x,''(/ to exit, h for help):''/
     *		1x,''no stand dynamics analyses'',t38,''<0>''/
     *  1x,''endogenous disturbance outliers'',t38,'' 1''/
     *  1x,''nowacki/abrams release detection'',t38,'' 2''/
     *  1x,''modified nowacki/abrams (by cook)'',t38,'' 3'',
     *		t45,''==> '',$)')
      read(*,'(a)')datum
      if(datum(1:1).eq.'/')stop
      if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
        call helpq(jer)
        goto 20
      endif
      if(datum(1:1).eq.' ')datum(1:1)='0'
      call intfrm(datum,frm)
      read(datum,frm,err=20)jems(jer,1)
	     if(jems(jer,1).lt.0.or.jems(jer,1).gt.3)goto 20
      if(jems(jer,1).gt.0)then
  201   yn=' '
        jems(jer,5)=0
        write(*,'(/
     *    1x,''plot the stand dynamics analyses? y/<n>'',t45,''==> '',$)')
        read(*,'(a)')yn
        if(yn.eq.' ')yn='n'
        if((yn.ne.'y'.and.yn.ne.'Y').and.(yn.ne.'n'.and.yn.ne.'N'))
     *    goto 201
        if(yn.eq.'y'.or.yn.eq.'Y')jems(jer,5)=1
      endif
      if(jems(jer,1).eq.2.or.jems(jer,1).eq.3)then
  202   call blank(datum)
        write(*,'(/1x,''enter running mean width for calculating''/
     *    2x,''percent growth changes (range 5-50)'',
     *   t45,''==> '',$)')
        read(*,'(a)')datum
        if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
          call helpq(jer)
          goto 202
        endif
        call intfrm(datum,frm)
        read(datum,frm,err=201)jems(jer,2)
        if(jems(jer,2).lt.5.or.jems(jer,2).gt.50)goto 202
  203   call blank(datum)
        write(*,'(/1x,''enter percent growth change theshold''/
     *    2x,''for identifying releases (range 5-200)'',
     *   t45,''==> '',$)')
        read(*,'(a)')datum
        if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
          call helpq(jer)
          goto 203
        endif
        call intfrm(datum,frm)
        read(datum,frm,err=202)jems(jer,3)
        if(jems(jer,3).lt.5.or.jems(jer,3).gt.200)goto 203
        if(jems(jer,1).eq.3)then
  204     call blank(datum)
          write(*,'(/1x,''enter standard error theshold for''/
     *      2x,''identifying probable release (range 0-5)'',
     *     t45,''==> '',$)')
          read(*,'(a)')datum
          if(datum(1:1).eq.'h'.or.datum(1:1).eq.'H')then
            call helpq(jer)
            goto 204
          endif
          call intfrm(datum,frm)
          read(datum,frm,err=203)jems(jer,4)
          if(jems(jer,4).lt.0.or.jems(jer,4).gt.5)goto 204
        endif
      endif
      return
      end
*sbr helpq
*
      subroutine helpq(jer)
      goto(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20),jer
    1 write(*,'(/
     *  1x,''tree-ring data formats that can be read in''/
     *  1x,''and processed. the list presently handles four''/
     *  1x,''different data formats.'')')
      goto 100
    2 write(*,'(/
     *  1x,''the missing value flag for series gaps is''/
     *  1x,''any negative number other than -9999. it allows''/
     *  1x,''gaps in the tree-ring series to be bridged in order''/
     *  1x,''to perserve more low-frequency information due''/
     *  1x,''segment length limitations.'')')
      goto 100
    3 write(*,'(/
     *  1x,''the data transformation options are pretty''/
     *  1x,''obvious, hopefully. no data transformation''/
     *  1x,''followed by indices calculated as ratios is''/
     *  1x,''the traditional way to standardize tree rings.''/
     *  1x,''the log transform (option 1) only works for''/
     *  1x,''data >0. if a zero is found, the log of 0.01''/
     *  1x,''is used. option 2 adds a constant of 1/6 to''/
     *  1x,''the data first to get around this problem and''/
     *  1x,''also reduces the tendency for strong negative''/
     *  1x,''skew caused by the straight log transform. this''/
     *  1x,''constant was suggested by tukey for data that''/
     *  1x,''fall in the range typically found in tree rings.''/
     *  1x,''the inverse hypersine transform (option 3) was''/
     *  1x,''first used in tree-ring research by paul c. van''/
     *  1x,''deusen. it is calculated as:''/
     *  1x,''   y(i) = log(y(i)+sqrt(y(i)+1.0))''/
     *  1x,''this transform can handle zero values and is''/
     *  1x,''more moderate than the straight log transform as''/
     *  1x,''well. the adaptive power transformation (option 4)''/
     *  1x,''uses the relationship between level and spread''/
     *  1x,''to provide a unique power transformation for''/
     *  1x,''each series to stabilize the variance.'')')
      goto 100
    4 write(*,'(/
     *  1x,''the options for a growth curve f(i) used to''/
     *  1x,''detrend tree-ring series y(i) over time t are:''//
     *  1x,''option -5: friedman variable span super smoother''//
     *  1x,''   f(i) = variable span smooth''//
     *  1x,''each series is smoothed with a locally adaptive''/
     *  1x,''variable span smoother created by Jerome Friedman.''/
     *  1x,''this method may be useful in modeling the growth''/
     *  1x,''curves of disturbed tree-ring series that do not''/
     *  1x,''evolve through time in a homogeneous way.''//
     *  1x,''option -4: lowess robust smoothing''//
     *  1x,''   f(i) = lowess smooth''//
     *  1x,''each series is smoothed using cleavlands robust''/
     *  1x,''lowess smoother. the smooth is a concatenation of''/
     *  1x,''robustly fit linear segments, with the segments''/
     *  1x,''defined by either a fixed width ranging from 3 to''/
     *  1x,''n years long, or by an integer percentage of the''/
     *  1x,''overall series length defined to fall in the''/
     *  1x,''negative range -1 to -100. at the limit of -100''/
     *  1x,''(i.e. width = n), a robust linear trend is fitted''/
     *  1x,''to the series. cool, huh?'')')
      pause
      write(*,'(/
     *  1x,''option -3: median smoothing''//
     *  1x,''   f(i) = median smooth''//
     *  1x,''each series is smoothed with a robust median''/
     *  1x,''filter, with the segments defined by either a''/
     *  1x,''fixed width for all series or as an integer''/
     *  1x,''percentage of the overall series length. see the''/
     *  1x,''above description for the lowess smoother for more''/
     *  1x,''details concerning the conventions for choosing''/
     *  1x,''the width(s) of the smoothing. the only difference''/
     *  1x,''is that the width of the median filter must be''/
     *  1x,''an odd integer. the median filter not only smooths''/
     *  1x,''data. it also sharpens edges caused by abrupt and''/
     *  1x,''persistent changes. its use in dendrochronology is''/
     *  1x,''untested and experimental.'')')
      pause
      write(*,'(/
     *  1x,''option -2: regional curve standardization''//
     *  1x,''   f(i) = one age-aligned curve''//
     *  1x,''all of the raw series are averaged together after''/
     *  1x,''alignment by biological age. a single growth curve''/
     *  1x,''is fit to this mean series using the negative''/
     *  1x,''exponential curve option 1. this curve is then used''/
     *  1x,''to detrend all of the series after they have been''/
     *  1x,''aligned by calendar year. in general, this method''/
     *  1x,''preserves the most low-frequency variance. however,''/
     *  1x,''it does not always work as well as advertised.''//
     *  1x,''option  -1: first-differences''//
     *  1x,''   f(i) = y(i) - y(i-1)''//
     *  1x,''this method effectively removes all low-frequency''/
     *  1x,''variance. it may be used when only the year-to-year''/
     *  1x,''high-frequency variance is of interest. otherwise,''/
     *  1x,''you will probably want to skip it.''//
     *  1x,''option   0: no detrending is applied at all'')')
      pause
      write(*,'(/
     *  1x,''option   1: modified negative exponential curve''//
     *  1x,''   f(i) = a * exp(-b*t(i)) + d     (d>0)''//
     *  1x,''this is the classic growth curve used for detrending''/
     *  1x,''the ring-width series of open-grown trees. its use''/
     *  1x,''in dendrochronology was introduced by h.c. fritts.''/
     *  1x,''it assumes from first-principles that the biological''/
     *  1x,''age-trend of tree-ring series should decrease in a''/
     *  1x,''non-linear, negative exponential way through time.''/
     *  1x,''if this curve fails, a linear trend of any slope''/
     *  1x,''is fit in its place, i.e. no = option 4. it assumes''/
     *  1x,''that a positive slope in the raw data series is also''/
     *  1x,''likely to be non-climatic and needs to be removed.''//
     *  1x,''option   2: modified negative exponential curve''//
     *  1x,''   f(i) = a * exp(-b*t(i)) + d     (d>0)''//
     *  1x,''this option is the same as option 1, but differs''/
     *  1x,''when the fitting procedure fails. if this curve fit''/
     *  1x,''fails, a linear regression with negative or zero ''/
     *  1x,''slope is fit in its place, i.e. no = option 5.  it''/
     *  1x,''assumes that a positive slope in the raw data series''/
     *  1x,''may be due to climate and, should to be preserved.''//
     *  1x,''option   3: modified negative exponential curve''//
     *  1x,''   f(i) = a * exp(-b*t(i+p)) + d  (any d)''//
     *  1x,''this option generalizes the modified negative''/
     *  1x,''exponential curve to allow for positive and negative''/
     *  1x,''asymptotes and a pith offset p.'')')
      pause
      write(*,'(/
     *  1x,''option   4: linear regression (any slope)''//
     *  1x,''   f(i) = +/-c*t(i) + d''//
     *  1x,''this option simply removes all linear trends from''/
     *  1x,''the raw data series, assuming that any linear trend''/
     *  1x,''is likely to be non-climatic in origin.''//
     *  1x,''option   5: linear regression (neg. or zero slope)''//
     *  1x,''   f(i) = -c*t(i) + d   ''//
     *  1x,''this option fits a linear trend to the series. if''/
     *  1x,''the resulting slope is positive, a horizontal line''/
     *  1x,''through the mean is used instead. it assumes that''/
     *  1x,''all negative slopes are linear, biologically-based,''/
     *  1x,''non-climatic growth trends. in constrast, positive''/
     *  1x,''slope in the raw data series may be assumed due''/
     *  1x,''to climate and, therefore, ought to be preserved.''/
     *  1x,''that is the assumption anyway. you be the judge.''//
     *  1x,''option   6: horizontal line through the mean''//
     *  1x,''   f(i) = mean(y(i))''//
     *  1x,''this option only removes the mean level from the raw''/
     *  1x,''data series. it assumes that the absolute level of''/
     *  1x,''growth is non-climatic, but not any of the positive''/
     *  1x,''or negative trends associated with that level.'')')
      pause
      write(*,'(/
     *  1x,''option   7: hugershoff growth curve''//
     *  1x,''   f(i) = a * t(i+p)**b * exp(-c*t(i+p)) + d''//
     *  1x,''this growth curve is theoretically based and is''/
     *  1x,''popular among some foresters, expecially in europe.''/
     *  1x,''it allows for increasing growth during the juvenile''/
     *  1x,''phase, followed by a negative, curvilinear decline''/
     *  1x,''as the tree matures. it has also been generalized to''/
     *  1x,''allow for a non-zero asymptote of any sign and an''/
     *  1x,''estimated pith offset p to account for missing inner''/
     *  1x,''rings.''//
     *  1x,''option   8: general negative exponential curve''//
     *  1x,''   f(i) = a * t(i+p) * exp(-c*t(i+p)) + d''//
     *  1x,''this curve is a special case of the hugershoff in''/
     *  1x,''which the b coefficient has been set equal to 1.0.''/
     *  1x,''this growth curve is also theoretically based and is''/
     *  1x,''likewise popular among some foresters. it too allows''/
     *  1x,''for increasing growth during the juvenile growth''/
     *  1x,''phase, followed by a negative exponential decline''/
     *  1x,''as the tree matures. it too has been generalized to''/
     *  1x,''allow for a non-zero asymptote of any sign and an''/
     *  1x,''estimated pith offset p to account for missing inner''/
     *  1x,''rings.'')')
      pause
      write(*,'(/
     *  1x,''option > 9: cubic smoothing spline filter''//
     *  1x,''   f(i) = fixed 50 percent variance cutoff''//
     *  1x,''this curve fit acts as a symmetric digital filter''/
     *  1x,''with a fixed transfer function cutoff in years, e.g.''/
     *  1x,''a value of 100 removes 50 percent of the variance''/
     *  1x,''in the series at a period of 100 years. the spline is''/
     *  1x,''purely data-adaptive and may remove too much low-''/
     *  1x,''frequency variance if used improperly. however, it''/
     *  1x,''does provide an a priori measure of how much low-''/
     *  1x,''frequency variance has been lost, unlike the other''/
     *  1x,''detrending methods available here.''//
     *  1x,''option <-9: cubic smoothing spline filter''//
     *  1x,''   f(i) = percent n 50 percent variance cutoff''//
     *  1x,''this curve fit acts as a symmetric digital filter''/
     *  1x,''with a transfer function cutoff equal to a percent''/
     *  1x,''of the total series length. a useful rule-of-thumb''/
     *  1x,''to use is 2/3 the series length, i.e. -66. a spline''/
     *  1x,''with this frequency response will remove most of the''/
     *  1x,''trend while leaving in most of the low-frequency''/
     *  1x,''variance that is resolvable from the trend.'')')
      pause
      goto 100
    5 write(*,'(/
     *  1x,''the options for second detrending are the same as for''/
     *  1x,''first detrending. in the case of the rcs (opt=-2)''/
     *  1x,''method, the second detrending is the curve used to''/
     *  1x,''model the age-aligned mean ring-width data.'')')
      goto 100
    6 write(*,'(/
     *  1x,''right now only non-robust least squares curve''/
     *  1x,''fitting is allowed. stay tuned for robust methods''/
     *  1x,''in a future release of this program.'')')
      goto 100
    7 write(*,'(/
     *  1x,''this option allows the user to interactively change''/
     *  1x,''the curve fit option used for detrending each tree-''/
     *  1x,''ring series. it obviously slows down the batch mode''/
     *  1x,''processing of the data. however, it allows for much''/
     *  1x,''more control over the standardization process.'')')
      goto 100
    8 write(*,'(/
     *  1x,''you may compute tree-ring indices by the''/
     *  1x,''traditional ratio method, or as differences''/
     *  1x,''from the growth trend. the latter should be''/
     *  1x,''used if the raw measurements are transformed''/
     *  1x,''first to stablize the variance, or if the data''/
     *  1x,''are believed to be homoscedastic already.'')')
      goto 100
    9 write(*,'(/
     *  1x,''the ar modeling options are (0) none if you''/
     *  1x,''want to skip the whole arstan phase of the run,''/
     *  1x,''(1) non-robust ar modeling (the default standard''/
     *  1x,''way to prewhiten time series with ar models),''/
     *  1x,''(2) robust ar modeling in which outliers are''/
     *  1x,''discounted in estimating the ar coefficients,''/
     *  1x,''and (3) robust ar modeling that also iteratively''/
     *  1x,''removes innovational outliers from the tree-ring''/
     *  1x,''series. robust prewhitening is experimental and''/
     *  1x,''you should use it with care to be sure that you''/
     *  1x,''are not throwing out useful information in the''/
     *  1x,''form of common climatic extremes in the data.'')')
      goto 100
   10 write(*,'(/
     *  1x,''the pooled ar order options are pretty obvious.''/
     *  1x,''the default mininum aic option automatically''/
     *  1x,''selects the best fitting ar model to the pooled''/
     *  1x,''data. the user-fixed ar order option over-rides''/
     *  1x,''the minimum aic selection criterion by forcing''/
     *  1x,''an a priori ar model on the data.'')')
      goto 100
   11 write(*,'(/
     *  1x,''the options here for selecting the order of the''/
     *  1x,''autoregressive model fit to each core series are''/
     *  1x,''pretty obvious. the original arstan technique''/
     *  1x,''always relies on fitting the same order ar model''/
     *  1x,''to the core series as was fitted to the pooled''/
     *  1x,''data, hence the default shown. selecting the''/
     *  1x,''second option (-1) will allow for a different''/
     *  1x,''order ar model to be fit to each core series''/
     *  1x,''using the minimum aic criterion. the 3rd option''/
     *  1x,''forces a user-specificed ar order on the series'')')
      goto 100
   12 write(*,'(/
     *  1x,''the options here for computing a mean chronology''/
     *  1x,''are pretty obvious, hopefully. you can skip it,''/
     *  1x,''calculate it using the non-robust arithmetic mean,''/
     *  1x,''calculate it using the robust biweight mean, or''/
     *  1x,''save a quantile chronology. the quantiles are''/
     *  1x,''order statistics for each year. by that i mean''/
     *  1x,''that the tree-ring values for each year are ranked''/
     *  1x,''and the jth quantile is selected as the chronology''/
     *  1x,''value for that year. the jth quantile may be the''/
     *  1x,''median (j=-50), the lower hinge (j=-25), the upper''/
     *  1x,''hinge (j=-75), or even the minimum (j=-1) or the''/
     *  1x,''maximum (j=-100). truth or dare. you be the judge.''/
     *  1x,''there is little operational experience yet in''/
     *  1x,''using quantile chronologies, and it is probably''/
     *  1x,''best used with large samples. so, caveat emptor!'')')
      goto 100
   13 write(*,'(/
     *  1x,''this option allows for the variance of a mean tree''/
     *  1x,''ring chronology to be adjusted for changing sample''/
     *  1x,''size or other effects that cause the variance to''/
     *  1x,''be time dependent. this adjustment can be done two''/
     *  1x,''different ways here. the first method is by keith''/
     *  1x,''briffa. it utilizes the sample size information for''/
     *  1x,''each year plus the average correlation between''/
     *  1x,''series (rbar) based on all possible series overlaps''/
     *  1x,''(n>20) to correctly adjust the variance due to''/
     *  1x,''changing sample size alone. the second method for''/
     *  1x,''adjusting the variance involves removing any time''/
     *  1x,''trend in the absolute differences of the mean''/
     *  1x,''chronology using a smoothing spline. this method is''/
     *  1x,''strictly ad hoc, but it allows for the variance to''/
     *  1x,''be stabilized even if the heteroscedascity is not''/
     *  1x,''related to changing sample size only.'')')
      goto 100
   14 write(*,'(/
     *  1x,''this option produces a common period analysis ala''/
     *  1x,''wigley-briffa-jones. so, for a specified common''/
     *  1x,''period, the average correlation (rbar), signal-to-''/
     *  1x,''noise ratio (snr), expressed population signal''/
     *  1x,''(eps), and subsample signal strength (sss) values''/
     *  1x,''are produced. this is done for all chronologies''/
     *  1x,''produced by the program.'')')
      goto 100
   15 write(*,'(/
     *  1x,''the site-tree-core mask tells how the series are''/
     *  1x,''to be separated into within- and between-tree''/
     *  1x,''groups for the common period analysis. this mask''/
     *  1x,''may be up to 8 characters long, but often will''/
     *  1x,''be fewer. thus, if the site id is 3 characters''/
     *  1x,''long, the tree id is 2 characters long, and the''/
     *  1x,''core id is 2 characters long, the mask would look''/
     *  1x,''like SSSTTCC. the mask is 7 characters long, with''/
     *  1x,''the 8th character left blank. or, if the site,''/
     *  1x,''tree, and core ids are 2, 2, and 1 character long,''/
     *  1x,''the mask would be ssttc. capeche? all that matters''/
     *  1x,''is that a consistent convention is used for the''/
     *  1x,''number of spaces used for the site, tree, and core''/
     *  1x,''ids. what could be easier. the site-tree-core mask''/
     *  1x,''is then used to scan the actual series ids and''/
     *  1x,''assign the series to tree #1, tree #2 ... tree #m.''/
     *  1x,''so, the actual mask used to separate the within-''/
     *  1x,''and between-tree correlations is really an integer''/
     *  1x,''array that tells which correlations belong to''/
     *  1x,''tree #1, tree #2 ... tree #m. see the batch detail''/
     *  1x,''file to see what i mean after running the program''/
     *  1x,''once. the proper separation also does not require''/
     *  1x,''that the within-tree series be grouped in the data''/
     *  1x,''file. all that matters is that the convention used''/
     *  1x,''to delimit the columns used for the site, tree,''/
     *  1x,''and core ids is consistently used throughout.'')')
      goto 100
   16 write(*,'(/
     *  1x,''a running rbar (i.e. the average correlation''/
     *  1x,''between series) can be computed across all series''/
     *  1x,''and over all time where the sample size is 2 or''/
     *  1x,''more. as computed here, the running rbar does not''/
     *  1x,''separate the cores into within-tree and between-''/
     *  1x,''tree classes. therefore, this rbar will be biased''/
     *  1x,''upward, but the bias should be small for any''/
     *  1x,''sample size period where the number of trees''/
     *  1x,''exceeds the average number of cores per tree by''/
     *  1x,''10 or more. the user must supply a window width''/
     *  1x,''and window overlap for calculating the running''/
     *  1x,''rbar. the overlap cannot exceed the window width.'')')
      goto 100
   17 write(*,'(/
     *  1x,''the options are mostly self-explanatory here. the''/
     *  1x,''volume of output increases markedly from option 1''/
     *  1x,''to option 4.'')')
      goto 100
   18 write(*,'(/
     *  1x,''you can save the individual tree-ring series in:''//
     *  1x,''     (1) tucson raw measurement format''/
     *  1x,''     (2) tucson tree-ring index format''/
     *  1x,''     (3) uea cru modified index format''/
     *  1x,''     (4) holmes compact data format''/
     *  1x,''     (5) space-delimited column format''/
     *  1x,''     (6) tab-delimited column format''/
     *  1x,''     (7) comma-delimited column format''//
     *  1x,''the tabbed column format is especially useful for''/
     *  1x,''importing the data into spreadsheets for plotting.''/
     *  1x,''the files of individual core series that are saved''/
     *  1x,''will be the raw input measurements, the transformed''/
     *  1x,''raw measurements if done, the detrended tree-ring''/
     *  1x,''indices, the fitted growth curves used to detrend''/
     *  1x,''the series, and the autoregressive residuals if''/
     *  1x,''ar modeling is performed. this option can also be''/
     *  1x,''used to reformat the input data from tucson, uea''/
     *  1x,''cru, or compact format to tucson ring-width/index''/
     *  1x,''format, uea cru data format, or compact format.'')')
      goto 100
   19 write(*,'(/
     *  1x,''high-resolution summary plots of tree-ring data.''/
     *  1x,''option 1 overlays the series at each stage of''/
     *  1x,''processing (the "spaghetti" plots) and also plots''/
     *  1x,''out and overlays the fitted growth curves. option 2''/
     *  1x,''shows the final chronologies, mean age and segment''/
     *  1x,''length plots, and the running rbar and eps plots.''/
     *  1x,''option 3 shows both the spaghetti plots and series''/
     *  1x,''plotted using option 2. for pure batch mode runs,''/
     *  1x,''option #0 (no plots) should be used.'')')
      goto 100
   20 write(*,'(/
     *  1x,''this is the start of a stand dynamics analysis part''/
     *  1x,''of arstan. so far now, you can identify endogenous''/
     *  1x,''outliers, which are defined as those extreme values''/
     *  1x,''that are found in the individual tree-ring series,''/
     *  1x,''but not in the mean chronology. endogenous outliers''/
     *  1x,''are identified as those extreme values that exceed''/
     *  1x,''3.5 standard deviations from the mean. this cutoff''/
     *  1x,''has an a priori probability of about 1 in 1000, a''/
     *  1x,''stringent level chosen because of the a posteriori''/
     *  1x,''nature of this analysis and the multiplicity of the''/
     *  1x,''testing environment.'')')
  100 return
      end
*sbr wlf
c
c *** write log files
c
      subroutine wlf(jems,cpm1,iu21)
      integer jems(30,5)
      character cpm1*8
c
c *** internal stuff
c
      character line*50,datum*10,datum1*6,datum2*6,datum3*6,frm*20
c
      jer=0
c option #1
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #2
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      call gmh(jer,jems(jer,2),line)
      write(iu21,'(a6,7x,a6,t20,a50)')datum,datum1,line
c option #3
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      if(jems(jer,2).eq.0)then
        jemsum=jems(jer,1)
      else
        jemsum=-jems(jer,1)
      endif
      call gmh(jer,jemsum,line)
      write(iu21,'(a6,7x,a6,t20,a50)')datum,datum1,line
c option #4
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      call blank(datum2)
      call intfrm1(jems(jer,3),frm)
      write(datum2,frm)jems(jer,3)
      call gmh(jer,jems(jer,1),line)
      line(2:5)='1st-'
      write(iu21,'(a6,1x,a6,a6,t20,a50)')datum,datum1,datum2,line
c option #5
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      call blank(datum2)
      call intfrm1(jems(jer,3),frm)
      write(datum2,frm)jems(jer,3)
      call gmh(jer,jems(jer,1),line)
      line(2:5)='2nd-'
      write(iu21,'(a6,1x,a6,a6,t20,a50)')datum,datum1,datum2,line
c option #6
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #7
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #8
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #9
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      if(jems(jer,2).eq.0)then
        jemsum=jems(jer,1)
      else
        jemsum=-jems(jer,1)
      endif
      call gmh(jer,jemsum,line)
      write(iu21,'(a6,7x,a6,t20,a50)')datum,datum1,line
c option #10
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      if(jems(jer,2).eq.0)then
        jemsum=jems(jer,1)
      else
        jemsum=-jems(jer,1)-1
      endif
      call gmh(jer,jemsum,line)
      write(iu21,'(a6,7x,a6,t20,a50)')datum,datum1,line
c option #11
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #12
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,2),frm)
      write(datum1,frm)jems(jer,2)
      call blank(datum2)
      call intfrm1(jems(jer,3),frm)
      write(datum2,frm)jems(jer,3)
      call blank(datum3)
      call intfrm1(jems(jer,4),frm)
      write(datum3,frm)jems(jer,4)
      if(jems(12,1).eq.1.and.jems(12,3).eq.0)then
        jemsum=1
      elseif(jems(12,1).eq.1.and.jems(12,3).eq.0)then
        jemsum=2
      elseif(jems(12,1).eq.1.and.jems(12,3).eq.1)then
        jemsum=6
      elseif(jems(12,1).eq.2.and.jems(12,3).eq.0)then
        jemsum=3
      elseif(jems(12,1).eq.2.and.jems(12,3).eq.1)then
        jemsum=7
      elseif(jems(12,1).lt.0.and.jems(12,3).eq.0)then
        jemsum=5
      elseif(jems(12,1).lt.0.and.jems(12,3).eq.1)then
        jemsum=8
      endif
      call gmh(jer,jemsum,line)
      write(iu21,'(a4,a4,a5,a1,t20,a50)')datum,datum2,datum3,datum1,line
c option #13
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line
c option #14
      jer=jer+1
      call blank(datum1)
      call intfrm1(jems(jer,1),frm)
      write(datum1,frm)jems(jer,1)
      call blank(datum2)
      call intfrm1(jems(jer,2),frm)
      write(datum2,frm)jems(jer,2)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(2a6,t20,a50)')datum1,datum2,line
c option #15
      jer=jer+1
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a8,t20,a50)')cpm1,line
c option #16
      jer=jer+1
      call blank(datum1)
      call intfrm1(jems(jer,1),frm)
      write(datum1,frm)jems(jer,1)
      call blank(datum2)
      call intfrm1(jems(jer,2),frm)
      write(datum2,frm)jems(jer,2)
      call blank(datum3)
      call intfrm1(jems(jer,3),frm)
      write(datum3,frm)jems(jer,3)
      jemsum=jems(16,1)
      if(jems(16,3).eq.1)jemsum=-jemsum
      call gmh(jer,jemsum,line)
      write(iu21,'(2a6,1x,a6,t20,a50)')datum1,datum2,datum3,line
c option #17
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line	  
c option #18
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line	  
c option #19
      jer=jer+1
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a10,t20,a50)')datum,line	  
c option #20
c      jer=jer+1
c      jer1=jer
c      call blank(datum)
c      call intfrm1(jems(jer,1),frm)
c      write(datum,frm)jems(jer,1)
c      call gmh(jer,jems(jer,1),line)
c      write(iu21,'(a10,t20,a50)')datum,line
c
      jer=jer+1
      jer1=jer
      call blank(datum)
      call intfrm1(jems(jer,1),frm)
      write(datum,frm)jems(jer,1)
      call blank(datum1)
      call intfrm1(jems(jer,5),frm)
      write(datum1,frm)jems(jer,5)
      call gmh(jer,jems(jer,1),line)
      write(iu21,'(a6,7x,a6,t20,a50)')datum,datum1,line
c
      jer1=jer1+1
      call blank(datum)
      call intfrm1(jems(jer,2),frm)
      write(datum,frm)jems(jer,2)
      call gmh(jer1,jems(jer,2),line)
      write(iu21,'(a10,t20,a50)')datum,line
      jer1=jer1+1 
      call blank(datum)
      call intfrm1(jems(jer,3),frm)
      write(datum,frm)jems(jer,3)
      call gmh(jer1,jems(jer,3),line)
      write(iu21,'(a10,t20,a50)')datum,line
      jer1=jer1+1  
      call blank(datum)
      call intfrm1(jems(jer,4),frm)
      write(datum,frm)jems(jer,4)
      call gmh(jer1,jems(jer,4),line)
      write(iu21,'(a10,t20,a50)')datum,line	  
      return
      end
*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
*sbr batch
*
      subroutine batch(ier,nfil,fil)
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** internal stuff
c
      character fil*40,line*80,head*50
CCC***      character datum*10,frm*20
c
      lun=iu21
      call blank(line)
      rewind lun
      read(lun,'(a)',end=100)line
      if(line(21:60).ne.fil(1:40))line(21:60)=fil(1:40)
      write(*,'(/1x,a)')line
      write(*,'(1x,''batch file inputs:''/
     *          1x,''inputs.............!input indentification'')')
      ier=0
      ndt1=0
c						
c     data type options:
c
c     mts = 1 -- tree-ring widths (tucson format)
c     mts = 2 -- tree-ring widths (uea cru format)
c     mts = 3 -- tree-ring indices (tucson format)
c     mts = 4 -- tree-ring compact data format
c     mts = 5 -- user-defined data format
c
      ier=1			
      mts=0	
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150)mts
      if(mts.ne.1.and.mts.ne.2.and.mts.ne.3.and.mts.ne.4)goto 150
      call gmh(ier,mts,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=mts
c
c     missing value flag:
c
c     ifg = missing value flag
c
      ier=2		
      ifg1=0
      ifg2=0	
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150)ifg1,ifg2
      call gmh(ier,ifg2,head)
      if(line(20:69).ne.head(1:50))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ifg1
      jems(ier,2)=ifg2
c
c     data transformation options:
c
c     itn = 0 -- no data transformation
c     itn = 1 -- log transform without adding a constant
c     itn = 2 -- log transform after adding 1/6 to each value
c     itn = 3 -- inverse hypersine transformation
c     itn = 4 -- spread vs level power transformation
c
      ier=3
      itn1=0
      itn2=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)itn1,itn2
      if(itn1.lt.0.or.itn1.gt.5)goto 150
      if(itn2.eq.0)then
        itns=itn1
      else
        itns=-itn1
      endif
      call gmh(ier,itns,head)
      if(line(20:59).ne.head(1:40))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=itn1
      jems(ier,2)=itn2
c
c     detrending options:
c
c     idt < -9 -- cubic smoothing spline (years cutoff=idt/100*n)
c     idt = -5 -- friedman variable span smoother
c     idt = -4 -- lowess robust smoothing
c     idt = -3 -- median filter sharpening and smoothing
c     idt = -2 -- regional curve detrending (briffa's rcs)
c     idt = -1 -- tree-ring first-differences
c     idt =  0 -- no detrending performed
c     idt =  1 -- modified negative exponential curve (k>0), no = opt 4
c     idt =  2 -- modified negative exponential curve (k>0), no = opt 5
c     idt =  3 -- modified negative exponential curve (any k)
c     idt =  4 -- linear regression, any slope curve
c     idt =  5 -- linear regression, negative slope only
c     idt =  6 -- horizontal line through mean
c     idt =  7 -- hugershoff growth curve
c     idt =  8 -- general negative exponential curve
c     idt >  9 -- cubic smoothing spline (fixed years cutoff=idt)
c
      ier=4
      idt=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)idt,ndt1,iplt
      if(idt.eq.-3.or.idt.eq.-4)then
        if(idt.eq.-3)then
          if(ndt1.gt.2)then
            if(mod(ndt1,2).eq.0)ndt1=ndt1-1
          elseif(ndt1.lt.0)then
            if(ndt1.lt.-100)ndt1=-100
          else
            if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)
     *        stop'*** median filter width inadmissable'
          endif
        elseif(idt.eq.-4)then
          if(ndt1.lt.0)then
            if(ndt1.lt.-100)ndt1=-100
          else
            if(ndt1.eq.0.or.ndt1.eq.1.or.ndt1.eq.2)
     *        stop'*** lowess smoother width inadmissable'
          endif
        endif
      endif
      call gmh(ier,idt,head)
      head(2:5)='1st-'
      if(line(20:59).ne.head(1:40))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=idt
      jems(ier,2)=ndt1
      jems(ier,3)=iplt
      idt1=idt
c
c     second detrending option or rcs growth curve option
c
      ier=5
      idt=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)idt,ndt2,iplt
      if(idt.eq.-3.or.idt.eq.-4)then
        if(idt.eq.-3)then
          if(ndt2.gt.2)then
            if(mod(ndt2,2).eq.0)ndt2=ndt2-1
          elseif(ndt2.lt.0)then
            if(ndt2.lt.-100)ndt2=-100
          else
            if(ndt2.eq.0.or.ndt2.eq.1.or.ndt2.eq.2)
     *        stop'*** median filter width inadmissable'
          endif
        elseif(idt.eq.-4)then
          if(ndt2.lt.0)then
            if(ndt2.lt.-100)ndt2=-100
          else
            if(ndt2.eq.0.or.ndt2.eq.1.or.ndt2.eq.2)
     *        stop'*** lowess smoother width inadmissable'
          endif
        endif
      endif
      call gmh(ier,idt,head)
      if(idt1.eq.-2)then
        head(2:5)='rcs-'
      else
        head(2:5)='2nd-'
      endif
      if(line(20:59).ne.head(1:40))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=idt
      jems(ier,2)=ndt2
      jems(ier,3)=iplt
c
c     robust detrending options:
c
c     irb = 0 -- none - raw data or differences used
c     irb = 1 -- no robust detrending methods used
c     irb = 2 -- robust detrending methods used
c
      ier=6
      irb=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)irb
      if(irb.ne.0.and.irb.ne.1.and.irb.ne.2)goto 150
      call gmh(ier,irb,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=irb
c
c     interactive detrending option:
c
c     ido = 0 -- no interactive detrending
c     ido = 1 -- interactive filling of gaps
c     ido = 2 -- interactive detrending used
c     ido = 3 -- interactive gap and detrend
c
      ier=7
      ido=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)ido
      if(ido.lt.0.or.ido.gt.3)goto 150
      call gmh(ier,ido,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ido
c
c     calculation of detrended tree-ring values:
c
c     ind = 0 -- no indices - raw data or differences used
c     ind = 1 -- tree-ring indices or ratios (rt/gt)
c     ind = 2 -- residuals or differences (rt-gt)
c
      ier=8
      ind=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)ind
      if(ind.ne.0.and.ind.ne.1.and.ind.ne.2)goto 150
ccc      if(itn1.eq.0.and.ind.eq.2)ind=1
ccc      if(itn1.gt.0.and.ind.eq.1)ind=2
      write(line(1:1),'(i1)')ind
      call gmh(ier,ind,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ind
c
c     autoregressive modeling options:
c
c     jrb = 0 -- no ar modeling done
c     jrb = 1 -- non-robust ar modeling done
c     jrb = 2 -- robust ar modeling done
c     jrb = 3 -- full removal of outliers
c
      ier=9
      jrb1=0
      jrb2=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)jrb1,jrb2
      if(jrb1.lt.0.or.jrb1.gt.3)goto 150
      if(jrb2.eq.0)then
        jrbs=jrb1
      else
        jrbs=-jrb1
      endif
      call gmh(ier,jrbs,head)
      if(line(20:69).ne.head(1:50))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=jrb1
      jems(ier,2)=jrb2
c
c     pooled ar model order selection
c
c     ipp = 0 -- minimum aic order selection
c     ipp = p -- user supplied ar order (max=10)
c
      ier=10
      ipp=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)ipp,ip2
      if(ipp.lt.0.or.ipp.gt.10)goto 150
      if(ip2.eq.0)then
        ips=ip2
      else
        ips=-ipp-1
      endif
      call gmh(ier,ips,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ipp
      jems(ier,2)=ip2
c
c     series ar model order selection
c
c     ips = 0 -- same as pooled model order
c     ips =-1 -- minimum aic order selection
c     ips = p -- user supplied ar order (max=10)
c
      ier=11
      ips=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)ips
      if(ips.lt.-1.or.ips.gt.10)goto 150
      call gmh(ier,ips,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ips
c
c     robust robust mean chronology options:
c
c     krb = 0 -- no mean chronology computed
c     krb = 1 -- non-robust (arithmetic) mean chronology
c     krb = 2 -- robust (biweight) mean chronology
c     krb < 0 -- quantile chronology
c
      ier=12
      krb1=0
      krb2=0
      krb3=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)krb1,krb3,krb4,krb2
      if(krb1.lt.-100.or.krb1.gt.2)goto 150
      if(krb2.lt.0.or.krb2.gt.1)goto 150
      if(krb3.lt.0.or.krb3.gt.1)goto 150
      if(krb1.eq.0)then
        krb12=1
      elseif(krb1.eq.1.and.krb3.eq.0)then
        krb12=2
      elseif(krb1.eq.1.and.krb3.eq.1)then
        krb12=6
      elseif(krb1.eq.2.and.krb3.eq.0)then
        krb12=3
      elseif(krb1.eq.2.and.krb3.eq.1)then
        krb12=7
      elseif(krb1.lt.0.and.krb3.eq.0)then
        krb12=5
      elseif(krb1.lt.0.and.krb3.eq.1)then
        krb12=8
      endif   
      call gmh(ier,krb12,head)
      if(line(20:46).ne.head(1:26))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=krb1
      jems(ier,2)=krb2
      jems(ier,3)=krb3
      jems(ier,4)=krb4
c
c     chronology variance stabilization options:
c
c     isb =  0 -- no variance stablization performed
c     isb =  1 -- keith briffa's rbar-weighted method
c     isb =  2 -- both briffa's and 67%n spline methods
c     isb < -9 -- cubic smoothing spline (years cutoff=idt/100*n)
c     isb >  9 -- cubic smoothing spline (fixed years cutoff=idt)
c
      ier=13
      isb=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)isb
      if(isb.ge.-9.and.isb.le.9.and.isb.ne.0.and.
     *  isb.ne.1.and.isb.ne.2)goto 150
      jsb=isb
      if(jsb.eq.2)jsb=1
      call gmh(ier,jsb,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=isb
c
c     common period analysis first and last years
c
      ier=14
      ifc=0
      ilc=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)ifc,ilc
      call gmh(ier,ifc,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ifc
      jems(ier,2)=ilc
c
c     site-tree-core mask
c
      ier=15
      call blank(line)
      read(lun,'(a)',end=100)line
      call blank(cpm1)
      cpm1(1:8)=line(1:8)
      call gmh(ier,0,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      if(line(1:8).eq.' none   ')then
        line(21:69)=head(1:50)
        line(20:20)=' '
        write(*,'(1x,a)')line(2:80)
      else
        write(*,'(1x,a)')line
      endif
      jems(ier,1)=0
c
c     running rbar window length and overlap:
c
c     nsg = cannont exceed series length or be less then 2
c     nsg < 0 skips running rbar calculation
c     nlp = cannot be greater then window length
c
      ier=16
      nsg=0
      nlp=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)nsg,nlp,npl
      jemsum=nsg
      if(npl.eq.1)jemsum=-jemsum
      call gmh(ier,nsg,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=nsg
      jems(ier,2)=nlp
      jems(ier,3)=npl
c
c     printout options:
c
c     ipo = 1 summary statistics of all series only
c     ipo = 2 summary+individual series statistics
c     ipo = 3 summary+individual+mean series long list
c     ipo = 4 summary+individual+long list+curve plots
c
      ier=17
      ipo=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)ipo
      if(ipo.lt.1.or.ipo.gt.4)goto 150
      call gmh(ier,ipo,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ipo
c
c     ics = 0 don't save individual core series
c     ics = 1 save core series in tucson raw data format
c     ics = 2 save core series in tucson index format
c     ics = 3 save core series in uea cru index format
c     ics = 4 save core series in rlh compact data format
c     ics = 5 save core series in space-delimited columns
c     ics = 6 save core series in tab-delimited columns
c     ics = 7 save core series in comma-delimited columns
c
      ier=18
      ics=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)ics
      if(ics.lt.0.or.ics.gt.7)goto 150
      call gmh(ier,ics,head)
      if(line(20:49).ne.head(1:30))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ics
c
c     ird = 0 no high resolution plots
c     ird = 1 spaghetti plots of all series
c     ird = 2 mean chronology plots
c     ird = 3 both sets of plots
c
      ier=19
      ird=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)ird
      if(ird.lt.0.or.ird.gt.3)goto 150
      call gmh(ier,ird,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=ird
c
c     isd = 0 no stand dynamics stuff done
c     isd = 1 nowacki/abrams release detection
c     isd = 2 nowacki/abrams (modified by cook)
c     isd = 3 endogenous outlier analysis done
c
      ier=20
      ier1=ier
c      isd=0
c	     call blank(line)
c	     read(lun,'(a)',end=100)line
c	     backspace lun
c      read(lun,*,err=150,end=100)isd
c      if(isd.lt.0.or.isd.gt.3)goto 150
c      call gmh(ier,isd,head)
c      if(line(20:39).ne.head(1:20))then
c        line(20:69)=head(1:50)
c      endif
c      write(*,'(1x,a)')line
c      jems(ier,1)=isd
c      if(isd.eq.0)then
c        jems(ier,2)=0
c        jems(ier,3)=0
c        jems(ier,4)=0
c        ier=0
c        return
c      endif
c
      isd1=0
      isd2=0
      call blank(line)
      read(lun,'(a)',end=100)line
      backspace lun
      read(lun,*,err=150,end=100)isd1,isd2
      if(isd1.lt.0.or.isd1.gt.3)goto 150
      call gmh(ier,isd1,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,1)=isd1
      jems(ier,5)=isd2
      if(isd1.eq.0)then
        jems(ier,2)=0
        jems(ier,3)=0
        jems(ier,4)=0
        ier=0
        return
      endif
c
      ier1=ier1+1
      nww=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)nww
      if((isd1.gt.1).and.nww.lt.5.or.nww.gt.50)goto 150   !new
      call gmh(ier1,nww,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,2)=nww
c
      ier1=ier1+1
      ipg=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)ipg
      if((isd1.gt.1).and.ipg.lt.5.or.ipg.gt.200)goto 150
      call gmh(ier1,ipg,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,3)=ipg
c
      ier1=ier1+1
      nse=0
	     call blank(line)
	     read(lun,'(a)',end=100)line
	     backspace lun
      read(lun,*,err=150,end=100)nse
      if((isd1.gt.1).and.nse.lt.0.or.nse.gt.5)goto 150
      call gmh(ier1,nse,head)
      if(line(20:39).ne.head(1:20))then
        line(20:69)=head(1:50)
      endif
      write(*,'(1x,a)')line
      jems(ier,4)=nse
c
      ier=0
      return
  100 write(*,'(/
     *  1x,''*** end-of-file reading batch commands. re-run''/
     *  1x,''*** the program in interactive mode to create''/
     *  1x,''*** the correct log files for batch mode runs.'')')
      return
  150 write(*,'(/
     *  1x,''*** error reading batch commands. re-run the''/
     *  1x,''*** program in interactive mode to create the''/
     *  1x,''*** correct log files for batch mode runs.'')')
ccc      write(*,'(1x,''ier: '',2i5)')ier,ier1
      return
      end
*sbr openit
*
      subroutine openit(fil,it,lun)
      character fil*(*),it,type*7
      call blank(fil)
      if((it.ne.'o'.and.it.ne.'O').and.(it.ne.'n'.and.it.ne.'N').and.
     *	(it.ne.'u'.and.it.ne.'U').and.(it.ne.'s'.and.it.ne.'S'))then
        write(*,'(/t2,''*** incorrect file type ***''/)')
        pause
        stop
      endif
      if(it.eq.'o'.or.it.eq.'O')then
        type='old    '
      elseif(it.eq.'n'.or.it.eq.'N')then
        type='new    '
      elseif(it.eq.'u'.or.it.eq.'U')then
        type='unknown'
      else
        type='scratch'
      endif
  100 write(*,'(1x,''file name (/ to exit)'',t45,
     *		''==> '',$)')
      read(*,'(a)')fil
      if(fil(1:1).eq.'/')stop
      open(lun,file=fil,status=type,err=101)
      return
  101 write(*,'(/t2,''*** file cannot be opened. try again or bailout'',
     *		'' ***'')')
      goto 100
      end
*sbr snoop
*
      subroutine snoop(iu4)
      character line*80,more
      logical tab
      tab=.false.
      rewind iu4
      write(*,'(/1x,''snooping in the data file '',
     *		    ''(first 80 characters/line):'')')
      write(*,'(5x,''.........1.........2.........3.........4.....'',
     *             ''....5.........6.........7.........8'')')
    9 i=0
   10 more=' '
   11 read(iu4,'(a)',end=20)line
      i=i+1
      if(tab)goto 13
      do 12 j=1,80
        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,80
          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'')')
      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'')')
      do 30 j=1,5
        read(iu4,'(a)',end=20)line
        if(tab)then
          do 27 k=1,80
            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
*sbr header
*
      subroutine header(head)
      character head*(*),tab
      tab=char(9)
      call blank(head)
      head(1:4)='year'
      head(5:5)=tab
      head(6:11)='ncores'
      head(12:12)=tab
      head(13:16)='mean'
      head(17:17)=tab
      head(18:22)='stdev'
      head(23:23)=tab
      head(24:28)='sterr'
      head(29:29)=tab
      head(30:34)='eff  '
      head(35:35)=tab
      head(36:39)='iter'
      head(40:40)=tab
      head(41:46)='stable'
      head(47:47)=tab
      head(48:52)='25pct'
      head(53:53)=tab
      head(54:59)='median'
      head(60:60)=tab
      head(61:65)='75pct'
      head(66:66)=tab
      head(67:72)='arstn1'
      head(73:73)=tab
      head(74:79)='arstn2'     
      return
      end
*sbr gmh -- get more head(ers)
*
      subroutine gmh(nj,jem,line)
      parameter(maxnj=30,mxlin=30)
      character list(maxnj,mxlin)*50,line*(*)
      call blank(line)
      do i=1,maxnj
        do j=1,mxlin
          call blank(list(i,j))
        enddo
      enddo
c
      nj1=1
      list(nj1,1)='!tucson ring-width format'
      list(nj1,2)='!uea cru tree-ring format'
      list(nj1,3)='!tucson tree-ring index format'
      list(nj1,4)='!tree-ring compact data format'
      list(nj1,5)='!user-defined data format'
c
      nj2=2
      list(nj2,1)='!missing values estimated (no plots)'
      list(nj2,2)='!missing values estimated (w/ plots)'
c
      nj3=3
      list(nj3,1)='!no data transformation (no plots)'
      list(nj3,2)='!log (rt) transform (no plots)'
      list(nj3,3)='!log (rt+1/6) transform (no plots)'
      list(nj3,4)='!inverse hypersine transform (no plots)'
      list(nj3,5)='!spread/level power transform (no plots)'
      list(nj3,6)='!adaptive power transform (no plots)'
      list(nj3,7)='!log (rt) transform (w/ plots)'
      list(nj3,8)='!log (rt+1/6) transform (w/ plots)'
      list(nj3,9)='!inverse hypersine transform (w/ plots)'
      list(nj3,10)='!spread/level power transform (w/ plots)'
      list(nj3,11)='!adaptive power transform (w/ plots)'
c
      nj4=4
      nj5=5
      list(nj4,1)='!    friedman super smoother & alpha'
      list(nj4,2)='!    lowess filter and percent length'
      list(nj4,3)='!    median filter and window length'
	  list(nj4,4)='!    regional curve method (briffa rcs)'
      list(nj4,5)='!    tree-ring first-differences'
      list(nj4,6)='!    no detrending performed'
      list(nj4,7)='!    neg expon curve (k>0), no = opt 4'
      list(nj4,8)='!    neg expon curve (k>0), no = opt 5'
      list(nj4,9)='!    neg expon curve (any k)'
      list(nj4,10)='!    linear regression, any slope curve'
      list(nj4,11)='!    linear regression, neg slope only'
      list(nj4,12)='!    horizontal line through mean'
      list(nj4,13)='!    hugershoff growth curve'
      list(nj4,14)='!    general negative exponential curve'
      list(nj4,15)='!    spline curve (fixed 50% cutoff)'
      list(nj4,16)='!    spline curve (pct n 50% cutoff)'
      list(nj4,17)='!    spline curve (median length 50% cutoff)'
c
      nj6=6
      list(nj6,1)='!no detrending - raw data or differences'
      list(nj6,2)='!non-robust detrending methods used'
      list(nj6,3)='!robust detrending methods used'
c
      nj7=7
      list(nj7,1)='!no interactive detrending'
      list(nj7,2)='!interactive filling of gaps'
      list(nj7,3)='!interactive detrending used'
      list(nj7,4)='!interactive gap and detrend'
c
      nj8=8
      list(nj8,1)='!no indices - raw data or differences used'
      list(nj8,2)='!tree-ring indices or ratios (rt/gt)'
      list(nj8,3)='!residuals or differences (rt-gt)'
c
      nj9=9
      list(nj9,1)='!no autoregressive modeling done'
      list(nj9,2)='!non-robust autoregressive modeling'
      list(nj9,3)='!robust ar modeling (no plots)'
      list(nj9,4)='!robust ar + outliers removed (no plots)'
      list(nj9,5)='!robust ar modeling (w/ plots)'
      list(nj9,6)='!robust ar + outliers removed (w/ plots)'
c
      nj10=10
      list(nj10,1)='!minimum aic pooled ar model order fit (no plots)'
      list(nj10,2)='!user-supplied pooled ar model order fit (no plots)' 
      list(nj10,3)='!minimum aic pooled ar model order fit (w/ plots)'
      list(nj10,4)='!user-supplied pooled ar model order fit (w/ plots)' 
c
      nj11=11
      list(nj11,1)='!pooled ar order fit to all series'
      list(nj11,2)='!each series order fit by minimum aic'
      list(nj11,3)='!supplied ar order fit to all series' 
c
      nj12=12
      list(nj12,1)='!no mean chronologies computed'
      list(nj12,2)='!non-robust (arithmetic) mean chronology'
      list(nj12,3)='!robust (biweight) mean chronology'
      list(nj12,4)='!robust (biweight) mean chronology'
ccc      list(nj12,4)='!robust chronology (w/ biweight plots)'
      list(nj12,5)='!jth quantile tree-ring chronology'
      list(nj12,6)='!arithmetic mean with bootstrap limits'
      list(nj12,7)='!robust mean with bootstrap limits'
      list(nj12,8)='!jth quantile with bootstrap limits'
c
      nj13=13
      list(nj13,1)='!no variance stabilization performed'
      list(nj13,2)='!rbar weighted stabilization method'
      list(nj13,3)='!spline stabilized (pct n 50% cutoff)'
      list(nj13,4)='!spline stabilized (fixed 50% cutoff)'
c
      nj14=14
      list(nj14,1)='!no common period analysis performed'
      list(nj14,2)='!first and last years of common period'
c
      nj15=15
      list(nj15,1)='!site-tree-core separation mask'
c
      nj16=16
      list(nj16,1)='!no running rbar analysis performed'
      list(nj16,2)='!running rbar window/overlap (no plots)'
      list(nj16,3)='!running rbar window/overlap (w/ plots)'
c
      nj17=17
      list(nj17,1)='!summary statistics of ensemble printed'
      list(nj17,2)='!summary & series statistics printed'
      list(nj17,3)='!summary, series & long list chronology'
      list(nj17,4)='!summary, series, long list, curve plts'
      list(nj17,5)='!full output plus interactive detrending'
c
      nj18=18
      list(nj18,1)='!no individual core series saved'
      list(nj18,2)='!series saved in tucson raw data format'
      list(nj18,3)='!series saved in tucson index format'
      list(nj18,4)='!series saved in uea cru index format'
      list(nj18,5)='!series saved in rlh compact data format'
      list(nj18,6)='!series saved in space-delimited columns' 
      list(nj18,7)='!series saved in tab-delimited columns'
      list(nj18,8)='!series saved in comma-delimited columns'
c
      nj19=19
      list(nj19,1)='!no spaghetti and mean chronology plots'
      list(nj19,2)='!spaghetti plots of all series'
      list(nj19,3)='!mean chronology plots'
      list(nj19,4)='!spaghetti and mean chronology plots' 
c
      nj20=20
      list(nj20,1)='!no stand dynamics analyses done'
      list(nj20,2)='!endogenous outlier analysis done'
      list(nj20,3)='!nowacki/abrams release detection'
      list(nj20,4)='!nowacki/abrams (modified by cook)'
      nj21=21
      list(nj20,5)='!running mean window width'
      nj22=22
      list(nj20,6)='!percent growth change threshold'
      nj23=23
      list(nj20,7)='!standard error limit threshold'
c
      if(nj.eq.nj1)then
        line=list(nj1,jem)
      elseif(nj.eq.nj2)then
        if(jem.eq.0)then
          line=list(nj2,1)
        else
          line=list(nj2,2)
        endif
      elseif(nj.eq.nj3)then
        if(jem.eq.0)then
          line=list(nj3,1)
        elseif(jem.eq.1)then
          line=list(nj3,2)
        elseif(jem.eq.2)then
          line=list(nj3,3)
        elseif(jem.eq.3)then
          line=list(nj3,4)
        elseif(jem.eq.4)then
          line=list(nj3,5)
        elseif(jem.eq.5)then
          line=list(nj3,6)
        elseif(jem.eq.-1)then
          line=list(nj3,7)
        elseif(jem.eq.-2)then
          line=list(nj3,8)
        elseif(jem.eq.-3)then
          line=list(nj3,9)
        elseif(jem.eq.-4)then
          line=list(nj3,10)
        elseif(jem.eq.-5)then
          line=list(nj3,11)
        endif
      elseif(nj.eq.nj4.or.nj.eq.nj5)then
        if(jem.eq.-5)then
          line=list(nj4,1)
        elseif(jem.eq.-4)then
          line=list(nj4,2)
        elseif(jem.eq.-3)then
          line=list(nj4,3)
        elseif(jem.eq.-2)then
          line=list(nj4,4)
        elseif(jem.eq.-1)then
          line=list(nj4,5)
        elseif(jem.eq.0)then
          line=list(nj4,6)
        elseif(jem.eq.1)then
          line=list(nj4,7)
        elseif(jem.eq.2)then
          line=list(nj4,8)
        elseif(jem.eq.3)then
          line=list(nj4,9)
        elseif(jem.eq.4)then
          line=list(nj4,10)
        elseif(jem.eq.5)then
          line=list(nj4,11)
        elseif(jem.eq.6)then
          line=list(nj4,12)
        elseif(jem.eq.7)then
          line=list(nj4,13)
        elseif(jem.eq.8)then
          line=list(nj4,14)
        elseif(jem.gt.9)then
          line=list(nj4,15)
        elseif(jem.lt.-9)then
          line=list(nj4,16)
        endif
      elseif(nj.eq.nj6)then
        if(jem.eq.0)then
          line=list(nj6,1)
        elseif(jem.eq.1)then
          line=list(nj6,2)
        elseif(jem.eq.2)then
          line=list(nj6,3)
        endif
      elseif(nj.eq.nj7)then
        if(jem.eq.0)then
          line=list(nj7,1)
        elseif(jem.eq.1)then
          line=list(nj7,2)
        elseif(jem.eq.2)then
          line=list(nj7,3)
        elseif(jem.eq.3)then
          line=list(nj7,4)
        endif
      elseif(nj.eq.nj8)then
        if(jem.eq.0)then
          line=list(nj8,1)
        elseif(jem.eq.1)then
          line=list(nj8,2)
        elseif(jem.eq.2)then
          line=list(nj8,3)
        endif
      elseif(nj.eq.nj9)then
        if(jem.eq.0)then
          line=list(nj9,1)
        elseif(jem.eq.1)then
          line=list(nj9,2)
        elseif(jem.eq.2)then
          line=list(nj9,3)
        elseif(jem.eq.3)then
          line=list(nj9,4)
        elseif(jem.eq.-2)then
          line=list(nj9,5)
        elseif(jem.eq.-3)then
          line=list(nj9,6)
        endif
c
c *** pooled ar modeling options
c
      elseif(nj.eq.nj10)then
        if(jem.eq.0)then
          line=list(nj10,1)
        elseif(jem.eq.1)then
          line=list(nj10,2)
        elseif(jem.eq.-1)then
          line=list(nj10,3)
        elseif(jem.eq.-2)then
          line=list(nj10,4)
        endif
c
c *** series ar modeling options
c
      elseif(nj.eq.nj11)then
        if(jem.eq.0)then
          line=list(nj11,1)
        elseif(jem.eq.-1)then
          line=list(nj11,2)
        elseif(jem.gt.0)then
          line=list(nj11,3)
        endif
c
c *** mean chronology options
c
      elseif(nj.eq.nj12)then
        if(jem.eq.0)then
          line=list(nj12,1)
        elseif(jem.eq.1)then
          line=list(nj12,2)
        elseif(jem.eq.2)then
          line=list(nj12,3)
        elseif(jem.eq.3)then
          line=list(nj12,4)
        elseif(jem.eq.5)then
          line=list(nj12,5)
        elseif(jem.eq.6)then
          line=list(nj12,6)
        elseif(jem.eq.7)then
          line=list(nj12,7)
        elseif(jem.eq.8)then
          line=list(nj12,8)
        endif
c
c *** variance stabilization options
c
      elseif(nj.eq.nj13)then
        if(jem.eq.0)then
          line=list(nj13,1)
        elseif(jem.eq.1)then
          line=list(nj13,2)
        elseif(jem.lt.-9)then
          line=list(nj13,3)
        elseif(jem.gt.9)then
          line=list(nj13,4)
        endif
c
c *** common period analysis options
c
      elseif(nj.eq.nj14)then
        if(jem.le.0)then
          line=list(nj14,1)
        else
          line=list(nj14,2)
        endif
c
c *** site/tree/core mask
c
      elseif(nj.eq.nj15)then
        line=list(nj15,1)
c
c *** running rbar analysis options
c
      elseif(nj.eq.nj16)then
        if(jem.eq.0)then
          line=list(nj16,1)
        elseif(jem.gt.0)then
          line=list(nj16,2)
        elseif(jem.lt.0)then
          line=list(nj16,3)
        endif
c
c *** output options
c
      elseif(nj.eq.nj17)then
        if(jem.eq.1)then
          line=list(nj17,1)
        elseif(jem.eq.2)then
          line=list(nj17,2)
        elseif(jem.eq.3)then
          line=list(nj17,3)
        elseif(jem.eq.4)then
          line=list(nj17,4)
        elseif(jem.eq.5)then
          line=list(nj17,5)
        endif
c
c *** data save options
c
      elseif(nj.eq.nj18)then
        if(jem.eq.0)then
          line=list(nj18,1)
        elseif(jem.eq.1)then
          line=list(nj18,2)
        elseif(jem.eq.2)then
          line=list(nj18,3)
        elseif(jem.eq.3)then
          line=list(nj18,4)
        elseif(jem.eq.4)then
          line=list(nj18,5)
        elseif(jem.eq.5)then
          line=list(nj18,6)
        elseif(jem.eq.6)then
          line=list(nj18,7)
        elseif(jem.eq.7)then
          line=list(nj18,8)
        endif
c
c *** high-resolution data display options
c
      elseif(nj.eq.nj19)then
        if(jem.eq.0)then
          line=list(nj19,1)
        elseif(jem.eq.1)then
          line=list(nj19,2)
        elseif(jem.eq.2)then
          line=list(nj19,3)
        elseif(jem.eq.3)then
          line=list(nj19,4)
        endif
c
c *** stand dynamics stuff
c
      elseif(nj.eq.nj20)then
        if(jem.eq.0)then
          line=list(nj20,1)
        elseif(jem.eq.1)then
          line=list(nj20,2)
        elseif(jem.eq.2)then
          line=list(nj20,3)
        elseif(jem.eq.3)then
          line=list(nj20,4)
        endif
      elseif(nj.eq.nj21)then
        line=list(nj20,5)
      elseif(nj.eq.nj22)then
        line=list(nj20,6)
      elseif(nj.eq.nj23)then
        line=list(nj20,7)
c
c *** who the hell knows
c
      else
        line='!bloody hell if i know!'
      endif
      return
      end
*sbr csr -- character string length
*
      subroutine csr(line,length,iopt)
      character line*(*)
      j=len(line)
      goto(1,2,3),iopt
    1 do i=1,j                            !go forwards
        k=i
        if(line(k:k).eq.' ')then
          length=k-1
          goto 10
        endif
      enddo
    2 do i=1,j                            !go backwards
        k=j-i+1
        if(line(k:k).ne.' ')then
          length=k
          goto 10
        endif
      enddo
    3 do i=1,j                            !special
        k=i
        if(line(k:k).eq.' '.or.line(k:k).eq.'.')then
          length=k-1
          goto 10
        endif
      enddo
   10 return
      end
*sbr intfrm1
*
      subroutine intfrm1(intnum,frm)
      integer intnum
      character frm*20
      call blank(frm)
      if(intnum.eq.0)frm(1:4)='(i1)'
      if(intnum.le.-1.and.intnum.gt.-10)frm(1:4)='(i2)'
      if(intnum.ge.1.and.intnum.lt.10)frm(1:4)='(i1)'
      if(intnum.le.-10.and.intnum.gt.-100)frm(1:4)='(i3)'
      if(intnum.ge.10.and.intnum.lt.100)frm(1:4)='(i2)'
      if(intnum.le.-100.and.intnum.gt.-1000)frm(1:4)='(i4)'
      if(intnum.ge.100.and.intnum.lt.1000)frm(1:4)='(i3)'
      if(intnum.le.-1000.and.intnum.gt.-10000)frm(1:4)='(i5)'
      if(intnum.ge.1000.and.intnum.lt.10000)frm(1:4)='(i4)'
      if(intnum.le.-10000.and.intnum.gt.-100000)frm(1:4)='(i6)'
      if(intnum.ge.10000.and.intnum.lt.100000)frm(1:4)='(i5)'
      if(intnum.le.-100000.and.intnum.gt.-1000000)frm(1:4)='(i7)'
      if(intnum.ge.100000.and.intnum.lt.1000000)frm(1:4)='(i6)'
      return
      end
*sbr trread
*
      subroutine trread(x,y,nss,nc,idate,id,ident,mxy,mxs,tit,
     *  gmn,stats,mgap)
      real*4 x(mxy,mxs),y(mxy),stats(mxs,12)
      integer idate(mxs+2,10),nss(mxy)
      character id*8,ident(mxs)*8,tit*(*),line*80,tag*3
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	  common/icommands/jems,ndd            !new pjk
c
c *** set up equivalence
c
      itn1=jems(3,1)
      itn2=jems(3,2)
      ipo=jems(17,1)              !printout option
c
c *** dummy up the array
c
      do i=1,mxy
        do j=1,mxs
          x(i,j)=-9.99
        enddo
      enddo
c
c *** read in data
c
      nc=0
      mgap=0
      iiyr=9999
      llyr=-9999
      ier=0
      ifl=0
      write(iu11,'(/t2,''|------------------- tree-ring series read '',
     *  ''in for processing ------------------|'')')
    1 call blank(id)
      tag='   '
      if(q.eq.'mr'.or.q.eq.'MR')then
        call trrw(id,iyr,n,y,nss,ifl,iu10,0,'mr',line,tag,mxy,itrdb)	!raw ring widths
        if(ifl.eq.1)then
          write(iu11,'(/2x,''data header lines:'')')
          do j=1,3
            if(itrdb(j)(1:6).ne.'      ')write(iu11,'(2x,a)')itrdb(j)
          enddo
        endif
        if(n.le.0)goto 2
      elseif(q.eq.'ir'.or.q.eq.'IR')then
        id(1:8)='********'
        call trrw(id,iyr,n,y,nss,ifl,iu10,0,'ir',line,tag,mxy,itrdb)	!tree-ring indices
        if(n.le.0)goto 2
      elseif(q.eq.'cr'.or.q.eq.'CR')then
        call rinfrn(id,iyr,n,y,nss,ifl,iu10,line,mxy)
        if(n.le.0)goto 2
      elseif(q.eq.'cd'.or.q.eq.'CD')then
        call cdf(id,y,iyr,n,ifl,iu10,mxy,line)
        if(n.lt.0)goto 2
      endif
      if(n.gt.mxy)then
        write(*,'(/t2,''*** series read in exceeds maximum allowable '',
     *    ''length: '',a8,2x,i5,'' > '',i5,'' max ***'')')id,n,mxy
        pause
        stop
      endif
      if(ifl.gt.mxs)then
        write(*,'(/t2,''*** number of series exceeds maximum allowed: '',
     *		  i3,'' max ***'')')mxs
        pause
        stop
      endif
c
c *** count and get earliest and latest years
c
      if(bf.eq.'y'.or.bf.eq.'Y')then
        if(idate(ifl,8).eq.1)then
          nc=nc+1
c          if(bd.eq.'y'.or.bd.eq.'y')then
c            if(id(1:8).ne.ident(ifl)(1:8))then
c              write(*,'(/1x,''*** id mismatch between batch detail '',
c     *          ''and data files'')')
c              write(*,'(1x,''*** series '',i4,''  id: '',a8,2x,
c     *          ''batch detail id: '',a8)')ifl,id(1:6),ident(ifl)(1:6)
c              pause
c              stop
c            endif
c            if(iyr.ne.idate(ifl,1))then
c              write(*,'(/1x,''*** first year mismatch between batch '',
c     *          ''detail and data files'')')
c              write(*,'(1x,''*** series '',i4,''  ify: '',i6,2x,
c     *          ''batch detail ify: '',i6)')ifl,iyr,idate(ifl,1)
c              pause
c              stop
c            endif
c            if(iyr+n-1.ne.idate(ifl,2))then
c              write(*,'(/1x,''*** last year mismatch between batch '',
c     *          ''detail and data files'')')
c              write(*,'(1x,''*** series '',i4,''  ily: '',i6,2x,
c     *          ''batch detail ily: '',i6)')ifl,iyr+n-1,idate(ifl,2)
c              pause
c              stop
c            endif
c          else
            idate(nc,1)=iyr
            idate(nc,2)=iyr+n-1
c          endif
          ident(nc)=id
          do j=1,9
            idate(nc,j)=idate(ifl,j)
          enddo
        else
          goto 1
        endif
      else
        nc=nc+1
        ident(nc)=id
        idate(nc,1)=iyr
        idate(nc,2)=iyr+n-1
      endif
      if(nc.eq.1)then
        call blank(tit)
        tit=line
      endif
      iiyr=min0(iyr,iiyr)
      llyr=max0(iyr+n-1,llyr)
ccc      do i=1,n
ccc        x(i,nc)=y(i)
ccc      enddo
c
c *** do missing values check
c
      if(nc.eq.1)then
        write(iu11,'(/t2,''|------------ series gaps found '',
     *    ''based on any negative number found ------------|'')')
        if(itn1.gt.0)then
          write(iu11,'(t2,''      *** when data are transformed, '',
     *      ''zeros are also treated as missing ***'')')
        endif
        write(iu11,'(/t2,''       series      ident      '',
     *    ''results of scans for gaps or missing values'')')
      endif
      m1=0
      call mia(y,ident(nc),nc,nss,n,m1,iyr,itn1,iu11)
      if(m1.gt.0)then
        mgap=mgap+1
      endif
      do i=1,n
        x(i,nc)=y(i)
      enddo
c
c *** compute series statistics
c
      call moment1(y,nss,n,ave,adev,sdev,var,skew,curt,sens,ac)
      stats(nc,1)=n-m1
      stats(nc,2)=ave
      stats(nc,3)=sdev
      stats(nc,4)=skew
      stats(nc,5)=curt
      stats(nc,6)=sens
      stats(nc,7)=ac
      goto 1
c
c *** end of file reading data, so rock-and-roll!!!
c

    2 if(nc.le.0)then     
        pause' *** nc .le. 0 after reading tree-ring data'
        stop
      endif
      if(mgap.eq.0)then
        write(iu11,'(/28x,''--- no gaps in data found ---'')')
      endif
      nyr=llyr-iiyr+1
      idate(nc+1,1)=iiyr
      idate(nc+1,2)=llyr
      if(ipo.gt.1)then
        write(iu11,'(/t2,''|------------------ statistics of '',
     *    ''raw tree-ring measurements ------------------|'')')
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          if(j.eq.1.or.mod(j,20).eq.0)then
            write(iu11,'(/t2,''series   ident   frst   last   '',
     *      ''year    mean   stdev   skew   kurt   sens   ac(1)'')')		                                   
          endif
          write(iu11,'(t2,i5,3x,a7,i6,2i7,2f8.3,3f7.3,f8.3)')
     *      j,ident(j),ify,ily,n,(stats(j,k),k=2,7)
        enddo
      endif
      write(*,'(/1x,i6,'' series from'',i7,'' to'',i7,i8,
     *		'' years'')')nc,iiyr,llyr,nyr
      write(iu11,'(/t8,''number of series read in: '',i4,''   from'',i7,
     *  ''  to'',i7,i8,'' years'')')nc,iiyr,llyr,nyr
      if(nc.eq.1)return
      write(iu11,'(/t2,''|---------------- summary of raw tree-ring '',
     *  ''series statistics ------------------|''/)')
      if(nyr.gt.mxy)then
        write(*,'(/t2,''*** total series length exceeds maximum '',
     *    ''allowable length: '',i6,'' > '',i6,'' max ***'')')nyr,mxy
        pause
        stop
      endif
      do j=1,nc
        nss(j)=1
      enddo
      do j=1,7
        call moment1(stats(1,j),nss,nc,ave,adev,sdev,var,skew,
     *    curt,sens,ac)
        call mfs1(stats(1,j),y,nss,nc,rmd,hh,hl,fsd,rmn,rmx)
        stats(1,j)=ave
        stats(2,j)=sdev
        stats(3,j)=rmd
        stats(4,j)=fsd
        stats(5,j)=rmn
        stats(6,j)=hl
        stats(7,j)=hh
        stats(8,j)=rmx
      enddo
      gmn=stats(8,2)               !use maximum raw for later scaling
      write(iu11,'(t33,''year    mean   stdev   skew   kurt   sens   '',
     *  ''ac(1)'')')		                                   
      write(iu11,'(t2,''arithmetic mean'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(1,1)+0.5),(stats(1,j),j=2,7)
      write(iu11,'(t2,''standard deviation'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(2,1)),(stats(2,j),j=2,7)
      write(iu11,'(t2,''median (50th quantile)'',t33,i4,2f8.3,3f7.3,
     *  f8.3)')ifix(stats(3,1)),(stats(3,j),j=2,7)
      write(iu11,'(t2,''interquartile range'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(4,1)),(stats(4,j),j=2,7)
      write(iu11,'(t2,''minimum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(5,1)),(stats(5,j),j=2,7)
      write(iu11,'(t2,''lower hinge (25th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(6,1)),(stats(6,j),j=2,7)
      write(iu11,'(t2,''upper hinge (75th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(7,1)),(stats(7,j),j=2,7)
      write(iu11,'(t2,''maximum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(8,1)),(stats(8,j),j=2,7)
      return
      end
*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*(*),ida*8,line*80,q*2,tit*(*),tag*3
      character itrdb(3)*85
      integer nc(mxy),iy(10),inc(10),flag
      real*4 y(mxy)
      flag=-9999
ccc      tag=tit(1:3)
      call blank(tit)
      ntit=min0(len(tit),80)
      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)stop'sbr trrw:  over 25 text lines'
      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
        tit(1:ntit)=line(1:ntit)
        itrdb(ier)(1:ntit)=line(1:ntit)
      else
        if(iuo .gt. 0)write(iuo,'(1x,a)')line
          if(ier.le.3)then
            itrdb(ier)(1:ntit)=line(1:ntit)
          endif
        write(*,'(1x,a)')line
      endif
    1 call blank(line)
      read(iu,'(a80)',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
*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 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
*sbr rinfrn
c
c *** subroutine rinfrn
c
c *** from keith briffa and phil jones for reading in
c *** tree-ring data in climatic research unit format
c
      subroutine rinfrn(dent,isyear,num,x,nc,ifl,lun,tit,mxy)   
      real*4 x(mxy)
      integer nc(mxy)
      character dent*8,line*80,tit*(*)
      ier=0
      call blank(tit)
    1 call blank(line)
      read(lun,'(a)',end=10)line 
      read(line,'(a6,2i4)',err=5)dent(1:6),isyear,ieyear
      goto 20
    5 ier=ier+1
      if(ier.eq.1)then
        ntit=min0(len(tit),80)
        write(*,'(/1x,''title of data:''/1x,a)')line
        tit(1:ntit)=line(1:ntit)
        goto 1
      elseif(ier.le.5)then
        goto 1
      else
        write(*,'(/1x,'' *** too many read errors in rinfrn'')')
        pause
        stop
      endif
   10 num=-999
      ifl=-999
      return
   20 dent(7:8)='  '
      n=ieyear-isyear+1
      k=mod(isyear,10)
      if(isyear.lt.0)k=10-k
      nr=n+k
      read(lun,'((10x,10(f4.2,i3)))',err=30)(x(i),nc(i),i=1,nr)
      do i=1,n
        nc(i)=nc(i+k) 
        x(i)=x(i+k) 
      enddo  
      num=ieyear-isyear+1
      ifl=ifl+1
      return
   30 write(*,'(1x,/'' *** error reading tree-ring data in uea '',
     *  ''cru data format: series '',a6)')dent(1:6)
      backspace(lun)
      call blank(line)
      read(lun,'(a)')line
      write(*,'(1x,''line: '',a)')line
      pause
      stop
      end
*sbr cdf
c
c *** subroutine to read compact tree-ring data format
c
c     id   series identification
c     y    data array read and returned
c     ify  first year of series
c     ny   total number of years
c     ifl  series count
c     lun  logical unit for reading data
c     mxy  maximum length of x (specified in main program)
c
      subroutine cdf(id,y,ify,ny,ifl,lun,mxy,tit)
      real*4 y(mxy)
      character id*8,line*80,frm*8,tit*(*)
      call blank(tit)
      ier=0
    5 call blank(line)
      call blank(id)
      call blank(frm)
      read(lun,'(a)',end=10)line
      read(line,'(1x,i7,2x,i8,3x,a8)',err=20)ny,ify,id
      if(ny.gt.mxy)goto 30
      read(line(69:71),'(i3)')nc
      read(line(72:79),'(a8)')frm
      read(lun,frm,err=40)(y(i),i=1,ny)
      fac=10.0**nc
      do i=1,ny
        y(i)=y(i)*fac
      enddo
      ifl=ifl+1
ccc      write(*,'(i5,2i6,a8,2x,a8)')ifl,ny,ify,id,frm
      return
   10 ny=-999
      ifl=-999
      return
   20 ier=ier+1
      if(ier.gt.3)then
        write(*,'(/t2,''*** header line read error in sbr cdf: ''/
     *    1x,a,1x,2i6,2x,a/1x,a)')id,ify,ny,frm,line
        pause
        stop
      endif
      if(ier.eq.1)then
        write(*,'(/1x,''title of data:''/1x,a)')line
        tit=line
        goto 5
      else
        write(*,'(1x,a)')line
      endif
   30 write(*,'(/t2,''*** series length exceeds maximum allowable '',
     *  ''length: '',a8,2x,i4,'' > '',i4)')id,ny,mxy
      pause
      stop
   40 ier=ier+1
      backspace lun
      call blank(line)
      read(lun,'(a)')line
      write(*,'(/t2,''*** error reading data in sbr cdf: ''/
     *  1x,a,1x,2i6,2x,a/1x,a)')id,ify,ny,frm,line
      pause
      stop
      end
*rtn datr: reads a time series in any of three formats:
*
* (~) compact
* (|) precision
* (@) condensed (obsolete)
*
* programmed copyright (c) feb 1990 by
* richard l holmes, lab. de dendrocronologÁa, cricyt - mendoza - argentina
* modified copyright (c) 30 mar 1999
*
* qid: series ident to 40 characters
* ny:  number of data in series; returned as zero at end of file
* rm:  real time series array
* jy:  first year of time series
* io:  logical unit for reading data
*
      subroutine datr(qid,ny,rm,jy,io,mxy)
      implicit character(q)
ccc      common/dpln/iu(64),iuo,iaj
      character qln*80,qf*8,qid*(*)
      real*4 rm(mxy)
*
* read line, check format
*#      lz=min0(len(qid),40)
    2 ny=0
      call blank(qln)
      read(io,'(a)',err=99,end=99)qln
      call csr(qln,ll,2)
ccc      ll=largo(qln)
*
* blank line
      if(ll.le.1)then
      goto 2
*
* compact format (~)
      elseif(qln(ll:ll).eq.'~')then
      goto 1
*
* precision format (|)
      elseif(qln(:1).eq.'|')then
      backspace io
      read(io,'(2a,2i8,$)',err=2,end=98)qz,qf,ny,jy
      qid=qf
      if(qz.ne.'|'.or.ny.le.0)goto 2
      read(io,*,err=97,end=98)(rm(j),j=1,ny)
      return
*
* condensed format (@)
      elseif(qln(ll:ll).eq.'@')then
      qf=qln(ll-7:ll-5)//'f'//qln(ll-2:ll-2)//'.0)'
      qln(ll-11:ll-1)='  0'//qf
      goto 1
      else
*
* text line
ccc      if(iuo.gt.0)write(iuo,'('' text in file: '',a)')qln
      goto 2
      endif
*
* read header and data
    1 lq=index(qln,'=')
      lqi=max0(lq-8,1)
      qf=qln(lqi:lq-1)
      read(qf,'(i8)',err=2,end=2)ny
      qln(lq:lq)=' '
      lq2=index(qln,'=')
      lqi=max0(lq2-8,lq+2)
      qf=qln(lqi:lq2-1)
      read(qf,'(i8)',err=2,end=2)jy
      lq=lq2+3
*
      read(qln(ll-11:ll-1),'(i3,a)',err=2,end=2)nc,qf
      qid=qln(lq:ll-11)
      read(io,qf,err=97,end=98)(rm(j),j=1,ny)
      fac=10.**nc
*
      do j=1,ny
      rm(j)=rm(j)*fac
      enddo
      return
*
* error messages
   97 write(*,'('' >> sbr datr:  read error'')')
      return
   98 write(*,'('' >> sbr datr:  eof unexpected'')')
   99 end ! datr
*rtn datw: write time series on disk file in compact format (~)
*
* programmed copyright (c) feb 1990 by
* richard l holmes, lab. de dendrocronologÁa, cricyt - mendoza - argentina
* modificado en inisefor, universidad nacional de costa rica,
* heredia, costa rica (c) 30 oct 1998
* modified copyright (c) 18 apr 1999
*
* qid: series ident to 40 characters
* rm:  time series array
* izz: integer output array
* ny:  number of data in series
* jy:  first year of time series
* io:  logical unit for writing data
* tag: data type identifier
* mxy: maximum length of array
*
      subroutine datw(qid,rm,izz,ny,jy,io,tag,mxy)
      parameter(mx=4096)
ccc      common/iarr/izz(mx)
      character qf*8,qid*(*),tag*3
      real*4 rm(mxy)
      integer izz(mxy)
*
      if(ny.le.0)return
      la=min0(len(qid),40)
      call csr(qid(1:la),lz,2)
ccc      lz=largo(qid(:la))
*
* encontrar espacio necesario:
      ne=1
      lmax=1
      vmax=0.
      fx=1.
*
      do i=1,ny
      fx=amax1(fx,rm(i),rm(i)*(-10.))
      if(abs(rm(i)).gt.vmax)then
      vmax=abs(rm(i))
      lmax=i
      endif
      enddo ! i loop
*
* factor para multiplicar datos
      fy=1.e16
      do k=16,-16,-1
      fy=10.**k
      if(fx*fy.lt.999999.5)goto 2
      enddo ! k loop
*
* convertir arreglo a entero por factor
    2 do j=1,ny
      izz(j)=nint(rm(j)*fy)
      enddo ! j loop
*
* calcular acortamiento - incrementar modulo hasta hallar discrepancia
      m=1
      do i=1,6
      m=m*10
      do j=1,ny
      if(mod(izz(j),m).ne.0)then
      m=m/10
      ne=7-i
      goto 1
      endif
      enddo ! j loop
      enddo ! i loop
*
* convertir datos enteros
    1 if(m.ge.10)then
      do j=1,ny
      izz(j)=izz(j)/m
      enddo ! j loop
      endif
*
      if(izz(lmax).ne.0)then
      v=abs(vmax/float(izz(lmax)))
      else
      v=0.
      endif
*
      if(v.gt.0.)then
      nc=nint(alog10(v))
      else
      nc=0
      endif
*
* primer rengl¢n:  n£mero de aÛos, primer aÛo, identificaci¢n,
* exponente, formato, c¢digo(~)
      nl=80/ne
      write(qf,'(''('',i2,''f'',i1,''.0)'')')nl,ne
      write(io,'(i8,''=n'',i8,''=i '',a,t69,i3,a,''~'',1x,a)')
     &ny,jy,qid(:lz),nc,qf,tag
      write(qf,'(''('',i2,''i'',i1,'')  '')')nl,ne
*
* escribir serie de datos
      write(io,qf)(izz(j),j=1,ny)
      end ! datw
*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
*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
*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
*sbr mfs1
*
*     computes the median, hinges, and fourth-spread of 
*     n observations allowing for missing values or gaps
*
*     inputs:
*
*     y    =  input series
*     x    =  work vector used for ranked data
*     ns   =  binary array, 1=good value; 0=missing value
*     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:  qcksrt
*
      subroutine mfs1(y,x,ns,n,xmed,hh,hl,fsd,rmn,rmx)
      real*4 x(n),y(n)
      real*4 ns(n)
c
      integer j,k,temp1,temp2       !pjk
*
* check for missing values
      n1=0
      do j=1,n
        if(ns(j).gt.0)then
          n1=n1+1
          x(n1)=y(j)
        endif
      enddo
*
* rank the observations
      call qcksrt(n1,x)
      rmn=x(1)
      rmx=x(n1)
      k=n1
      j=(k/2)+1
      temp1=n1+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=n1-k+j
      temp2=n1+1-j
      hh=(x(temp1)+x(temp2))/2.0
*
* the fourth-spread
      fsd=hh-hl
      return
      end
*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
*sbr mia -- missing in action
*
c  for detrending tree-ring series with gaps indicated by flags
c  the missing values indicated by the missing value flag are
c  stripped out of the series. the reduced series is returned
c  with order number information for input into the detrending
c  routines that detrend tree-ring series as a function of time
c
c     x     original series with possible missing values
c     id    identifier of series being scanned
c     nc    sequence number of series being scanned
c     ns    binary array: 1=true value; 0=missing value
c     n     total series length including missing values
c     m1    number of missing values
c     ify   first year of input tree-ring series
c     iu11  logical unit number for printer
c
      subroutine mia(x,id,nc,ns,n,m1,ify,itn1,iu11)
      real*4 x(n)
      integer ns(n),msy(1000),jgap(500)     !dimension?? -pjk
      character id*(*)
      zero=0.0e0
      m1=0
c
c *** check for esper plateaus
c
      do i=1,n
        x1=x(i)
        if(x1.gt.0.and.i.lt.n)then
          j=0
          nsame=0
   10     j=i+nsame+1
          if(j.le.n.and.(x(j).eq.x1))then
            nsame=nsame+1
            goto 10
          endif
          if(nsame.gt.3)then
            do j=1,nsame+1
              k=i+j-1
              x(k)=-x(k)
            enddo
          endif
        endif
      enddo
c
c *** test for missing values
c
      do i=1,n
        ns(i)=1
        if(itn1.eq.0)then
          if(x(i).lt.zero)then
            ns(i)=0
            m1=m1+1
            msy(m1)=i+ify-1
          endif
        elseif(itn1.gt.0)then
          if(x(i).le.zero)then
            ns(i)=0
            m1=m1+1
            msy(m1)=i+ify-1
          endif
        endif
      enddo
c
c *** if found, determine what years and write out results
c
      if(m1.gt.0)then
        ngap=0
        if((msy(m1)-msy(1)+1).eq.m1)then
          ngap=1
          ifyr=msy(1)
          ilyr=msy(m1)
          jgap((ngap-1)*2+1)=ifyr
          jgap((ngap-1)*2+2)=ilyr    
        else
          ifyr=msy(1)
          do i=2,m1
            ndif=0
            ndif=msy(i)-msy(i-1)
            if(ndif.gt.1.and.i.le.m1)then
              ngap=ngap+1
              ilyr=msy(i-1)
              jgap((ngap-1)*2+1)=ifyr
              jgap((ngap-1)*2+2)=ilyr    
              ifyr=msy(i)
              if(ndif.gt.1.and.i.eq.m1)then
                ngap=ngap+1
                ifyr=msy(m1)
                ilyr=msy(m1)
                jgap((ngap-1)*2+1)=ifyr
                jgap((ngap-1)*2+2)=ilyr  
              endif
            elseif(ndif.eq.0.or.i.eq.m1)then
              ngap=ngap+1
              ilyr=msy(i)
              jgap((ngap-1)*2+1)=ifyr
              jgap((ngap-1)*2+2)=ilyr    
            endif
          enddo
        endif
        write(iu11,'(i12,7x,a8,7x,''missing values found:'',i4,
     *    '' in'',i4,'' gaps'')')nc,id,m1,ngap
        write(iu11,'((13x,''/'',4(i5,1x,i5,'' /'')))')
     *    (jgap(k),k=1,ngap*2)
        write(iu11,'(7x,68(''-''))')
      endif
      return
      end
*sbr sis
c
c *** save individual series
c
c     x(i,j) --  matrix of tree-ring data to be saved
c     nc     --  number of series in matrix x
c     idate  --  matrix of information on series (dates, etc.)
c     ident  --  matrix of series ids
c     nss    --  sample size information
c     keep   --  array of series to be saved, used internally
c     ics    --  data save options:
c                1 = tucson raw data format
c                2 = tucson index format
c                3 = uea cru index format
c                4 = rlh compact format
c                5 = column format, with space delimiters
c                6 = column format, with tab delimiters
c                7 = column format, with comma delimiters
c     tit    --  title of data set, used for ics = 1
c     fil1   --  character array for file names
c     mxy    --  maximum row dimension of x, from main program
c     mxs    --  maximum column dimension of x, from main program
c     tag    --  tag for series type
c
      subroutine sis(x,wrk,nc,idate,ident,nss,keep,tit,mxy,mxs,tag)
      parameter(maxlen=9006)
      real*4 x(mxy,mxs),wrk(mxy)
      integer idate(mxs+2,10),nss(mxy),keep(mxs)
      character ident(mxs)*8,tit*(*),tag*3,tag1*3,tab
      character line*9006,tit1*85
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      ics=jems(18,1)
c
      if(ics.gt.4)then
        maxl=nc*9+6
        if(maxl.gt.maxlen)then
          write(*,'(/1x,''*** too many series to store in '',
     *      ''column mode ***'')')
          return
        endif
      endif
      if(ics.eq.6)then
        tab=char(9)
      elseif(ics.eq.7)then
        tab=','
      endif
      ll=len(fil1)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(fil1(jj:jj).ne.' ')goto 10
      enddo
   10 ll=jj
c
c *** write out header line for tucson ring-width or column format files
c
      nk=0
      if(ics.gt.4)then
        ifk=9999
        ilk=-9999
        iskp=0
        nk=0
        do j=1,nc
          if(idate(j,9).eq.1)then
            nk=nk+1
            keep(nk)=j
            ify=idate(j,1)
            ily=idate(j,2)
            ifk=min0(ify,ifk)
            ilk=max0(ily,ilk)
          endif
        enddo
        iskp=ifk-idate(nc+1,1)
        nyk=ilk-ifk+1
        if(nk.eq.0)then
          return
        endif
        if(ics.eq.5)then
          write(iu14,'(''  year'',1000(1x,a8))')
     *      (ident(keep(j))(1:8),j=1,nk)
        elseif(ics.gt.5)then
          write(iu14,'('' year'',1000(a,a8))')
     *      (tab,ident(keep(j))(1:8),j=1,nk)
        endif
      endif
c
c *** save the individual series now
c
      if(ics.lt.5)then
        ifmn=idate(nc+1,1)
        nk=0
        do j=1,nc
          tag1=tag
          if(idate(j,9).eq.1)then
            nk=nk+1
            ify=idate(j,1)
            ily=idate(j,2)
            nyr=ily-ify+1
            ist=ify-ifmn+1
            if(ics.eq.1)then
              call trrw(ident(j),ify,nyr,x(ist,j),nss,ifl,iu14,0,'mw',
     *     	    tit1,tag1,mxy,itrdb)
            elseif(ics.eq.2)then
              do i=1,nyr
                nss(i)=1
                ii=i+ist-1
                wrk(i)=x(ii,j)
                if(wrk(i).lt.0)wrk(i)=0.0
              enddo
              call trrw(ident(j),ify,nyr,wrk,nss,ifl,iu14,0,'iw',
     *    		    tit1,tag1,mxy,itrdb)
            elseif(ics.eq.3)then
              do i=1,nyr
                nss(i)=1
                ii=i+ist-1
                wrk(i)=x(ii,j)
                if(wrk(i).lt.0)wrk(i)=0.0
              enddo
              call trrw(ident(j),ify,nyr,wrk,nss,ifl,iu14,0,'cr',
     *    		    tit1,tag1,mxy,itrdb)
            elseif(ics.eq.4)then
              call datw(ident(j),x(ist,j),nss,nyr,ify,iu14,tag1,mxy)
            endif
          endif
        enddo
        if(nk.eq.0)then
          return
        endif
      elseif(ics.ge.5)then
        if(ics.eq.5)tab=' '
        nkk=nk*9+6
        do i=1,nyk
          call blank(line)
          write(line,'(i6,1000(a,f8.4))')ifk+i-1,
     *      (tab,x(i+iskp,keep(j)),j=1,nk)
          if(ics.eq.5)then
            do j=1,nkk
              k=j+7
              if(line(j:k).eq.' -9.9900')line(j:k)='   .    '
            enddo
          endif
          write(iu14,'(a)')line(1:nkk)
        enddo
      endif
      return
      end
*sbr fillin
*
      subroutine fillin(x,nss,wrk1,wrk2,wrk3,nc,idate,ident,mxy,mxs)
      parameter(mxr=1000)
      real*4 x(mxy,mxs),wrk1(mxy),wrk2(mxy),wrk3(mxy)
      real*4 gap1(500),gap2(500),wgt(mxr)
      integer idate(mxs+2,10),nss(mxy),msy(500),jgap(500),ns(mxr)
      character ident(mxs)*8,id*8,tit*85,datum*8,frm*20
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
      open(iu14,file='curves.dat',status='unknown')
      close(iu14,status='delete')
      open(iu14,file='curves.dat',status='unknown')
c
c *** detrend each series with a 20-year spline
c
      ifg1=jems(2,1)
      ifg2=jems(2,2)
      iplt=jems(2,2)
      itn1=jems(3,1)
      itn2=jems(3,2)
      ido=jems(7,1)
      krb1=jems(12,1)
      krb2=jems(12,2)
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        ist=ify-ifmny+1
c
c *** create missing value mask in array nss and give missing values large weights
c
        n1=0
        m1=0
        do i=1,nyr
          ii=ist+i-1
          nss(i)=1
          wrk3(i)=1.0
          if(itn1.eq.0)then
            if(x(ii,j).lt.0.0)then
              nss(i)=0
              wrk3(i)=999.0
              if(x(ii,j).ne.-9.99)x(ii,j)=-9.99
              m1=m1+1
              msy(m1)=i+ify-1
              n1=n1+1
            endif
          elseif(itn1.gt.0)then
            if(x(ii,j).le.0.0)then
              nss(i)=0
              wrk3(i)=999.0
              if(x(ii,j).ne.-9.99)x(ii,j)=-9.99
              m1=m1+1
              msy(m1)=i+ify-1
              n1=n1+1
            endif
          endif
          wrk1(i)=x(ii,j)
        enddo
        if(m1.gt.0)then
          ngap=0
          if((msy(m1)-msy(1)+1).eq.m1)then
            ngap=1
            ifyr=msy(1)
            ilyr=msy(m1)
            jgap((ngap-1)*2+1)=ifyr
            jgap((ngap-1)*2+2)=ilyr    
          else
            ifyr=msy(1)
            do i=2,m1
              ndif=0
              ndif=msy(i)-msy(i-1)
              if(ndif.gt.1.and.i.le.m1)then
                ngap=ngap+1
                ilyr=msy(i-1)
                jgap((ngap-1)*2+1)=ifyr
                jgap((ngap-1)*2+2)=ilyr    
                ifyr=msy(i)
                if(ndif.gt.1.and.i.eq.m1)then
                  ngap=ngap+1
                  ifyr=msy(m1)
                  ilyr=msy(m1)
                  jgap((ngap-1)*2+1)=ifyr
                  jgap((ngap-1)*2+2)=ilyr  
                endif
              elseif(ndif.eq.0.or.i.eq.m1)then
                ngap=ngap+1
                ilyr=msy(i)
                jgap((ngap-1)*2+1)=ifyr
                jgap((ngap-1)*2+2)=ilyr    
              endif
            enddo
          endif
          do k=1,ngap
            k1=(k-1)*2+1
            k2=k1+1
            if1=jgap(k1)
            il1=jgap(k2)
            ngp=il1-if1+1
            if(ngp.gt.20)then
              ngb=10
              ngb=min0(ngb,if1-ify)
              ngf=10
              ngf=min0(ngf,ily-il1)
              if(ngb.gt.0)then
                do i=1,ngb
                  ifgb=if1-ngb+i-1
                  gap1(i)=ifgb
                  ii=ifgb-ify+1
                  gap2(i)=wrk1(ii)
                  ns(i)=1
                  if(gap2(i).eq.-9.99)ns(i)=0
                enddo
              else
                ngb=0
              endif
              if(ngf.gt.0)then
                do i=1,ngf
                  ilgb=il1+i
                  gap1(i+ngb)=ilgb
                  ii=ilgb-ify+1
                  gap2(i+ngb)=wrk1(ii)
                  ns(i+ngb)=1
                  if(gap2(i+ngb).eq.-9.99)ns(i+ngb)=0
                enddo
              else
                ngf=0
              endif
              ngt=ngb+ngf
              call pearsn1(gap1,gap2,ns,ngt,r,a,b)
c              call wmse(gap1,gap2,ngt,a,b)
              do i=1,ngp
                ii=if1-ify+i
                rfy=if1+i-1
                wrk1(ii)=rfy*b+a
                wrk3(ii)=1.0
              enddo
            endif
          enddo
        endif
c
c *** fit 20-year spline to the series, with large weights to ignore missing values
c
        neg=0
        ls=20
        rdt=float(ls)/100.
ccc   10   call spl2w(wrk1,nyr,wrk2,wrk3,p,ls,mxy)
   10   call spl2w(mxy,nyr,wrk1,wrk3,pp,wrk2,ls)
c
        if(ido.eq.1.or.ido.eq.3)then
          if(n1.gt.0)then
            do i=1,nyr
              k=0
              call blank(id)
              do kk=1,8
                if(ident(j)(kk:kk).ne.' ')then
                  k=k+1
                  id(k:k)=ident(j)(kk:kk)
                endif
              enddo
              call crnplt5(wrk1,wrk2,nyr,ify,id,' in-filled growth trend',
     *          'years','measurements (y)',pixels,m1,msy,iplt)
c              if(iplt.eq.0)then
c                if(ido.eq.1)ido=0
c                if(ido.eq.3)ido=2
c                goto 20
c              endif
   15         call blank(datum)
c              write(*,'(/1x,''enter new spline stiffness in years''/
              write(*,'(/1x,''the default setting is a 20 year''/
     *          1x,''spline for the low-frequency gap filling''/
     *          1x,''part. hit <ret> to accept and continue or''/
     *          1x,''enter in your new spline value'',t45,''==> '',$)')
              read(*,'(a)')datum
              if(datum(1:1).eq.' ')then
                goto 20
              endif
              call intfrm(datum,frm)
              read(datum,frm,err=15)ls
              do kk=1,nyr
                wrk3(kk)=sqrt(wrk3(kk))
              enddo
              goto 10
            enddo
          endif
        endif
c
   20   do i=1,nyr
          ii=ist+i-1
          if(nss(i).eq.1)then
cccc        x(ii,j)=x(ii,j)/wrk2(i)
            x(ii,j)=x(ii,j)
          else
            x(ii,j)=-9.99
          endif
          nss(i)=1
        enddo
c
c *** save spline growth curve for later use
c
c        call trrw(ident(j),ify,nyr,wrk2,nss,ifl,iu14,0,'iw',tit,
c     *    '20y',mxy,itrdb)
        call datw(ident(j),wrk2,nss,nyr,ify,iu14,'20y',mxy)
      enddo
      close(iu14)
c
c *** calculate the mean index series
c
      jems(12,1)=2
      do i=1,maxn
        iyr=ifmny+i-1
        ncnt=0
        do j=1,nc
          if(x(i,j).ne.-9.99)then
            ncnt=ncnt+1
            wrk2(ncnt)=x(i,j)
          endif
        enddo
        if(ncnt.gt.0)then
          call biwgt(wrk2,wrk3,7.5,ncnt,bimn,bisg,bise,eff,iter,wgt)
          wrk1(i)=bimn
          nss(i)=ncnt
c          wrk3(i)=1.0
        else
          wrk1(i)=-9.99
c          wrk3(i)=999.0
        endif
ccc        write(*,'(i5,f8.3)')iyr,wrk1(i)
      enddo
      do i=1,maxn
        wrk3(i)=1.0
        if(wrk1(i).eq.-9.99)then
          wrk3(i)=999.
        endif
      enddo
      jems(12,1)=krb1
      ls=maxn/3
ccc      open(33,file='spline_test.out',status='unknown')
ccc      close(33,status='delete')
ccc      open(33,file='spline_test.out',status='unknown')
c      do i=1,maxn
c        wrk2(i)=0.0
c      enddo
ccc      call spl2w(wrk1,maxn,wrk2,wrk3,p,ls,mxy)
      call spl2w(mxy,maxn,wrk1,wrk3,pp,wrk2,ls)
      do i=1,maxn
        iyr=ifmny+i-1
        wrksave=wrk1(i)
        wrk1(i)=wrk1(i)/wrk2(i)
ccc        write(33,'(i5,4f8.3)')iyr,wrksave,wrk3(i),wrk2(i),wrk1(i)
      enddo
ccc      close(33)
ccc      pause
c
c *** stabilize the variance of the mean series
c
      do i=1,maxn
        iyr=ifmny+i-1
        wrk2(i)=wrk1(i)
        wrksave=wrk2(i)
        if(wrk2(i).eq.-9.99)then
          nss(i)=0
          wrk2(i)=1.0
        endif
ccc        write(*,'(i5,2f8.3,i5)')iyr,wrksave,wrk2(i),nss(i)
      enddo
      call stabit(wrk2,wrk3,wrk1,nss,maxn,50)
c
c *** add the missing values into the individual series
c
      open(iu14,file='curves.dat',status='old')
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        ist=ify-ifmny+1
        call blank(id)
ccc        call trrw(id,if1,n,wrk2,nss,ifl,iu14,0,'ir',tit,'   ',mxy,itrdb)
        call cdf(id,wrk2,if1,n,ifl,iu14,mxy,tit)
        n1=0
        do i=1,nyr
          ii=ist+i-1
          nss(i)=1
          if(wrk1(ii).eq.-9.99)then
            nss(i)=0
            n1=n1+1
            msy(n1)=i+ify-1
          endif
        enddo
ccc        write(*,*)j,ify,ily,nyr,ifmny,ist
ccc        if(j.eq.7.or.j.eq.8)then
ccc          do i=ist,nyr+ist-1
ccc            iyr=ifmny+i-1
ccc            write(*,'(i5,f8.3)')iyr,wrk1(i)
ccc          enddo
ccc          pause
ccc        endif
        call moment1(wrk1(ist),nss,nyr,ave3,adev,sdev3,var,skew,
     *    curt,sens,ac)
        do i=1,nyr
          ii=ist+i-1
          nss(i)=1
          if(x(ii,j).eq.-9.99)then
            nss(i)=0
          endif
          if(nss(i).eq.1)x(ii,j)=x(ii,j)/wrk2(i)
        enddo
        call moment1(x(ist,j),nss,nyr,ave2,adev,sdev2,var,skew,
     *    curt,sens,ac)
ccc        write(*,*)ave3,sdev3,ave2,sdev2
ccc        pause
c
c *** restore the spline growth trends
c
        n1=0
        m1=0
        do i=1,nyr
          ii=ist+i-1
          iyr=ify+i-1
          rmiss=0.0
          rmiss1=0.0
          if(x(ii,j).eq.-9.99)then
            n1=n1+1
            m1=m1+1
            msy(m1)=i+ify-1
            if(wrk1(ii).ne.-9.99)then
              rmiss=wrk1(ii)
              rmiss=(rmiss-ave3)/sdev3
              rmiss=rmiss*sdev2+ave2
              x(ii,j)=rmiss
ccc              write(*,'(i5,4f8.3)')iyr,wrk1(ii),rmiss,x(ii,j),x(ii,j)*wrk2(i)
            endif
          endif
          if(x(ii,j).ne.-9.99)then
            x(ii,j)=x(ii,j)*wrk2(i)
ccc            write(*,'(29x,f8.3)')x(ii,j)
          endif
        enddo
ccc        pause
        if((ido.eq.1.or.ido.eq.3).and.iplt.eq.0)iplt=1   !erc add
        if(n1.gt.0)then
          if(iplt.eq.1)then
            k=0
            call blank(id)
            do kk=1,8
              if(ident(j)(kk:kk).ne.' ')then
                k=k+1
                id(k:k)=ident(j)(kk:kk)
              endif
            enddo
            call crnplt5(x(ist,j),wrk2,nyr,ify,id,' in-filled growth trend',
     *        'years','measurements (y)',pixels,m1,msy,iplt)
ccc          else
c            write(*,'(1x,''series: '',i6,2x,a8,2x,''gaps filled'')')j,ident(j)
          endif
        endif
      enddo
ccc      pause
      close(iu14,status='delete')
      return
      end
*sbr spl2w
*                                                                       
      subroutine spl2w(mxy,n,y,w,pp,a,nfit)
c   is spl2gen for unit abscissal increments but variable weights,
c   that is, a time varying digital filter.
c
      parameter (nmax=2500)
      parameter (i0=0,i1=1,i2=2,i3=3,idgt=10)
      real*4    y(mxy),w(mxy),a(mxy)
      real*8    p,r(nmax-i2,i3),cd(nmax-i2),d0,d1,d2,d6,twopi
      real*8    vfr,arg,wwa,wwb,wwc
      parameter (d0=0d0,d1=1d0,d2=2d0,d6=6d0)
      real*8    det1,det2
      twopi=6.2831853076d0
      vfr=dfloat(nfit)                                                                  
      arg=twopi/vfr                                                             
      p=(d6*(dcos(arg)-d1)**d2)/(dcos(arg)+d2)
      pp=sngl(p)
c
c make r and q'y.                                              
      nm2=n-i2
      wwa=w(i1)
      wwa=wwa*wwa
      w(i1)=wwa                                                                   
      wwb=w(i2)
      wwb=wwb*wwb
      w(i2)=wwb
      do i=i1,nm2                                                              
        r(i,i1) = wwa
        r(i,i2) = -d2*(wwa+wwb) + p*0.3333333333d0
        ip2=i+i2
        wwc=w(ip2)
        wwc=wwc*wwc
        w(ip2)=wwc
        r(i,i3) = wwa + 4d0*wwb + wwc + p*1.3333333333d0
        cd(i) = y(i) - d2*y(i+i1) + y(ip2)
        wwa=wwb
        wwb=wwc
      enddo
      r(i1,i1)=d0                                                              
      r(i1,i2)=d0                                                              
      r(i2,i1)=d0
c solve r(c/p) = q'y.                                                              
      nc=i2                                                                      
      nr=nmax-i2                                                                   
      m=i1                                                                       
      call leq1pb(nr,r,nm2,nc,nr,cd,nr,m,idgt,det1,det2,ier)                            
      if(ier.ne.i0) then
        write(*,'(/1x,''in spl2w ier from leq1pb ='',i5,''.'')')ier
        pause
        return
      endif
c   make a = y - d'dq(c/p) from cd.
c   note that w now contains the squared weights.
      a(i1) = y(i1) - w(i1)*cd(i1)
      a(i2) = y(i2) - w(i2)*(-d2*cd(i1) + cd(i2))
      do i=i3,nm2
        im1=i-i1
        im2=i-i2
        a(i) = y(i) - w(i)*(cd(im2) - d2*cd(im1) + cd(i))
      enddo
      nm1 = n-i1
      a(nm1) = y(nm1) - w(nm1)*(cd(n-i3) - d2*cd(nm2))
      a(n) = y(n) - w(n)*cd(nm2)
      return                                                                    
      end
c                                                                       
c     subroutine leq1pb (nmax,a,n,nc,ia,b,ib,m,idgt,d1,d2,ier)               !libp0010
c                                                                       !libp0020
c-leq1pb--------s/d-----library 1---------------------------------------!libp0030
c                                                                       !libp0040
c   function            - linear equation solver - symmetric band       !libp0050
c                           storage mode - space economizer solution    !libp0060
c   usage               - call leq1pb (nmax,a,n,nc,ia,b,ib,m,idgt,d1,d2,ier) !libp0070
c   parameters   a      - the coefficient matrix of the equation        !libp0080
c                           ax = b, where a is assumed to be an n x n   !libp0090
c                           positive definite symmetric band matrix. a  !libp0100
c                           is stored in symmetric band storage mode    !libp0110
c                           and therefore has dimension n by (nc+1).    !libp0120
c                           (input)                                     !libp0130
c                         on output, a is replaced by l where           !libp0140
c                           a = l*l-transpose. l is a lower band        !libp0150
c                           matrix stored in band form and therefore    !libp0160
c                           has dimension n by (nc+1). note that the    !libp0170
c                           diagonal elements of l are stored in        !libp0180
c                           reciprocal form. (output)                   !libp0190
c                n      - order of matrix a and number of rows in b.    !libp0200
c                           (input)                                     !libp0210
c                nc     - number of upper or lower co-diagonals of a.   !libp0220
c                           (input)                                     !libp0230
c                ia     - row dimension of a as specified in the main   !libp0240
c                           program.(input)                             !libp0250
c                b      - input matrix of dimension n x m containing    !libp0260
c                           the m right-hand sides of the equation      !libp0270
c                           ax = b.                                     !libp0280
c                         on output, the n x m solution matrix x        !libp0290
c                           replaces b.                                 !libp0300
c                ib     - row dimension of b as specified in the main   !libp0310
c                           program.(input)                             !libp0320
c                m      - number of right hand sides (columns in b)     !libp0330
c                           (input)                                     !libp0340
c                idgt   - the elements of a are assumed to be correct   !libp0350
c                           to idgt decimal digits (input - currently   !libp0360
c                           not used)                                   !libp0370
c                d1,d2  - components of the determinant of a.           !libp0380
c                           determinant(a) = d1*2.**d2. (output)        !libp0390
c                ier    - error parameter.                              !libp0400
c                         terminal error = 128+n.                       !libp0410
c                           n = 1 indicates that the matrix a is        !libp0420
c                             algorithmically not positive definite.    !libp0430
c   precision           - single/double                                 !libp0440
c   reqd. imsl routines - ludapb,luelpb,uertst                          !libp0450
c   language            - fortran                                       !libp0460
c-----------------------------------------------------------------------!libp0470
c   latest revision     - february 6,1974                               !libp0480
c                                                                       !libp0490
      subroutine leq1pb (nmax,a,n,nc,ia,b,ib,m,idgt,d1,d2,ier)               !libp0500
c                                                                       !libp0510
      dimension a(nmax,3), b(nmax)                                              
      double precision a,b,d1,d2                                                   
      ier = 0                                                           !libp0540
c                                  decomposition of matrix a into       !libp0550
c                                  l*l-transpose                        !libp0560
      call ludapb(nmax,a,n,nc,ia,a,ia,d1,d2,ier)                             !libp0570
      if (ier .ne. 0) go to 9000                                        !libp0580
c                                  solution of ax = b                   !libp0600
      call luelpb(nmax,a,b,n,nc,ia,b)                                                
      go to 9005                                                        !libp0630
 9000 continue                                                          !libp0640
 9005 return                                                            !libp0660
      end
c                                                               !libp0670
c     subroutine luelpb (nmax,ul,b,n,nc,ia,x)                                !lulp0010
c                                                                       !lulp0020
c-luelpb--------s/d-----library 1---------------------------------------!lulp0030
c                                                                       !lulp0040
c   function            - elimination portion of the solution of ax = b !lulp0050
c                           symmetric band storage mode                 !lulp0060
c   usage               - call luelpb(nmax,ul,b,n,nc,ia,x)                   !lulp0070
c   parameters   ul     - the result l computed in the routine ludapb   !lulp0080
c                           where a = l*l-transpose. l is a lower band  !lulp0090
c                           matrix stored in band storage mode and      !lulp0100
c                           therefore has dimension n x (nc+1). the main!lulp0110
c                           diagonal elements of l are stored in        !lulp0120
c                           reciprocal form. (input)                    !lulp0130
c                b      - vector of length n containing the right hand  !lulp0140
c                           side of the equation ax = b. (input)        !lulp0150
c                n      - order of a and the length of b and x. (input) !lulp0160
c                nc     - number of lower co-diagonals of a. (input)    !lulp0170
c                ia     - row dimension of ul as specified in the main  !lulp0180
c                           program. (input)                            !lulp0190
c                x      - vector of length n containing the solution to !lulp0200
c                           the equation ax = b. (output)               !lulp0210
c   precision           - single/double                                 !lulp0220
c   language            - fortran                                       !lulp0230
c-----------------------------------------------------------------------!lulp0240
c   latest revision     - february 6,1974                               !lulp0250
c                                                                       !lulp0260
      subroutine luelpb(nmax,ul,b,n,nc,ia,x)                                 !lulp0270
c                                                                       !lulp0280
      dimension ul(nmax,3), b(nmax), x(nmax)                                    
      double precision   ul,b,x,zero,sum                                              
      data               zero/0.d0/                                     !lulp0310
c                                  solution ly = b                      !lulp0330
      nc1 = nc+1                                                        !lulp0340
      iw = 0                                                            !lulp0350
      l = 0                                                             !lulp0360
      do 15 i = 1,n                                                     !lulp0370
         sum = b(i)                                                     !lulp0380
         if (nc .le. 0) go to 10                                        !lulp0390
         if (iw .eq. 0) go to 9                                         !lulp0400
         l = l+1                                                        !lulp0410
         if (l .gt. nc) l = nc                                          !lulp0420
         k = nc1-l                                                      !lulp0430
         kl = i-l                                                       !lulp0440
         do 5 j = k,nc                                                  !lulp0450
            sum = sum -x(kl) * ul(i,j)                                  !lulp0460
            kl = kl+1                                                   !lulp0470
    5    continue                                                       !lulp0480
         go to 10                                                       !lulp0490
    9    if (sum .ne. zero) iw = 1                                      !lulp0500
   10    x(i) = sum*ul(i,nc1)                                           !lulp0510
   15 continue                                                          !lulp0520
c                                  solution ux = y                      !lulp0530
   20 x(n) = x(n)*ul(n,nc1)                                             !lulp0540
      if (n .le. 1) go to 40                                            !lulp0550
      n1 = n+1                                                          !lulp0560
      do 35 i = 2,n                                                     !lulp0570
         k = n1-i                                                       !lulp0580
         sum = x(k)                                                     !lulp0590
         if (nc .le. 0) go to 30                                        !lulp0600
         kl = k+1                                                       !lulp0610
         k1 = min0(n,k+nc)                                              !lulp0620
         l = 1                                                          !lulp0630
         do 25 j = kl,k1                                                !lulp0640
            sum = sum -x(j) * ul(j,nc1-l)                               !lulp0650
            l = l+1                                                     !lulp0660
   25    continue                                                       !lulp0670
   30    x(k) = sum*ul(k,nc1)                                           !lulp0680
   35 continue                                                          !lulp0690
   40 return                                                            !lulp0700
      end
c                                                               !lulp0710
c     subroutine ludapb (nmax,a,n,nc,ia,ul,iu,d1,d2,ier)                     !luap0010
c                                                                       !luap0020
c-ludapb--------s/d-----library 1---------------------------------------!luap0030
c                                                                       !luap0040
c   function            - lu decomposition of a positive definite       !luap0050
c                           symmetric band matrix - cholesky            !luap0060
c                           decomposition                               !luap0070
c   usage               - call ludapb(nmax,a,n,nc,ia,ul,iu,d1,d2,ier)        !luap0080
c   parameters   a      - n x n positive definite symmetric band matrix !luap0090
c                           stored in symmetric band storage mode.      !luap0100
c                           a should be an array of size n by nc+1, at  !luap0110
c                           least. (input)                              !luap0120
c                n      - row dimension of a for the present call       !luap0130
c                           (input).                                    !luap0140
c                nc     - number of upper or lower co-diagonals (input) !luap0150
c                ia     - row dimension of a as specified in the main   !luap0160
c                           program. (input)                            !luap0170
c                ul     - output matrix l where a = l*l-transpose. l is !luap0180
c                           stored in band storage mode. ul should be   !luap0190
c                           an array of size n by nc+1, at least.       !luap0200
c                           note - the diagonal of ul contains the      !luap0210
c                           reciprocals of the actual diagonal elements.!luap0220
c                iu     - row dimension of ul as specified in the main  !luap0230
c                           program. (input)                            !luap0240
c                d1,d2  - components of the determinant of a.           !luap0250
c                           determinant(a) = d1*2.**d2. (output)        !luap0260
c                ier    - error parameter.                              !luap0270
c                         terminal error = 128+n.                       !luap0280
c                           n = 1 indicates that the matrix a is        !luap0290
c                             algorithmically not positive definite.    !luap0300
c   precision           - single/double                                 !luap0310
c   reqd. imsl routines - uertst                                        !luap0320
c   language            - fortran                                       !luap0330
c-----------------------------------------------------------------------!luap0340
c   latest revision     - january 23,1975                               !luap0350
c                                                                       !luap0360
      subroutine ludapb(nmax,a,n,nc,ia,ul,iu,d1,d2,ier)                      !luap0370
c                                                                       !luap0380
      dimension a(nmax,3), ul(nmax,3)                                           
CCC***      double precision a,ul,zero,d1,d2,one,half,xinf,sum,rn,four                   
      double precision a,ul,zero,d1,d2,one,sum,rn,four                   
      double precision sixtn, sixth                                             
      data               zero/0.d0/,four/4.d0/,sixtn/16.d0/,sixth/.0625d!luap0420
     1                   0/,one/1.0d0/                                  !luap0430
      ier = 0                                                           !luap0460
      rn = one/(n*sixtn)                                                !luap0470
      d1 = one                                                          !luap0480
      d2 = zero                                                         !luap0490
      ncp1 = nc+1                                                       !luap0500
      if (nc .eq. 0) go to 15                                           !luap0510
c                                  initialize zero elements             !luap0520
      do 10 i = 1,nc                                                    !luap0530
         do 5 j = i,nc                                                  !luap0540
            k = ncp1-j                                                  !luap0550
            ul(i,k) = zero                                              !luap0560
    5    continue                                                       !luap0570
   10 continue                                                          !luap0580
c                                  i is row index of element being      !luap0590
c                                  computed                             !luap0600
   15 do 60 i = 1,n                                                     !luap0610
         imncp1 = i-ncp1                                                !luap0620
         i1 = max0(1,1-imncp1)                                          !luap0630
c                                  j is column index of element being   !luap0640
c                                  computed                             !luap0650
         do 60 j = i1,ncp1                                              !luap0660
c                                  l is row index of previously computed!luap0670
c                                  vector being used to compute inner   !luap0680
c                                  product                              !luap0690
            l = imncp1+j                                                !luap0700
            i2 = ncp1-j                                                 !luap0710
            sum = a(i,j)                                                !luap0720
            jm1 = j-1                                                   !luap0730
            if (jm1) 30,30,20                                           !luap0740
   20       do 25 k = 1,jm1                                             !luap0750
c                                  m is column index                    !luap0760
               m = i2+k                                                 !luap0770
               sum = sum-ul(i,k)*ul(l,m)                                !luap0780
   25       continue                                                    !luap0790
   30       if (j .ne. ncp1) go to 55                                   !luap0800
            if(a(i,j)+sum*rn .le. a(i,j))go to 65                       !luap0810
            ul(i,j) = one/dsqrt(sum)                                    !luap0820
c                                  update the determinant               !luap0840
            d1 = d1*sum                                                 !luap0850
   35       if (dabs(d1)-one) 45,45,40                                  !luap0860
   40       d1 = d1*sixth                                               !luap0880
            d2 = d2+four                                                !luap0890
            go to 35                                                    !luap0900
   45       if (dabs(d1)-sixth) 50,50,60                                !luap0910
   50       d1 = d1*sixtn                                               !luap0930
            d2 = d2-four                                                !luap0940
            go to 45                                                    !luap0950
   55       ul(i,j) = sum*ul(l,ncp1)                                    !luap0960
   60 continue                                                          !luap0970
      go to 9005                                                        !luap0980
   65 ier = 129                                                         !luap0990
 9000 continue                                                          !luap1000
 9005 return                                                            !luap1020
      end
*sbr pearsn -- pearson product-moment correlation coefficient
*
      subroutine pearsn(x,y,n,r,a,b)
      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
*sbr pearsn1 -- pearson product-moment correlation coefficient
*
      subroutine pearsn1(x,y,ns,n,r,a,b)
      real*4 x(n),y(n)
      integer ns(n)
      ax=0.
      ay=0.
      n1=0
      do j=1,n
        if(ns(j).gt.0)then
          n1=n1+1
          ax=ax+x(j)
          ay=ay+y(j)
        endif
      enddo
      rn1=n1
      ax=ax/rn1
      ay=ay/rn1
      sxx=0.
      syy=0.
      sxy=0.
      do j=1,n
        if(ns(j).gt.0)then
          xt=x(j)-ax
          yt=y(j)-ay
          sxx=sxx+xt**2
          syy=syy+yt**2
          sxy=sxy+xt*yt
        endif
      enddo
      sgy=sqrt(syy/(rn1-1.))
      sgx=sqrt(sxx/(rn1-1.))
      yxr=sgy/sgx
      r=sxy/sqrt(sxx*syy)
      b=yxr*r
      a=ay-b*ax
      return
      end
*sbr biwgt: biweight robust mean estimation using the newton-raphson algorithm
*
*  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
*      c  - input  - tuning constant used for computing biweight mean
*		                  where:  c usually falls between 6 and 9, inclusive
*      n  - input  - number of observations in data vector x
*    bimn - output - biweight robust mean
*    bisg - output - biweight standard deviation
*    bise - output - biweight mean standard error
*     eff - output - efficiency of biweight mean relative to
*                    the gaussian mean
*    iter - output - number of newton-raphson iterations
*
*    	subroutines called - sort
*  
      subroutine biwgt(x,wrk,c,n,bimn,bisg,bise,eff,iter,wgt)
      parameter(iii=10000)
      real*4 x(n),wrk(n),med,mad,wgt(n)
      real*8 xlb(11),xsb(11)
      real*8 u1(iii),u2(iii),c1,c2,d1,d5,dx,s1,s2,s3,s4,zero
      real*8 xm,xmm,xmadm,xlbiwt1,xsbiwt1
ccc      real*8 xsum,ysum,u,usq,dusq,fusq,cmad,absu,dep,zero,one,five,tol
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
ccc      data zero,one,five/0.d0,1.d0,5.d0/
ccc      data tol/0.001d0/			                        !tolerance criterion
      krb1=jems(12,1)
      iter=0				                                  !initialize iteration count
      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
*
      if(n .eq. 1)then			                         !if n=1, just return
        bimn=x(1)	
        bisg=0.0
        bise=0.0
        eff=0.0
        return
      endif
*
      gmean=0.				                                !compute gaussian mean and	
      do 5 i=1,n			                               !variance for later
        gmean=gmean+x(i)		                        !efficiency test (eff)
    5 continue
      rn=n
      gmean=gmean/rn			                           !gaussian mean (gmean)
      sq=0.					
      do 6 i=1,n		
        sq=sq+(x(i)-gmean)**2
    6 continue
      gvar=sq/(rn-1.)			                          !gaussian variance (gvar)
      if(krb1.eq.1)then
        bimn=gmean
        bisg=sqrt(gvar)
        bise=bisg/sqrt(rn)
        eff=1.0
        return
      endif
      call mfs(x,n,smed,shh,shl,sfsd,smn,smx)
      if(krb1.lt.0)then
        iqt=iabs(krb1)
        if(iqt.eq.1)then
          bimn=x(1)
        elseif(iqt.eq.25)then
          bimn=shl
        elseif(iqt.eq.50)then
          bimn=smed
        elseif(iqt.eq.75)then
          bimn=shh
        elseif(iqt.eq.100)then
          bimn=x(n)
        else
          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
ccc      save=smed
      do 10 i=1,n
        wrk(i)=abs(x(i)-med)		                     !absolute departures from med
   10 continue
      call qcksrt(n,wrk)
      mad=(wrk(m)+wrk(mm))/2.		                    !median absolute deviation (mad)
*
      if(mad.lt.0.0001.and.n.gt.5)then
        bimn=med
        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
*
* compute bisquare mean using the median as the initial estimate -- this code from ROSTAT
*
        c1 = dble(c)
        c2 = dble(c)
        d1 = 1.d0
        d5 = 5.d0
        zero = 0.d0

        xm = dble(med)
        xmadm = dble(mad)
ccc        if(xmadm.lt.0.0001d0)then
ccc        write(*,*)xmadm
ccc        pause'1'
ccc        endif
  
        do 11 i = 1,n
        dx=dble(x(i))
        u1(i) = (dx - xm)/(c1*xmadm)
        u2(i) = (dx - xm)/(c2*xmadm)
11      continue
 
        s1 = zero
        s2 = zero
        s3 = zero
        s4 = zero
 
        do 12 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
12      continue

ccc        if(s1.lt.0.00001d0)write(*,*)'1s1: ',s1
ccc        if(s2.lt.0.00001d0)write(*,*)'1s2: ',s2
ccc        if(s3.lt.0.00001d0)write(*,*)'1s3: ',s3
ccc        if(s4.lt.0.00001d0)write(*,*)'1s4: ',s4

c--- here are the one-step estimators
 
        xlbiwt1 = xm+s3/s4
        xsbiwt1 = dfloat(n)/(dfloat(n-1))**0.5d0*s1**0.5d0/dabs(s2)
 
c--- now obtain the fully-iterated versions
 
c--- solve for new estimates of u1 and u2
 
        xlb(1) = xlbiwt1
        xsb(1) = xsbiwt1
 
        do 15 j = 2,4   !assuming 3 iterations is sufficient
 
        xmm = xlb(j-1)
        do 13 i = 1,n
        dx=dble(x(i))
        u1(i) = (dx - xmm)/(c1*xmadm)
        u2(i) = (dx - xmm)/(c2*xmadm)
13      continue
 
        s1 = zero
        s2 = zero
        s3 = zero
        s4 = zero
 
        do 14 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
        endif
14      continue

ccc        if(s1.lt.0.00001d0)write(*,*)'2s1: ',s1
ccc        if(s2.lt.0.00001d0)write(*,*)'2s2: ',s2
ccc        if(s3.lt.0.00001d0)write(*,*)'2s3: ',s3
ccc        if(s4.lt.0.00001d0)write(*,*)'2s4: ',s4
 
        xlb(j) = xlb(j-1)+s3/s4
        xsb(j) = dfloat(n)/(dfloat(n-1))**0.5d0*s1**0.5d0/dabs(s2)
 
15      continue
 
        bimn = sngl(xlb(4))
        bisg = sngl(xsb(4))
        iter = 3

        bise = bisg/sqrt(rn)
        if (bisg.gt.0) then
          eff = gvar/bisg**2
        else
          eff=1.0
        endif
 
20      continue
        return
        end
*sbr stabbm
c
c *** stablize the variance of mean-value time series using briffa's method
c
c     x    --  input  -- mean-value time series to be stablized
c     ns   --  input  -- sample replication per year for series x
c     ify  --  input  -- first year of time series to be stabilized
c     ily  --  input  -- last year of time series to be stabilized
c     n    --  input  -- number of years of time series
c     ifr  --  input  -- first year of reference period for rescaling
c     ilr  --  input  -- last year of reference period for rescaling
c                        if ifr and ilr are both zero, the reference
c                        period is set to the full series length
c     rbar --  input  -- average correlation between series
c     y    --  output -- stabilized time series scaled to reference period
c     rc   --  output -- effective replication per year
c 
      subroutine stabbm(x,ns,ify,ily,n,ifr,ilr,rbar,y,rc)
      real*4 x(n),y(n),rc(n)
      integer ns(n)
ccc      n=ily-ify+1
      if(ifr.eq.0.and.ilr.eq.0)then
        ifr=ify
        ilr=ily
      endif
      n1=ilr-ifr+1
c
c *** some error checks
c
      if(n.le.0)then
        write(*,'(/1x,''*** time series length .le. 0 in '',
     *    ''sbr stabbm ***'')')
        pause
        stop
      elseif(n1.le.0)then
        write(*,'(/1x,''*** reference period length .le. 0 '',
     *    ''in sbr stabbm ***'')')
        pause
        stop
      elseif(rbar.lt.0)then
        write(*,'(/1x,''*** rbar .le. 0 in sbr stabbm ***'')')
        return
      endif
c
c *** calculate the effective replication and stablize the series
c
      sm=0.0
      n2=0
      do i=1,n
        if(ns(i).gt.0)then
          n2=n2+1
          sm=sm+x(i)
        endif
      enddo
      rn2=n2
      xm=sm/rn2
      do i=1,n
        if(ns(i).gt.0)then
          rns=ns(i)
          rc(i)=rns/(1.0+(rns-1.0)*rbar)
          y(i)=(x(i)-xm)*sqrt(rc(i))
        else
          rc(i)=0.0
        endif
      enddo
c
c *** scale the stabilized series to the mean and standard deviation of
c *** the reference period in the original, unstabilized time series
c
      ist=ifr-ify+1
      sm1=0.0
      sm2=0.0
      n3=0
      do i=ist,n
        if(ns(i).gt.0)then
          n3=n3+1
          sm1=sm1+x(i)
          sm2=sm2+y(i)
        endif
      enddo
      rn3=n3
      xm1=sm1/rn3
      xm2=sm2/rn3
      sq1=0.0
      sq2=0.0
      do i=ist,n
        if(ns(i).gt.0)then
          sq1=sq1+(x(i)-xm1)**2
          sq2=sq2+(y(i)-xm2)**2
        endif
      enddo
      sg1=sqrt(sq1/(rn3-1.0))
      sg2=sqrt(sq2/(rn3-1.0))
      do i=1,n
        if(ns(i).gt.0)then
          y(i)=(y(i)-xm2)/sg2
          y(i)=y(i)*sg1+xm1
        endif
      enddo
      return
      end
*sbr stabit: stabilize variance of a series
*
      subroutine stabit(tr,cv,sb,nc,n,ls)
      parameter(mxy=5000)
      real*4 tr(n),cv(n),sb(n)
      real*8 p
      integer nc(n)
      character isign(mxy)
      rn=n
      sm=0.0
      sq=0.0
      sm1=0.0
      sq1=0.0
      nc3=0
      do i=1,n
        sm=sm+tr(i)
        sq=sq+tr(i)*tr(i)
        if(nc(i).gt.3)then
          nc3=nc3+1
          sm1=sm1+tr(i)
          sq1=sq1+tr(i)*tr(i)
        endif
      enddo
      xbar=sm/rn
      sig=sqrt((sq-xbar*xbar*rn)/(rn-1.0))
      if(nc3.gt.n/3)then
        rnc3=nc3
        xbar1=sm1/rnc3
        sig1=sqrt((sq1-xbar1*xbar1*rnc3)/(rnc3-1.0))
      else
        xbar1=xbar
        sig1=sig
      endif
      do i=1,n
        tr(i)=tr(i)-xbar1
      enddo
      do i=1,n
        if(tr(i).lt.0.0)then
          isign(i)='-'
        else
          isign(i)='+'
        endif
        tr(i)=abs(tr(i))
      enddo
      if(ls.lt.-9)then
        ls=abs((float(ls)/100.0)*float(n))
      endif
      call spline(n,tr,cv,p,ls)
      sm=0.0
      sq=0.0
      do i=1,n
        sb(i)=tr(i)/cv(i)
        if(isign(i).eq.'-')sb(i)=-sb(i)
        sm=sm+sb(i)
        sq=sq+sb(i)*sb(i)
      enddo
      xbar=sm/rn
      sig=sqrt((sq-xbar*xbar*rn)/(rn-1.0))
      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
*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(5000)
      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
*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 model 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:   length (stiffness) of spline to be used to model series
* a:    working array of dimension (n,4)
*
********************************************************************
*
      subroutine spline(n,y,f,pp,ls)
      parameter(mxy=5000)
      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=dfloat(ls)
      arg=(2.d0*pi)/v
      p=(6.d0*(dcos(arg)-1.d0)**2.d0)/(dcos(arg)+2.d0)
      pp=sngl(p)
ccc      p1=((1.d0/(1.d0-pct)-1.d0)*6.d0*(dcos(pi*2.d0/v)-1.d0)**2)/
ccc     +     (dcos(pi*2.d0/v)+2.d0)
ccc      p2=(6.d0*(dcos(arg)-1.d0)**2.d0)/((2.d0**0.5d0-1.d0)*
ccc     *		(dcos(arg)+2.d0))
      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
*sbr rbar
*
      subroutine rbar(x,idate,ident,nc,mxy,mxs,iu11,ave)
      real*4 x(mxy,mxs)
      real*8 x1,x2,x3,x4,dr,fac1,fac2,fac3,fac4,fac5,rn
      real*8 dave,ddev,derr,dskew,dcurt
      integer idate(mxs+2,10)
      character ident(mxs)*8
      ifyf=idate(nc+1,1)
      nr=0
      nmint=0
      rxcor=-1.0
      rncor=1.0
      x1=0.d0
      x2=0.d0
      x3=0.d0
      x4=0.d0
      do i=1,nc-1
        ify1=idate(i,1)
        ily1=idate(i,2)
        do j=i+1,nc
          ify2=idate(j,1)
          ily2=idate(j,2)
          ifmx=max0(ify1,ify2)
          ilmn=min0(ily1,ily2)
          nmin=ilmn-ifmx+1
          if(nmin.gt.20)then
            nmint=nmint+nmin
            ist=ifmx-ifyf+1
            call pearsn(x(ist,i),x(ist,j),nmin,r,a,b)
            if(r.gt.rxcor)then
              rxcor=r
              mxi=i
              mxj=j
              mxn=nmin
            endif
            if(r.lt.rncor)then
              rncor=r
              mni=i
              mnj=j
              mnn=nmin
            endif
            nr=nr+1
            dr=r
            x1=x1+dr
            x2=x2+dr*dr
            x3=x3+dr*dr*dr
            x4=x4+dr*dr*dr*dr
          endif
        enddo
      enddo
      rn=dfloat(nr)
      dave=x1/rn
      ave=sngl(dave)
      ddev=dsqrt((x2-rn*dave*dave)/(rn-1.d0))
      sdev=sngl(ddev)
      derr=(dsqrt((x2-rn*dave*dave)/(rn-1.d0)))/dsqrt(rn)
      serr=sngl(derr)
      dskew=(rn*x3-3.d0*x1*x2+(2.d0*x1**3)/rn)/((rn-1.d0)*
     *  (rn-2.d0)*ddev**3)
      skew=sngl(dskew)
      fac1=rn*x4
      fac2=4.d0*x1*x3
      fac3=6.d0*x1*x1*x2/rn
      fac4=3.d0*x1**4/(rn*rn)
      fac5=(rn-1.d0)*(rn-2.d0)*(rn-3.d0)*ddev**4
      dcurt=((rn-1.d0)*(fac1-fac2+fac3-fac4))/fac5
      curt=sngl(dcurt)
      write(*,'(/1x,''all possible series rbar: '',f7.4,2x,''+/-'',
     *  f9.4,'' 1sd'')')ave,sdev
      write(iu11,'(/t2,
     *  ''|-------------------- all possible series rbar statistics '',
     *  ''---------------------|''//t4,
     *  ''total    mean   standard   standard  skewess   kurtosis   '',
     *  ''minimum   maximum''/t4,''corrs    rbar   deviation    '',
     *  ''error    coeff      coeff      corr      corr'')')
      if(nr.lt.1000)then
        write(iu11,'(i7,f9.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *    nr,ave,sdev,serr,skew,curt,rncor,rxcor
      else
        write(iu11,'(i8,f8.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *    nr,ave,sdev,serr,skew,curt,rncor,rxcor
      endif
      rnr=nr
      rnc=nc
      pap=(rnr/((rnc*rnc-rnc)/2.0))*100.0
      nmax=idate(nc+1,2)-idate(nc+1,1)+1
      nmax=nmax*(nc*nc-nc)/2.0
      pty=float(nmint)/float(nmax)*100.0
      write(*,'(1x,''percent of all possible cross-correlations:'',
     *		t49,f6.2)')pap
      write(*,'(1x,''percent of all possible tree-ring years used:'',
     *  t49,f6.2)')pty
      write(iu11,'(/t4,''minimum correlation: '',f6.3,''   series  '',
     *  a8,''   and  '',a8,i7,'' years'')')rncor,ident(mni),ident(mnj),mnn
      write(iu11,'(t4,''maximum correlation: '',f6.3,''   series  '',
     *  a8,''   and  '',a8,i7,'' years'')')rxcor,ident(mxi),ident(mxj),mxn
      write(iu11,'(/t8,''percent of all possible correlations used '',
     *  ''(n>20 years): '',t68,f6.2)')pap
      write(iu11,'(t8,''percent of all possible tree-ring years '',
     *  ''used in rbar: '',t68,f6.2)')pty
      return
      end
*sbr runr
*
      subroutine runr(x,idate,n,nc,rxm,ncnt,mxy,mxs)
      real*4 x(mxy,mxs),rxm(mxy,7)
      integer idate(mxs+2,10)
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      nsg=jems(16,1)	         !running rbar segment length
      nlp=jems(16,2)	         !running rbar segment overlap
      nseg=0
      ncnt=0
      ifmn=idate(nc+1,1)
      ilmx=idate(nc+1,2)
      write(*,'(1x,''window length: '',t22,i5,
     *  /1x,''window overlap: '',t22,i5)')
     *  nsg,nlp
      do i=1,n,nsg-nlp
        nseg=nseg+1
        if(nseg.eq.2)then
          ifmn=ifmn/10*10
          if(idate(nc+1,1).lt.0)ifmn=ifmn-10
          ndif=10-(idate(nc+1,1)-ifmn)
          ifmn=idate(nc+1,1)+ndif
        endif
        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,idate,nc,ifskp,ilskp,nr,ave,sdev,see,mxy,mxs)
          if(ave.ne.-99.9)then
            ncnt=ncnt+1
            rxm(ncnt,1)=iyr
            rxm(ncnt,2)=nr
            rxm(ncnt,3)=ave
            rxm(ncnt,4)=sdev
            rxm(ncnt,5)=see
            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
      write(*,'(1x,''segments calculated: '',t22,i5)')ncnt
        write(iu11,'(/t2,''|--------------------------- running rbar '',
     *    ''statistics --------------------------|'')')
      if(ipo.gt.2.or.ncnt.le.50)then
        nc10=ncnt/10*10
        ndif=ncnt-nc10
        do i=1,nc10/10
          j=(i-1)*10+1
          k=j+9
          write(iu11,'(/t5,''year'',1x,10f7.0)')(rxm(l,1),l=j,k)
          write(iu11,'(t5,''corr'',1x,10f7.0)')(rxm(l,2),l=j,k)
          write(iu11,'(t5,''rbar'',10f7.3)')(rxm(l,3),l=j,k)
          write(iu11,'(t5,''sdev'',10f7.3)')(rxm(l,4),l=j,k)
          write(iu11,'(t5,''serr'',10f7.3)')(rxm(l,5),l=j,k)
          write(iu11,'(t5,''eps '',10f7.3)')(rxm(l,6),l=j,k)
          write(iu11,'(t5,''nss '',10f7.1)')(rxm(l,7),l=j,k)
        enddo
        if(ncnt.gt.nc10)then
          write(iu11,'(/t5,''year'',1x,10f7.0)')(rxm(l,1),l=nc10+1,ncnt)
          write(iu11,'(t5,''corr'',1x,10f7.0)')(rxm(l,2),l=nc10+1,ncnt)
          write(iu11,'(t5,''rbar'',10f7.3)')(rxm(l,3),l=nc10+1,ncnt)
          write(iu11,'(t5,''sdev'',10f7.3)')(rxm(l,4),l=nc10+1,ncnt)
          write(iu11,'(t5,''serr'',10f7.3)')(rxm(l,5),l=nc10+1,ncnt)
          write(iu11,'(t5,''eps '',10f7.3)')(rxm(l,6),l=nc10+1,ncnt)
          write(iu11,'(t5,''nss '',10f7.1)')(rxm(l,7),l=nc10+1,ncnt)
        endif
      else
        write(iu11,'(/10x,i6,'' running rbar segments calculated and '',
     *    ''stored in file'')')ncnt
      endif
      return
      end
*sbr rrbar
*
      subroutine rrbar(x,idate,nc,ifskp,ilskp,nr,ave,sdev,see,mxy,mxs)
      real*4 x(mxy,mxs)
      real*8 x1,x2,dr,rn
      integer idate(mxs+2,10)
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      nsg=jems(16,1)	         !running rbar segment length
      nlp=jems(16,2)	         !running rbar segment overlap
      ifyf=idate(nc+1,1)
      ntree=0
      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)
            nr=nr+1
            dr=r
            x1=x1+dr
            x2=x2+dr*dr
          endif
   10   continue
   20 continue
      if(nr.eq.0)then
        ave=-99.9
        see=-99.9
        return
      elseif(nr.eq.1)then
        ave=r
        see=0.0
        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
*sbr stc -- site-tree-core
c
c *** creates mask for separating series into within and between tree records
c
c     ident  --  matrix of 8 character series identifiers
c     idate  --  matrix of information on series (dates, etc.)
c            --  on output, column 10 contains mask that separates series
c     nc     --  number of series to be processed
c     mask   --  site-tree-core mask for separating series by tree
c     mxs    --  maximum column dimension of x, from main program
c
      subroutine stc(ident,idate,nc,mask,mxs)
      integer idate(mxs+2,10)
      character ident(mxs)*8,mask*8,id*8
      is=0
      it=0
      ic=0
      do i=1,8
        if(mask(i:i).eq.'s'.or.mask(i:i).eq.'S')is=is+1
        if(mask(i:i).eq.'t'.or.mask(i:i).eq.'T')it=it+1
        if(mask(i:i).eq.'c'.or.mask(i:i).eq.'C')ic=ic+1
      enddo
      it=is+it
      ic=it+ic
      ntree=1
      ntcore=0
      do i=1,nc
        idate(i,10)=0
      enddo
   10 do i=1,nc
        call blank(id)
        if(idate(i,10).eq.0)then
          id(1:8)=ident(i)(1:8)
          goto 15
        endif
      enddo
   15 do i=1,nc
        if(id(1:is).eq.ident(i)(1:is))then
          if(id(is+1:it).eq.ident(i)(is+1:it).and.idate(i,10).eq.0)then
            idate(i,10)=ntree
            ntcore=ntcore+1
          endif
        endif
      enddo
      if(ntcore.eq.nc)then
        goto 20
      endif
      ntree=ntree+1
      goto 10
   20 return
      end
*sbr comper *** common period analysis
c
c     x(i,j) --  matrix of tree-ring data to be saved
c     corr   --  matrix for holding common period correlations
c     pr     --  array for holding correlation coefficients
c     idate  --  matrix of information on series (dates, etc.)
c     ident  --  matrix of series ids of the complete data matrix
c     id1    --  matrix of series ids used in common period analysis
c     nc     --  number of series in matrix x
c     mxy    --  maximum row dimension of x, from main program
c     mxs    --  maximum column dimension of x, from main program
c     stats  --  matrix for holding common period statistics
c     rbar   --  average correlation between series
c     rbsg   --  rbar standard deviation
c     eps    --  expressed population signal
c     itp    --  data type - raw(1), transformed(2), detrended(3), prewhitened(4)
c
      subroutine comper(x,corr,a,b,c,pr,idate,ident,id1,nc,mxy,mxs,stats,rbar,rbsg,eps,itp)
      parameter(mxr=5000,mxc=100)
      real*4 x(mxy,mxs),pr(mxy),stats(mxs,12),stats1(8,7),corr(mxs,mxs),fs(mxr,mxc)
      real*4 a(mxs,mxs),b(mxs,mxs),c(mxs,mxs)
      real*8 x1,x2,x3,x4,dr,fac1,fac2,fac3,fac4,fac5,rn,dave,ddev,derr,dskew,dcurt
      integer idate(mxs+2,10),kdate(2)
      character ident(mxs)*8,id1(mxs)*8,star,yn
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	  common/icommands/jems,ndd            !new pjk
c
      ifc=jems(14,1)          !first year of common period
      ilc=jems(14,2)          !last year of common period 
      ipo=jems(17,1)	      !print out option
      ird=jems(19,1)          !flag for plotting the pca results, do so if ird=3
c
      if(nc.lt.2)then
        write(iu11,'(/t10,''*** number of series < 2, no common '',
     *    ''period analysis performed ***'')')
        return
      endif
      if(ipo.gt.1)then
        write(iu11,'(/t2,''|----------------------- statistics of '',
     *    ''the common period ----------------------|'')')
      endif
      ns=0
      ntest=1.00*(ilc-ifc+1)
      yn='n'
      kdate(1)=ifc
      kdate(2)=ilc
      do j=1,nc
        star=' '
        ify=idate(j,1)
        ily=idate(j,2)
        n=min0(ilc,ily)-max0(ifc,ify)+1
        if(n.ge.ntest)then
          if(ify.gt.ifc.or.ily.lt.ilc)then
            star='*'
            yn='y'
          endif
          ns=ns+1
          call blank(id1(ns))
          id1(ns)=ident(j)
          ify=max0(ifc,ify)
          ily=min0(ilc,ily)
          ist=ify-idate(nc+1,1)+1
          call moment(x(ist,j),n,ave,adev,sdev,var,skew,curt,sens,ac)
          do k=1,n
            k1=k+ist-1
            fs(k,ns)=(x(k1,j)-ave)/sdev
          enddo
          stats(ns,1)=n
          stats(ns,2)=ave
          stats(ns,3)=sdev
          stats(ns,4)=skew
          stats(ns,5)=curt
          stats(ns,6)=sens
          stats(ns,7)=ac
          if(ipo.gt.1)then
            if(ns.eq.1.or.mod(ns,20).eq.0)then
              write(iu11,'(/t2,''series   ident   frst   last   '',
     *          ''year    mean   stdev   skew   kurt   sens   ac(1)'')')		                                   
            endif
            write(iu11,'(t2,i5,1x,a,a8,i6,2i7,2f8.3,3f7.3,f8.3)')
     *        ns,star,ident(j),ify,ily,n,ave,sdev,skew,curt,sens,ac
          endif
        endif
      enddo
      if(ns.eq.0)then
        write(iu11,'(/t18,''*** no series found in common '',
     *    ''analysis period ***'')')
        return
      elseif(ns.eq.1)then
        write(iu11,'(/t15,''*** only one series found in common '',
     *    ''analysis period ***'')')
        return
      endif
      if(ipo.gt.1.and.yn.eq.'y')then
        write(iu11,'(/t14,''* at least 90 percent of the chosen '',
     *    ''common period length'')')
      endif
      write(iu11,'(/t2,''|------------ summary of common period '',
     *  ''tree-ring series statistics ------------|''/)')
      do j=1,7
        call moment(stats(1,j),ns,ave,adev,sdev,var,skew,curt,sens,ac)
        call mfs(stats(1,j),ns,rmd,hh,hl,fsd,rmn,rmx)
        stats1(1,j)=ave
        stats1(2,j)=sdev
        stats1(3,j)=rmd
        stats1(4,j)=fsd
        stats1(5,j)=rmn
        stats1(6,j)=hl
        stats1(7,j)=hh
        stats1(8,j)=rmx
      enddo
      write(iu11,'(t33,''year    mean   stdev   skew   kurt   sens   '',
     *  ''ac(1)'')')		                                   
      write(iu11,'(t2,''arithmetic mean'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats1(1,1)+0.5),(stats1(1,j),j=2,7)
      write(iu11,'(t2,''standard deviation'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats1(2,1)),(stats1(2,j),j=2,7)
      write(iu11,'(t2,''median (50th quantile)'',t33,i4,2f8.3,3f7.3,
     *  f8.3)')ifix(stats1(3,1)),(stats1(3,j),j=2,7)
      write(iu11,'(t2,''interquartile range'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats1(4,1)),(stats1(4,j),j=2,7)
      write(iu11,'(t2,''minimum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats1(5,1)),(stats1(5,j),j=2,7)
      write(iu11,'(t2,''lower hinge (25th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats1(6,1)),(stats1(6,j),j=2,7)
      write(iu11,'(t2,''upper hinge (75th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats1(7,1)),(stats1(7,j),j=2,7)
      write(iu11,'(t2,''maximum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats1(8,1)),(stats1(8,j),j=2,7)
c
c *** do common period rbar analysis
c
      nr=0
      rxcor=-1.0
      rncor=1.0
      do i=1,nc
        do j=1,nc
          corr(i,j)=0.0
          if(j.eq.i)corr(i,j)=1.0
        enddo
      enddo
      k=0
      x1=0.d0
      x2=0.d0
      x3=0.d0
      x4=0.d0
      do i=1,nc-1
        ify1=idate(i,1)
        ily1=idate(i,2)
        if((ify1.le.ifc).and.(ily1.ge.ilc))k=k+1
        l=0
        do j=i+1,nc
          ify2=idate(j,1)
          ily2=idate(j,2)
          if((ify2.le.ifc).and.(ily2.ge.ilc))l=l+1
          ifmx=max0(ify1,ify2)
          ilmn=min0(ily1,ily2)
          n=min0(ilc,ilmn)-max0(ifc,ifmx)+1
          nyc=ilc-ifc+1
          if(n.ge.ntest)then
            ist=ifc-idate(nc+1,1)+1
            call pearsn(x(ist,i),x(ist,j),nyc,r,a,b)
            if(r.gt.rxcor)then
              rxcor=r
              mxi=i
              mxj=j
              mxn=n
            endif
            if(r.lt.rncor)then
              rncor=r
              mni=i
              mnj=j
              mnn=n
            endif
            nr=nr+1
            dr=r
            x1=x1+dr
            x2=x2+dr*dr
            x3=x3+dr*dr*dr
            x4=x4+dr*dr*dr*dr
            corr(l+k,k)=r
            corr(k,l+k)=r
          endif
        enddo
      enddo
c
c *** do unrotated and rotated pca of common period correlation matrix is ns.gt.1
c
      if(ns.gt.1)then
        call pca(fs,a,b,c,stats(1,8),stats(1,9),fil1,id1,ns,kdate,corr,ird,itp,mxs,mxr,mxc,iu11)
      endif
c
c *** among all radii rbar
c
      rn=dfloat(nr)
      dave=x1/rn
      ave=sngl(dave)
      ddev=dsqrt((x2-rn*dave*dave)/(rn-1.d0))
      sdev=sngl(ddev)
      derr=ddev/dsqrt(rn)
      serr=sngl(derr)
      dskew=(rn*x3-3.d0*x1*x2+(2.d0*x1**3)/rn)/((rn-1.d0)*(rn-2.d0)*ddev**3)
      skew=sngl(dskew)
      fac1=rn*x4
      fac2=4.d0*x1*x3
      fac3=6.d0*x1*x1*x2/rn
      fac4=3.d0*x1**4/(rn*rn)
      fac5=(rn-1.d0)*(rn-2.d0)*(rn-3.d0)*ddev**4
      dcurt=((rn-1.d0)*(fac1-fac2+fac3-fac4))/fac5
      curt=sngl(dcurt)
      write(iu11,'(/t2,
     *  ''|------------------ all series common period rbar '',
     *  ''statistics ------------------|''//t4,
     *  ''total    mean   standard   standard  skewess   kurtosis   '',
     *  ''minimum   maximum''/t4,''corrs    rbar   deviation    '',
     *  ''error    coeff      coeff      corr      corr'')')
      if(nr.lt.1000)then
        write(iu11,'(i7,f9.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *    nr,ave,sdev,serr,skew,curt,rncor,rxcor
      else
        write(iu11,'(i8,f8.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *    nr,ave,sdev,serr,skew,curt,rncor,rxcor
      endif
      write(iu11,'(/t4,''minimum correlation: '',f6.3,''   series  '',
     *  a8,''   and  '',a8,i7,'' years'')')rncor,ident(mni),ident(mnj),
     *  mnn
      write(iu11,'(t4,''maximum correlation: '',f6.3,''   series  '',
     *  a8,''   and  '',a8,i7,'' years'')')rxcor,ident(mxi),ident(mxj),
     *  mxn
      rtot=ave
      rdev=sdev
c
c *** within-tree radii rbar
c
      call wtcpa(x,idate,nc,ifc,ilc,mxy,mxs,ntree,nwr,ceff,rwt,
     *  wdev,iu11)
c
c *** between-tree radii rbar
c
      call btcpa(x,idate,nc,ifc,ilc,mxy,mxs,nbr,rbt,bdev,iu11)
c
c *** final rbar, eps, sss statistics
c
      write(iu11,'(/t2,
     *  ''|--------------------- final rbar, eps, and sss statistics '',
     *  ''--------------------|'')')
      write(iu11,'(/t40,''number     rbar     sdev'')')
      write(iu11,'(t15,''      all series rbar: '',i7,f10.3,f9.3)')
     *  nr,rtot,rdev
      write(iu11,'(t15,''    within-trees rbar: '',i7,f10.3,f9.3)')
     *  nwr,rwt,wdev
      write(iu11,'(t15,''   between-trees rbar: '',i7,f10.3,f9.3)')
     *  nbr,rbt,bdev
      if(nwr.gt.0)then
        reff=rbt/(rwt+((1.0-rwt)/ceff))
        ruse=reff
        write(iu11,'(/t20,''effective number of cores  -  ceff: '',
     *    t56,f8.3)')ceff
      else
        ruse=rbt
      endif
      ruse=rtot
      rnt=float(ns)
      snr=ruse*rnt/(1.0-ruse)
      eps=ruse/(ruse+(1.0-ruse)/rnt)
      rbar=ruse
      rbsg=bdev
      write(iu11,'(/t18,''effective chronology signal  -  reff: '',
     *  t56,f8.3)')reff
      write(iu11,'(t24,''signal-to-noise ratio  -   snr: '',
     *  t56,f8.3)')snr
      write(iu11,'(t18,''expressed population signal  -   eps: '',
     *  t56,f8.3)')eps
      do i=1,ns
        ri=i
        pr(i)=(ri*(1.0+(rnt-1.0)*ruse))/(rnt*(1.0+(ri-1.0)*ruse))
      enddo
      write(iu11,'(/
     *  t4,''fractional common variance between the reduced '',
     *      ''sample-size chronology and the''/
     *  t13,''fully replicated chronology ('',
     *      ''subsample signal strength - sss)'')')
      write(iu11,'(/t20,''sss as function of the number of trees '',
     *  ''in sample'')')
      do i=1,ns,12
        j=min0(i+11,ns)
        write(iu11,'(t8,12i6)')(k,k=i,j)
        write(iu11,'(t2,'' sss:'',t9,12f6.3)')(pr(k),k=i,j)
      enddo
      write(iu11,'(/
     *  t6,''fractional common variance between the reduced '',
     *      ''sample-size chronology and''/
     *  t19,''the expressed population signal or eps chronology'')')
      write(iu11,'(/t20,''eps as function of the number of trees '',
     *  ''in sample'')')
      do i=1,ns,12
        j=min0(i+11,ns)
        write(iu11,'(t8,12i6)')(k,k=i,j)
        write(iu11,'(t2,'' eps:'',t9,12f6.3)')(eps*pr(k),k=i,j)
      enddo
      return
      end
*sbr wtcpa
c
c *** within-tree common period analysis
c
c     x(i,j) --  matrix of tree-ring data to be saved
c     idate  --  matrix of information on series (dates, etc.)
c     nc     --  number of series in matrix x
c     ifc    --  first year of common period
c     ilc    --  last year of common period
c     mxy    --  maximum row dimension of x, from main program
c     mxs    --  maximum column dimension of x, from main program
c     ntree  --  number of trees encountered
c     nwr    --  number of within-tree corrleations
c     pr     --  array of within-tree correlation coefficients
c
      subroutine wtcpa(x,idate,nc,ifc,ilc,mxy,mxs,ntree,nwr,
     *  ceff,rwt,wdev,iu11)
      parameter(mxx=10000)
      real*4 x(mxy,mxs)
      real*8 x1,x2,x3,x4,dr,fac1,fac2,fac3,fac4,fac5,rn
      real*8 dave,ddev,dder,dskew,dcurt
      integer idate(mxs+2,10),nseq(mxx)
      kt=1
      ntree=0
      ntcore=0
      nwr=0
      ntest=1.00*(ilc-ifc+1)
      x1=0.d0
      x2=0.d0
      x3=0.d0
      x4=0.d0
      rxcor=-1.0
      rncor=1.0
      do i=1,nc
        nwt=0
        nbt=0
        do j=1,nc
          nseq(j)=0
        enddo
        do j=1,nc
          if(idate(j,10).eq.kt)then
            nwt=nwt+1
            nseq(nwt)=j
            ntcore=ntcore+1
            if(nwt.eq.1)ntree=ntree+1
          endif
        enddo
        if(nwt.gt.1)then
          do j=1,nwt-1
            jj=nseq(j)
            ify1=idate(jj,1)
            ily1=idate(jj,2)
            do k=j+1,nwt
              kk=nseq(k)
              ify2=idate(kk,1)
              ily2=idate(kk,2)
              ifmx=max0(ify1,ify2)
              ilmn=min0(ily1,ily2)
              n=min0(ilc,ilmn)-max0(ifc,ifmx)+1
              nyc=ilc-ifc+1              
              if(n.ge.ntest)then
                ist=ifc-idate(nc+1,1)+1
                call pearsn(x(ist,jj),x(ist,kk),nyc,r,a,b)
                if(r.gt.rxcor)then
                  rxcor=r
                  mxi=j
                  mxj=k
                  mxn=nyc
                endif
                if(r.lt.rncor)then
                  rncor=r
                  mni=j
                  mnj=k
                  mnn=nyc
                endif
                nwr=nwr+1
                dr=r
                x1=x1+dr
                x2=x2+dr*dr
                x3=x3+dr*dr*dr
                x4=x4+dr*dr*dr*dr
              endif
            enddo
          enddo
        endif
        if(ntcore.eq.nc)goto 10
        kt=kt+1
      enddo
   10 if(nwr.gt.0)then
        rn=dfloat(nwr)
        dave=x1/rn
        wave=sngl(dave)
        ddev=dsqrt((x2-rn*wave*wave)/(rn-1.d0))
        wdev=sngl(ddev)
        dder=ddev/dsqrt(rn)
        wder=sngl(dder)
        dskew=(rn*x3-3.d0*x1*x2+(2.d0*x1**3)/rn)/((rn-1.d0)*
     *    (rn-2.d0)*ddev**3)
        skew=sngl(dskew)
        fac1=rn*x4
        fac2=4.d0*x1*x3
        fac3=6.d0*x1*x1*x2/rn
        fac4=3.d0*x1**4/(rn*rn)
        fac5=(rn-1.d0)*(rn-2.d0)*(rn-3.d0)*ddev**4
        dcurt=((rn-1.d0)*(fac1-fac2+fac3-fac4))/fac5
        curt=sngl(dcurt)
        rwr=nwr
        if(wave.eq.1.0)then
          wdev=0.0
          wder=0.0
        endif
        write(iu11,'(/t2,
     *    ''|------------------ within-tree common period rbar '',
     *    ''statistics -----------------|''//t4,
     *  ''total    mean   standard   standard  skewess   '',
     *  ''kurtosis   minimum   maximum''/t4,''corrs    rbar   '',
     *  ''deviation    error    coeff      coeff      '',
     *  ''corr      corr'')')
        if(nr.lt.1000)then
          write(iu11,'(i7,f9.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *      nwr,wave,wdev,wder,skew,curt,rncor,rxcor
        else
          write(iu11,'(i8,f8.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *      nwr,wave,wdev,wder,skew,curt,rncor,rxcor
        endif
        rwt=wave
        ceff=0.0
        do i=1,ntree
          ncore=0
          do j=1,nc
            if(idate(j,10).eq.i)then
              ncore=ncore+1
            endif
          enddo
          if(ncore.gt.0)ceff=ceff+1.0/float(ncore)
        enddo
        ceff=1.0/(ceff/float(ntree))
      else
        write(iu11,'(/t2,
     *    ''|------------------ within-tree common period rbar '',
     *    ''statistics -----------------|''//
     *    t30,''no within-tree series found'')')
        rwt=0.0
        wdev=0.0
        ceff=nc
      endif
      return
      end
*sbr btcpa
c
c *** between-tree common period analysis
c
c     x(i,j) --  matrix of tree-ring data to be saved
c     idate  --  matrix of information on series (dates, etc.)
c     nc     --  number of series in matrix x
c     ifc    --  first year of common period
c     ilc    --  last year of common period
c     mxy    --  maximum row dimension of x, from main program
c     mxs    --  maximum column dimension of x, from main program
c     nbr    --  number of between-tree corrleations
c
      subroutine btcpa(x,idate,nc,ifc,ilc,mxy,mxs,nbr,rbt,bdev,iu11)
      real*4 x(mxy,mxs)
      real*8 x1,x2,x3,x4,dr,fac1,fac2,fac3,fac4,fac5,rn
      real*8 dave,ddev,dder,dskew,dcurt
      integer idate(mxs+2,10)
      nbr=0
      ntest=1.00*(ilc-ifc+1)
      x1=0.d0
      x2=0.d0
      x3=0.d0
      x4=0.d0
      rxcor=-1.0
      rncor=1.0
      do i=1,nc-1
        if(idate(i,10).ne.0)then
          ify1=idate(i,1)
          ily1=idate(i,2)
          do j=i+1,nc
            if((idate(j,10).ne.idate(i,10)).and.(idate(j,10).ne.0))then
              ify2=idate(j,1)
              ily2=idate(j,2)
              ifmx=max0(ify1,ify2)
              ilmn=min0(ily1,ily2)
              n=min0(ilc,ilmn)-max0(ifc,ifmx)+1
              nyc=ilc-ifc+1              
              if(n.ge.ntest)then
                ist=ifc-idate(nc+1,1)+1
                call pearsn(x(ist,i),x(ist,j),n,r,a,b)
                if(r.gt.rxcor)then
                  rxcor=r
                  mxi=j
                  mxj=k
                  mxn=nyc
                endif
                if(r.lt.rncor)then
                  rncor=r
                  mni=j
                  mnj=k
                  mnn=nyc
                endif
                nbr=nbr+1
                dr=r
                x1=x1+dr
                x2=x2+dr*dr
                x3=x3+dr*dr*dr
                x4=x4+dr*dr*dr*dr
              endif
            endif
          enddo
        endif
      enddo
      if(nbr.gt.0)then
        call moment(pr,nbr,bave,adev,bdev,var,skew,curt,sens,ac)
        rbr=nbr
        rn=dfloat(nbr)
        dave=x1/rn
        bave=sngl(dave)
        ddev=dsqrt((x2-rn*bave*bave)/(rn-1.d0))
        bdev=sngl(ddev)
        dder=ddev/dsqrt(rn)
        bder=sngl(dder)
        dskew=(rn*x3-3.d0*x1*x2+(2.d0*x1**3)/rn)/((rn-1.d0)*
     *    (rn-2.d0)*ddev**3)
        skew=dskew
        fac1=rn*x4
        fac2=4.d0*x1*x3
        fac3=6.d0*x1*x1*x2/rn
        fac4=3.d0*x1**4/(rn*rn)
        fac5=(rn-1.d0)*(rn-2.d0)*(rn-3.d0)*ddev**4
        dcurt=((rn-1.d0)*(fac1-fac2+fac3-fac4))/fac5
        curt=sngl(dcurt)
        if(bave.eq.1.0)then
          bdev=0.0
          bder=0.0
        endif
        write(iu11,'(/t2,
     *    ''|----------------- between-tree common period rbar '',
     *    ''statistics -----------------|''//t4,
     *  ''total    mean   standard   standard  skewess   kurtosis   '',
     *  ''minimum   maximum''/t4,''corrs    rbar   deviation    '',
     *  ''error    coeff      coeff      corr      corr'')')
        if(nr.lt.1000)then
          write(iu11,'(i7,f9.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *      nbr,bave,bdev,bder,skew,curt,rncor,rxcor
        else
          write(iu11,'(i8,f8.3,f10.3,f11.3,f9.3,f11.3,2f10.3)')
     *      nbr,bave,bdev,bder,skew,curt,rncor,rxcor
        endif
        rbt=bave
      else
        write(iu11,'(/t2,
     *    ''|----------------- between-tree common period rbar '',
     *    ''statistics -----------------|''//
     *    t29,''no between-tree series found'')')
      endif
      return
      end
*sbr trnfrm
*
      subroutine trnfrm(x,wk1,wk2,wk3,wk4,wk5,wk6,idate,ident,nc,stats)
      parameter(mxy=5000,mxs=3000)
      real*4 x(mxy,mxs),wk1(mxy),wk2(mxy),wk3(mxy),wk4(mxy),wk5(mxy),wk6(mxy)
      real*4 stats(mxs,12),eq(7)
      integer idate(mxs+2,10),ns(mxy)
      character ident(mxs)*8,tit*40,id*8
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** tsi graphics stuff
c
      real*4 y(mxy,16)
      common/tsi2/y
c
      itn1=jems(3,1)
      itn2=jems(3,2)
      iplt=jems(3,2)
      jtn=itn1
      ipo=jems(17,1)
      ird=jems(19,1)
      jrd=ird
      iopt=1
      if(itn1.eq.4)iopt=2
c
      write(*,'(/1x,''transform the individual tree-ring series''/)')
      if(ipo.gt.1)then
        write(iu11,'(/t2,''|------------------ statistics of '',
     *    ''transformed tree-ring data ------------------|''/)')
        write(iu11,'(t61,''spread vs level tests'')')
      endif
      do j=1,nc
        write(*,'(1x,i6,2x,a8)')j,ident(j)
        if(bf.eq.'y'.or.bf.eq.'Y')then
          jtn=idate(j,4)
        endif
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ist=idate(j,1)-idate(nc+1,1)+1
        do i=1,n
          wk1(i)=x(i+ist-1,j)
          wk4(i)=wk1(i)
        enddo
        call moment(wk1,n,ave1,adev1,sdev1,var1,skew1,curt1,sens1,ac1)
c
        y(j,1)=skew1
c
        call qcksrt(n,wk1)
        rmin=wk1(1)
        rmax=wk1(n)
        range=rmax-rmin
        call mndf(x(ist,j),n,nseg,wk1,wk2,iopt)
        stats(j,7)=nseg
        rseg=nseg
        call pearsn(wk1,wk2,nseg,r,a,b)
c
        y(j,2)=r
c
ccc     if(nseg.le.500)then
ccc       call wmse(wk1,wk2,nseg,a,b)
ccc     endif
        stats(j,8)=r
        p=1.0-b
        if(p.lt.0.05)p=0
        if(p.gt.1.0)p=1.0
        stats(j,10)=p
c
        y(j,3)=p
c
        if(jtn.lt.4)then
          do i=1,n
            datum=x(i+ist-1,j)
            if(jtn.eq.1)then
              if(datum.gt.0)then
                datum=alog(datum)
              else
                datum=alog(0.01)
              endif
              x(i+ist-1,j)=datum
              wk1(i)=datum
            elseif(jtn.eq.2)then
              datum=alog(datum+1./6.)
              x(i+ist-1,j)=datum
              wk1(i)=datum
            elseif(jtn.eq.3)then
              datum=alog(datum+sqrt(datum*datum+1.0))
              x(i+ist-1,j)=datum
              wk1(i)=datum
            endif
          enddo
        else
ccc          if(bf.eq.'y'.or.bf.eq.'y')then
ccc            if(jtn.gt.6)then
ccc              p=float(jtn)/1000.0
ccc            endif
ccc          endif
          do i=1,n
            datum=x(i+ist-1,j)
            if(p.gt.0)then
              if(datum.lt.0.01)datum=0.01
              datum=datum**p
            else
              if(datum.gt.0)then
                datum=alog(datum)
              else
                datum=alog(0.05)
              endif
            endif
            x(i+ist-1,j)=datum
            wk1(i)=datum
          enddo
        endif
        call qcksrt(n,wk1)
        rminp=wk1(1)
        rmaxp=wk1(n)
        rangep=rmaxp-rminp
        do i=1,n
          datum=x(i+ist-1,j)
          datum=(datum-rminp)*range/rangep+rmin
          x(i+ist-1,j)=datum
        enddo
        call moment(x(ist,j),n,ave,adev,sdev,var,skew,curt,sens,ac)
c
        y(j,4)=skew
c
        stats(j,1)=ave
        stats(j,2)=sdev
        stats(j,3)=skew
        stats(j,4)=curt
        stats(j,5)=sens
        stats(j,6)=ac
        call mndf(x(ist,j),n,nseg,wk1,wk2,iopt)
        call pearsn(wk1,wk2,nseg,r,a,b)
c
        y(j,5)=r
        y(j,6)=1.0-b
c
        stats(j,9)=r
        if(ipo.gt.1)then
          if(j.eq.1)then
            write(iu11,'(t2,''series   ident    mean   sdev    '',
     *        ''skew   kurt   sens  ac(1)  corr1   corr2  power'')')
          elseif(mod(j,20).eq.0)then
            write(iu11,'(/t2,''series   ident    mean   sdev    '',
     *        ''skew   kurt   sens  ac(1)  corr1   corr2  power'')')
          endif                                  
          write(iu11,'(t2,i5,2x,a8,2f7.3,f8.3,2f7.3,2f7.3,f8.3,f7.3)')
     *      j,ident(j),(stats(j,k),k=1,6),(stats(j,k),k=8,10)
        endif
        if(bf.eq.'n'.or.bf.eq.'N')then
          if(itn1.gt.3)then
            idate(j,4)=max(ifix(p*1000.),4)  !Tom Melvins idea
          else
            idate(j,4)=jtn
          endif
        endif
c
c *** begin new tsi graphics
c
        if(iplt.eq.1)then
          call spline(n,wk4,wk1,p,n/10)
          call spline(n,x(ist,j),wk2,p,n/10)
          call blank(tit)
          if(itn1.eq.1)then
            tit=' transformed series, ln(rt)'
          elseif(itn1.eq.2)then
            tit=' transformed series, ln(rt+1/6)'
          elseif(itn1.eq.3)then
            tit=' transformed series, inverse hypersine'
          elseif(itn1.eq.4)then
            tit(1:25)=' transformed series, p ='
            write(tit(26:30),'(f5.2)')stats(j,10)
          endif
          call blank(id)
          k=0
          do i=1,8
            if(ident(j)(i:i).ne.' ')then
              k=k+1
              id(k:k)=ident(j)(i:i)
            endif
          enddo
c	    pause'ars itype=2'
          call crnplt1(wk4,wk1,wk5,x(ist,j),wk2,wk6,ns,n,ify,1,id,
     *      ' original series',tit,'years','measurement (y)',
     *      'years','measurement (z)',2,pixels,iplt,mxy,eq,jdt)
        endif
c
c *** end new tsi graphics
c
      enddo
      write(iu11,'(/t2,''|------------- summary of transformed '',
     *  ''tree-ring series statistics -------------|''/)')
      write(iu11,'(t61,''spread vs level tests'')')
      do j=1,10
        call moment(stats(1,j),nc,ave,adev,sdev,var,skew,curt,sens,ac)
        call mfs(stats(1,j),nc,rmd,hh,hl,fsd,rmn,rmx)
        stats(1,j)=ave
        stats(2,j)=sdev
        stats(3,j)=rmd
        stats(4,j)=fsd
        stats(5,j)=rmn
        stats(6,j)=hl
        stats(7,j)=hh
        stats(8,j)=rmx
      enddo
      corr1=stats(1,8)
      corr2=stats(1,9)
      power=stats(1,10)
      write(iu11,'(t16,''   mean   sdev    skew   kurt   sens  '',
     *  ''ac(1)  corr1   corr2   power'')')
      write(iu11,'(t2,''arith mean'',t16,2f7.3,f8.3,2f7.3,2f7.3,
     *  2f8.3)')(stats(1,k),k=1,6),(stats(1,k),k=8,10)
      write(iu11,'(t2,''std deviation'',t16,2f7.3,f8.3,2f7.3,
     *  2f7.3,2f8.3)')(stats(2,k),k=1,6),(stats(2,k),k=8,10)
      write(iu11,'(t2,''median'',t16,2f7.3,f8.3,2f7.3,
     *  2f7.3,2f8.3)')(stats(3,k),k=1,6),(stats(3,k),k=8,10)
      write(iu11,'(t2,''interquartile'',t16,2f7.3,f8.3,2f7.3,
     *  2f7.3,2f8.3)')(stats(4,k),k=1,6),(stats(4,k),k=8,10)
      write(iu11,'(t2,''minimum value'',t16,2f7.3,f8.3,2f7.3,2f7.3,
     *  2f8.3)')(stats(5,k),k=1,6),(stats(5,k),k=8,10)
      write(iu11,'(t2,''lower hinge'',t16,2f7.3,f8.3,2f7.3,2f7.3,
     *  2f8.3)')(stats(6,k),k=1,6),(stats(6,k),k=8,10)
      write(iu11,'(t2,''upper hinge'',t16,2f7.3,f8.3,2f7.3,2f7.3,
     *  2f8.3)')(stats(7,k),k=1,6),(stats(7,k),k=8,10)
      write(iu11,'(t2,''maximum value'',t16,2f7.3,f8.3,2f7.3,2f7.3,
     *  2f8.3)')(stats(8,k),k=1,6),(stats(8,k),k=8,10)
      if(itn2.eq.1.or.jrd.eq.2.or.jrd.eq.3)then
        call power1(nc,fil1,tit)
      endif
      return
      end
*sbr mndf -- computes the mean and difference
*
      subroutine mndf(x,n,nseg,mn,df,iopt)
      real*4 x(n),mn(n),df(n)
      ncnt=0
      do i=1,n-1
        if(iopt.eq.1)xm=(x(i)+x(i+1))/2.
        if(iopt.eq.2)xm=x(i+1)
        dif=abs(x(i+1)-x(i))
	       if(xm.gt.0.and.dif.gt.0)then
	         ncnt=ncnt+1
	         mn(ncnt)=alog(xm)
	         df(ncnt)=alog(dif)
	       endif
      enddo
   	  nseg=ncnt
   	  return
   	  end
*sbr mndf1 -- computes the mean and difference
*
      subroutine mndf1(x,ns,n,nseg,mn,df,iopt)
      real*4 x(n),mn(n),df(n)
      integer ns(n)
      ncnt=0
      do i=1,n-1
        if(ns(i).gt.0.and.ns(i+1).gt.0)then
          if(iopt.eq.1)xm=(x(i)+x(i+1))/2.
          if(iopt.eq.2)xm=x(i+1)
          dif=abs(x(i+1)-x(i))
	         if(xm.gt.0.and.dif.gt.0)then
	           ncnt=ncnt+1
	           mn(ncnt)=alog(xm)
	           df(ncnt)=alog(dif)
	         endif
        endif
      enddo
   	  nseg=ncnt
   	  return
   	  end
*sbr acf
*
	     subroutine acf(x,n,nlags,ac,pac,seac)
c
c compute the autocorrelation function of a time series
c
	     parameter(mx=101)
	     dimension x(n),ac(12),pac(12),seac(12),wk(mx)
c
c compute the mean and variance of the series
c
      sm=0.
      do 9 i=1,n
        sm=sm+x(i)
    9 continue
      rn=n
      xm=sm/rn
      sq=0.
      do 10 i=1,n
        sq=sq+(x(i)-xm)**2
   10 continue
      var=sq/rn
      sd=sqrt(var)
c
c normalize the input series
c
      do 20 i=1,n
        x(i)=(x(i)-xm)/sd
   20 continue
c
c compute the autocorrelations out to nlags
c
      do 11 j=1,nlags+1
        cxx=0.
        do 12 i=j+1,n
          cxx=cxx+x(i)*x(i-j)
   12   continue
        ac(j)=cxx/rn
   11 continue
c
c compute the partial autocorrelations out to nlags
c
      pac(1)=ac(1)
      do 13 j=2,nlags+1
        j1=j-1
        wk(j1)=pac(j1)
        j2=j1/2
        if(j.eq.2) goto 15
        do 14 k0=1,j2
          jimk=j1-k0
	         temp2=wk(k0)-pac(j1)*wk(jimk)
	         wk(jimk)=wk(jimk)-pac(j1)*wk(k0)
	         wk(k0)=temp2
   14   continue
   15   temp=0.
   	    temp1=0.
	       do 16 i=1,j1
	         temp=temp+ac(j-i)*wk(i)
	         temp1=temp1+ac(i)*wk(i)
   16   continue
   	    pac(j)=(ac(j)-temp)/(1.0-temp1)
   13 continue
c
c compute the standard errors of the autocorrelation function
c
      seac(1)=2.0/sqrt(rn)
      do 17 i=2,nlags+1
	       sm=0.
	       k=i-1
	       do 18 j=1,k
	         sm=sm+ac(j)*ac(j)
   18   continue
   	    seac(i)=sqrt(1.0+2.0*sm)*2.0/sqrt(rn)
   17 continue
c
c denormalize the input series
c
      do 21 i=1,n
        x(i)=x(i)*sd+xm
   21 continue
      return
      end
*sbr acf1
*
	     subroutine acf1(x,ns,n,nlags,ac,pac,seac)
c
c compute the autocorrelation function of a time series
c
	     parameter(mx=101)
	     dimension x(n),ac(12),pac(12),seac(12),wk(mx),ns(n)
c
c compute the mean and variance of the series
c
      sm=0.
      n1=0
      do 9 i=1,n
        if(ns(i).gt.0)then
          n1=n1+1
          sm=sm+x(i)
        endif
    9 continue
      rn1=n1
      xm=sm/rn1
      sq=0.
      do 10 i=1,n
        if(ns(i).gt.0)then
          sq=sq+(x(i)-xm)**2
        endif
   10 continue
      var=sq/rn1
      sd=sqrt(var)
c
c normalize the input series
c
      do 20 i=1,n
        if(ns(i).gt.0)then
          x(i)=(x(i)-xm)/sd
        endif
   20 continue
c
c compute the autocorrelations out to nlags
c
      do 11 j=1,nlags+1
        cxx=0.
        do 12 i=j+1,n
          if(ns(i).gt.0.and.ns(i-j).gt.0)then
            cxx=cxx+x(i)*x(i-j)
          endif
   12   continue
        ac(j)=cxx/rn1
   11 continue
c
c compute the partial autocorrelations out to nlags
c
      pac(1)=ac(1)
      do 13 j=2,nlags+1
        j1=j-1
        wk(j1)=pac(j1)
        j2=j1/2
        if(j.eq.2) goto 15
        do 14 k0=1,j2
          jimk=j1-k0
	         temp2=wk(k0)-pac(j1)*wk(jimk)
	         wk(jimk)=wk(jimk)-pac(j1)*wk(k0)
	         wk(k0)=temp2
   14   continue
   15   temp=0.
   	    temp1=0.
	       do 16 i=1,j1
	         temp=temp+ac(j-i)*wk(i)
	         temp1=temp1+ac(i)*wk(i)
   16   continue
   	    pac(j)=(ac(j)-temp)/(1.0-temp1)
   13 continue
c
c compute the standard errors of the autocorrelation function
c
      seac(1)=2.0/sqrt(rn1)
      do 17 i=2,nlags+1
	       sm=0.
	       k=i-1
	       do 18 j=1,k
	         sm=sm+ac(j)*ac(j)
   18   continue
   	    seac(i)=sqrt(1.0+2.0*sm)*2.0/sqrt(rn1)
   17 continue
c
c denormalize the input series
c
      do 21 i=1,n
        if(ns(i).gt.0)then
          x(i)=x(i)*sd+xm
        endif
   21 continue
      return
      end
*sbr pltdec1: plots of 10- or 5-year means
*
*  programmed by
*
*     edward r cook
*     tree-ring laboratory
*     lamont-doherty geological observatory
*     palisades, new york  10964
*
*  modified by r l holmes 16 nov 1987
*
* rs:    raw series
* ev:    curve series
* ri:    index values
* n:     number of data values
* ifyr:  first year of series
* li:    length of interval plotted
* mxd:   dimension of arrays rw,cv and ynd
*
      subroutine pltdec1(rs,ev,ri,n,ifyr,li,iuo,ipo,ido)
      parameter(mxc=500)
      real*4 rs(n),ev(n),ri(n),rw(mxc),cv(mxc),ynd(mxc)
      character iout(54)
      if(ipo.lt.5)then
        write(iuo,'(/t10,''***'',i3,''-year means of '',
     *    ''measurements, curve fit (x), and indices ***'')')li
        write(iuo,'(/t9,''msmt curve'',t55,''index'')')
        write(iuo,'(''  year'',2('' means''),t55,''means''/)')
      elseif(ido.eq.2)then
        write(*,'(/t10,''***'',i3,''-year means of '',
     *    ''measurements, curve fit (x), and indices ***'')')li
        write(*,'(/t9,''msmt curve'',t55,''index'')')
        write(*,'(''  year'',2('' means''),t55,''means''/)')
      endif
*
* initialize
      ilyr=ifyr+n-1
      kfyr=ifyr/li*li
      ist=kfyr-ifyr
      n1=n-ist
      ndec=n1/li
      if(mod(n1,li).eq.0)ndec=ndec-1
      if(mod(ilyr,10).eq.0)ndec=ndec-1
      v=float(li)
*
* calculate interval mean measurement, curve and index
ccc      write(*,'(/1x,''li: '',i5,5x,''n: '',i5)')li,n
ccc      write(*,'(1x,''ifyr: '',i5,5x,''kfyr: '',i5,5x,
ccc     *  ''ndec: '',i4)')ifyr,kfyr,ndec
      do i=1,ndec
        j=(i-1)*li+1
        k=j+li-1
        if(k.gt.n)then
          ndec=ndec-1
          goto 10
        endif
        sm1=0.0
        sm2=0.0
        sm3=0.0
ccc        write(*,'(1x,''i,j,k: '',3i10)')i,j,k
        do l=j,k
          sm1=sm1+rs(l)
          sm2=sm2+ev(l)
          sm3=sm3+ri(l)
        enddo
        rw(i)=sm1/v
        cv(i)=sm2/v
        ynd(i)=sm3/v
      enddo
ccc      do i=1,ndec
ccc        write(*,'(3f10.3)')rw(i),cv(i),ynd(i)
ccc      enddo
ccc      pause
   10 continue
*
* find max and min values for plots
      amx1=-999999.0
      amn1= 999999.0
      amx2=amx1
      amn2=amn1
      do i=1,ndec
        amx1=max(amx1,rw(i),cv(i))
        amn1=min(amn1,rw(i),cv(i))
        amx2=max(amx2,ynd(i))
        amn2=min(amn2,ynd(i))
      enddo
      range1=amx1-amn1
      units1=range1/32.0
      range2=amx2-amn2
      units2=range2/20.0
*
* calculate and print plot points
      do k=1,ndec
        do j=1,54
          iout(j)=' '
        enddo
        jp1=(ynd(k)-amn2)/units2+34.5
        jp4=(1.0-amn2)/units2+34.5
        jp2=(rw(k)-amn1)/units1+1.5
        jp3=(cv(k)-amn1)/units1+1.5
        j=mod(kfyr/10,10)
        iout(jp4)='|'
        write(iout(jp1),'(i1)')j
        write(iout(jp2),'(i1)')j
        if(jp2.ne.jp3)iout(jp3)='x'
        if(ipo.lt.5)then
          write(iuo,'(t2,i5,2f6.2,t54,f6.2,t21,33a1,t62,21a1)')
     *      kfyr,rw(k),cv(k),ynd(k),iout
        elseif(ido.eq.2)then
          write(*,'(t2,i5,2f6.2,t54,f6.2,t21,33a1,t62,21a1)')
     *      kfyr,rw(k),cv(k),ynd(k),iout
        endif
        kfyr=kfyr+li
      enddo
      return
      end
*sbr memcof
*
      subroutine memcof(data,n,m,ip,pm,cof,iopt,wk1,wk2,wkm)
      real*4 data(n),cof(12),wk1(n),wk2(n),wkm(n)
      rn=n
      pm=0.0
      sm=0.0
      do j=1,n
        sm=sm+data(j)
      enddo
      xm=sm/rn  
      p=0.0
      do 11 j=1,n
        data(j)=data(j)-xm
        p=p+data(j)**2
   11 continue
      pm=p/rn
      pmm=pm
      sst=pmm
      aicm=rn*alog(pm)+2.0
      aicmm=aicm
      wk1(1)=data(1)
      wk2(n-1)=data(n)
      do 12 j=2,n-1
        wk1(j)=data(j)
        wk2(j-1)=data(j)
   12 continue
      do 18 k=1,m
        pneum=0.0
        denom=0.0
        do 13 j=1,n-k
          pneum=pneum+wk1(j)*wk2(j)
          denom=denom+wk1(j)**2+wk2(j)**2
   13   continue
        cof(k)=2.0*pneum/denom
        pm=pm*(1.0-cof(k)**2)
        rk=k
        ht=2.0*(rk+1.0)*(rk+2.0)/(rn-rk-2.0)
        aic=rn*alog(pm)+2.0*(rk+1.0)+ht
        if(k.ne.1)then
          do 14 i=1,k-1
            cof(i)=wkm(i)-cof(k)*wkm(k-i)
   14     continue
        endif
        if(iopt.lt.1)then
          if(k.gt.1.and.aic.gt.aicm)then
            ip=k-1
            pm=1.0-pm/sst
            aic=aicm
            do 15 i=1,ip
              cof(i)=wkm(i)
   15       continue
            if(aicm.gt.aicmm)then
              ip=0
              pm=0.0
              aic=aicmm
            endif
            goto 19
          endif
        else
          if(k.eq.m)then
            goto 18
          endif
        endif
        do 16 i=1,k
          wkm(i)=cof(i)
   16   continue
        do 17 j=1,n-k-1
          wk1(j)=wk1(j)-wkm(k)*wk2(j)
          wk2(j)=wk2(j+1)-wkm(k)*wk1(j+1)
   17   continue
        pmm=pm
        aicm=aic
ccc        write(*,'(1x,i2,f10.2,11f7.3)')k,aic,(cof(j),j=1,k)
   18 continue
      ip=m-1
      pm=1.0-pm/sst
      aic=aicm
      do i=1,ip
        cof(i)=wkm(i)
      enddo
   19 do j=1,n
        data(j)=data(j)+xm
      enddo
      return
      end
*sbr memcof1
*
      subroutine memcof1(data,ns,n,m,ip,pm,cof,iopt,wk1,wk2,wkm)
      real*4 data(n),cof(m),wk1(n),wk2(n),wkm(m)
      integer ns(n)
      rn=n
      pm=0.0
      sm=0.0
      n1=0
      do j=1,n
        if(ns(j).gt.0)then
          n1=n1+1
          sm=sm+data(j)
        endif
      enddo
      rn1=n1
      xm=sm/rn1  
      p=0.0
      do 11 j=1,n
        if(ns(j).gt.0)then
          data(j)=data(j)-xm
          p=p+data(j)**2
        endif
   11 continue
      pm=p/rn1
      pmm=pm
      sst=pmm
      aicm=rn1*alog(pm)+2.0
      aicmm=aicm
      wk1(1)=data(1)
      wk2(n-1)=data(n)
      do 12 j=2,n-1
        wk1(j)=data(j)
        wk2(j-1)=data(j)
   12 continue
      do 18 k=1,m
        pneum=0.0
        denom=0.0
        do 13 j=1,n-k
          if(ns(j).gt.0)then
            pneum=pneum+wk1(j)*wk2(j)
            denom=denom+wk1(j)**2+wk2(j)**2
          endif
   13   continue
        cof(k)=2.0*pneum/denom
        pm=pm*(1.0-cof(k)**2)
        rk=k
        ht=2.0*(rk+1.0)*(rk+2.0)/(rn1-rk-2.0)
        aic=rn1*alog(pm)+2.0*(rk+1.0)+ht
        if(k.ne.1)then
          do 14 i=1,k-1
            cof(i)=wkm(i)-cof(k)*wkm(k-i)
   14     continue
        endif
        if(iopt.lt.1)then
          if(k.gt.1.and.aic.gt.aicm)then
            ip=k-1
            pm=1.0-pm/sst
            aic=aicm
            do 15 i=1,ip
              cof(i)=wkm(i)
   15       continue
            if(aicm.gt.aicmm)then
              ip=0
              pm=0.0
              aic=aicmm
            endif
            goto 19
          endif
        else
          if(k.eq.m)then
            goto 18
          endif
        endif
        do 16 i=1,k
          wkm(i)=cof(i)
   16   continue
        do 17 j=1,n-k-1
          if(ns(j).gt.0.and.ns(j+1).gt.0)then
            wk1(j)=wk1(j)-wkm(k)*wk2(j)
            wk2(j)=wk2(j+1)-wkm(k)*wk1(j+1)
          endif
   17   continue
        pmm=pm
        aicm=aic
ccc        write(*,'(1x,i2,f10.2,11f7.3)')k,aic,(cof(j),j=1,k)
   18 continue
      ip=m-1
      pm=1.0-pm/sst
      aic=aicm
      do i=1,ip
        cof(i)=wkm(i)
      enddo
   19 do j=1,n
        if(ns(j).gt.0)then
          data(j)=data(j)+xm
        endif
      enddo
      return
      end
*sbr rcs
c
c *** estimate the biological age curve for briffa's rcs method
c *** and detrend the data taking into account any pith offsets
c
      subroutine rcs(y,f,ns,stats,wrk1,wrk2,wrk3,wrk4,wrk5,gmn,
     *  nshft,tit,bierr,shl,shh)
      parameter(mxy=5000,mxs=3000)
      real*4 y(mxy,16),f(mxy),stats(mxs,12)
ccc      real*4 rmeta(10),cfs(3,10,4)
      real*4 wrk1(mxy),wrk2(mxy),wrk3(mxy),wrk4(mxy),wrk5(mxy),eq(7)
      real*4 bierr(mxy),xmean(mxs),sigma(mxs),shl(mxy),shh(mxy)
      integer ns(mxy),nshft(mxs)
      integer jdate(mxs+2,10),nss(mxy),keep(mxs)
      character fil*40,frm*40,tit*(*),id*8,tit1*85,tag*3,line1*60
      character ccf,yn,ans
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** tsi common block variables
c
      real*4 x(mxy,mxs),crn(mxy)
      integer idate(mxs+2,10)
      character ident(mxs)*8
c
c *** tsi graphics stuff
c
      common/tsi1/x,crn,idate,ident,nc
c
      idt1=jems(4,1)
      iplt=jems(4,3)
      id2=jems(5,1)
      if(id2.eq.-3.or.id2.eq.-4)then
        ndt1=jems(5,2)
      else
        ndt1=0
      endif
      irb=jems(6,1)
      ido=jems(7,1)
      ind=jems(8,1)
      krb1=jems(12,1)         !mean chronology option
      krb2=jems(12,2)         !plot bootstrap
      krb3=jems(12,3)         !bootstrap chronology
      krb4=jems(12,4)         !splined bootstrap limits
      ipo=jems(17,1)
      ics=jems(18,1)
      ird=jems(19,1)
      jrd=ird
      idtt=idt1
c
c *** open up rcs pith offset file if needed
c
      if(bf.eq.'n'.or.bf.eq.'N')then
   10   call blank(fil)
        write(*,'(/1x,''open rcs pith offset file:'')')
        write(*,'(1x,''file name (/ to exit, 0 = none)'',t45,
     *    ''==> '',$)')
        read(*,'(a)')fil
        if(fil(1:1).eq.'/')stop
        if(fil(1:1).eq.' '.or.fil(1:1).eq.'0')goto 15
        open(iu14,file=fil,status='old',err=13)
        call helpm(8)
        call snoop(iu14)
        write(*,'(/
     *    1x,''reformat the data? this act might be useful if the''/
     *    1x,''pith offset data are stored columnwise, are in some ''/
     *    1x,''column other than column #1, and are left-justified''/
     *    1x,''in that column. in this case, you can not use either''/
     *    1x,''the formated or free format read option. also, if''/
     *    1x,''your data are in the form of the number of the first''/
     *    1x,''cambial age years present, you will want to reformat''/
     *    1x,''the data as well because the program assumes that''/
     *    1x,''the pith offset data are the number of years missing.''/
     *    1x,''in any case, do not worry about doing this. if you''/
     *    1x,''reformat the data, your original file will be saved.''//
     *    1x,''so, again, reformat the data? y/<n>'',t45,''==> '',$)')
        yn=' '
        read(*,'(a)')yn
        if(yn.eq.' ')yn='n'
        if(yn.eq.'y'.or.yn.eq.'Y')then
          call csr(fil,ijk,2)
          fil(ijk+1:ijk+5)='_save'
          open(iu15,file=fil,status='unknown')
          close(iu15,status='delete')
          open(iu15,file=fil,status='unknown')
   86     call blank(tit1)
          read(iu14,'(a)',end=87)tit1
          write(iu15,'(a)')tit1
          goto 86
   87     fil(ijk+1:ijk+5)='     '
          close(iu14,status='delete')
          open(iu14,file=fil,status='unknown')
          rewind(iu15)
   88     ncol=0
          write(*,'(1x,''how many columns in file'',t45,''==> '',$)')
          read(*,*,err=88)ncol
          write(*,'(1x,''which column has the pith offset data?'',
     *      t45,''==> '',$)')
   89     read(*,*,err=89)jcol
          if(jcol.gt.ncol)goto 89
   90     write(*,'(
     *      1x,''is each listed pith offset value the''/
     *      1x,''      number of years missing         (1)''/
     *      1x,''              or the''/
     *      1x,''  first cambial age year present?     (2)'',
     *      t45,''==> '',$)')
          read(*,*,err=90)ncgy
          if(ncgy.ne.1.and.ncgy.ne.2)goto 90
          ncgy=ncgy-1
          nsh=0
   91     read(iu15,*,err=91,end=92)(nshft(j),j=1,ncol)
          nsh=nsh+1
          write(iu14,'(i5)')nshft(jcol)-ncgy
          goto 91
   92     write(*,'(/1x,''reformatted pith offset data: '',i5,'' values''/)')nsh
          write(*,'(1x,''  *** read them in free format mode ***'')')
          rewind(iu14)
          close(iu15)
          goto 11
        else
          goto 11
        endif
   11   call blank(frm)
        write(*,'(1x,''data format (h to help, <ret> = free form)'',
     *    t45,''==> '',$)')
        read(*,'(a)')frm
        if(frm(1:1).eq.' ')frm(1:1)='*'
        if(frm(1:1).eq.'h'.or.frm(1:1).eq.'H')then
          call snoop(iu14)
          goto 11
        endif
        nsh=0
        ier=0
   12   if(frm(1:1).eq.'*')then
          read(iu14,*,err=14,end=15)ish
        else
          read(iu14,frm,err=14,end=15)ish
        endif
        nsh=nsh+1
        nshft(nsh)=ish
        goto 12
   13   write(*,'(/1x,''*** error opening rcs pith offset file: '',a)')
     *    fil
        goto 10
   14   ier=ier+1
        if(ier.eq.1)then
          backspace(iu14)
          call blank(tit1)
          read(iu14,'(a)')tit1
          write(*,'(/1x,''*** pith offset title:''/1x,a40)')tit1
          goto 12
        else
          write(*,'(/1x,''*** error reading rcs pith offset file'')')
          write(*,'(1x,''*** error in line number: '',i4)')nsh
          close(iu14)
          pause
          stop
        endif
   15   if(fil(1:1).eq.' '.or.fil(1:1).eq.'0')then
          do i=1,nc
            nshft(i)=0
          enddo
        else
          write(*,'(/1x,''pith offset values read: '',i5)')nsh
          if(nsh.ne.nc)then
            write(*,'(/1x,''*** pith offset values read .ne. '',
     *        ''number of series. oops!'')')
            pause
            stop
          endif
          if(ipo.gt.1)then
            write(iu11,'(/9x,''rcs pith offset file processed:  '',a30/)')
     *        fil
            do i=1,nc,8
              j=i
              k=i+7
              if(k.gt.nc)k=nc
              write(iu11,'(''  id: '',8(1x,a8))')(ident(ii),ii=j,k)
              write(iu11,'(3x,8i9)')(nshft(ii),ii=j,k)
            enddo
          endif
          close(iu14)
        endif
      else
        do j=1,nc
          nshft(j)=idate(j,3)
        enddo
        if(ipo.gt.1)then
          isum=0
          do i=1,nc
            isum=isum+nshft(i)
          enddo
          write(iu11,'(/16x,''rcs pith offset data read in from '',
     *      ''batch detail file''/)')
          if(isum.gt.0)then
            do i=1,nc,8
              j=i
              k=i+7
              if(k.gt.nc)k=nc
              write(iu11,'(''  id: '',8(1x,a8))')(ident(ii),ii=j,k)
              write(iu11,'(3x,8i9)')(nshft(ii),ii=j,k)
            enddo
          else
            write(iu11,'(20x,''***   all pith offset data are zero   ***'')')
          endif
        endif
      endif
c
c *** properly align the data for rcs mean curve calculation
c
      do j=1,nc+2
        do k=1,10
          jdate(j,k)=idate(j,k)
        enddo
      enddo
      lsl=9999
      do j=1,nc
        if(nshft(j).lt.lsl)lsl=nshft(j)
c        write(*,'(2i10)')nshft(j),lsl
      enddo
      msl=-9999
      do j=1,nc
        ish=nshft(j)
        idate(j,3)=ish
        idate(j,5)=idtt
        jdate(j,3)=ish
        jdate(j,5)=idtt
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        idate(j,1)=ish-lsl+1
        idate(j,2)=nyr+idate(j,1)-1
        if(nyr+ish-lsl.gt.msl)msl=nyr+ish-lsl
        ist=ify-idate(nc+1,1)
c        write(*,'(8i6)')j,ish,idate(j,1),idate(j,2),ify,ily,nyr,ist
        do i=1,nyr
          wrk1(i)=x(i+ist,j)
          x(i+ist,j)=-9.99
        enddo
        do i=1,nyr
          ii=i+ish-lsl
          x(ii,j)=wrk1(i)
        enddo
      enddo
      mmsl=msl
      do j=1,nc
        idate(j,1)=idate(j,1)+lsl
        idate(j,2)=idate(j,2)+lsl
      enddo

      isv1=idate(nc+1,1)
      isv2=idate(nc+1,2)
      idate(nc+1,1)=1+lsl
      idate(nc+1,2)=msl+lsl
      idate(nc+2,1)=1+lsl
      idate(nc+2,2)=msl+lsl
      jdate(nc+1,1)=1+lsl
      jdate(nc+1,2)=msl+lsl
      jdate(nc+2,1)=1+lsl
      jdate(nc+2,2)=msl+lsl
c
c *** save rcs-aligned raw tree-ring data
c
      if(ics.gt.0)then
        ll=len(fil1)
        jj=0
        do j=1,ll
          jj=ll-j+1
          if(fil1(jj:jj).ne.' ')goto 16
        enddo
   16   ll=jj
        call blank(fil)
        fil=fil1
        fil(ll+1:ll+10)='_rcs_raw  '
        open(iu14,file=fil,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil,status='unknown')
        if(ics.le.3)then
          do j=1,3
            itrdb(j)(81:85)='  rcs'
            write(iu14,'(a)')itrdb(j)
          enddo
        endif
        call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'raw')
        close(iu14)
      endif
c
c *** calculate mean rcs data
c
      call robsum(ns,y(1,2),y(1,3),y(1,10),wrk1,wrk2,
     *  wrk3,wrk4,wrk5,gmn,rbr,'b',bierr,shl,shh)
      do i=1,msl
        crn(i)=y(i,10)
        wrk1(i)=y(i,10)
      enddo
      if(ird.eq.1.or.ird.eq.3)then
        call crnplt3('rcs-aligned data with mean','years',
     *    'measurements',5)
      endif
      mslskp=0
      do i=1,msl
        y(i,8)=i
        y(i,9)=ns(i)
        y(i,11)=wrk3(i)
        if(ns(i).gt.5)mslskp=mslskp+1
      enddo
c
c *** save rcs chronology with bootstrap 95% confidence limits
c
      if(krb3.eq.1)then
        do i=1,msl
          wrk2(i)=0.0
          wrk3(i)=0.0
        enddo
        call spline(msl,crn,wrk1,p,krb4)
        call spline(mslskp,shl,wrk2,p,krb4)
        call spline(mslskp,shh,wrk3,p,krb4)
        do i=1,msl
          if(shl(i).eq.0)then
            shl(i)=crn(i)
            shh(i)=crn(i)
            wrk2(i)=wrk1(i)
            wrk3(i)=wrk1(i)
          endif
        enddo
c
        if(krb2.gt.0)then
          call crnplt1(crn,shl,shh,wrk1,wrk2,wrk3,ns,msl,1,2,fil1,
     *      ' rcs ring width bootstrap',' splined rcs bootstrap',
     *      'years','ring widths (z)','years','ring widths (y)',9,pixels,jrd,mxy,eq,jdt)
        endif
        ll=len(fil1)
        jj=0
        do j=1,ll
          jj=ll-j+1
          if(fil1(jj:jj).ne.' ')goto 17
        enddo
   17   ll=jj
        call blank(fil)
        fil=fil1
        fil(ll+1:ll+10)='_rcs_95%cl'
        call blank(line1)
        line1(1:60)='  year    nc     std    2.5%   97.5%     spl    2.5%   97.5%'
        write(line1(37:41),'(i5)')krb4
        open(iu14,file=fil,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil,status='unknown')
        write(iu14,'(a60)')line1
        do i=1,msl
          write(iu14,'(2i6,6f8.3)')i,ns(i),crn(i),shl(i),shh(i),
     *      wrk1(i),wrk2(i),wrk3(i)
        enddo
        close(iu14)
      endif
c
c *** save rcs mean chronology and errors
c
      ll=len(fil1)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(fil1(jj:jj).ne.' ')goto 18
      enddo
   18 ll=jj
      if(tit(1:6).eq.'      ')then
        call blank(tit)
        tit(1:ll)=fil1(1:ll)
        tit(ll+1:ll+34)=' -- no data title line provided --'
      endif
      tit(54:80)=' age-aligned rcs chronology'
      if(qq.ne.'cr')then
        do j=1,3
          itrdb(j)(81:85)='  rcs'
          write(iu13,'(a)')itrdb(j)
          write(iu17,'(a)')itrdb(j)
          write(iu34,'(a)')itrdb(j)
          write(iu39,'(a)')itrdb(j)
        enddo
      endif
      call blank(id)
      if(ll.gt.6)then
        id(1:6)=fil1(1:6)
      else
        id(1:6)=fil1(1:ll)
      endif                                   
      tag='rcs'                                  
      call trrw(id,1,msl,y(1,10),ns,ifl,iu13,0,qq,tit1,
     *		tag,mxy,itrdb)
      call trrw(id,1,msl,y(1,10),ns,ifl,iu34,0,qq,tit1,
     * 	tag,mxy,itrdb)
      tag='err'
      call trrw(id,1,msl,bierr,ns,ifl,iu17,0,qq,tit1,
     * 	tag,mxy,itrdb)
      call trrw(id,1,msl,bierr,ns,ifl,iu39,0,qq,tit1,
     *		tag,mxy,itrdb)
c
c *** calculate rcs curve from mean rcs chronology
c
      write(iu11,'(/t2,80(''=''))')
      do i=1,7
        eq(i)=0.0
      enddo
      ccf='n'
      write(*,'(/1x,''regional curve estimation'')')
      if(ipo.gt.1)then
        if(irb.eq.1)then
          write(iu11,'(/t2,''|--------------- growth curve used '',
     *      ''for detrending tree-ring data --------------|'')')
        else
          write(iu11,'(/t2,''|----------- robust growth curve used '',
     *      ''for detrending tree-ring data -----------|'')')
        endif
        write(iu11,'(1x,''  option'')')
        write(iu11,'(/t3,''  -5: friedman variable span smoother'',
     *    ''         f(i) = variable span smooth'')')
        write(iu11,'(t3,''  -4: lowess robust smoother'',
     *    ''         f(i) = pct series length'')')
        write(iu11,'(t3,''  -3: median smoothing'',
     *    ''               f(i) = median width in years'')')
        write(iu11,'(t3,''  -2:  regional curve '',
     *    ''detrending      f(i) = one age-aligned curve'')')
        write(iu11,'(t3,''  -1:  first-differences'',
     *    ''              f(i) = y(i) - y(i-1)'')')
        write(iu11,'(t3,''   1:  neg expon curve, '',
     *    ''no = opt 4    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
        write(iu11,'(t3,''   2:  neg expon curve, '',
     *    ''no = opt 5    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
        write(iu11,'(t3,''   3:  neg expon curve, '',
     *    ''(general)     f(i) = a*exp(-b*t(i+p)) + d (any d)'')')
        write(iu11,'(t3,''   4:  linear regression '',
     *    ''(any slope)  f(i) = +/-c*t(i) + d'')')
        write(iu11,'(t3,''   5:  linear regression '',
     *    ''(neg slope)  f(i) = -c*t(i) + d   '')')
        write(iu11,'(t3,''   6:  horizontal line through '',
     *    ''mean   f(i) = mean(y(i)) = d'')')
        write(iu11,'(t3,''   7:  hugershoff growth '',
     *    ''function     f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
        write(iu11,'(t3,''   8:  general exponential (b = 1)    '',
     *    ''f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
        write(iu11,'(t3,''  >9:  cubic smoothing spline'',
     *    ''         fixed 50 pct variance cutoff'')')
        write(iu11,'(t3,'' <-9:  cubic smoothing spline'',
     *    ''         pct n 50 pct variance cutoff'')')
        write(iu11,'(/3x,''(a, b, c are coefficients, d is intercept '',
     *    ''or asymptote, p is pith offset)'')')
        write(iu11,'(/t2,''series   ident     option       '',
     *    ''a           b           c           d         p'')')
      endif
      jdt=id2
   20 if(jdt.gt.9.or.jdt.lt.-9)ndt1=jdt
      if(jdt.eq.-3.or.jdt.eq.-4.or.jdt.lt.-9)then
        if(ndt1.gt.msl)ndt1=msl
        if(ndt1.lt.0)then
          ndt1=abs(ndt1)
          rdt=float(ndt1)/100.
          ndt1=rdt*float(msl)
          if(jdt.eq.-3)then
            if(mod(ndt1,2).eq.0)ndt1=ndt1-1
          endif
        endif
      endif
      call detrend1(crn,f,wrk2,wrk3,msl,eq,jdt,mxy,mxs,ndt1)
      eq(7)=-2
      do i=1,msl
        if(f(i).le.0)then
          write(*,'(/1x,''*** rcs growth curve goes negative! '',
     *      ''***''/1x,''year: '',i6,2x,f7.3)')ify+i-1,f(i)
          ier=1
          jer=1
          pause' hit <ret> to display the dirty dog!'
          goto 21
        endif
      enddo
      if(ipo.gt.1)then
        if(jdt.eq.-3)then
          write(iu11,'(t2,''  all'',3x,''  rcs '',i5,i7,8x,
     *      ''median smoothed rcs curve and window width'')')
     *      jdt,ndt1
        elseif(jdt.eq.-4)then
          write(iu11,'(t2,''  all'',3x,''  rcs '',i5,i7,8x,
     *      ''lowess smoothed rcs curve and window width'')')
     *      jdt,ndt1
        elseif(jdt.eq.-5)then
          write(iu11,'(t2,''  all'',3x,''  rcs '',i5,i7,8x,
     *      ''friedman variable span smoothed rcs curve'')')
     *      jdt,ndt1
        elseif(jdt.lt.-9.or.jdt.gt.9)then
          write(iu11,'(t2,''  all'',3x,''  rcs '',i5,i7,8x,
     *      ''spline smoothed rcs curve and window width'')')
     *      jdt,ndt1
        else
          if(jdt.eq.6.or.jdt.eq.7)then
            irt=eq(6)
          else
            irt=0
          endif
          write(iu11,'(t2,''  all'',3x,''  rcs '',i8,2x,4f12.6,i8)')
     *      jdt,(eq(k),k=1,3),eq(5),irt
        endif
      endif
      ish=0
      call calind(crn,f,msl,ind,mxy)
      li=n/10
      if(ipo.eq.4)then
        if(n.le.200)then
          li=5
        elseif(n.gt.200.and.n.le.400)then
          li=10
        elseif(n.gt.400.and.n.le.800)then
          li=20
        elseif(n.gt.800.and.n.le.1600)then
          li=40
        elseif(n.gt.1600.and.n.le.2000)then
          li=50
        else
          li=100
        endif
        call pltdec1(wrk1,f,crn,msl,1,li,iu11,4,ido)
      endif
   21 if(ido.eq.2.or.iplt.eq.1.or.ier.gt.o.or.ird.eq.2.or.ird.eq.3)then
c
c *** new tsi graphics
c
        do i=1,msl
          wrk1(i)=y(i,10)
          wrk2(i)=1.0
        enddo
        wrk4(1)=-999.0
        call crnplt1(wrk1,f,wrk3,crn,wrk2,wrk4,ns,msl,1,1,fil1,
     *    ' rcs growth trend',' rcs residuals',
     *    'years','measurements (y)','years','indices (z)',6,
     *    pixels,iplt,mxy,eq,jdt)
   30 yn='n'
      write(*,'(/1x,''truncate the rcs curve? y/<n>/h'',
     *      t45,''==> '',$)')
      read(*,'(a)')yn
      if(yn.eq.'y'.or.yn.eq.'Y')then
   31   write(*,'(1x,''new length must be <'',i4,'' years'')')mmsl
        write(*,'(1x,''please enter the new rcs curve length'', 
     *      t45,''==> '',$)')
        read(*,*,err=31)newsl
        if(newsl.lt.1.or.newsl.gt.mmsl)goto 31
        msl=newsl
        write(iu11,'(16x,''*** rcs curve and data truncated at age: '',i5,
     *    '' ***'')')msl
        do i=1,msl
          crn(i)=y(i,10)
          wrk1(i)=y(i,10)
        enddo
        call detrend1(crn,f,wrk2,wrk3,msl,eq,jdt,mxy,mxs,ndt1)
        eq(7)=-2
        call calind(crn,f,msl,ind,mxy)
        do i=1,msl
          wrk2(i)=1.0
        enddo
        call crnplt1(wrk1,f,wrk3,crn,wrk2,wrk4,ns,msl,1,1,fil1,
     *    ' rcs growth trend',' rcs residuals',
     *    'years','measurements (y)','years','indices (z)',6,
     *    pixels,iplt,mxy,eq,jdt)
c        ccf=' '
c          write(*,'(/1x,''change curve fit? y/<n>/h'',
c     *      t45,''==> '',$)')
c          read(*,'(a)')ccf
c          do i=1,msl
c            crn(i)=wrk1(i)
c          enddo
c        goto 20
      endif
c
c *** change rcs curve fit it needed or desired
c
   22   ccf=' '
        if(ido.eq.2.or.iplt.eq.1.or.jer.gt.0.or.ird.eq.2.or.ird.eq.3)then
          write(*,'(/1x,''change curve fit? y/<n>/h'',
     *      t45,''==> '',$)')
          read(*,'(a)')ccf
          if(ccf.ne.'y'.and.ccf.ne.'Y'.and.ccf.ne.'n'.and.
     *      ccf.ne.'N'.and.ccf.ne.'h'.and.ccf.ne.'H'.and.
     *      ccf.ne.' ')goto 22
        else
          ccf='n'
        endif
        if(ccf.eq.' ')then
          ccf='n'
        endif
   23   if(ccf.eq.'h'.or.ccf.eq.'H')then
          write(*,'(/1x,''you can change the current curve '',
     *      ''fit with any one of the following 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'')')
          write(*,'(t3,''  -3:  median smoothing'',
     *      ''               must have odd window length'')')
          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'')')
          goto 22
        endif
        if(ccf.eq.'y'.or.ccf.eq.'Y')then
          write(*,'(1x,''enter new option (h for help)'',t45,
     *      ''==> '',$)')
          read(*,*,err=24)jdt
          if(jdt.lt.-5.and.jdt.gt.-10)goto 24
          if(jdt.eq.9)goto 24
          goto 25
   24     ccf='h'
          goto 23
   25     ndt1=0
          if(jdt.eq.-3.or.jdt.eq.-4)then
            if(jdt.eq.-3)then 
              write(*,'(/1x,''enter the new median window width''/
     *          1x,''fixed width: a positive odd integer >2'')')
            elseif(jdt.eq.-4)then
              write(*,'(/1x,''enter the new lowess window width''/
     *          1x,''fixed width: a positive integer >2'')')
            endif
            write(*,'(1x,''and < the series length ('',i4,'') or a''/
     *        1x,''percent length: a negative integer''/
     *        1x,''between -1 and -100, inclusive'', t45,''==> '',$)')
     *        msl
            read(*,*,err=25)ndt1
            if(ndt1.eq.0)then
              goto 25
            elseif(ndt1.gt.0)then
              if(ndt1.gt.msl)ndt1=msl
              if(ndt1.le.2)goto 25
              if(jdt.eq.-3.and.mod(ndt1,2).eq.0)ndt1=ndt1-1
            elseif(ndt1.lt.0)then
              if(ndt1.lt.-100)ndt1=-100
              ndt1=abs(ndt1)
              rdt=float(ndt1)/100.
              ndt1=rdt*float(msl)
              if(jdt.eq.3.and.mod(ndt1,2).eq.0)ndt1=ndt1-1
            endif
          endif
          do i=1,msl
            crn(i)=wrk1(i)
          enddo
          goto 20
        elseif(ier.eq.1)then
          ans=' '
          write(*,'(/1x,''the program will terminate now if''/
     *      1x,''you do not change the curve fit''/
     *      1x,''option to avoid a negative fit.''/
     *      1x,''is that what you really want? y/n'',t45,''==> '',$)')
          read(*,'(a)')ans
          if(ans.eq.'n'.or.ans.eq.'N')then
            goto 21
          else
            write(*,'(/1x,''okay, hasta la vista, baby!''/)')
          endif
          close(iu12,status='delete')
          close(iu13,status='delete')
          close(iu17,status='delete')
          close(iu30,status='delete')
          close(iu31,status='delete')
          close(iu32,status='delete')
          close(iu33,status='delete')
          close(iu34,status='delete')
          close(iu35,status='delete')
          close(iu36,status='delete')
          close(iu37,status='delete')
          close(iu38,status='delete')
          close(iu39,status='delete')
          stop'*** negative growth curve value ***'
        endif
      endif
      do i=1,msl
        y(i,12)=f(i)
      enddo
c
c *** calculate rcs tree-ring indices
c
      iplt=jems(4,3)
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        if(nyr.gt.msl)then
          nyr=msl
          ily=ify+msl-1
          idate(j,2)=ily
        endif
        ish=idate(j,3)
        if(ind.eq.2)then
          call moment(x(1,j),nyr,xmean(j),adev,sigma(j),var,skew,
     *      curt,sens,ac)
        endif
c        if(j.eq.77)then
c          do i=1,msl
c            write(*,'(i5,f8.4)')i,f(i)
c          enddo
c          write(*,*)ish,lsl
c          do i=1,nyr
c            write(*,'(2i5,3f8.4)')i,ify+i-1,x(ish-lsl+i,j),f(ish-lsl+i),
c     *        x(ish-lsl+i,j)/f(ish-lsl+i)
c          enddo
c          pause
c        endif
        call calind(x(ish-lsl+1,j),f(ish-lsl+1),nyr,ind,mxy)
      enddo
c
c *** save age-aligned tree-ring indices
c
      if(ics.gt.0)then
        fil(ll+1:ll+10)='_rcs_ind1 '
        open(iu14,file=fil,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil,status='unknown')
        if(ics.le.3)then
          do j=1,3
            itrdb(j)(81:85)=' rcs'
            write(iu14,'(a)')itrdb(j)
          enddo
        endif
        call sis(x,wrk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'ind')
        close(iu14)
      endif
c
c *** re-align the data chronologically by calendar year of growth
c
      idate(nc+1,1)=isv1
      idate(nc+1,2)=isv2
      jdate(nc+1,1)=isv1
      jdate(nc+1,2)=isv2
      do j=1,nc+2
        do k=1,10
          idate(j,k)=jdate(j,k)
        enddo
      enddo
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        if(nyr.gt.msl)then
          nyr=msl
          ily=ify+msl-1
          idate(j,2)=ily
          jdate(j,2)=ily
        endif
        ist=ify-idate(nc+1,1)
        ish=idate(j,3)
c        if(ish.gt.0)then
          do i=1,nyr
            wrk1(i)=x(i+ish-lsl,j)
c            x(i,j)=x(i+ish-lsl,j)
          enddo
          do i=1,nyr+ish-lsl
            x(i,j)=-9.99
c            x(i+nyr,j)=-9.99
          enddo
c        endif
c        if(ist.gt.0)then
          do i=1,nyr
c            ii=nyr-i+1
            x(i+ist,j)=wrk1(i)
c            x(ii+ist,j)=x(ii,j)
          enddo
          if(ist.gt.0)then
            do i=1,ist
              x(i,j)=-9.99
            enddo
          endif
c
c *** new tsi graphics
c
        if(iplt.eq.1)then
          do i=1,nyr
            if(ind.eq.1)then
              wrk1(i)=x(i+ist,j)*f(i+ish-lsl)
            elseif(ind.eq.2)then
              wrk1(i)=x(i+ist,j)+f(i+ish-lsl)
            endif
            wrk2(i)=1.0
          enddo
          if(ind.eq.2)then
            call moment(wrk1,nyr,ave,adev,sdev,var,skew,
     *        curt,sens,ac)
            do i=1,nyr
              wrk1(i)=(wrk1(i)-ave)/sdev
              wrk1(i)=wrk1(i)*sigma(j)+xmean(j)
            enddo
          endif
          call blank(id)
          k=0
          do i=1,8
            if(ident(j)(i:i).ne.' ')then
              k=k+1
              id(k:k)=ident(j)(i:i)
            endif
          enddo
          call crnplt1(wrk1,f,wrk3,x(ist+1,j),wrk2,wrk4,ns,nyr,ify,1,id,' ',' ',
     *      'years','measurements (y)','years','rcs indices (z)',1,pixels,iplt,mxy,eq,jdt)
        endif
      enddo
c
c *** calculate statistics of rcs tree-ring indices
c
      call sstat(x,stats,idate,ident,nc,mxy,mxs,iu11,ipo)
      return
      end
*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     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,nyr,ind,mxy)
      real*4 y(mxy),f(mxy)
      do i=1,nyr
c        ys=y(i)
        y(i)=y(i)/f(i)
c        write(*,'(i5,3f8.4)')i,ys,f(i),y(i)
      enddo
      if(ind.eq.2)then
        call moment(y,nyr,ave1,adev,sdev1,var,skew,curt,sens,ac)
        do i=1,nyr
          y(i)=y(i)*f(i)
          y(i)=y(i)-f(i)
        enddo
        call moment(y,nyr,ave,adev,sdev,var,skew,curt,sens,ac)
        do i=1,nyr
          y(i)=(y(i)-ave)/sdev
          y(i)=y(i)*sdev1+ave1
ccc          if(y(i).lt.0.0)y(i)=0.0
        enddo
      endif
      return
      end
*sbr sstat
c
c *** single and summary tree-ring series statistics
c
c      x     --  array of tree-ring series to be analyzed
c     stats  --  work array for holding single-series statistics
c     idate  --  array of single-series first and last years
c      nc    --  number of series to be processed
c      mxy   --  maximum length series, from calling program
c      mxs   --  maximum number of series, from calling program
c      ipo   --  printout option
c                1 = statistics for each series are output
c               >1 = summary of single-series statistics only
c     iu11   --  logical unit number for output file
c
c     subroutines called:  moment, mfs
c
      subroutine sstat(x,stats,idate,ident,nc,mxy,mxs,iu11,ipo)
      real*4 x(mxy,mxs),stats(mxs,12)
      integer idate(mxs+2,10)
      character ident(mxs)*8
      if(ipo.gt.1)then
        write(iu11,'(/t2,''|-------------------- statistics of '',
     *    ''single tree-ring series -------------------|'')')
      endif
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        nyr=ily-ify+1
        ist=idate(j,1)-idate(nc+1,1)+1
        call moment(x(ist,j),nyr,ave,adev,sdev,var,skew,curt,sens,ac)
        stats(j,1)=nyr
        stats(j,2)=ave
        stats(j,3)=sdev
        stats(j,4)=skew
        stats(j,5)=curt
        stats(j,6)=sens
        stats(j,7)=ac
        if(ipo.gt.1)then
          if(j.eq.1.or.mod(j,20).eq.0)then
            write(iu11,'(/t2,''series   ident   frst   last   '',
     *        ''year    mean   stdev   skew   kurt   sens   ac(1)'')')		                                   
          endif
          write(iu11,'(t2,i5,2x,a8,i6,2i7,2f8.3,3f7.3,f8.3)')
     *      j,ident(j),ify,ily,nyr,ave,sdev,skew,curt,sens,ac
        endif
      enddo
      if(nc.eq.1)return
      write(iu11,'(/t2,''|---------------- summary of single '',
     *  ''tree-ring series statistics ---------------|''/)')
      do j=1,7
        call moment(stats(1,j),nc,ave,adev,sdev,var,skew,curt,sens,ac)
        call mfs(stats(1,j),nc,rmd,hh,hl,fsd,rmn,rmx)
        stats(1,j)=ave
        stats(2,j)=sdev
        stats(3,j)=rmd
        stats(4,j)=fsd
        stats(5,j)=rmn
        stats(6,j)=hl
        stats(7,j)=hh
        stats(8,j)=rmx
      enddo
      write(iu11,'(t33,''year    mean   stdev   skew   kurt   sens   '',
     *  ''ac(1)'')')		                                   
      write(iu11,'(t2,''arithmetic mean'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(1,1)+0.5),(stats(1,j),j=2,7)
      write(iu11,'(t2,''standard deviation'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(2,1)),(stats(2,j),j=2,7)
      write(iu11,'(t2,''median (50th quantile)'',t33,i4,2f8.3,3f7.3,
     *  f8.3)')ifix(stats(3,1)),(stats(3,j),j=2,7)
      write(iu11,'(t2,''interquartile range'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(4,1)),(stats(4,j),j=2,7)
      write(iu11,'(t2,''minimum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(5,1)),(stats(5,j),j=2,7)
      write(iu11,'(t2,''lower hinge (25th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(6,1)),(stats(6,j),j=2,7)
      write(iu11,'(t2,''upper hinge (75th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(7,1)),(stats(7,j),j=2,7)
      write(iu11,'(t2,''maximum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(8,1)),(stats(8,j),j=2,7)      
      return
      end
*sbr detrend
*
      subroutine detrend(f,wk1,wk2,wk3,wk4,eq,ns,stats)
      parameter(mxy=5000,mxs=3000)
      parameter(flag=-999.0)
      real*4 f(mxy),stats(mxs,12),eq(7)
      real*4 wk1(mxy),wk2(mxy),wk3(mxy),wk4(mxy)
      integer ns(mxy),nss(mxy),keep(mxs)
      character ccf,tit*85,tag*3,id*8,fil2*40,bdd,lable*17,ans,cid
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** tsi common block variables
c
      real*4 x(mxy,mxs),crn(mxy)
      integer idate(mxs+2,10)
      character ident(mxs)*8
c
c *** tsi graphics stuff
c
      common/tsi1/x,crn,idate,ident,nc
c
      bdd='n'
      idt=jems(4,1)
      id2=jems(5,1)
      irb=jems(6,1)
      ido=jems(7,1)
      ind=jems(8,1)
      krb1=jems(12,1)
      krb2=jems(12,2)
      ipo=jems(17,1)
      ics=jems(18,1)
      ird=jems(19,1)
      if(ndd.eq.1)then
        ndt=jems(4,2)
        iplt=jems(4,3)
        idtt=idt
      elseif(ndd.eq.2)then
        ndt=jems(5,2)
        iplt=jems(5,3)
        idtt=id2
      endif
      if(ics.gt.0.or.ird.eq.1.or.ird.eq.3)then
        ll=len(fil1)
        jj=0
        do j=1,ll
          jj=ll-j+1
          if(fil1(jj:jj).ne.' ')goto 10
        enddo
   10   ll=jj
        call blank(fil2)
        fil2=fil1
        tag='crv'
        if(ndd.eq.1)fil2(ll+1:ll+10)='_crv1     '
        if(ndd.eq.2)fil2(ll+1:ll+10)='_crv2     '
        open(iu14,file=fil2,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil2,status='unknown')
        open(iu16,file='index.tmp',status='unknown')
        close(iu16,status='delete')
        open(iu16,file='index.tmp',status='unknown')
      endif
      jrd=ird
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
c
      ccf='n'
      if(ndd.eq.1)then
        write(*,'(/1x,''first detrending of individual tree-ring '',
     *    ''series''/)')
      elseif(ndd.eq.2)then
        write(*,'(/1x,''second detrending of individual tree-ring '',
     *    ''series''/)')
      endif
      if(ipo.gt.1)then
        if(irb.eq.1)then
          write(iu11,'(/t2,''|--------------- growth curve used '',
     *      ''for detrending tree-ring data --------------|'')')
        else
          write(iu11,'(/t2,''|------------ robust growth curve used '',
     *      ''for detrending tree-ring data -------------|'')')
        endif
        write(iu11,'(1x,''  option'')')
        write(iu11,'(t3,''   -5: variable span smoother'',
     *    ''         f(i) = variable span smooth'')')
        write(iu11,'(t3,''   -4: lowess robust smoother'',
     *    ''         f(i) = lowess robust smooth'')')
        write(iu11,'(t3,''   -3: median smoothing'',
     *    ''               f(i) = median sharp/smooth'')')
        write(iu11,'(t3,''  -2:  regional curve '',
     *    ''detrending      f(i) = one age-aligned curve'')')
        write(iu11,'(t3,''  -1:  first-differences'',
     *    ''              f(i) = y(i) - y(i-1)'')')
        write(iu11,'(t3,''   1:  neg expon curve, '',
     *    ''no = opt 4    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
        write(iu11,'(t3,''   2:  neg expon curve, '',
     *    ''no = opt 5    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
        write(iu11,'(t3,''   3:  neg expon curve  '',
     *    ''(general)     f(i) = a*exp(-b*t(i)) + d   (any d)'')')
        write(iu11,'(t3,''   4:  linear regression '',
     *    ''(any slope)  f(i) = +/-c*t(i) + d'')')
        write(iu11,'(t3,''   5:  linear regression '',
     *    ''(neg slope)  f(i) = -c*t(i) + d   '')')
        write(iu11,'(t3,''   6:  horizontal line through '',
     *    ''mean   f(i) = mean(y(i)) = d'')')
        write(iu11,'(t3,''   7:  hugershoff growth '',
     *    ''function     f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
        write(iu11,'(t3,''   8:  general exponential (b = 1)    '',
     *    ''f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
        write(iu11,'(t3,''  >9:  cubic smoothing spline'',
     *    ''         fixed 50 pct variance cutoff'')')
        write(iu11,'(t3,'' <-9:  cubic smoothing spline'',
     *    ''         pct n 50 pct variance cutoff'')')
        write(iu11,'(/3x,''(a, b, c are coefficients, d is intercept '',
     *    ''or asymptote, p is pith offset)'')')
      endif
      do j=1,nc
        if(ierr.eq.0)then
ccc          write(*,'(1x,i6,2x,a8)')j,ident(j)
        else
          if(ndd.eq.1)then
            write(*,'(/1x,''first detrending of individual tree-ring '',
     *        ''series continued''/)')
          elseif(ndd.eq.2)then
            write(*,'(/1x,''second detrending of individual tree-ring '',
     *        ''series continued''/)')
          endif
ccc          write(*,'(1x,i6,2x,a8)')j,ident(j)
        endif
        if(bdd.eq.'y'.or.bdd.eq.'Y')then
          jdt=idate(j,5)
          jdtt=idate(j,5)
        else
          jdt=idtt
        endif
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ist=idate(j,1)-idate(nc+1,1)+1
        do i=1,n
          ii=ist+i-1
          wk1(i)=x(ii,j)
        enddo
        ier=0
        ierr=0
        ndt1=ndt
   20   if(jdt.eq.-3.or.jdt.eq.-4.or.jdt.lt.-9)then
          if(ndt1.gt.n)ndt1=n
          if(ndt1.lt.0)then
            ndt1=abs(ndt1)
            rdt=float(ndt1)/100.
            ndt1=rdt*float(n)
            if(jdt.eq.-3)then
              if(mod(ndt1,2).eq.0)ndt1=ndt1-1
            endif
          endif
        endif
        jjdt=jdt
        call detrend1(x(ist,j),f,wk2,wk3,n,eq,jdt,mxy,mxs,ndt1)
c        eq(7)=jdt
        if(jdt.eq.-5)eq(5)=float(ndt1)
        if(jdt.eq.7.or.jdt.eq.8)then
          do i=1,n  
            wk4(i)=wk3(i)
          enddo
        else
          wk4(1)=-999.0
        endif
        if(jdt.eq.-1)then
          jer=0
          ify=ify+1
          idate(j,1)=ify
          ist=idate(j,1)-idate(nc+1,1)+1
        endif
        if(jdt.ne.-1)then
          jer=0
          do i=1,n
            if(f(i).le.0)then
              write(*,'(/1x,''*** series: '',a8,2x,''growth curve goes '',
     *          ''negative! ***''/1x,''year: '',i6,2x,f7.3)')ident(j),
     *          ify+i-1,f(i)
              ier=1
              ierr=1
              jer=1
              eq(7)=jdt
              pause' hit <ret> to display the dirty dog!'
              goto 21
            endif
          enddo
        endif
        if(ipo.gt.1)then
          if((j.eq.1.and.(ccf.ne.'y'.and.ccf.ne.'Y')).or.ipo.eq.4)then
            write(iu11,'(/t2,''series   ident     option       '',
     *        ''a           b           c           d         p'')')
          elseif(j.gt.19.and.mod(j,20).eq.0)then
            write(iu11,'(/t2,''series   ident     option       '',
     *        ''a           b           c           d         p'')')
          endif
          if(jdt.eq.-3)then
            eq(7)=ndt1
            write(iu11,'(t2,i5,3x,a8,i4,i5,11x,
     *        ''median filter curve and window width'')')
     *        j,ident(j),jdt,ndt1
          elseif(jdt.eq.-4)then
            eq(7)=ndt1
            write(iu11,'(t2,i5,3x,a8,i4,i5,11x,
     *        ''lowess robust curve and window width'')')
     *        j,ident(j),jdt,ndt1
          elseif(jdt.eq.-5)then
            write(iu11,'(t2,i5,3x,a8,i4,i5,11x,
     *        ''friedman super smoother curve and alpha'')')
     *        j,ident(j),jdt,ndt1
          elseif(jdt.lt.-9.or.jdt.gt.9)then
            if(jdt.lt.0)then
              rdt=abs(float(jdt)/100.)
              ndt1=float(n)*rdt
            else
              ndt1=jdt
            endif
            write(iu11,'(t2,i5,3x,a8,i5,i5,9x,
     *        ''smoothing spline curve and window width'')')
     *        j,ident(j),jdt,ndt1
            eq(7)=ndt1
          else
            if(jdt.eq.3.or.jdt.eq.7.or.jdt.eq.8)then
              irt=eq(6)
            else
              irt=0
            endif
            if(jdt.ne.idtt.and.(ccf.ne.'y'.and.ccf.ne.'Y'))then
              write(iu11,'(t2,i5,3x,a8,i7,3x,''--> curve fit option failed '',
     *          ''and changed to: '',i5)')j,ident(j),idtt,jdt
ccc              write(*,'(/t3,i5,3x,a8,2x,''--> curve fit option failed '',
ccc     *          ''and changed from '',i5,'' to '',i5)')j,ident(j),idtt,jdt
            elseif(jdt.ne.jjdt.and.(ccf.eq.'y'.or.ccf.eq.'Y'))then
              write(iu11,'(t2,i5,3x,a8,i7,3x,''--> curve fit option failed '',
     *          ''and changed to: '',i5)')j,ident(j),jjdt,jdt
ccc              write(*,'(/t3,i5,3x,a8,2x,''--> curve fit option failed '',
ccc     *          ''and changed from '',i5,'' to '',i5)')j,ident(j),jjdt,jdt
            endif
            write(iu11,'(t2,i5,3x,a8,i7,1x,4f12.6,i8)')j,ident(j),
     *        jdt,(eq(k),k=1,3),eq(5),irt
          endif
        endif
c
c *** calculate the detrended tree-ring indices or residuals if idtt.ne.-1
c
        if(jdt.eq.-1)then
          call xmean(x(ist,j),n,xm)
          do i=1,n
            ii=ist+i-1
            x(ii,j)=x(ii,j)-xm+1.0
          enddo
        else
          ish=0
          call calind(x(ist,j),f,n,ind,mxy)
        endif                                        !new change
        li=n/10
        if(ipo.eq.4)then
          if(n.le.200)then
            li=5
          elseif(n.gt.200.and.n.le.400)then
            li=10
          elseif(n.gt.400.and.n.le.800)then
            li=20
          elseif(n.gt.800.and.n.le.1600)then
            li=40
          elseif(n.gt.1600.and.n.le.2000)then
            li=50
          else
            li=100
          endif
          call pltdec1(wk1,f,x(ist,j),n,ify,li,iu11,4,ido)
        endif
        iplt1=iplt
c   21   if(ido.eq.2.or.iplt.eq.1.or.ier.gt.0)then
   21   if(ido.eq.2.or.ido.eq.3.or.iplt.eq.1.or.jer.gt.0.or.ierr.gt.0)then
ccc   21   if(ido.eq.2.or.jrd.eq.2.or.jrd.eq.3.or.ier.gt.0)then
c
c *** begin new tsi graphics
c
          do i=1,n
            wk2(i)=1.0
          enddo
          if(jer.gt.0)then
            wk2(1)=0.0
          else
            ier=0
            call spline(n,x(ist,j),wk2,p,n/10)
          endif
          call blank(id)
          k=0
          do i=1,8
            if(ident(j)(i:i).ne.' ')then
              k=k+1
              id(k:k)=ident(j)(i:i)
            endif
          enddo
          call blank(lable)
          if(ndd.eq.1.and.id2.eq.0)lable=' detrending      '
          if(ndd.eq.1.and.id2.ne.0)lable=' 1st detrending  '
          if(ndd.eq.2)lable=' 2nd detrending  '
c	    write(*,'(/1x,''Before call to crnplt1 itype =1 '')')
c	    pause'pjk1'
          call crnplt1(wk1,f,wk3,x(ist,j),wk2,wk4,ns,n,ify,1,id,lable,
     *      ' tree-ring indices','years','measurements (y)','years',
     *      'indices (z)',1,pixels,iplt,mxy,eq,jdt)
ccc          if(jrd.ne.krd)ido=1
        endif
c
c *** change curve fit it needed or desired
c
   22   ccf=' '
        if(ido.eq.2.or.ido.eq.3.or.iplt.eq.1.or.jer.gt.0.or.ierr.gt.0)then
ccc        if(ido.eq.2.or.jrd.eq.2.or.jrd.eq.3.or.
ccc     *    jer.gt.0)then
          write(*,'(/1x,''change curve fit? y/<n>'',
     *      t45,''==> '',$)')
          read(*,'(a)')ccf
          if(ccf.eq.' ')ccf='n'
          if(ccf.ne.'y'.and.ccf.ne.'Y'.and.ccf.ne.'n'.and.
     *      ccf.ne.'N'.and.ccf.ne.'h'.and.ccf.ne.'H')goto 22
c     *      ccf.ne.'N'.and.ccf.ne.'h'.and.ccf.ne.'H'.and.
c     *      ccf.ne.'n')goto 22
c        else
c          ccf='n'
        endif
        if(ccf.eq.'n'.or.ccf.eq.'N')then
c       if((ccf.eq.'n'.or.ccf.eq.'N').and.ido.eq.2)then
          cid='y'
          write(*,'(1x,''continue interactive detrending? <y>/n'',
     *      t45,''==> '',$)')
          read(*,'(a)')cid
          if(cid.eq.'n'.or.cid.eq.'N')then
            ido=0
            iplt=0
          endif
c        elseif(ccf.eq.' ')then
c          ccf='n'
        endif
   23   if(ccf.eq.'y'.or.ccf.eq.'Y'.or.ccf.eq.'h'.or.ccf.eq.'H')then
          write(*,'(/1x,''you can change the current curve '',
     *      ''fit with any one of the following options:''/)')
          write(*,'(t1,''  -5:  friedman super smoother'',
     *      ''        lower alpha (0-9) gives more local fit'')')
          write(*,'(t1,''  -4:  robust lowess smoother'',
     *      ''         integer percent or fixed length of n'')')
          write(*,'(t1,''  -3:  median smoothing'',
     *      ''               must have odd window length'')')
          write(*,'(t1,''   1:  neg expon curve, '',
     *      ''no = opt 4    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
          write(*,'(t1,''   2:  neg expon curve, '',
     *      ''no = opt 5    f(i) = a*exp(-b*t(i)) + d    (d>0)'')')
          write(*,'(t1,''   3:  neg expon curve  '',
     *      ''(general)     f(i) = a*exp(-b*t(i)) + d   (any d)'')')
          write(*,'(t1,''   4:  linear regression '',
     *      ''(any slope)  f(i) = +/-c*t(i) + d'')')
          write(*,'(t1,''   5:  linear regression '',
     *      ''(neg slope)  f(i) = -c*t(i) + d   '')')
          write(*,'(t1,''   6:  horizontal line through '',
     *      ''mean   f(i) = mean(y(i)) = d'')')
          write(*,'(t1,''   7:  hugershoff growth '',
     *      ''function     f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
          write(*,'(t1,''   8:  general exponential (b = 1)    '',
     *      ''f(i) = a*t(i+p)**b * exp(-c*t(i+p)) + d'')')
          write(*,'(t1,''  >9:  cubic smoothing '',
     *      ''spline         fixed 50 pct variance cutoff'')')
          write(*,'(t1,'' <-9:  cubic smoothing '',
     *      ''spline         pct n 50 pct variance cutoff'')')
c          if(ccf.eq.'h'.or.ccf.eq.'H')goto 22
        endif
        if(ccf.eq.'y'.or.ccf.eq.'Y')then
          write(*,'(/1x,''enter new option (h for help)'',t45,
     *      ''==> '',$)')
          read(*,*,err=24)jdt
          if(jdt.lt.-5.and.jdt.gt.-10)goto 24
          if(jdt.eq.-2)goto 24
          if(jdt.eq.-1)goto 24
          if(jdt.eq.0)goto 24
          if(jdt.eq.9)goto 24
          goto 25
   24     ccf='h'
          goto 23
   25     ndt1=0
          if(jdt.eq.-5)then
            if(jdt.ne.idtt.and.jer.gt.0)then
              ndt1=5
            elseif((jdt.eq.idtt).or.(jdt.ne.idtt.and.jer.eq.0))then
              write(*,'(/1x,''a super smoother alpha = 9 is''/
     *          1x,''for a very stiff local fit. reduce''/
     *          1x,''it between 0-8 to increase the local fit''/
     *          1x,''where alpha = 0 is the most flexible fit''/
     *          1x,''so enter your alpha already!'',t45,''==> '',$)')
              read(*,*,err=25)ndt1
              if(ndt1.lt.0.or.ndt1.gt.9)then
                write(*,'(/1x,''wake up! bad alpha: '',i2)')ndt1
                goto 25
              endif
            endif
          elseif(jdt.eq.-3.or.jdt.eq.-4)then
            if(jdt.eq.-3)then 
              write(*,'(/1x,''enter the new median window width''/
     *          1x,''fixed width: a positive odd integer >2'')')
            elseif(jdt.eq.-4)then
              write(*,'(/1x,''enter the new lowess window width''/
     *          1x,''fixed width: a positive integer >2'')')
            endif
            write(*,'(1x,''and < the series length ('',i4,'') or a''/
     *        1x,''percent length: a negative integer''/
     *        1x,''between -1 and -100, inclusive'', t45,''==> '',$)')n
            read(*,*,err=25)ndt1
            if(ndt1.eq.0)then
              goto 25
            elseif(ndt1.gt.0)then
              if(ndt1.gt.n)ndt1=n
              if(ndt1.le.2)goto 25
              if(jdt.eq.-3.and.mod(ndt1,2).eq.0)ndt1=ndt1-1
            elseif(ndt1.lt.0)then
              if(ndt1.lt.-100)ndt1=-100
              ndt1=abs(ndt1)
              rdt=float(ndt1)/100.
              ndt1=rdt*float(n)
              if(jdt.eq.3.and.mod(ndt1,2).eq.0)ndt1=ndt1-1
            endif
          endif
          do i=1,n
            ii=ist+i-1
            x(ii,j)=wk1(i)
          enddo
c          ierr=0
          goto 20
        elseif(ier.eq.1)then
          ans=' '
          write(*,'(/1x,''the program will terminate now if''/
     *      1x,''you do not change the curve fit''/
     *      1x,''option to avoid a negative fit.''/
     *      1x,''is that what you really want? y/n'',t45,''==> '',$)')
          read(*,'(a)')ans
          if(ans.eq.'n'.or.ans.eq.'N')then
            goto 21
          else
            write(*,'(/1x,''okay, hasta la vista, baby!''/)')
          endif
          close(iu12,status='delete')
          close(iu13,status='delete')
          close(iu17,status='delete')
          close(iu30,status='delete')
          close(iu31,status='delete')
          close(iu32,status='delete')
          close(iu33,status='delete')
          close(iu34,status='delete')
          close(iu35,status='delete')
          close(iu36,status='delete')
          close(iu37,status='delete')
          close(iu38,status='delete')
          close(iu39,status='delete')
          stop'*** negative growth curve value ***'
        endif
c
c *** save individual fitted growth curves if desired
c
        if(ics.gt.0.or.ird.eq.1.or.ird.eq.3)then
          write(iu14,'(a8,3i6)')ident(j),ify,ify+n-1,n
          write(iu14,'(10f9.4)')(f(i),i=1,n)
          ii=ist
          jj=ist+n-1
          write(iu16,'(a8,3i6)')ident(j),ify,ify+n-1,n
          write(iu16,'(10f9.4)')(x(i,j),i=ii,jj)
        endif
c
c *** store final curve fit option used in idate
c
        if(jdt.ne.jdtt)then
          idate(j,5)=jdt
        endif
c
      enddo
c
c *** read in curve fits for plotting
c
      if(jdt.eq.-1)then
        idate(nc+1,1)=idate(nc+1,1)+1
        ifmny=idate(nc+1,1)
        ilmxy=idate(nc+1,2)
        maxn=ilmxy-ifmny+1
        do i=1,maxn
          do j=1,nc
            x(i,j)=x(i+1,j)
          enddo          
        enddo
        do j=1,nc
          x(maxn+1,n)=-9.99
        enddo
      endif
      if(ics.gt.0.or.(ird.eq.1.or.ird.eq.3))then
        rewind(iu14)
        do j=1,nc
          read(iu14,'(a8,3i6)')ident(j),ify,ily,n
          read(iu14,'(10f9.4)')(x(i,j),i=1,n)
        enddo
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          ish=ify-idate(nc+1,1)
          do i=1,n
            ii=n-i+1
            x(ii+ish,j)=x(ii,j)
          enddo
          do i=1,ish
            x(i,j)=-9.99
          enddo
        enddo
c
        if(ird.eq.1.or.ird.eq.3)then
          jems(12,1)=1
          do i=1,maxn
            ncnt=0
            do j=1,nc
              if(x(i,j).ne.-9.99)then
                ncnt=ncnt+1
                wk1(ncnt)=x(i,j)
              endif
            enddo
            if(ncnt.gt.0)then
              call biwgt(wk1,wk2,7.5,ncnt,bimn,bisg,bise,eff,iter,wk3)
              crn(i)=bimn
            else
              crn(i)=-9.99
            endif
          enddo
          jems(12,1)=krb1
c
          if(ndd.eq.1)then
            call crnplt3('1st-detrending curves with mean','years',
     *        'measurements',6)
          elseif(ndd.eq.2)then
            call crnplt3('2nd-detrending curves with mean','years',
     *        'indices',7)
          endif
        endif
        close(iu14,status='delete')
        if(ics.gt.0)then
          open(iu14,file=fil2,status='unknown')
          if(ics.le.3)then
            do k=1,3
              if(ndd.eq.1)itrdb(k)(80:85)=' crv1'
              if(ndd.eq.2)itrdb(k)(80:85)=' crv2'
              write(iu14,'(a)')itrdb(k)
            enddo
          endif
          call sis(x,wk1,nc,idate,ident,nss,keep,tit,mxy,mxs,'crv')
          close(iu14)
        endif
c
c *** now re-store the tree-ring index matrix
c
        rewind(iu16)
        do j=1,nc
          read(iu16,'(a8,3i6)')ident(j),ify,ily,n
          read(iu16,'(10f9.4)')(x(i,j),i=1,n)
        enddo
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          ish=ify-idate(nc+1,1)
          do i=1,n
            ii=n-i+1
            x(ii+ish,j)=x(ii,j)
          enddo
          do i=1,ish
            x(i,j)=-9.99
          enddo
        enddo
      endif
      if(ics.gt.0.or.ird.eq.1.or.ird.eq.3)then
        close(iu16,status='delete')
      endif
      call sstat(x,stats,idate,ident,nc,mxy,mxs,iu11,ipo)
      return
      end
*sbr detrend1
*
      subroutine detrend1(x,f,wk2,wk3,n,eq,jdt,mxy,mxs,ndt)
      parameter (i1=1,i2=2,i3=3,i4=4,i5=5,i6=6,i10=10,i21=21,iu11=11)
	  parameter (nemax=2500,ndmax=i5,ndmaxp1=i6,r0=0e0,r1=1e0,nmax=10000)
	  real*4 x(mxy),f(mxy),wk2(mxy),wk3(mxy),eq(7)
      real*4 pam(ndmaxp1,ndmax),yam(ndmaxp1),v(ndmax)
      real*4 span,alpha,w(nmax),sc(nmax,7)
      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
        alpha=float(ndt)
        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
        rdt=float(ndt)/100.
c        rdt=float(ndt)
        call lowess(wk2,f,n,rdt)
      elseif(jdt.eq.-3)then
        do i=1,n
          wk2(i)=x(i)
        enddo
c        do i=2,n
c          wk2(i-1)=x(i)
c        enddo
        call msmoor(wk2,f,wk3,n,ndt,iter,ier,mxy)
      elseif(jdt.eq.-1)then
        do i=2,n
          wk2(i-1)=x(i)
        enddo
        call xmean(x(2),n-1,xm1)
        do i=2,n
          wk3(i-1)=x(i)-x(i-1)						                !first-difference
        enddo
        x(1)=-9.99
        n=n-1
        do i=1,n
          x(i+1)=wk3(i)
        enddo
c        call xmean(x,n,xm)
c        sum=0.0
c        do i=1,n
c          sum=sum+xm
c          f(i)=sum
c        enddo
c        call xmean(f,n,xm2)
c        do i=1,n
c          f(i)=f(i)-xm2+xm1
c        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
        call curve(n,x,f,eq)							               !negative exponential curve
        if(eq(2).le.0.or.eq(5).lt.0)then
          do i=1,7
            eq(i)=0.0
          enddo
          call trend(n,x,f,eq(3),eq(5))
          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 xmean(x,n,eq(5))
            do i=1,n
              f(i)=eq(5)
            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
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter,iopt,nemax,n,wk2,x,f,sumsq)
        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
          call trend(n,x,f,eq(3),eq(5))
        endif
      elseif(jdt.eq.4.or.jdt.eq.5)then
        call trend(n,x,f,eq(3),eq(5))				        !linear regression
        if(jdt.eq.5.and.eq(3).gt.0)then
          jdt=6
          eq(3)=0.0
          eq(5)=0.0
          call xmean(x,n,eq(5))						            !arithmetic mean
          do i=1,n
            f(i)=eq(5)
          enddo 
        endif       
      elseif(jdt.eq.6)then
        call xmean(x,n,eq(5))						              !arithmetic mean
        do i=1,n
          f(i)=eq(5)
        enddo
      elseif(jdt.eq.7)then
        do i=1,n
          wk2(i)=i
        enddo
        call hughdi(wk2,x,n,f,eq,flag)           !hugershoff growth curve
        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
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter,iopt,nemax,n,wk2,x,f,sumsq)
        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
        call gexp(x,n,f,wk2,wk3,eq,flag)         !general exponential curve
        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
        call gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter,iopt,nemax,n,wk2,x,f,sumsq)
        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
          call trend(n,x,f,eq(3),eq(5))
        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
*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,z,f,eq)
      real*4 z(n),f(n),eq(7)
      real*8 a,b,d,e,g,eh,ah,bh(3),rss(3),yf,yl,rn,dlt,ab,arg,zz,dinc
      data dinc/.0000005d0/
      nit=0
      if(n .lt. 20)then
      write(*,'(''>> sbr curve:  only'',i3,
     +'' values, no exponential curve fit'')')n
      goto 99
      endif
      rn=dble(n)
      yf=0.d0
      do 5 i=1,10
    5 yf=yf+dble(z(i))
      yf=yf/10.d0
      yl=0.d0
      do 8 i=n-9,n
    8 yl=yl+dble(z(i))
      yl=yl/10.d0
      bh(2)=(dlog(yf)-dlog(yl))/(rn-10.d0)
      if(bh(2) .le. 0.)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,n
      arg=ab*dfloat(i)
      if(arg .gt. 112.8d0)goto 99
   19 f(i)=dexp(-bh(k)*dfloat(i))
      a=dble(n)
      b=0.d0
      d=0.d0
      e=0.d0
      g=0.d0
      do 21 i=1,n
      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,n
      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
        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
*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,y,f,sl,yi)
      implicit real*8 (a-h,o-z)
      real*4 y(n),f(n),sl,yi
      an=dfloat(n)
      t=0.d0
      w=0.d0
      x=0.d0
      z=0.d0
      do i=1,n
        ai=dfloat(i)
        z=z+ai
        t=t+ai*ai
        x=x+dble(y(i))*ai
        w=w+dble(y(i))
      enddo
      ymean=w/an
      dsl=(x-w*z/an)/(t-z*z/an)
      dyi=ymean-dsl*z/an
      do i=1,n
        ai=dfloat(i)
        f(i)=sngl(dsl*ai+dyi)
      enddo
      sl=sngl(dsl)
      yi=sngl(dyi)
      return
      end
*sbr hughdi
*
      subroutine hughdi(x,y,ntot,xy,coef,flag)
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
      do k = 1,ntot 
        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))
      do k = 1,ntot 
        xy(k) = xy(k)*cc 
      enddo
      goto 700
  500 continue
c     berechnen der ausgleichskurve und xy in kolonne 1 setzen
      do k = 1,ntot 
        xk = dble(x(k))
        dxy = dcoef(1) * xk**dcoef(2) * dexp(dcoef(3)*xk)
        xy(k) = sngl(dxy) 
      enddo
  700 return
      end 
*sbr gexp
*
      subroutine gexp(y,n,f,wk1,wk2,coef,flag)
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)
      do i=1,n
        ri=dble(i)
        f(i)=sngl(a*ri*dexp(b*ri))
      enddo
      coef(1)=sngl(a)
      coef(2)=-sngl(b)
      return
      end
*sbr xmean
*
      subroutine xmean(x,n,xm)
      real*4 x(n)
      if(n.le.0)then
        write(*,'(/1x,''error in xmean: n=0'')')
        pause
        stop
      endif
      rn=n
      xm=0.0
      do i=1,n
        xm=xm+x(i)
      enddo
      xm=xm/rn
      return
      end
*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(y,ys,n,f)
      parameter(mxy=5000)
      integer n
      integer nsteps
ccc      real x(n), y(n), f, delta, ys(n), rw(n)
ccc      real res(n)
      real x(mxy), y(n), f, delta, ys(n), rw(mxy)
      real res(mxy)
      integer nright, min0, max0, i, j, ifix
      integer iter, last, m1, m2, ns, nleft
      real abs, cut, cmad, r, d1, d2
      real 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 = 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 = 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
      subroutine lowest(x,y,n,xs,ys,nleft,nright,w,userw,rw,ok)
      parameter(mxy=5000)
      integer n
      integer nleft, nright
ccc      real x(n), y(n), xs, ys, w(n), rw(n)
      real x(mxy), y(n), xs, ys, w(n), rw(n)
      logical userw, ok
      integer nrt, j
      real abs, a, b, c, h, r
      real h1, sqrt, h9, amax1, range
      range = x(n)-x(1)
      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.-9.99)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
*sbr msmoor
*
      subroutine msmoor(x,y,z,n,m,iter,ier,mxy)
c     repeatedly calls msmoo until either absum < small or iter > 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.
      iter=i0
   10 iter=iter+i1
      if(iter.gt.itmax) then
        ier=20
		      write(*,'(/1x,''*** maximum iterations reached in '',
     *    ''msmoor ***'')')
        return
      endif
      call msmoo(x,y,z,n,m,iter,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)') iter,absum
c      write(11,'(/1x,i5,f10.7)') iter,absum
      if(absum.lt.small) return
      do i=i1,n
        x(i)=y(i)
      enddo
      go to 10
      end 
*sbr msmoo
*                                                                      
      subroutine msmoo(x,y,z,n,m,iter,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
c                                                           
      subroutine rank(data,nobs,nmax)                                              
      dimension data(nmax)                                                         
      r=nobs                                                                    
      do 10 i=1,nobs                                                            
      big=data(i)                                                               
      save=data(i)                                                              
      k=i                                                                       
      do 20 j=i,nobs                                                            
      if(data(j).le.big) go to 20                                               
      big=data(j)                                                               
      k=j                                                                       
   20 continue                                                                  
      data(k)=save                                                              
      data(i)=big                                                               
   10 continue                                                                  
      return                                                                    
      end
*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
*sbr symmetry
c
      subroutine symmetry(x,wk1,wk2,wk3,wk4,n,ns)
      real*4 x(n),wk1(n),wk2(n),wk3(n),wk4(n)
      integer ns(n)
      iter=0
      do i=1,n
        wk1(i)=x(i)
        wk4(i)=x(i)
      enddo
      call moment1(wk1,ns,n,ave1,adev1,sdev1,var1,skew1,curt1,sens1,ac1)
      skew=skew1
      sskew=abs(skew)
      nit=0
   10 call mndf1(wk1,ns,n,nseg,wk2,wk3,2)
      call pearsn1(wk2,wk3,ns,nseg,r,a,b)
      if(iter.eq.0)then
        p=1.0
      endif
      if(skew.lt.0.and.b.lt.0)then
        p=1.0-b
      elseif(skew.gt.0.and.b.gt.0)then
        p=1.0-b
      elseif(skew.lt.0.and.b.gt.0)then
        p=1.0+b
      elseif(skew.gt.0.and.b.lt.0)then
        p=1.0+b
      endif
      do i=1,n
        if(ns(i).gt.0)then
          datum=wk1(i)
          if(datum.lt.0)datum=0.0
          wk1(i)=datum**p
        endif
      enddo
      call moment1(wk1,ns,n,ave2,adev2,sdev2,var2,skew2,curt2,sens2,ac2)
      skew=skew2
      iter=iter+1
      if(abs(skew).lt.sskew)then
        nit=iter
        sskew=abs(skew)
        do i=1,n
          wk4(i)=wk1(i)
        enddo
      endif
      if(iter.lt.10)goto 10
      if(nit.eq.0)then
        return
      endif
      call moment1(wk4,ns,n,ave2,adev2,sdev2,var2,skew2,curt2,sens2,ac2)
      do i=1,n
        if(ns(i).gt.0)then
          dep=(wk4(i)-ave2)/sdev2
          x(i)=dep*sdev1+ave1
        endif
      enddo
      return
      end
*sbr pool: pooled autoregression analysis
c
c *** programmed by:
c
c     edward r cook
c     tree-ring laboratory
c     lamont-doherty earth observatory
c     palisades, new york  10964
c
c *** pool performs pooled autoregression analysis for estimating the
c *** common persistence structure of an ensemble of tree-ring series.
c
      subroutine pool(y,nc,maxn,ipr,darps,dp,mxy,mxs,idate,mask,vif)
      integer nlv
      parameter(nlv=11)
      real*4 y(mxy,mxs),avarps(12),gr(12),aic(12),wk(12),darps(12)
      real*4 rfw(111),vfac(10),y1(nlv,4)
      integer idate(mxs+2,10),mask(mxs)
      
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      logical test
      test=.false.
c
      ipp=jems(10,1)
      ip2=jems(10,2)
      ird=jems(19,1)
c
c *** subtract means and zero out unused portions of the array
c
      ifmny=idate(nc+1,1)
      if(cvp.eq.'n'.or.cvp.eq.'N')then
        write(*,'(/1x,''computing pooled autoregression'')')
      endif
      rnt=maxn
      do j=1,nc
        if(mask(j).eq.1)then
          sum=0.0
         if1=idate(j,1)
          il1=idate(j,2)
          ny1=il1-if1+1
          iskp=if1-ifmny
          if(iskp.lt.0)then
            write(*,'(1x,''error in pool: iskp = '',i4)')iskp
            pause
          endif
          do i=1,ny1
            sum=sum+y(i+iskp,j)
          enddo
          sum=sum/float(ny1)			                !compute mean of series j
          do i=1,ny1
            y(i+iskp,j)=y(i+iskp,j)-sum			     !remove mean from series j
          enddo
        endif
      enddo
c
c *** calculate and pool lag product sums
c
      nmult=0
      mxmult=0
      do j=1,12
        mxmult=mxmult+(maxn-j+1)*nc*nc
      enddo
      do 20 k=1,12
        np=maxn-k+1
        gsum=0.0
        do 19 i=1,nc
          if(mask(i).eq.0)goto 19
          ify1=idate(i,1)
          ily1=idate(i,2)
        do 19 j=1,nc
          ify2=idate(j,1)
          ily2=idate(j,2)
          if(ify2.gt.ily1.or.ily2.lt.ify1.or.
     *	     ify1.gt.ily2.or.ily1.lt.ify2)goto 19
          ifmx=max0(ify1,ify2)
          ilmn=min0(ily1,ily2)
          np=ilmn-ifmx-k+2
          if(np.lt.1)goto 19
          ist=ifmx-idate(nc+1,1)
          sum=0.0
          do 18 kk=1,np
            sum=sum+y(kk+ist,i)*y(kk+k-1+ist,j)		!calculate lag products
            nmult=nmult+1
   18     continue
          gsum=gsum+sum					                     !accumulate lag products
   19   continue
        gr(k)=gsum					                          !save lag product sums
c        if(cvp.eq.'n'.or.cvp.eq.'n')then
c          write(*,'(4x,''lag '',i2,'' computed'')')k-1
c        endif
   20 continue
      pindex=(1.0-float(nmult)/float(mxmult))*100.0
ccc      write(*,'(/1x,''pooling efficiency: '',f9.2,
ccc     *	'' percent fewer multiplications'')')pindex
ccc      write(iu11,'(//t10,''pooling efficiency: '',2i10,f9.2,
ccc     *	'' percent fewer multiplications'')')nmult,mxmult,pindex
      do i=1,11
        avarps(i)=gr(i)/gr(1)
        avfac=avarps(i)
        j=i-1
        if(j.gt.0)then
          vfac(j)=avfac
        endif
      enddo
      y1(1,1)=1.0
      do i=2,11
        y1(i,1)=avarps(i)
      enddo
      if(cvp.eq.'n'.or.cvp.eq.'N')then
        write(iu11,'(/t2,''pooled autocorrelations:''/)')
        write(iu11,'(t2,''lag   '',10(''  t='',i3))')(-i,i=1,10)
        write(iu11,'(t8,10f7.3)')(avarps(i),i=2,11)
c
c *** solve for pooled ar coefficients using levinson-durbin recursion
c
        write(iu11,'(/t2,''yule-walker estimates of '',
     *    ''autoregression:''/)')
        write(iu11,'(t2,''order '',10(''  t='',i3))')(-i,i=1,10)
      endif
      avarps(1)=1.0
      vp=gr(1)
      aic(1)=rnt*alog(vp)+2.0
      aicm=aic(1)
      avarps(2)=gr(2)/gr(1)
      nn=1
      if(cvp.eq.'n'.or.cvp.eq.'N')then
        write(iu11,'(t2,i4,2x,10f7.3)')nn,(avarps(i),i=2,nn+1)
      endif
      y1(1,2)=1.0
      y1(2,2)=avarps(2)
      ipr=0
      do nn=2,11
        rn=nn
        vp=gr(1)
        dp=gr(nn+1)
        do i=2,nn
          vp=vp-avarps(i)*gr(i)
          dp=dp-avarps(i)*gr(nn-i+2)
        enddo
        avarps(nn+1)=dp/vp
        aic(nn)=rnt*alog(vp)+2.0*rn
        if(test)goto 10
        if(ipr.gt.0.and.aic(nn).gt.aicm.and.ipp.eq.0)then
          test=.true.
          goto 10
        elseif(ipp.gt.0.and.ipp.eq.nn-1)then
          ipr=nn-1
          do i=1,ipr
            darps(i)=avarps(i+1)
          enddo
          test=.true.
          goto 10          
        elseif(aic(nn).le.aicm)then
          ipr=nn-1
          do i=1,ipr
            darps(i)=avarps(i+1)
          enddo
          aicm=aic(nn)
        endif
   10   do i=2,nn
          wk(i)=avarps(i)-avarps(nn+1)*avarps(nn+2-i)
        enddo
        do i=2,nn
          avarps(i)=wk(i)
        enddo
        if(cvp.eq.'n'.or.cvp.eq.'N')then
          if(nn.lt.11)write(iu11,'(t2,i4,2x,10f7.3)')nn,
     *      (avarps(i),i=2,nn+1)
        endif
        if(nn.lt.11)y1(nn+1,2)=avarps(nn+1)
      enddo
      if(cvp.eq.'n'.or.cvp.eq.'N')then
        write(iu11,'(/t2,''last term in each row above equals the '',
     *	  	''partial autocorrelation coefficient'')')
        write(iu11,'(/t2,''akaike information criterion:'')')
        write(iu11,'(/t3,6(''    ar('',i2,'')  '')/t1,6f12.2)')
     *  		(j-1,j=1,6),(aic(i),i=1,6)
        write(iu11,'(/t3,5(''    ar('',i2,'')  '')/t1,5f12.2)')
     *	  	(j-1,j=7,11),(aic(i),i=7,11)
        write(iu11,'(/t2,''selected autoregression order:'',i4)')ipr
        write(*,'(/1x,''selected autoregression order:'',i4)')ipr
        if(ipp.eq.0)then
          write(iu11,'(/t2,''ar order selection criterion: ipp=0  '',
     *	  	''first-minimum aic selection'')')
        elseif(ipp.lt.0)then
          write(iu11,'(/t2,''ar order selection criterion: ipp<0  '',
     *  		''full-minimum aic selection'')')
        else      
          write(iu11,'(/t2,''ar order selection criterion: ipp>0  '',
     *  		''constrained ar order selection = ipp'')')
        endif
        write(iu11,'(/t2,''the aic trace should be checked to see if '',
     *    ''ar order selection criterion <ipp>''/t2,''is '',
     *    ''adequate. e.g. if ar-orders of the first-minimum '',
     *    ''and the full-minimum aic''/t2,''are close, an '',
     *    ''arstan run with full-minimum aic order selection '',
     *    ''might be tried'')')
      endif
      if(ipr.gt.0)then
        if(cvp.eq.'n'.or.cvp.eq.'N')then
          write(iu11,'(/t2,''autoregression coefficients:''/)')
          write(iu11,'(t3,10(''t='',i3,''   ''))')(0-i,i=1,10)
          write(iu11,'(f7.3,9f8.3)')(darps(i),i=1,ipr)
        endif
        dp=0.0
        y1(1,3)=1.0
        do i=1,ipr
          dp=dp+(gr(i+1)/gr(1))*darps(i)
          y1(i+1,3)=darps(i)
        enddo
        if(cvp.eq.'n'.or.cvp.eq.'N')then
          write(iu11,'(/t2,''r-squared due to pooled autoregression:'',
     *	    	f8.2,'' pct'')')dp*100.0
          vif=1.0
          do i=1,ipr
            vif=vif-darps(i)*vfac(i)
          enddo
          vif=(1.0/vif)*100.0
          write(iu11,'(t2,''variance inflation from autoregression:'',
     *      f8.2,'' pct'')')vif
          write(*,'(1x,''r-squared due to pooled autoregression:'',
     *	    	f8.2,'' pct'')')dp*100.0
          write(*,'(1x,''variance inflation from autoregression:'',
     *      f8.2,'' pct'')')vif
          vif=vif/100.0
        endif
c
c *** calculate impulse response function weights of the ar(ip) process
c
        do i=1,ipr-1
          rfw(i)=0.0
        enddo
        rfw(ipr)=1.0
        do i=1,100
          ii=i+ipr
          rfw(ii)=0.0
          do j=1,ipr
            rfw(ii)=rfw(ii)+darps(j)*rfw(ii-j)
          enddo
        enddo
        if(cvp.eq.'n'.or.cvp.eq.'N')then
          write(iu11,'(/t2,''impulse response function weights '',
     *      ''for this ar ('',i2,'') process out to order 50:''/)')ipr
          write(iu11,'((t3,f6.4,9f8.3))')(rfw(i),i=ipr,ipr+49)
        endif
      endif
      y1(1,4)=1.0
      do i=1,10
        y1(i+1,4)=rfw(i+ipr)
      enddo
c      do i=1,10
c       if(i.le.ipr)then
c          write(*,'(4f8.4)')(y1(i,j),j=1,4)
c       else
c          write(*,'(2f8.4,8x,f8.4)')(y1(i,j),j=1,2),y1(i,4)
c       endif
c      enddo
c      pause
      if(ird.eq.2.or.ird.eq.3.or.ip2.eq.1)then
        call arhist1(y1,nlv,ipr,fil1,maxn,ird)
      endif
      return
      end
*sbr armod
*
      subroutine armod(y,wrk1,wrk2,wrk3,wrk4,wrk5,wrk6,cof,ipr,stats)
      parameter(mxy=5000,mxs=3000)
      real*4 y(mxy,16),wrk1(mxy),wrk2(mxy),wrk3(mxy),
     *  wrk4(mxy),wrk5(mxy),wrk6(mxy),cof(12,mxs)
      real*4 stats(mxs,12),eq(7)
      integer nss(mxy),keep(mxs)
      character id*8,fil*40,tag*3
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c *** tsi common block variables
c
      real*4 x(mxy,mxs),crn(mxy)
      integer idate(mxs+2,10)
      character ident(mxs)*8
c
c *** tsi graphics stuff
c
      common/tsi1/x,crn,idate,ident,nc
c
      jrb1=jems(9,1)
      jrb2=jems(9,2)
      ips=jems(11,1)
      ipo=jems(17,1)
      ics=jems(18,1)
      ird=jems(19,1)
      jrd=ird
c
      write(*,'(/1x,''calculate individual series autoregressions''/)')
      if(ipo.gt.1)then
        if(jrb1.eq.1)then
          write(iu11,'(/t2,''|---------------- individual series '',
     *      ''autoregressive coefficients ---------------|'')')
        else
          write(iu11,'(/t2,''|------------ individual series robust '',
     *      ''autoregressive coefficients ------------|'')')
        endif
      endif
      if(ips.eq.0)then
        jopt=1
        jpr=ipr+1
      elseif(ips.gt.0)then
        jopt=1
        jpr=ips+1
      else
        jopt=ips
        jpr=11
      endif
      maxp=-999
      ifmny=idate(nc+1,1)
      ilmxy=idate(nc+1,2)
      maxn=ilmxy-ifmny+1
      do i=1,maxn
        y(i,13)=0.0
        y(i,14)=0.0
      enddo
      if(jrb1.gt.1)then
        ll=len(fil1)
        jj=0
        do j=1,ll
          jj=ll-j+1
          if(fil1(jj:jj).ne.' ')goto 10
        enddo
   10   ll=jj
        call blank(fil)
        fil=fil1
        fil(ll+1:ll+11)='_auto_outs '
        tag='out'
        open(iu14,file=fil,status='unknown')
        close(iu14,status='delete')
        open(iu14,file=fil,status='unknown')
        open(iu16,file='res.tmp',status='unknown')
        close(iu16,status='delete')
        open(iu16,file='res.tmp',status='unknown')
      endif
c
c *** prewhiten data
c
      liar=0
      do j=1,nc
ccc        write(*,'(1x,i6,2x,a8)')j,ident(j)
        if(bf.eq.'y'.or.bf.eq.'Y')then
          kopt=idate(j,6)
          if(kopt.eq.0)then
            jopt=1
            jpr=ipr+1
          elseif(kopt.gt.0)then
            jopt=1
            jpr=kopt+1
          else
            jopt=kopt
            jpr=11
          endif
        endif
        ify=idate(j,1)
        n=idate(j,2)-ify+1
        ist=idate(j,1)-idate(nc+1,1)+1
        call robar(x(ist,j),j,ident(j),n,wrk1,wrk2,wrk3,wrk4,wrk5,
     *    jpr,jopt,cof(1,j),ip,pm,mxy)
c
c *** begin new tsi graphics
c
        if(jrb1.gt.1)then
          nlier=0
          do i=1,n
            dep=wrk3(i)-1.0
            if(abs(dep).gt.0.1)then
              nlier=nlier+1
            endif
            wrk4(i)=1.0
          enddo
          if(nlier.eq.0)then
            do i=1,n
              wrk3(i)=1.0
            enddo
          endif
          if(jrb2.gt.0)then
            call blank(id)
            k=0
            do i=1,8
              if(ident(j)(i:i).ne.' ')then
                k=k+1
                id(k:k)=ident(j)(i:i)
              endif
            enddo
            eq(7)=0
            wrk6(1)=-999.0
            call crnplt1(wrk1,wrk2,wrk5,wrk3,wrk4,wrk6,nss,n,ify,1,id,' with and without outliers',
     *        ' autoregressive outliers','years','indices (y)','years','outliers (z)',1,
     *        pixels,jrb2,mxy,eq,jdt)
          endif
        endif
c
c *** end new tsi graphics
c
        if(jrb1.gt.1)then
          xm=0.0
          do i=1,n
            xm=xm+wrk3(i)
          enddo
          xm=xm/float(n)
          iskp=ify-ifmny
          do i=1,n
            dep=wrk3(i)-xm
            if(dep.lt.-0.2)then
              y(i+iskp,13)=y(i+iskp,13)-1
            elseif(dep.gt.0.2)then
              y(i+iskp,14)=y(i+iskp,14)+1
            else
              wrk3(i)=1.0
            endif
          enddo
        endif
        cof(11,j)=pm
        cof(12,j)=ip
        if(ip.gt.maxp)maxp=ip
        idate(j,6)=ips
        if(jrb1.gt.1)then
          write(iu14,'(a8,3i6)')ident(j),ify,ify+n-1,n
          write(iu14,'(10f9.4)')(wrk3(i),i=1,n)
          ii=ist
          jj=ist+n-1
          write(iu16,'(a8,3i6)')ident(j),ify,ify+n-1,n
          write(iu16,'(10f9.4)')(x(i,j),i=ii,jj)
        endif
      enddo
c
      if(jrb1.gt.1)then
        rewind(iu14)
        do j=1,nc
          read(iu14,'(a8,3i6)')ident(j),ify,ily,n
          read(iu14,'(10f9.4)')(x(i,j),i=1,n)
        enddo
        close(iu14,status='delete')
        if(ics.gt.0)open(iu14,file=fil,status='unknown')
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          ish=ify-idate(nc+1,1)
          do i=1,n
            ii=n-i+1
            x(ii+ish,j)=x(ii,j)
          enddo
          do i=1,ish
            x(i,j)=-9.99
          enddo
        enddo
c        do i=1,maxn
        crn(1)=-9.99
c        enddo
        jrb2=jems(9,2)
        if(jrb2.gt.0.or.ird.gt.0)then
          call crnplt3('autoregressive outliers','years',
     *      'index units',12)
        endif
        if(ics.gt.0)then
          if(ics.le.3)then
            do k=1,3
              itrdb(k)(82:85)=' aout'  !pjk was 86
              write(iu14,'(a)')itrdb(k)
            enddo
          endif
          call sis(x,wrk3,nc,idate,ident,nss,keep,tit,mxy,mxs,'out')
          close(iu14)
        endif
        rewind(iu16)
        do j=1,nc
          read(iu16,'(a8,3i6)')ident(j),ify,ily,n
          read(iu16,'(10f9.4)')(x(i,j),i=1,n)
        enddo
        do j=1,nc
          ify=idate(j,1)
          ily=idate(j,2)
          n=ily-ify+1
          ish=ify-idate(nc+1,1)
          do i=1,n
            ii=n-i+1
            x(ii+ish,j)=x(ii,j)
          enddo
          do i=1,ish
            x(i,j)=-9.99
          enddo
        enddo
        close(iu16,status='delete')
      endif
c
      if(jrb1.gt.1)then
        do i=1,maxn
          if(abs(y(i,13)).gt.0)then
            y(i,15)=y(i,13)/y(i,1)
          endif
          if(y(i,14).gt.0)then
            y(i,16)=y(i,14)/y(i,1)
          endif
        enddo
        if(jrb2.gt.0.or.ird.gt.0)then
          call crnplt1(y(1,13),y(1,14),wrk5,y(1,15),y(1,16),wrk6,nss,maxn,ifmny,1,fil1,
     *      ' number of autoregressive outliers',' fraction of autoregressive outliers',
     *      'years','number (y)','years','fraction (z)',7,pixels,jrd,mxy,eq,jdt)
        endif
      endif
c
      if(ipo.gt.1)then
        do j=1,nc
          ip=cof(12,j)
          if(j.eq.1.or.mod(j,20).eq.0)then
            write(iu11,'(/t6,''series    ident    order     rsq     '',
     *        ''t-1     t-2     t-3   .....    t-ip'')')
          endif
          if(ip.gt.5)then
            ip5=5
          else
            ip5=ip
          endif
          if(jrb1.eq.1.or.(jrb1.gt.1.and.ipo.le.4))then
            write(iu11,'(t6,i5,3x,a8,i6,2x,6f8.3)')j,ident(j),
     *        ifix(cof(12,j)),cof(11,j),(cof(k,j),k=1,ip5)
            if(ip.gt.ip5)then
              write(iu11,'(37x,5f8.3)')(cof(k,j),k=6,ip)
            endif
          elseif(jrb1.gt.1.and.(ido.eq.2.or.ido.eq.3))then
            write(iu11,'(t21,i7,2x,6f8.3)')ifix(cof(12,j)),cof(11,j),
     *        (cof(k,j),k=1,ip5)
            if(ip.gt.ip5)then
              write(iu11,'(37x,5f8.3)')(cof(k,j),k=6,ip)
            endif
          endif
        enddo
      endif
c
      if(jrb1.eq.1)then
        write(iu11,'(/t2,''|------------- summary statistics for '',
     *    ''autoregressive coefficients -------------|''/)')
      else
        write(iu11,'(/t2,''|---------- summary statistics for '',
     *    ''robust autoregressive coefficients ---------|''/)')
        endif
      if(ips.ge.0)then
        do j=1,maxp+2
          do k=1,nc
            if(j.le.maxp)then
              wrk4(k)=cof(j,k)
            elseif(j.eq.maxp+1)then
              wrk4(k)=cof(11,k)
            else
              wrk4(k)=cof(12,k)
            endif
          enddo
          call moment(wrk4,nc,ave,adev,sdev,var,skew,curt,sens,ac)
          call mfs(wrk4,nc,rmd,hh,hl,fsd,rmn,rmx)
          if(sdev.lt.0)sdev=0.0
          stats(1,j)=ave
          stats(2,j)=sdev
          stats(3,j)=rmd
          stats(4,j)=fsd
          stats(5,j)=rmn
          stats(6,j)=hl
          stats(7,j)=hh
          stats(8,j)=rmx
        enddo
        if(maxp.gt.5)then
          ip5=5
        else
          ip5=maxp
        endif
        write(iu11,'(t25,''order     rsq     t-1     t-2     '',
     *    ''t-3   .....    t-ip'')')
        write(iu11,'(t4,''arithmetic mean'',t25,i3,2x,6f8.3)')
     *    ifix(stats(1,maxp+2)),stats(1,maxp+1),(stats(1,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(1,j),j=6,maxp)
        endif
        write(iu1	1,'(t4,''standard deviation'',t25,i3,2x,6f8.3)')
     *    ifix(stats(2,maxp+2)),stats(2,maxp+1),(stats(2,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(2,j),j=6,maxp)
        endif
        write(iu11,'(t4,''median'',t25,i3,2x,6f8.3)')
     *    ifix(stats(3,maxp+2)),stats(3,maxp+1),(stats(3,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(3,j),j=6,maxp)
        endif
        write(iu11,'(t4,''interquartile range'',t25,i3,2x,6f8.3)')
     *    ifix(stats(4,maxp+2)),stats(4,maxp+1),(stats(4,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(4,j),j=6,maxp)
        endif
        write(iu11,'(t4,''minimum value'',t25,i3,2x,6f8.3)')
     *    ifix(stats(5,maxp+2)),stats(5,maxp+1),(stats(5,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(5,j),j=6,maxp)
        endif
        write(iu11,'(t4,''lower hinge'',t25,i3,2x,6f8.3)')
     *    ifix(stats(6,maxp+2)),stats(6,maxp+1),(stats(6,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(6,j),j=6,maxp)
        endif
        write(iu11,'(t4,''upper hinge'',t25,i3,2x,6f8.3)')
     *    ifix(stats(7,maxp+2)),stats(7,maxp+1),(stats(7,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(7,j),j=6,maxp)
        endif
        write(iu11,'(t4,''maximum value'',t25,i3,2x,6f8.3)')
     *    ifix(stats(8,maxp+2)),stats(8,maxp+1),(stats(8,j),j=1,ip5)
        if(maxp.gt.5)then
          write(iu11,'(t39,5f8.3)')(stats(8,j),j=6,maxp)
        endif
      else
        do j=1,2
          do k=1,nc
            if(j.eq.1)then
              wrk4(k)=cof(11,k)
            else
              wrk4(k)=cof(12,k)
            endif
          enddo
          call moment(wrk4,nc,ave,adev,sdev,var,skew,curt,sens,ac)
          call mfs(wrk4,nc,rmd,hh,hl,fsd,rmn,rmx)
          if(sdev.lt.0)sdev=0.0
          stats(1,j)=ave
          stats(2,j)=sdev
          stats(3,j)=rmd
          stats(4,j)=fsd
          stats(5,j)=rmn
          stats(6,j)=hl
          stats(7,j)=hh
          stats(8,j)=rmx
        enddo
        write(iu11,'(t25,''order     rsq'')')
        write(iu11,'(t4,''arithmetic mean'',t25,i3,2x,f8.3)')
     *    ifix(stats(1,2)+0.5),stats(1,1)
        write(iu1	1,'(t4,''standard deviation'',t25,i3,2x,f8.3)')
     *    ifix(stats(2,2)),stats(2,1)
        write(iu11,'(t4,''median'',t25,i3,2x,f8.3)')
     *    ifix(stats(3,2)),stats(3,1)
        write(iu11,'(t4,''interquartile range'',t25,i3,2x,f8.3)')
     *    ifix(stats(4,2)),stats(4,1)
        write(iu11,'(t4,''minimum value'',t25,i3,2x,f8.3)')
     *    ifix(stats(5,2)),stats(5,1)
        write(iu11,'(t4,''lower hinge'',t25,i3,2x,f8.3)')
     *    ifix(stats(6,2)),stats(6,1)
        write(iu11,'(t4,''upper hinge'',t25,i3,2x,f8.3)')
     *    ifix(stats(7,2)),stats(7,1)
        write(iu11,'(t4,''maximum value'',t25,i3,2x,f8.3)')
     *    ifix(stats(8,2)),stats(8,1)
      endif
      arav=stats(1,maxp+1)
      arsg=stats(2,maxp+1)
      if(ipo.gt.1)then
        write(iu11,'(/t2,''|------------------- statistics of '',
     *    ''prewhitened tree-ring data -----------------|'')')
      endif
      do j=1,nc
        ify=idate(j,1)
        ily=idate(j,2)
        n=ily-ify+1
        ist=ify-idate(nc+1,1)+1
        ip=cof(12,j)
        do i=1,n
          x(ist+i-1,j)=x(ist+i-1,j)+1.0
          if(x(ist+i-1,j).lt.0)x(ist+i-1,j)=0.0
        enddo
        call moment(x(ist,j),n,ave,adev,sdev,var,skew,curt,sens,ac)
        stats(j,1)=n
        stats(j,2)=ave
        stats(j,3)=sdev
        stats(j,4)=skew
        stats(j,5)=curt
        stats(j,6)=sens
        stats(j,7)=ac
        if(ipo.gt.1)then
          if(j.eq.1.or.mod(j,20).eq.0)then
            write(iu11,'(/t2,''series   ident   frst   last   '',
     *        ''year    mean   stdev   skew   kurt   sens   ac(1)'')')		                                   
          endif
          write(iu11,'(t2,i5,2x,a8,i6,2i7,2f8.3,3f7.3,f8.3)')
     *      j,ident(j),ify,ily,n,ave,sdev,skew,curt,sens,ac
        endif
      enddo
      write(iu11,'(/t2,''|------------- summary of prewhitened '',
     *  ''tree-ring series statistics -------------|''/)')
      do j=1,7
        call moment(stats(1,j),nc,ave,adev,sdev,var,skew,curt,sens,ac)
        call mfs(stats(1,j),nc,rmd,hh,hl,fsd,rmn,rmx)
        stats(1,j)=ave
        stats(2,j)=sdev
        stats(3,j)=rmd
        stats(4,j)=fsd
        stats(5,j)=rmn
        stats(6,j)=hl
        stats(7,j)=hh
        stats(8,j)=rmx
      enddo
      write(iu11,'(t33,''year    mean   stdev   skew   kurt   sens   '',
     *  ''ac(1)'')')		                                   
      write(iu11,'(t2,''arithmetic mean'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(1,1)+0.5),(stats(1,j),j=2,7)
      write(iu11,'(t2,''standard deviation'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(2,1)),(stats(2,j),j=2,7)
      write(iu11,'(t2,''median (50th quantile)'',t33,i4,2f8.3,3f7.3,
     *  f8.3)')ifix(stats(3,1)),(stats(3,j),j=2,7)
      write(iu11,'(t2,''interquartile range'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(4,1)),(stats(4,j),j=2,7)
      write(iu11,'(t2,''minimum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(5,1)),(stats(5,j),j=2,7)
      write(iu11,'(t2,''lower hinge (25th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(6,1)),(stats(6,j),j=2,7)
      write(iu11,'(t2,''upper hinge (75th quantile)'',t33,i4,2f8.3,
     *  3f7.3,f8.3)')ifix(stats(7,1)),(stats(7,j),j=2,7)
      write(iu11,'(t2,''maximum value'',t33,i4,2f8.3,3f7.3,f8.3)')
     *  ifix(stats(8,1)),(stats(8,j),j=2,7)
      return
      end
*sbr robar
*
      subroutine robar(x,j,ident,n,wk1,wk2,wk3,wk4,wk5,mip,iopt,
     *  cof,ip,pm,mxy)
      real*4 x(mxy),wk1(mxy),wk2(mxy),wk3(mxy),wk4(mxy),wk5(mxy),cof(12)
      real*4 wgt(5000)
      character ident*8
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      jrb1=jems(9,1)
      krb1=jems(12,1)
c
      xm=0.0
      do i=1,n
        wk4(i)=x(i)
        xm=xm+x(i)
      enddo
      xm=xm/float(n)
c
      iter=1
  100 call memcof(x,n,mip,ip,pm,cof,iopt,wk1,wk2,wk3)
      if(jrb1.eq.1)then
        do i=1,n
          x(i)=wk4(i)
        enddo
      elseif(jrb1.eq.2)then
        if(iter.eq.5)then
          call albino(x,wk1,n,ip,cof,mxy)
          do i=1,n
            wk2(i)=x(i)+1.0
          enddo
        endif
        do i=1,n
          x(i)=wk4(i)
        enddo
      elseif(jrb1.eq.3)then
        if(iter.lt.5)then
          do i=1,n
            x(i)=wk4(i)
          enddo
        endif
      endif
      call albino(x,wk1,n,ip,cof,mxy)
      xm=0.0
      do i=1,n
        xm=xm+x(i)
      enddo
      xm=xm/float(n)
      do i=1,n
        x(i)=x(i)-xm
      enddo
      if(jrb1.eq.1)return
      if(iter.eq.1)then
        do i=1,n
          wk5(i)=x(i)
        enddo
      endif
      if(iter.eq.5)then
        do i=1,n
          wk1(i)=wk5(i)+1.0
          if(jrb1.eq.3)then
            wk2(i)=x(i)+1.0
          endif
          wk3(i)=wk1(i)-wk2(i)+1.0
        enddo
        return
      endif
      do i=1,n
        wk1(i)=x(i)
      enddo
      jems(12,1)=2
      call biwgt(wk1,wk2,7.5,n,bimn,bisg,bise,eff,iter1,wgt)
      do i=1,n
        wk1(i)=x(i)
      enddo
      bisg=qn(wk1,n)
      jems(12,1)=krb1
      do i=1,n
        res=x(i)/(3.0*bisg)
        if(abs(res).lt.1.0)then
          psi=res*exp(-exp(3.0*(abs(res)-3.0)))
        else
          psi=0.0
        endif
        x(i)=3.0*bisg*psi
      enddo
      call commie(x,wk1,n,cof,ip,mxy)
      iter=iter+1
      goto 100
      end
cc#####################################################################
cc######################  file qn.for :  ##############################
cc#####################################################################
cc
cc   this file contains a fortran function for a new robust estimator
cc   of scale denoted as qn, decribed in rousseeuw and croux (1993).
cc   the estimator has a high breakdown point and a bounded influence
cc   function. the implementation given here is very fast (running in
cc   o(nlogn) time) and needs little storage space.
cc
cc   rousseeuw, p.j. and croux, c. (1993), "alternatives to the
cc      median absolute deviation," journal of the american
cc      statistical association, vol. 88, 1273-1283.
cc
cc   a fortran function for the estimator sn, described in the same
cc   paper, is also available. for both estimators, implementations
cc   in the pascal language can be obtained from the authors.
cc
cc   this software may be used and copied freely for scientific
cc   and/or non-commercial purposes, provided reference is made
cc   to the abovementioned paper.
cc
cc   for questions, problems or comments contact:
cc
cc              peter rousseeuw (rousse@wins.uia.ac.be)
cc              christophe croux (croux@wins.uia.ac.be)
cc              department of mathematics and computing
cc              universitaire instelling antwerpen
cc              universiteitsplein 1
cc              b-2610 wilrijk (antwerp)
cc              belgium
cc
cc--------------------------------------------------------------------
cc
cc   efficient algorithm for the scale estimator:
cc
cc       qn = dn * 2.2219 * {|x_i-x_j|; i<j}_(k)
cc
cc   parameters of the function qn :
cc       x  : real array containing the observations
cc       n  : number of observations (n >=2)
cc
cc   the function qn uses the procedures:
cc      whimed(a,iw,n): finds the weighted high median of an array
cc                      a of length n, using the array iw (also of
cc                      length n) with positive integer weights.
cc      sort(x,n,y) : sorts an array x of length n, and stores the
cc                    result in an array y (of size at least n)
cc      pull(a,n,k) : finds the k-th order statistic of an
cc                    array a of length n
cc
      function qn(x,n)
      dimension x(n)
      dimension y(5000),work(5000)
      integer left(5000),right(5000),weight(5000),q(5000),p(5000)
      integer h,k,knew,jhelp,nl,nr,sumq,sump
      logical found
      h=n/2+1
      k=h*(h-1)/2
      call sortq(x,n,y)
      do 20 i=1,n
          left(i)=n-i+2
          right(i)=n
20    continue 
      jhelp=n*(n+1)/2
      knew=k+jhelp
      nl=jhelp
      nr=n*n
      found=.false.
200   continue
      if ( (nr-nl.gt.n).and.(.not.found) ) then
          j=1
          do 30 i=2,n
          if (left(i).le.right(i)) then
              weight(j)=right(i)-left(i)+1
              jhelp=left(i)+weight(j)/2
              work(j)=y(i)-y(n+1-jhelp)
              j=j+1
          endif
30        continue
          trial=whimed(work,weight,j-1)
          j=0
          do 40 i=n,1,-1
45            continue
              if ((j.lt.n).and.((y(i)-y(n-j)).lt.trial)) then
                  j=j+1
                  goto 45
              endif
              p(i)=j
40        continue
          j=n+1
          do 50 i=1,n
55            continue
              if ((y(i)-y(n-j+2)).gt.trial) then
                  j=j-1
                  goto 55
              endif
              q(i)=j
50        continue
          sump=0
          sumq=0
          do 60 i=1,n
              sump=sump+p(i)
              sumq=sumq+q(i)-1
60        continue
          if (knew.le.sump) then
              do 70 i=1,n
                  right(i)=p(i)
70            continue
              nr=sump
          else
              if (knew.gt.sumq) then
                  do 80 i=1,n
                      left(i)=q(i)
80                continue
                  nl=sumq
              else
                  qn=trial
                  found=.true.
              endif
          endif
      goto 200
      endif
      if (.not.found) then
          j=1
          do 90 i=2,n
          if (left(i).le.right(i)) then
              do 100 jj=left(i),right(i)
                  work(j)=y(i)-y(n-jj+1)
                  j=j+1
100           continue
          endif
90        continue
          qn=pull(work,j-1,knew-nl)
      endif
      if (n.le.9) then
          if (n.eq.2) dn=0.399
          if (n.eq.3) dn=0.994
          if (n.eq.4) dn=0.512
          if (n.eq.5) dn=0.844
          if (n.eq.6) dn=0.611
          if (n.eq.7) dn=0.857
          if (n.eq.8) dn=0.669
          if (n.eq.9) dn=0.872
      else
          if (mod(n,2).eq.1) dn=n/(n+1.4)
          if (mod(n,2).eq.0) dn=n/(n+3.8)
      endif
      qn=dn*2.2219*qn
      return
      end
cc
cc  algorithm to compute the weighted high median in o(n) time.
cc
cc  the whimed is defined as the smallest a(j) such that the sum
cc  of the weights of all a(i) <= a(j) is strictly greater than
cc  half of the total weight.
cc
cc  parameters of this function:
cc        a: real array containing the observations
cc        n: number of observations
cc       iw: array of integer weights of the observations.
cc
cc  this function uses the function pull.
cc
cc  the size of acand, iwcand must be at least n.
cc
      function whimed(a,iw,n)
      dimension a(n),iw(n)
      dimension acand(5000),iwcand(5000)
      integer wtotal,wrest,wleft,wmid,wright
      nn=n
      wtotal=0
      do 20 i=1,nn
          wtotal=wtotal+iw(i)
20    continue
      wrest=0
100   continue
      trial=pull(a,nn,nn/2+1)
      wleft=0
      wmid=0
      wright=0
      do 30 i=1,nn
          if (a(i).lt.trial) then
              wleft=wleft+iw(i)
          else
              if (a(i).gt.trial) then
                  wright=wright+iw(i)
              else
                  wmid=wmid+iw(i)
              endif
          endif
30    continue
      if ((2*wrest+2*wleft).gt.wtotal) then
          kcand=0
          do 40 i=1,nn
              if (a(i).lt.trial) then
                  kcand=kcand+1
                  acand(kcand)=a(i)
                  iwcand(kcand)=iw(i)
              endif
40        continue
          nn=kcand
      else
          if ((2*wrest+2*wleft+2*wmid).gt.wtotal) then
              whimed=trial
              return
          else
              kcand=0
              do 50 i=1,nn
                  if(a(i).gt.trial) then
                      kcand=kcand+1
                      acand(kcand)=a(i)
                      iwcand(kcand)=iw(i)
                  endif
50            continue
              nn=kcand
              wrest=wrest+wleft+wmid
          endif
      endif
      do 60 i=1,nn
          a(i)=acand(i)
          iw(i)=iwcand(i)
60    continue
      go to 100
      end
      subroutine sortq(a,n,b)
cc  sorts an array a of length n<=1000, and stores
cc  the result in the array b.
      dimension a(n),b(n),jlv(5000),jrv(5000)
      do 15 j=1,n
      b(j)=a(j)
15    continue
      jss=1
      jlv(1)=1
      jrv(1)=n
10    jndl=jlv(jss)
      jr=jrv(jss)
      jss=jss-1
20    jnc=jndl
      j=jr
      jtwe=(jndl+jr)/2
      xx=b(jtwe)
30    if (b(jnc).ge.xx) goto 40
      jnc=jnc+1
      goto 30
40    if (xx.ge.b(j)) goto 50
      j=j-1
      goto 40
50    if (jnc.gt.j) goto 60
      amm=b(jnc)
      b(jnc)=b(j)
      b(j)=amm
      jnc=jnc+1
      j=j-1
60    if (jnc.le.j) goto 30
      if ((j-jndl).lt.(jr-jnc)) goto 80
      if (jndl.ge.j) goto 70
      jss=jss+1
      jlv(jss)=jndl
      jrv(jss)=j
70    jndl=jnc
      goto 100
80    if (jnc.ge.jr) goto 90
      jss=jss+1
      jlv(jss)=jnc
      jrv(jss)=jr
90    jr=j
100   if (jndl.lt.jr) goto 20
      if (jss.ne.0) goto 10
      return
      end
      function pull(a,n,k)
cc  finds the kth order statistic of an array a of length n<=1000
      dimension a(n),b(5000)
      do 15 j=1,n
      b(j)=a(j)
15    continue
      l=1
      lr=n
20    if (l.ge.lr) goto 90
      ax=b(k)
      jnc=l
      j=lr
30    if(jnc.gt.j)goto 80
40    if (b(jnc).ge.ax)goto 50
      jnc=jnc+1
      goto 40
50    if (b(j).le.ax)goto 60
      j=j-1
      goto 50
60    if(jnc.gt.j)goto 70
      buffer=b(jnc)
      b(jnc)=b(j)
      b(j)=buffer
      jnc=jnc+1
      j=j-1
70    goto 30
80    if(j.lt.k)l=jnc
      if(k.lt.jnc)lr=j
      goto 20
90    pull=b(k)
      return
      end
*sbr albino
c
c *** prewhitens a red noise series as autoregressive process
c
c     x      --  red noise series to be prewhitened
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     ip     --  order of autoregressive model
c     cof    --  array of autoregressive coefficients
c
c     calls bckcst
c
      subroutine albino(x,wrk,n,ip,cof,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      sm=0.0
      do i=1,n
        sm=sm+x(i)
      enddo
      xm=sm/float(n)
      do i=1,n
        x(i)=x(i)-xm
        wrk(i)=x(i)
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      nip=n+ip
      irs=ip+1
      do i=irs,nip
        ii=i-ip
        temp=wrk(i)
        do j=1,ip
          temp=temp-cof(j)*wrk(i-j)
        enddo
        x(ii)=temp
      enddo
      do i=1,n
        x(i)=x(i)+xm
      enddo
      return
      end
*sbr albino1
c
c *** prewhitens a red noise series as autoregressive process
c
c     x      --  red noise series to be prewhitened
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     ip     --  order of autoregressive model
c     cof    --  array of autoregressive coefficients
c
c     calls bckcst
c
      subroutine albino1(x,ns,wrk,n,ip,cof,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      integer ns(n)
      sm=0.0
      n1=0
      do i=1,n
        if(ns(i).gt.0)then
          n1=n1+1
          sm=sm+x(i)
        endif
      enddo
      xm=sm/float(n1)
      do i=1,n
        if(ns(i).gt.0)then
          x(i)=x(i)-xm
        else
          x(i)=0.0
        endif
        wrk(i)=x(i)
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      nip=n+ip
      irs=ip+1
      do i=irs,nip
        temp=wrk(i)
        ii=i-ip
        do j=1,ip
          temp=temp-cof(j)*wrk(i-j)
        enddo
        x(ii)=temp
      enddo
      do i=1,n
        if(ns(i).gt.0)then
          x(i)=x(i)+xm
        else
          x(i)=1.0
        endif
      enddo
      return
      end
*sbr commie
c
c *** adds autoregressive red noise into a white noise series
c
c     x      --  series of white noise residuals
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     cof    --  array of autoregressive coefficients
c     ip     --  order of autoregressive model
c
c     calls bckcst
c
      subroutine commie(x,wrk,n,cof,ip,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      sm=0.0
      do i=1,n
        sm=sm+x(i)
      enddo
      xm=sm/float(n)
      do i=1,n
        wrk(i)=x(i)-xm
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      do i=1,n
        do j=1,ip
          wrk(i+ip)=wrk(i+ip)+wrk(i+ip-j)*cof(j)
        enddo
        x(i)=wrk(i+ip)+xm
      enddo
      return
      end
*sbr commie1
c
c *** adds autoregressive red noise into a white noise series
c
c     x      --  series of white noise residuals
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     cof    --  array of autoregressive coefficients
c     ip     --  order of autoregressive model
c
c     calls bckcst
c
      subroutine commie1(x,ns,wrk,n,cof,ip,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      integer ns(n)
      sm=0.0
      n1=0
      do i=1,n
        if(ns(i).gt.0)then
          n1=n1+1
          sm=sm+x(i)
        endif
      enddo
      xm=sm/float(n1)
      do i=1,n
        if(ns(i).gt.0)then
          wrk(i)=x(i)-xm
        else
          wrk(i)=0.0
        endif
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      do i=1,n
        if(ns(i).gt.0)then
          do j=1,ip
            wrk(i+ip)=wrk(i+ip)+wrk(i+ip-j)*cof(j)
          enddo
          x(i)=wrk(i+ip)+xm
        else
          x(i)=1.0
        endif
      enddo
      return
      end
*sbr commie2
c
c *** adds autoregressive red noise into a white noise series
c
c     x      --  series of white noise residuals
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     cof    --  array of autoregressive coefficients
c     ip     --  order of autoregressive model
c
c     calls bckcst
c
      subroutine commie2(x,wrk,n,cof,ip,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      sm=0.0
      do i=1,n
        sm=sm+x(i)
      enddo
      xm=sm/float(n)
      do i=1,n
        wrk(i)=x(i)-1.0
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      do i=1,n
        do j=1,ip
          wrk(i+ip)=wrk(i+ip)+wrk(i+ip-j)*cof(j)
        enddo
        wrk(i)=wrk(i+ip)+1.0
      enddo
      return
      end
*sbr commie3
c
c *** adds autoregressive red noise into a white noise series
c
c     x      --  series of white noise residuals
c     wrk    --  work array, dimension must be .ge. n + ip
c     n      --  length of time series x
c     cof    --  array of autoregressive coefficients
c     ip     --  order of autoregressive model
c
c     calls bckcst
c
      subroutine commie3(x,ns,wrk,n,cof,ip,mxy)
      real*4 x(mxy),wrk(mxy),cof(12)
      integer ns(n)
      sm=0.0
      n1=0
      do i=1,n
        if(ns(i).gt.5)then
          n1=n1+1
          sm=sm+x(i)
        endif
      enddo
      xm=sm/float(n1)
      do i=1,n
        if(ns(i).gt.5)then
          wrk(i)=x(i)-xm
        else
          wrk(i)=0.0
        endif
      enddo
      call bckcst(wrk,n,ip,cof,ip,mxy)
      do i=1,n
        if(ns(i).gt.5)then
          do j=1,ip
            wrk(i+ip)=wrk(i+ip)+wrk(i+ip-j)*cof(j)
          enddo
          x(i)=wrk(i+ip)+xm
        else
          x(i)=0.0
        endif
      enddo
      return
      end
*sbr bckcst
c
c *** backcasts autoregressive time series
c
c     x      --  series of white noise residuals
c                dimension must be .ge. n + nbc
c     n      --  length of time series x
c     ip     --  order of autoregressive model
c     phi    --  array of autoregressive coefficients
c     nbc    --  number of backcasts
c
      subroutine bckcst(x,n,ip,phi,nbc,mxy)
      real*4 x(mxy),phi(12)
      if(ip.eq.0)return
      if(n+nbc.gt.mxy)then
        write(*,'(/1x,''*** no room in array for backcasts ***'')')
        pause
        stop
      endif
      do i=1,n
        j=n-i+1
        x(j+nbc)=x(j)
      enddo
      do i=1,nbc
        ii=nbc-i+1
        x(ii)=0.0
        do j=1,ip
          x(ii)=x(ii)+x(ii+j)*phi(j)
        enddo
      enddo
      return
      end
*sbr nowacki
*
      subroutine nowacki(data,id,ify,ny,nw,npg,nse,bif,xms,see,pgc,mxy,iplt)
	integer*4 ify
      real*4 data(mxy),xms(mxy),see(mxy),pgc(mxy)
      character id*8,tit1*30,bif
c
c *** common block variables
c
      integer jems(30,5),ndd                    
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
      jopt=jems(20,1)
      rnw=nw
      ncnt=0
c
      if(bif.eq.'y'.or.bif.eq.'Y')then
        do i=2,ny-1
          xms(i-1)=0.25*data(i-1)+0.50*data(i)+0.25*data(i+1)
        enddo
        ny=ny-2
        ify=ify+1
        do i=1,ny
          data(i)=xms(i)
        enddo
      endif
c
      do i=1,ny-nw+1
        j1=i
        j2=j1+nw-1
        sm=0.0
        do k=j1,j2
          sm=sm+data(k)
        enddo
        xm=sm/rnw
        sq=0.0
		      do k=j1,j2
		        sq=sq+(data(k)-xm)**2
		      enddo
        ncnt=ncnt+1
        xms(ncnt)=xm
		      sig=sqrt(sq/(rnw-1.0))
		      see(ncnt)=sig/sqrt(rnw)
      enddo
      do i=1,ncnt-nw
        j=i+nw
ccc        pgc(i)=(xms(j)-xms(i))/((xms(i)+xms(j))/2.0)
        pgc(i)=(xms(j)-xms(i))/xms(i)
      enddo
      call blank(tit1)
ccc      write(tit1,'(i4)')nw
      tit1(1:27)=' running mean growth series'
c      write(*,'(1x,''Before crnplt11 ify= '',i4)')ify
c	pause 'ars'
      if(iplt.gt.0)then
c      pause'crnplt11'
        call crnplt11(data,xms(1),see(1),xms(nw+1),see(nw+1),pgc,ify,ny,ncnt-nw,
     *    nw,npg,nse,id,tit1,' % growth change (blue) and raw data (red)',
     *    'years','running growth','years','relative growth',iplt,mxy,jopt,bif)
      endif
      return
      end
*sbr findrl
*
      subroutine findrl(x1,x2,x3,x4,pgc,mcnt,ify,mw,mpg,mse,iopt,iyor,nrl,mxr)
      real*4 x1(mxr),x2(mxr),x3(mxr),x4(mxr),pgc(mxr)
      character iyor(100)*4
      nrl=0
      rpg=float(mpg)/100.0
ccc      write(*,*)mw,mpg,mse,rpg
ccc      pause
c
c *** look for maximum percent growth change (pgc(i)) above threshold mpg
c 
      do i=3,mcnt-2
        if(iopt.eq.2)then
ccc          if(pgc(i).gt.rpg.and.(pgc(i).gt.pgc(i-1).and.
ccc     *      pgc(i).ge.pgc(i+1)))then
          if(pgc(i).gt.rpg.and.(pgc(i-1).gt.pgc(i-2).and.pgc(i).gt.pgc(i-1).and.
     *      pgc(i).ge.pgc(i+1)))then
            if(nrl.eq.0)then
              nrl=nrl+1
              ify1=ify+i-1
              call blank(iyor(nrl))
              write(iyor(nrl),'(i4)')ify1
            elseif(nrl.gt.0)then
              ify2=ify+i-1
              ndif=ify2-ify1
              if(ndif.gt.mw)then
                nrl=nrl+1
                ify1=ify+i-1
                call blank(iyor(nrl))
                write(iyor(nrl),'(i4)')ify1
              endif
            endif
          endif
        elseif(iopt.eq.3)then
          y1=x1(i)+mse*x2(i)
          y2=x3(i)-mse*x4(i)
          if(y2.gt.y1)then
ccc            if((pgc(i).gt.rpg).and.(pgc(i).gt.pgc(i-1).and.
ccc     *        pgc(i).ge.pgc(i+1)))then
            if((pgc(i).gt.rpg).and.(pgc(i-1).gt.pgc(i-2).and.pgc(i).gt.pgc(i-1).and.
     *        pgc(i).ge.pgc(i+1)))then
              if(nrl.eq.0)then
                nrl=nrl+1
                ify1=ify+i-1
                call blank(iyor(nrl))
                write(iyor(nrl),'(i4)')ify1
              elseif(nrl.gt.0)then
                ify2=ify+i-1
                ndif=ify2-ify1
                if(ndif.gt.mw)then
                  nrl=nrl+1
                  ify1=ify+i-1
                  call blank(iyor(nrl))
                  write(iyor(nrl),'(i4)')ify1
                endif
              endif
            endif
          endif
        endif
      enddo
      return
      end
      subroutine gamoeba(pam,yam,v,ndmaxp1,ndmax,nd,iter,
     *                   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
      parameter (i1=1,i2=2,i3=3,i4=4,i5=5,i6=6)
      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,iter,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)
    9 do ie=i1,ne
	       time=float(ie)+t
	       yfit(ie)=a*exp(b*alog(time)+c*time)+rk
	     enddo
	     return
	     end
      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
      subroutine amoeba(p,y,mp,np,ndim,iter,ftol,iopt,
     *                 nemax,ne,x,ye)
      integer iter,mp,ndim,np,nmax,itmax
      real 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 rtol,sum,swap,ysave,ytry,psum(nmax)
      iter=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 (iter.ge.itmax) then
        pause 'itmax exceeded in amoeba'
        return
      endif
      iter=iter+2
c	  write(*,'(1x,''iter,y: '',i5,3e14.7)') iter,(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
          iter=iter+ndim
          goto 1
        endif
      else
        iter=iter-1
      endif
      goto 2
      end
      function ametry(p,y,psum,mp,np,ndim,ihi,fac,iopt,
     *                nemax,ne,xe,ye)
      integer ihi,mp,ndim,np,nmax
      real fac,p(mp,np),psum(np),y(mp)
	     real*4    xe(nemax),ye(nemax)
      parameter (nmax=5)
cu    uses gamoff
      integer j
      real 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
*sbr random
*
      real function random(l)
c
c	algorithm as 183  appl. statist. (1982) vol. 31, no. 2
c
c	returns a pseudo-random number uniformly distributed
c	between 0 and 1.
c
c	ix,iy, and iz should be set to integer values between
c	1 and 30000 before first entry.
c
c	the cycle length of this generator exceeds 6.95 * 10**12
c
c	integer arithmetic up to 30323 is required
c
c *************************************************************************
c
c	l	integer		input:  a dummy argument.  any value will do
c
c   rand	common		input:  on first call only.  the 3 initial
c				        seeds, all within the range 1-30,000
c
c *************************************************************************
c
      common /rand/ ix,iy,iz
c
c	the following 3 lines of code require integer arithmetic
c	up to 5 212 632
c
      ix = mod(171 * ix, 30269)
      iy = mod(172 * iy, 30307)
      iz = mod(170 * iz, 30323)	
c
c 	the following block of code is for machines with
c	integer arithmetic up to 30323 -- replace the preceeding
c	3 lines of code with it if necessary.
c
c	ix = 171 * mod(ix, 177) - 2 * (ix / 177)
c	iy = 172 * mod(iy, 176) - 35 * (iy / 176)
c	iz = 170 * mod(iz, 178) - 63 * (iz / 178)
c	
      if (ix .lt. 0) ix = ix + 30269
      if (iy .lt. 0) iy = iy + 30307
      if (iz .lt. 0) iz = iz + 30323
c
      random = amod(float(ix) / 30269.0 + float(iy) / 30307.0 +
     +              float(iz) / 30323.0, 1.0)
      return
      end
c------------------------------------------------------------------------------
        subroutine mccon(x,xout,infav,n,conf,xave,mcconf,nsims,msim,mxy)
c------------------------------------------------------------------------------
 
c--- this routine obtains the bootstrap confidence
c    intervals for an input parameter
c
c    conf = confidence limits (e.g. 95 or 99)
c*****************************************************************************
        parameter(mxr=1000) 
        real*4 x(mxy),xout(mxy),infav(mxy),mcconf(8),msim(1000),wgt(mxr)
        real*4 snum1,sden1,aave,temp
        logical lsb,lbb
c
c *** common block variables
c
      integer jems(30,5),ndd
      character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	common/icommands/jems,ndd            !new pjk
c
c--    calculate the acceleration constants for the data set
c      using the jacknife estimation of frangos and schucany
c      comp. stat. & data anal. 9 (1990) 271-281
c
        rn=n
        do i=1,n
          temp=x(i)                         ! store original value in temp
          x(i)=-32368.                      ! replace with dropped value 
          call update(n,x,m,xout)
          call biwgt(xout,wrk5,7.5,m,bimn,bisg,bise,eff,iter,wgt)
          xnave=bimn
          infav(i)=(rn-1.0)*(xave-xnave)
          x(i)=temp                         ! reset original data point
        enddo
ccc        write(*,'(1x,''mccon1'')')
        snum1=0.0
        sden1=0.0
        do i=1,n
          snum1= snum1 + infav(i)**3
          sden1= sden1 + infav(i)**2
        enddo
        aave=snum1/(6.0*(sden1**1.5))
ccc        write(*,'(1x,''mccon2'')')
c--- obtain monte-carlo estimators of intervals
c--- get confidence interval of the mean from msim
        lsb=.true.
        sbound=0.0
        lbb=.true.
        bbound=0.0
        ifault = 0
ccc        write(*,'(1x,''mccon before monte'')')        
        call monte (xave,conf,nsims,aave,msim,lsb,sbound,lbb,bbound,
     *    mcconf(1),mcconf(2),mcconf(3),mcconf(4),mcconf(5),mcconf(6),
     *    mcconf(7),mcconf(8),ifault)
ccc        write(*,'(1x,''mccon after monte'')')        
        return
        end
c------------------------------------------------------------------------------
        subroutine monte(est,confi,nsims,acc,simval,lsb,
     +                   sbound,lbb,bbound,alow,ahi,blow,bhi,
     +                   clow,chi,dlow,dhi,ifault)
c------------------------------------------------------------------------------
 
c
c--- algorithm as 214 appl. stat. (1985) vol. 34, no.3
c
c--- sets up monte carlo confidence intervals
c    uses function ppnd -  as 111
c    uses function alnorn -- as 66
c
c--- the user supplies the estimate est of a parameter, and monte
c    obtains the appropriate confidence intervals
c
c               alow: lower conf. limit, symmetric
c               ahi:  upper conf. limit, symmetric
c               blow: lower conf. limit, percentile
c               bhi:  upper conf. limit, percentile
c               clow: lower conf. limit, bias corrected
c               chi:  upper conf. limit, bias corrected
c               dlow: lower conf. limit, bias corrected accelerated
c               dhi:  upper conf. limit, bias corrected accelerated
c
c***************************************************************************
 
        logical lsb,lbb
        dimension simval(nsims)
        data least/5/
        data zero,half,one,two,hun,big
     +       /0.0e0,0.5e0,1.0e0,2.0e0,1.0e2,1.e20/
        ifault = 0
        sbnd = sbound
        bbnd = bbound
        if (confi .ge. hun) ifault = 6
        if (confi .le. zero) ifault = 7
        if (ifault .gt. 0) return
c
c--- symmetric mci
c
c--- find mean and variance
c
        v1 = zero
        v2 = zero
        do 10 j = 1,nsims
        fj = float(j)
        v2 = v2 + (fj - one)*(simval(j) - v1)**2/fj
        v1 = (simval(j) + (fj - one)*v1)/fj
 10     continue
 
        stderr = zero
        if (v2 .gt. zero) stderr = sqrt(v2/float(nsims - 1))
        alpha = half*(hun - confi)/hun
        z = -ppnd(alpha,ifault)
        if (ifault .eq. 0) goto 20
        ifault = 6
        return
 20     ahi = z*stderr
        alow = est - ahi
        ahi = est + ahi
c		write(*,'(10x,3f8.4)')est,alow,ahi
c
c--- calculate bias adjustment, so that the number
c    of values that must be ordered is known
c
        call biasad(est,nsims,acc,simval,z,limit1,limit2,
     +              limita1,limita2,ifault)
 
        limitl = alpha*float(nsims + 1) + half
        limitu = (one - alpha)*float(nsims + 1) + half
        if (limitl .lt. least) ifault = 5
        if (limitl .eq. limitu) ifault = 7
        if (ifault .gt. 0) return
        l1 = max0(limit1, 2*limitl)
        l2 = min0(limit2, 2*limitu - nsims - 1)
        if (lsb) sbnd = -big
        if (lbb) bbnd = big
c
c--- select and order the l1 smallest and the nsims+1-l2 largest
c    values
c
 
        call sort(nsims,simval)
        if (sbnd .le. simval(1)) goto 40
        if (lsb) goto 30
        ifault = 1
        return
 30     sbnd = simval(1)*two
        if (sbnd .gt. zero) sbnd = -sbnd
 40     if (bbnd .ge. simval(nsims)) goto 60
        if (lbb) goto 50
        ifault = 2
        return
 50     bbnd = simval(nsims)*two
        if (bbnd .lt. zero) bbnd = -bbnd
c
c--- equal tails mci (percentile method)
c
 60     if (limitl .gt. 0) blow = simval(limitl)
        if (limitl .le. 0) blow = simval(1)
        if (limitu .le. nsims) bhi = simval(limitu)
        if (limitu .gt. nsims) bhi = simval(nsims)
c		write(*,'(2i5,3f8.4)')limitl,limitu,est,blow,bhi
c
c--- bias-corrected percentile method
c
        clow = sbnd
        if (limit1 .gt. 0) clow = simval(limit1)
        if (limit1.le.0) clow = simval(1)
        chi = bbnd
        if (limit2 .le. nsims) chi = simval(limit2)
        if (limit2.gt.nsims) chi = simval(nsims)
c		write(*,'(2i5,3f8.4)')limit1,limit2,est,clow,chi 
c--  accelerated bias corrected
 
        dlow = sbnd
        if (limita1 .gt. 0) dlow = simval(limita1)
        if (limita1.le.0.or.limita1.gt.nsims) dlow = simval(1)
        dhi = bbnd
        if (limita2 .le. nsims) dhi = simval(limita2)
        if (limita2.le.0.or.limita2.gt.nsims) dhi = simval(nsims)
c		write(*,'(3i6,3f10.4)')nsims,limita1,limita2,est,dlow,dhi
c		pause'in monte'
        return
        end
c-----------------------------------------------------------------------------
        subroutine update (n,xdata,m,xout)
c-----------------------------------------------------------------------------
 
        real*4 xdata(n),xout(n)
 
c--- only copy data from xdata to xout if it is not = -32368
 
        j=0
        miss=0
 
        do 10 i=1,n
          if (xdata(i).ne.-32368.) then
            j=j+1
            xout(j)=xdata(i)
          else
            miss = miss + 1
          endif
10      continue
 
        m = j
 
        return
        end
c------------------------------------------------------------------------------
        subroutine biasad (est,nsims,acc,simval,z,limit1,limit2,
     +                     limita1,limita2,ifault)
c------------------------------------------------------------------------------
 
c--- finds adjustment required to implement bias-corrected percentile method
c
c    uses functions alnorm and ppnd algorithms as 66 and as 111
c
        dimension simval(nsims)
        data half,two/0.5e0,2.0e0/
        j = 0
        k = 0
c
c--- m = (number of values less than est) + (half the
c         number equal to est), rounded up if not integral
c
        do 30 m = 1,nsims
        if (simval(m) - est) 10,20,30
 10     j = j+1
 20     k = k+1
 30     continue
        m = (j + k + 1)/2
        if (m .eq. 0) ifault = 3
        if (m .eq. nsims) ifault = 4
        if (ifault .gt. 0) return
        zed = two*ppnd(float(m)/float(nsims),ifault)
c
c--- ifail cannot exceed 0 simce m .ge. 1 and m .le. nsims - 1
c
        fn1 = float(nsims + 1)
        limit1 = fn1*alnorm(zed - z,.false.) + half
        limit2 = fn1*alnorm(zed + z,.false.) + half
 
c
c--   calculate limits from the acceleration constant
c
        xzed1 = zed/two + ((zed/two - z)/(1-acc*(zed/two-z)))
        xzed2 = zed/two + ((zed/two + z)/(1-acc*(zed/two+z)))
        limita1 = fn1*alnorm(xzed1,.false.) + half
        limita2 = fn1*alnorm(xzed2,.false.) + half
 
        return
        end
c-----------------------------------------------------------------------------
        real function ppnd(p,ifault)
c-----------------------------------------------------------------------------
 
c--- algorithm as 111  appl. stat. (1977), vol. 26, no.1
c
c--- produces normal deviate corresponding to lower tail area of p
c    real version for eps = 2**(-31)
c    the hash sums are the sums of the moduli of the coefficients
c    they have no inherent meanings but are included for use in
c    checking transcriptions.
c    standard functions  abs,alog and sqrt are used.
c
        real*4 zero,split,half,one
        real*4 a0,a1,a2,a3,b1,b2,b3,b4,c0,c1,c2,c3,d1,d2
        real*4 p,q,r
        data zero/0.0e0/,half/.5e0/,one/1.0e0/
        data split /.42e0/
        data a0/   2.50662823884e0/
        data a1/ -18.61500062529e0/
        data a2/  41.39119773534e0/
        data a3/ -25.44106049637e0/
        data b1/  -8.47351093090e0/
        data b2/  23.08336743743e0/
        data b3/ -21.06224101826e0/
        data b4/   3.13082909833e0/
c
c--- hash sum ab 143.70383558076
c
        data c0/   -2.78718931138e0/
        data c1/   -2.29796479134e0/
        data c2/    4.85914127135e0/
        data c3/    2.32121276858e0/
        data d1/    3.54388924762e0/
        data d2/    1.63706781897e0/
c
c--- hash sum cd 17.43746520924
c
        ifault = 0
        q = p - half
        if (abs(q) .gt. split) goto 1
        r = q*q
        ppnd = q*(((a3*r + a2)*r + a1)*r + a0)/
     +         ((((b4*r + b3)*r + b2)*r + b1)*r + one)
        return
 1      r = p
        if (q .gt. zero) r = one - p
        if (r .le. zero) goto 2
        r = sqrt(-alog(r))
        ppnd = (((c3*r + c2)*r + c1)*r + c0)/
     +         ((d2*r + d1)*r + one)
        if (q .lt. zero) ppnd = -ppnd
        return
 2      ifault = 1
        ppnd = zero
        return
        end
c-----------------------------------------------------------------------------
        function alnorm(x,upper)
c-----------------------------------------------------------------------------
 
c--- algorithm as 66  appl. stat. (1973) vol. 22, no.3
c
c--- evaluates the tail area of the standardised normal curve
c    from x to infinity if upper is .true. or from minus
c    infinity to x if upper is .false.
c
        real*4 ltone,utzero,zero,half,one,con,z,y,x
        logical upper,up
c
c--- ltone and utzero must be set to suit the particular
c    computer (see introductory text)
c
        data ltone,utzero/7.0,18.66/
        data zero,half,one,con/0.0,.5,1.0,1.28/
        up = upper
        z = x
        if (z .ge. zero) goto 10
        up = .not.up
        z = -z
 10     if ((z .le. ltone) .or. (up .and. (z .le. utzero))) goto 20
        alnorm = zero
        goto 40
 20     y = half*z*z
        if (z .gt. con) goto 30
c
c
        alnorm = half - z*(.398942280444 - .399903438504*y/
     +           (y + 5.75885480458 - 29.8213557808 /
     +           (y + 2.62433121679 + 48.6959930692 /
     +           (y + 5.92885724438))))
        goto 40
c
c
 30     alnorm = .398942280385*exp(-y)/
     +           (z + 3.805e-8 + 1.00000615302/
     +           (z + 3.98064794e-4 + 1.98615381364/
     +           (z - .151679116635 + 5.29330324926/
     +           (z + 4.8385912808 - 15.1508972451/
     +           (z + .742380924027 + 30.789933034/
     +           (z + 3.99019417011))))))
c
c
 40     if (.not.up) alnorm = one - alnorm
        return
        end
      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
      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
*********************************************************************************
*sbr pca
      subroutine pca(fs,a,b,c,ev,wk,fil1,id,ns,kdate,eig,ird,itp,mxs,mxr,mxc,iu11)
      parameter(mxr1=5000,mxc1=100)
      parameter(iu14=14)
      real*4 fs(mxr,mxc),fs1(mxr1,mxc1),eig(mxs,mxs),pct(4),ev(mxs),wk(mxs)
      real*4 a(mxs,mxs),b(mxs,mxs),c(mxs,mxs)
c
      integer tmxs,ytp          !new local variable 
      parameter (tmxs=3000)   !must equal mxs in main program 
      real*4 ty(tmxs,7)     !new temporary array to send to loads1 for plotting -pjk
c
      integer kdate(2)
      character tit*65,fil1*40,id(mxc)*8,fil2*52,fil3*53
cBegin subroutine
c
c	  write(*,'(/,''From Subroutine PCA. itp= '',i2)')itp
      ifc=kdate(1)
      ilc=kdate(2)
      nyc=ilc-ifc+1
      do i=1,nyc
        do j=1,ns
          fs1(i,j)=fs(i,j)
        enddo
      enddo
      ntest=nyc
      call blank(fil2)
      fil2(1:40)=fil1(1:40)
      call blank(fil3)
      fil3(1:40)=fil1(1:40)
      ll=len(fil1)
      jj=0
      do j=1,ll
        jj=ll-j+1
        if(fil1(jj:jj).ne.' ')goto 11
      enddo
   11 ll=jj
      npc=mxc
      if(ns.lt.npc)npc=ns
      rns=npc
c
c *** do the unrotated pca on the common period correlation matrix
c
      call htdql(ns,mxs,ev,wk,eig)
c
c *** reflect eigenvector loadins if needed
c
      call gmas(eig,ns,npc,mxs,wk)
c
c *** check for positive definitness and adjust eigenvalues if not
c
      nteig=npc
      npeig=min0(nteig,nyc-1)
      if(npeig.lt.nteig)then
        smev=0.0
        do j=1,npeig
          smev=smev+ev(j)
        enddo
        xmev=smev/float(npeig)
        rns=0.0
        do j=1,npeig
          rlam=ev(j)/xmev
          rlam=rlam*float(npeig)/float(nteig)
          ev(j)=rlam
          rns=rns+ev(j)
        enddo
        npc=npeig
        rns=npc
        if(npc.gt.mxc)npc=mxc
      endif
      smev=0.0
      do j=1,npc
        smev=smev+ev(j)
      enddo
c
c *** determine number of eigenvalues >1.0
c
      neig=0
      do j=1,npc
        if(ev(j).ge.1.0)neig=neig+1
        wk(j)=ev(j)/smev
      enddo
      if(neig.gt.mxc)neig=mxc
c
c *** print out eigenvector loadings out to order 10
c
      write(iu11,'(/t2,
     *  ''|----------- all series common period principal components analysis -----------|''/t2,
     *  ''|--------- refer to saved output files for complete tabulated results ---------|''//t14,
     *  ''ev #1  ev #2  ev #3  ev #4  ev #5  ev #6  ev #7  '',
     *  ''ev #8  ev #9  ev#10'')')
      write(iu11,'(t2,
     *  ''eigenvalue:'',f6.3,9f7.3)')(ev(j),j=1,10)
      write(iu11,'(t2,
     *  ''% variance:'',f6.3,9f7.3)')(wk(j),j=1,10)
      cum=0.0
      do j=1,npc
        cum=cum+wk(j)
        wk(j)=cum
      enddo
      write(iu11,'(t2,''cumulative:'',f6.3,9f7.3)')(wk(j),j=1,10)
      write(iu11,'(/13x,''|---------------------- eigenvector loadings '',
     *                  ''----------------------|'')')
      write(iu11,'(t2,
     *  ''series id   eg_#1  eg_#2  eg_#3  eg_#4  eg_#5  '',
     *  ''eg_#6  eg_#7  eg_#8  eg_#9  eg#10'')')
      do i=1,ns
        write(iu11,'(t3,a8,1x,10f7.3)')id(i),(eig(i,j),j=1,10)
      enddo
c
c *** save the pc loadings
c
      if(itp.eq.1)then
        fil2(ll+1:ll+13)='_pcloads_raw'
      elseif(itp.eq.2)then
        fil2(ll+1:ll+13)='_pcloads_trn'
      elseif(itp.eq.3)then
        fil2(ll+1:ll+13)='_pcloads_det'
      elseif(itp.eq.4)then
        fil2(ll+1:ll+13)='_pcloads_res'
      endif      
      open(iu14,file=fil2,status='unknown')
      close(iu14,status='delete')
      open(iu14,file=fil2,status='unknown')
      write(iu14,'(t2,
     *  ''eigenvalue'',f7.3,(999f8.3))')(ev(j),j=1,npc)
      do j=1,npc
        wk(j)=ev(j)/smev
      enddo
      write(iu14,'(t2,
     *  ''% variance'',f7.3,(999f8.3))')(wk(j),j=1,npc)
      cum=0.0
      do j=1,npc
        cum=cum+wk(j)
        wk(j)=cum
      enddo
      write(iu14,'(t2,
     *  ''cumulative'',f7.3,(999f8.3))')(wk(j),j=1,npc)
      write(iu14,'('' series_id   #'',i3,999(5x,i3))')(j,j=1,npc)
      do i=1,ns
        write(iu14,'(2x,a8,1000f8.3)')id(i),(eig(i,j),j=1,npc)
      enddo
      close(iu14)
c
c plotting of eigenvector loadings if ird=3
c
      if(ird.eq.2.or.ird.eq.3)then
        np=4
        do j=1,np
          pct(j)=ev(j)/rns*100.0
c          write(*,'(1x,''ev= '',f8.3)')ev(j)
        enddo
        call blank(tit)
        if(itp.eq.1)then
          tit(1:52)=' raw measurements common period principal components'
        elseif(itp.eq.2)then
          tit(1:52)=' transformed data common period principal components'
        elseif(itp.eq.3)then
          tit(1:52)=' detrended indices common period principal components'
        elseif(itp.eq.4)then
          tit(1:52)=' residual indices common period principal components'
        endif
        do i=1,ns
          do j=1,7
            ty(i,j)=eig(i,j)
          enddo
        enddo
        ytp=1   !-pjk
c        write(*,'(1x,''Before first call to loads1 itp= '',i2)')itp  !pjk
c        write(*,'(1x,4(1x,''pct('',i1,'')='',f8.4))')(i,pct(i),i=1,4)
c        call loads1(eig,ns,np,fil1,tit,pixels,ird,mxc,itp,pct)
        call loads1(ty,ns,np,fil1,tit,ird,tmxs,itp,pct,ytp) ! -pjk
      endif
c
c *** compute the pc scores
c
      do i=1,nyc
        do j=1,npc
          sum=0.0
          do k=1,ns
            sum=sum+fs(i,k)*eig(k,j)
          enddo
          wk(j)=sum
        enddo
        do j=1,npc
          fs(i,j)=wk(j)
        enddo
      enddo
c
c *** save the pc scores
c
      if(itp.eq.1)then
        fil2(ll+1:ll+13)='_pcscores_raw'
      elseif(itp.eq.2)then
        fil2(ll+1:ll+13)='_pcscores_trn'
      elseif(itp.eq.3)then
        fil2(ll+1:ll+13)='_pcscores_det'
      elseif(itp.eq.4)then
        fil2(ll+1:ll+13)='_pcscores_res'
      endif
      open(iu14,file=fil2,status='unknown')
      close(iu14,status='delete')
      open(iu14,file=fil2,status='unknown')
      write(iu14,'(''  year  #'',i4,999(5x,i3))')(j,j=1,npc)
      do i=1,nyc
        write(iu14,'(i6,1000f8.3)')ifc+i-1,(fs(i,j),j=1,npc)
      enddo
      close(iu14)
c
c *** normalize the pc scores for easy plotting
c
      do i=1,nyc
        do j=1,npc
          fs(i,j)=fs(i,j)/sqrt(ev(j))
        enddo
      enddo
c
c plotting of eigenvector scores if ird=3
c
      if(ird.eq.3)then     
        call blank(tit)
        if(itp.eq.1)then
          tit(1:40)='raw measurements common period pc scores'
        elseif(itp.eq.2)then
          tit(1:40)='transformed data common period pc scores'
        elseif(itp.eq.3)then
          tit(1:41)='detrended indices common period pc scores'
        elseif(itp.eq.4)then
          tit(1:40)='residual indices common period pc scores'
        endif
        ytp=1
c        write(*,'(1x,''Before first call to scores1 itp= '',i2)')itp  !pjk
c        write(*,'(1x,4(1x,''pct('',i1,'')='',f8.4))')(i,pct(i),i=1,4)
        call scores1(fs(1,1),kdate,np,fil1,tit,ird,mxr,4,pct,itp,ytp) 
      endif   
c
      if(neig.lt.2)then
        write(iu11,'(/t16,''only 1 eigenvalue >1, no varimax '',
     *    ''rotation performed'')')
        return
      endif
c
c *** do the varimax rotation now
c
      write(iu11,'(/t2,
     *  ''|--------- all series common period varimax factor rotation - ev>1.0) ---------|''/t2,
     *  ''|--------- refer to saved output files for complete tabulated results ---------|'')')
      do j=1,neig
        do i=1,ns
          eig(i,j)=eig(i,j)*sqrt(ev(j))
        enddo
      enddo
      call varimax(eig,ns,neig,a,b,ev,wk,mxs)
      call gmas(a,ns,neig,mxs,wk)
c
c *** print out varimax loadings out to order neig
c
      write(iu11,'(/t14,
     *  ''vf #1  vf #2  vf #3  vf #4  vf #5  vf #6  vf #7  '',
     *  ''vf #8  vf #9  vf#10'')')
      write(iu11,'(t2,''% variance:'',f6.3,9f7.3)')(ev(j),j=1,neig)
      cum=0.0
      do j=1,neig
        cum=cum+ev(j)
        wk(j)=cum
      enddo
      write(iu11,'(t2,
     *  ''cumulative:'',f6.3,9f7.3)')(wk(j),j=1,neig)
      write(iu11,'(/13x,''|--------------------- varimax factor loadings '',
     *                  ''--------------------|'')')
      do i=1,ns
        if(i.eq.1.or.mod(i,20).eq.0)then
          write(iu11,'(t2,
     *      ''series id   vl_#1  vl_#2  vl_#3  vl_#4  vl_#5  '',
     *      ''vl_#6  vl_#7  vl_#8  vl_#9  vl#10'')')
        endif
        write(iu11,'(t3,a8,1x,10f7.3)')id(i),(a(i,j),j=1,neig)
      enddo
c
c *** save the varimax loadings
c
      if(itp.eq.1)then
        fil3(ll+1:ll+13)='_vfloads_raw'
      elseif(itp.eq.2)then
        fil3(ll+1:ll+13)='_vfloads_trn'
      elseif(itp.eq.3)then
        fil3(ll+1:ll+13)='_vfloads_det'
      elseif(itp.eq.4)then
        fil3(ll+1:ll+13)='_vfloads_res'
      endif      
      open(iu14,file=fil3,status='unknown')
      close(iu14,status='delete')
      open(iu14,file=fil3,status='unknown')
      write(iu14,'(t2,
     *  ''% variance'',f7.3,(999f8.3))')(ev(j),j=1,neig)
      write(iu14,'(t2,
     *  ''cumulative'',f7.3,(999f8.3))')(wk(j),j=1,neig)
      write(iu14,'('' series_id   #'',i3,999(5x,i3))')(j,j=1,neig)
      do i=1,ns
        write(iu14,'(2x,a8,1000f8.3)')id(i),(a(i,j),j=1,neig)
      enddo
      close(iu14)
c
c plotting of varimax loadings if ird=3
c
      if(ird.eq.2.or.ird.eq.3)then
        do i=1,np
          pct(i)=ev(i)*100.0
        enddo
        call blank(tit)
        if(itp.eq.1)then
          tit(1:47)=' raw measurements common period varimax factors'
        elseif(itp.eq.2)then
          tit(1:47)=' transformed data common period varimax factors'
        elseif(itp.eq.3)then
          tit(1:47)=' detrended indices common period varimax factors'
        elseif(itp.eq.4)then
          tit(1:47)=' residual indices common period varimax factors'
        endif
        do i=1,ns
          do j=1,7
            ty(i,j)=a(i,j)
          enddo
        enddo
        ytp=2
c        write(*,'(1x,''Before second call to loads1 itp= '',i2)')itp  !pjk
c        write(*,'(1x,4(1x,''pct('',i1,'')='',f5.1))')(i,pct(i),i=1,4)
        call loads1(ty,ns,np,fil1,tit,ird,tmxs,2,pct,ytp) !new -pjk
c        call loads1(a,ns,np,fil1,tit,ird,mxc,2,pct) !old -erc
      endif
c
c *** compute the varimax scores
c
      do i=1,neig
        do j=1,neig
          c(i,j)=0.0
          do k=1,ns
            c(i,j)=c(i,j)+a(k,i)*a(k,j)
          enddo
        enddo
      enddo
      ier=0
      call crout(c,neig,det,mxs,ier)
      if(ier.gt.0)return
      do i=1,ns
        do j=1,neig
          b(i,j)=0.0
          do k=1,neig
            b(i,j)=b(i,j)+a(i,k)*c(k,j)
          enddo
        enddo
      enddo
      do i=1,nyc
        do j=1,npc
          sum=0.0
          do k=1,ns
            sum=sum+fs1(i,k)*b(k,j)
          enddo
          wk(j)=sum
        enddo
        do j=1,npc
          fs(i,j)=wk(j)
        enddo
      enddo
c
c *** save the varimax scores
c
      if(itp.eq.1)then
        fil3(ll+1:ll+13)='_vfscores_raw'
      elseif(itp.eq.2)then
        fil3(ll+1:ll+13)='_vfscores_trn'
      elseif(itp.eq.3)then
        fil3(ll+1:ll+13)='_vfscores_det'
      elseif(itp.eq.4)then
        fil3(ll+1:ll+13)='_vfscores_res'
      endif
      open(iu14,file=fil3,status='unknown')
      close(iu14,status='delete')
      open(iu14,file=fil3,status='unknown')
      write(iu14,'(''  year  #'',i4,999(5x,i3))')(j,j=1,neig)
      do i=1,nyc
        write(iu14,'(i6,1000f8.3)')ifc+i-1,(fs(i,j),j=1,neig)
      enddo
      close(iu14)
c
c plotting of varimax scores if ird=3
c
      if(ird.eq.3)then
        call blank(tit)
        if(itp.eq.1)then
          tit(1:45)='raw measurements common period varimax scores'
        elseif(itp.eq.2)then
          tit(1:45)='transformed data common period varimax scores'
        elseif(itp.eq.3)then
          tit(1:46)='detrended indices common period varimax scores'
        elseif(itp.eq.4)then
          tit(1:45)='residual indices common period varimax scores'
        endif
        ytp=2
c        write(*,'(1x,''Before second call to scores1 itp= '',i2)')itp  !pjk
c        write(*,'(1x,4(1x,''pct('',i1,'')='',f5.1))')(i,pct(i),i=1,4)
        call scores1(fs(1,1),kdate,neig,fil1,tit,ird,mxr,4,pct,itp,ytp)
      endif
      return
      end
*sbr htdql: compute eigenvalues and eigenvectors a#
*
**************************************************************
* routine htdql is based on algol procedures
* 'tred2' by martin, reinsch and wilkinson (1971), and
* 'tql2' by bowdler, martin, reinsch and wilkinson (1971).
*
* arguments:
*
* n:    order of symmetric matrix
* nn:   dimension for two-dimensional eigenvector array
* d:    array of length n, contains eigenvalues
*         in descending order on exit.
* e:    array of length n, used as work space.
* z:    array of length nn,nn; contains column normalized
*         eigenvectors on exit.
*
* latest modification  rlh  7 sep 1984
**************************************************************
*
      subroutine htdql(n,nn,d,e,z)
      real d(1),e(1),z(nn,nn)
*
* compute ch, smallest number where 1.+ch > 1. in computer storage;
* and tl, the smallest positive number possible in computer
* storage divided by ch.  exponent in next two lines will depend on
* storage in your particular computer.
      ch=2.**(-24)
      tl=2.**(-124)/ch
      i=n+1
      do 12 ij=2,n
      i=i-1
      l=i-2
      f=z(i,i-1)
      g=0.
      if(l .eq. 0)goto 3
      do 2 k=1,l
    2 g=g+z(i,k)*z(i,k)
    3 h=g+f*f
      if(g .gt. tl)goto 4
      e(i)=f
      h=0.
      goto 11
    4 l=l+1
      g=sqrt(h)
      if(f .ge. 0.)g=-g
      e(i)=g
      h=h-f*g
      z(i,i-1)=f-g
      f=0.
      do 9 j=1,l
      z(j,i)=z(i,j)/h
      g=0.
      do 5 k=1,j
    5 g=g+z(j,k)*z(i,k)
      j1=j+1
      if(l .lt. j1)goto 8
      do 6 k=j1,l
    6 g=g+z(k,j)*z(i,k)
    8 e(j)=g/h
    9 f=f+g*z(j,i)
      hh=f/(h+h)
      do 10 j=1,l
      f=z(i,j)
      g=e(j)-hh*f
      e(j)=g
      do 10 k=1,j
   10 z(j,k)=z(j,k)-f*e(k)-g*z(i,k)
   11 d(i)=h
   12 continue
      d(1)=0.
      e(1)=0.
      do 16 i=1,n
      l=i-1
      if(l .eq. 0 .or. d(i) .eq. 0.)goto 14
      do 13 j=1,l
      g=0.
      do 123 k=1,l
  123 g=g+z(i,k)*z(k,j)
      do 13 k=1,l
   13 z(k,j)=z(k,j)-g*z(k,i)
   14 d(i)=z(i,i)
      z(i,i)=1.
      if(l .eq. 0)goto 16
      do 15 j=1,l
      z(i,j)=0.
   15 z(j,i)=0.
   16 continue
      do 17 i=2,n
   17 e(i-1)=e(i)
      e(n)=0.
      b=0.
      f=0.
      do 27 l=1,n
      j=0
      h=ch*(abs(d(l))+abs(e(l)))
      if(b .lt. h)b=h
      do 18 m=l,n
      if(abs(e(m)) .le. b)goto 19
   18 continue
   19 if(m .eq. l)goto 27
   20 if(j .eq. 30)goto 31
      j=j+1
      g=d(l)
      p=(d(l+1)-g)/(2.*e(l))
      r=sqrt(p*p+1.)
      rr=p+r
      if(p .lt. 0.)rr=p-r
      d(l)=e(l)/rr
      h=g-d(l)
      l1=l+1
      do 21 i=l1,n
      if(l .eq. n)goto 22
   21 d(i)=d(i)-h
   22 f=f+h
      p=d(m)
      c=1.
      s=0.
      i=m
      ll=m-1
      if(ll .lt. l)goto 26
      do 25 li=l,ll
      i=i-1
      g=c*e(i)
      h=c*p
      if(abs(p) .lt. abs(e(i)))goto 23
      c=e(i)/p
      r=sqrt(c*c+1.)
      e(i+1)=s*p*r
      s=c/r
      c=1./r
      goto 24
   23 c=p/e(i)
      r=sqrt(c*c+1.)
      e(i+1)=s*e(i)*r
      s=1./r
      c=c/r
   24 p=c*d(i)-s*g
      d(i+1)=h+s*(c*g+s*d(i))
      do 25 k=1,n
      h=z(k,i+1)
      z(k,i+1)=s*z(k,i)+c*h
   25 z(k,i)=c*z(k,i)-s*h
   26 e(l)=s*p
      d(l)=c*p
      if(abs(e(l)) .gt. b)goto 20
   27 d(l)=d(l)+f
      l1=n-1
      do 30 i=1,l1
      k=i
      p=d(i)
      j1=i+1
      do 28 j=j1,n
      if(p .gt. d(j))goto 28
      p=d(j)
      k=j
   28 continue
      if(k .eq. i)goto 30
      d(k)=d(i)
      d(i)=p
      do 29 j=1,n
      p=z(j,i)
      z(j,i)=z(j,k)
   29 z(j,k)=p
   30 continue
      return
   31 write(6,'(''0>>sbr htdql: eigenvector computation terminated'',
     &'' after 30 iterations'')')
      n=0
      return
      end
*sbr varimax -- imsl subroutine ofrota modified for varimax rotation only
*
c     subroutine argument list
c
c     a(nv,nf) -- unrotated principal component factor loadings (input)
c     nv       -- number of variables (input)
c     nf       -- number of retained factors (input)
c     b(nv,nf) -- orthogonally rotated varimax factor loadings (output)
c     t(nf,nf) -- transformation matrix (mainly for work in this case)
c     f(nf)    -- variance accounted for by each rotated factor (output)
c     wk(nv)   -- work array
c     mxc      -- maximum column dimension from calling program
c
      subroutine varimax(a,nv,nf,b,t,f,wk,mxc)
      parameter(maxit=30,eps=.0001,delta=.001,w=1.0)
      real*4 a(mxc,nf),b(mxc,nf),t(mxc,nf),wk(1),f(1)
      real*8 temp,ss,dd,save,dnv
      data zero,one,two,fourth/0.0e0,1.0e0,2.0e0,0.25e0/
      ier = 0
      dnv = nv*nv
      nff = ((nf-1)*nf)/2
      eps4 = eps*fourth
      wsnv = w/nv
      do 15 i=1,nf
         do 10 j=1,nf
            t(i,j) = zero
   10    continue
         t(i,i) = one
   15 continue
*                                  row normalization performed
      do 30 i=1,nv
         temp = 0.0d0
         do 20 j=1,nf
            temp = temp+dble(a(i,j))**2
   20    continue
         hold = dsqrt(temp)
         wk(i) = hold
         hold = one/hold
         do 25 j=1,nf
            b(i,j) = a(i,j)*hold
   25    continue
   30 continue
      mv = 1
      nc = 0
      ncount = 0
      vvv = zero
*                                  begin orthomax iteration
   55 mv = mv+1
      vv = vvv
*                                  calculate rotation criterion
      temp = 0.0d0
      do 65 j=1,nf
         ss = 0.0d0
         dd = 0.0d0
         do 60 i=1,nv
            save = dble(b(i,j))**2
            dd = dd+save
            ss = ss+save*save
   60    continue
         temp = temp+((nv*ss)-(w*dd*dd))/dnv
   65 continue
      vvv = temp
      if (nf.le.1) go to 115
      if (mv.le.maxit) go to 70
      ier = 66
      go to 115
   70 tvv = vvv-vv
      if (tvv.gt.delta*vv) go to 75
      nc = nc+1
      if (nc.ge.2) go to 115
   75 nfm1 = nf-1
      do 110 j=1,nfm1
         jp1 = j+1
         do 105 k=jp1,nf
*                                  calculate ratio of kaiser tan(4*phi)
            as = zero
            bs = zero
            tt = zero
            bb = zero
            do 80 i=1,nv
               u = (b(i,j)+b(i,k))*(b(i,j)-b(i,k))
               v = two*b(i,j)*b(i,k)
               as = as+u
               bs = bs+v
               bb = bb+(u+v)*(u-v)
               tt = tt+u*v
   80       continue
            tt = tt+tt
            tt = tt-two*as*bs*wsnv
            bb = bb-(as+bs)*(as-bs)*wsnv
            if (abs(tt)+abs(bb).gt.eps) go to 90
   85       ncount = ncount+1
            if (ncount.lt.nff) go to 105
*                                  complete cycle without rotation
            go to 115
   90       phi = fourth*atan2(tt,bb)
*                                  is angle essentially zero
            if (abs(phi).lt.eps4) go to 85
            cosp = cos(phi)
            sinp = sin(phi)
            ncount = 0
*                                  rotate matrices by angle phi
            do 95 i=1,nv
               save = b(i,j)*cosp+b(i,k)*sinp
               b(i,k) = -b(i,j)*sinp+b(i,k)*cosp
               b(i,j) = save
   95       continue
            do 100 i=1,nf
               save = t(i,j)*cosp+t(i,k)*sinp
               t(i,k) = -t(i,j)*sinp+t(i,k)*cosp
               t(i,j) = save
  100       continue
  105    continue
  110 continue
      go to 55
*                                  rescaling
  115 do 125 i=1,nv
         hold = wk(i)
         do 120 j=1,nf
            b(i,j) = b(i,j)*hold
  120    continue
  125 continue
*                                  variance accounted for by factors
      do 140 i=1,nf
         temp = 0.0d0
         do 135 k=1,nv
            temp = temp+dble(b(k,i))**2
  135    continue
         f(i) = temp/float(nv)
  140 continue
      if (ier.eq.0) go to 145
      write(*,'(/'' >> sbr varimax: error'',i6)')ier
      pause
      stop
  145 return
      end
*sbr gmas
*
      subroutine gmas(a,nv,nf,mxc,ittw)
      real*4 a(mxc,mxc)
      integer ittw(mxc)
      do 15 i=1,nf
        sq1=0.0
        sq2=0.0
        np=0
        nm=0
        ittw(i)=1
        do 5 j=1,nv
          if(a(j,i).ge.0.0)then
            np=np+1
            sq1=sq1+a(j,i)**2
          else
            nm=nm+1
            sq2=sq2+a(j,i)**2
          endif
    5   continue
        if(sq2.gt.sq1)then
          ittw(i)=-1
          do 10 j=1,nv
            a(j,i)=-a(j,i)
   10     continue
        endif
   15 continue
      return
      end
********************************************************************
*sbr crout
*
      subroutine crout(x,m,det,mx)
      implicit real*8 (a-h,o-z)
      parameter(nmax=500)
      real*4 x(mx,m),det
      real*8 a(nmax,nmax),y(nmax,nmax),indx(nmax),vv(nmax),ddet
      if(m.gt.nmax)then
        pause'*** matrix dimension too large for crout ***'
        ier=1
        return
      endif
      do i=1,m
        do j=1,m
          a(i,j)=dble(x(i,j))
          y(i,j)=0.d0
        enddo
        y(i,i)=1.d0
      enddo
      ddet=1.d0
      call ludcmp(a,m,nmax,indx,vv,ddet,ier)
      if(ier.eq.2)return
      do j=1,m
        ddet=ddet*a(j,j)
      enddo
      do j=1,m
        call lubksb(a,m,nmax,indx,y(1,j))
      enddo
      do i=1,m
        do j=1,m
          x(i,j)=sngl(y(i,j))
        enddo
      enddo
      det=sngl(ddet)
      return
      end
*sbr ludcmp
*
      subroutine ludcmp(a,n,nmax,indx,vv,d,ier)
      implicit real*8 (a-h,o-z)
      parameter(tiny=1.0d-20)
      dimension a(nmax,nmax),indx(nmax),vv(nmax)
      data zero,one/0.d0,1.d0/
      d=one
      do i=1,n
        aamax=zero
        do j=1,n
          if (dabs(a(i,j)).gt.aamax) aamax=dabs(a(i,j))
        enddo
        if (aamax.eq.zero)then
          pause '*** singular matrix in crout ***'
          ier=2
          return
        endif
        vv(i)=one/aamax
      enddo
      do j=1,n
        if (j.gt.1) then
          do i=1,j-1
            sum=a(i,j)
            if (i.gt.1)then
              do k=1,i-1
                sum=sum-a(i,k)*a(k,j)
              enddo
              a(i,j)=sum
            endif
          enddo
        endif
        aamax=zero
        do i=j,n
          sum=a(i,j)
          if (j.gt.1)then
            do k=1,j-1
              sum=sum-a(i,k)*a(k,j)
            enddo
            a(i,j)=sum
          endif
          dum=vv(i)*dabs(sum)
          if (dum.ge.aamax) then
            imax=i
            aamax=dum
          endif
        enddo
        if (j.ne.imax)then
          do k=1,n
            dum=a(imax,k)
            a(imax,k)=a(j,k)
            a(j,k)=dum
          enddo
          d=-d
          vv(imax)=vv(j)
        endif
        indx(j)=imax
        if(j.ne.n)then
          if(a(j,j).eq.zero)a(j,j)=tiny
          dum=one/a(j,j)
          do i=j+1,n
            a(i,j)=a(i,j)*dum
          enddo
        endif
      enddo
      if(a(n,n).eq.zero)a(n,n)=tiny
      return
      end
*sbr lubksb
*
      subroutine lubksb(a,n,nmax,indx,b)
      implicit real*8 (a-h,o-z)
      dimension a(nmax,nmax),indx(nmax),b(nmax)
      data zero/0.d0/
      ii=0
      do i=1,n
        ll=indx(i)
        sum=b(ll)
        b(ll)=b(i)
        if (ii.ne.0)then
          do j=ii,i-1
            sum=sum-a(i,j)*b(j)
          enddo
        else if (sum.ne.zero) then
          ii=i
        endif
        b(i)=sum
      enddo
      do i=n,1,-1
        sum=b(i)
        if(i.lt.n)then
          do j=i+1,n
            sum=sum-a(i,j)*b(j)
          enddo
        endif
        b(i)=sum/a(i,i)
      enddo
      return
      end
cSUBROUTNIE PLOTSTYLE *******************************************************************
	subroutine arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)             
c
c	sets up variables for passing to plplot routines that govern color and 
c	line style changes to plots and all sorts of bells and whistles -pjk
c
	integer*4 gopt,opt,mxvar
	integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
	integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
	real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      character*8 dev
      logical bg
c local
c	integer*4 winu2
c	parameter(winu2=92)
	integer*4 tmp
c
c Begin subroutine
	if((gopt.gt.1.and.gopt.le.5).or.(gopt.eq.21))then
c	  open(unit=*,file='PlotStyleWindow',access='window,290,522,26,388')
	  write(*,'(/13x,''color table ______________________________________________'')')
	  write(*,'(13x,''white(0) red(1)  yellow(2)  green(3)  aquamarine(4) pink(5) '')')
	  write(*,'(13x,''wheat(6)  grey(7)  browm(8)  blue(9)  blueviolet(10)'')')
	  write(*,'(13x,''cyan(11)  turquoise(12)  magenta(13)  salmon(14)  black(15)'')')
	  write(*,'(13x,''___________________________________________________________'',/)')
	else if(gopt.eq.1)then
c	  open(unit=*,file='plotstylewindow',access='window,290,522,26,388')
	  write(*,'(/13x,''color table (background only) ____________________________'')')
	  write(*,'(13x,''black(0) white(1)  user defined (2)'')')
	  write(*,'(13x,''___________________________________________________________'',/)')
	else if(gopt.ge.6.and.gopt.le.21)then
c	  open(unit=*,file='PlotStyleWindow',access='window,290,522,26,388')
	endif  
	select case (gopt)
	   case(1)
	      write(*,'(/13x,''select new background color [0/1/2] : '',$)')
	      read(*,*)tmp
	      if(tmp.eq.0)then
	        red=0
	        blue=0
	        green=0
	        bg=.true.
	      elseif(tmp.eq.1)then
	        red=255
	        green=255
	        blue=255
	        bg=.false.
	      elseif(tmp.eq.2)then
	        write(*,'(13x,''enter red value [0-255] > '',$)')
	        read(*,*)red
	        write(*,'(13x,''enter green value [0-255] > '',$)')
	        read(*,*)green
	        write(*,'(13x,''enter blue value [0-255] > '',$)')
	        read(*,*)blue
	        bg=.false.
	      endif
c	      close(winu2)
	      return
	   case(2)
	      write(*,'(13x,''select new frame color [0-15] : '',$)')
	      read(*,*)colbox
c	      close(winu2)
	      return
	   case(3)
	      write(*,'(/13x,''select new text color: [0-15] : '',$)')
	      read(*,*)coltext
c	      close(winu2)
	      return
	   case(4)
	      write(*,'(13x,''select new line color: [0-15] : '',$)')
	      read(*,'(i4)')colline(1)
c	      close(winu2)
	      return
	   case(5)
	      write(*,'(13x,''select new curve color: [0-15] : '',$)')
	      read(*,'(i4)')colline(2)
c	      close(winu2)
	      return
	   case(6)
	      write(*,'(/13x,''select new line style: [0-8] : '',$)')
	      read(*,'(i4)')pen(1)
c	      close(winu2)
	      return
	   case(7)
	      write(*,'(/13x,''select new curve width: [0-8]  : '',$)')
	      read(*,'(i4)')pen(2)
c	      close(winu2)
	      return
	   case(8)
	      write(*,'(/13x,''change x axis major tics from: '',f6.0)')mxxtic
	      write(*,'(13x,''to > '',$)')
	      read(*,*)mxxtic
c	      close(winu2)
	      return
	   case(9)
	      write(*,'(/13x,''change x axis minor tics from: '',i4)')mnxtic
	      write(*,'(13x,''to > '',$)')
	      read(*,*)mnxtic
c	      close(winu2)
	      return
	   case(10)
	      write(*,'(/13x,''change y axis major tics from: '',f6.0)')mxytic
	      write(*,'(13x,''to > '',$)')
	      read(*,*)mxytic
c	      close(winu2)
	      return
	   case(11)
	      write(*,'(/13x,''change y axis minor tics from: '',i4)')mnytic
	      write(*,'(13x,''to > '',$)')
	      read(*,'(i4)')mnytic
c	      close(winu2)
	      return
	   case(12)
	      write(*,'(/13x,''change z axis major tics from: '',f6.0)')mxztic
	      write(*,'(13x,''to > '',$)')
	      read(*,*)mxztic
c	      close(winu2)
	      return
	   case(13)
	      write(*,'(/13x,''change z axis minor tics from: '',i4)')mnztic
	      write(*,'(13x,''to > '',$)')
	      read(*,'(i4)')mnztic
c	      close(winu2)
	      return
	   case(14)
	      write(*,'(/13x,''change x axis max value from: '',f8.3)')xhigh
	      write(*,'(13x,''to > '',$)')
	      read(*,*)xhigh
c	      close(winu2)
	      return
	   case(15)
	      write(*,'(/13x,''change x axis min value from: '',f8.3)')xlow
	      write(*,'(13x,''to > '',$)')
	      read(*,*)xlow
c	      close(winu2)
	      return
	   case(16)
	      write(*,'(/13x,''change y axis max value from: '',f8.3)')yhigh
	      write(*,'(13x,''to > '',$)')
	      read(*,*)yhigh
c	      close(winu2)
	      return
	   case(17)
	      write(*,'(/13x,''change y axis min value from: '',f8.3)')ylow
	      write(*,'(13x,''to > '',$)')
	      read(*,*)ylow
c	      close(winu2)
	      return
	   case(18)
	      write(*,'(/13x,''change z axis max value from: '',f8.3)')zhigh
	      write(*,'(13x,''to > '',$)')
	      read(*,*)zhigh
c	      close(winu2)
	      return
	   case(19)
	      write(*,'(/13x,''change z axis min value from: '',f8.3)')zlow
	      write(*,'(13x,''to > '',$)')
	      read(*,*)zlow
c	      close(winu2)
	      return
	   case(20)
	      write(*,'(/13x,''change symbol [0-126, 32 = no symbol]: '',i4)')symbol(1)
	      write(*,'(13x,''to > '',$)')
	      read(*,*)symbol(1)
c	      close(winu2)
	      return
	   case(21)
	      write(*,'(/13x,''change symbol color from: '',i4)')colsym(1)
	      write(*,'(13x,''to > '',$)')
	      read(*,*)colsym(1)
c	      close(winu2)
	      return
	   case(99)     !reset all options
	      red=255
	      blue=255
	      green=255
	      coltext=15
	      colbox=15
	      pen(1)=1
	      pen(2)=2
	      colsym(1)=9
	      symbol(1)=20
	      colline(1)=15
	      colline(2)=1
	      colline(3)=9
	      dev='win3'
	      bg=.false.
	end select   
100	return
	end
*sbr crnplt1 
*sets up data and lables for plotting and provides for customizing plots by calls to arsplotstyle.
* erc/pjk 12/04
*
      subroutine crnplt1(y1,f1,g1,y2,f2,g2,ns,n,ify,nplot,fil,tit1,tit2,
     *  xlab1,ylab1,xlab2,ylab2,itype,pixels,iplt,mxy,eq,jdt)
c
      integer mxy,ns(mxy),n,ify,nplot,itype,jdt
      real*4 y1(mxy),f1(mxy),g1(mxy),y2(mxy),f2(mxy),g2(mxy),eq(7)
      character fil*(*),tit1*(*),tit2*(*),pixels
      character xlab1*(*),ylab1*(*),xlab2*(*),ylab2*(*)
c
c *** local variables
	integer j,i,span,mnbtic,ifix,cnt1,winu1
	parameter(winu1=69)
	real*4 tzhigh,bhigh,blow,mxbtic,xm,yt1,sum
	character ans*2
      character*70 title1,title2
      logical noplot
c
c *** plotstyle variables
	integer*4 gopt,opt,mxvar
	parameter (mxvar=20)
	integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
	integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
	real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
	character dev*8
	logical bg
c
c *** common block variables for passing to plotting routines
c
      parameter(mxr=5000)
      real*4 year(mxr),crn1(mxr),crv1(mxr),wrk1(mxr),crn2(mxr),
     *  crv2(mxr),wrk2(mxr),ones(mxr),nss(mxr),fq(7)
      integer age,np,itp
      character*70 id1,id2
      character*60 name,savefile,xlable1,ylable1,xlable2,ylable2
c
c *** common block declaration
c
      common /rdata/ year,crn1,crv1,wrk1,crn2,crv2,wrk2,ones,nss,fq
      common /idata/age,np,itp
      common /thenames/ id1,id2,name,savefile,
     *  xlable1,ylable1,xlable2,ylable2
c
c begin subroutine
c
	noplot=.false.
	dev='win3'
	gopt=99
20      call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
      itp=itype
      if(itp.ne.5)then
        do i=1,n
          year(i)=i+ify-1
          crn1(i)=y1(i)
          crv1(i)=f1(i)
          wrk1(i)=g1(i)
          crn2(i)=y2(i)
          crv2(i)=f2(i)
          wrk2(i)=g2(i)
          nss(i)=float(ns(i))
        end do
      else
        do i=1,n
          year(i)=f1(i)
          crn1(i)=y1(i)
          crn2(i)=y2(i)
          crv2(i)=f2(i)
          wrk1(i)=g1(i)
          wrk2(i)=g2(i)
          nss(i)=float(ns(i))
        enddo
      endif
      do i=1,7
        fq(i)=eq(i)
      enddo
      if((eq(7).gt.0.and.eq(7).le.3).and.(eq(2).gt.0.0))then
        fq(3)=fq(2)
        fq(2)=1.0
      elseif((eq(7).gt.0.and.eq(7).le.3).and.(eq(1).eq.0.0.or.eq(2).eq.0.0))then
        fq(1)=fq(3)
        fq(2)=1.0
        fq(3)=0.0
        if(jdt.gt.-3)fq(7)=4
      elseif(eq(7).eq.4.or.eq(7).eq.5)then
        fq(1)=fq(3)
        fq(2)=1.0
        fq(3)=0.0
        if(jdt.gt.-3)fq(7)=4
      endif
      if(eq(7).gt.0.and.eq(7).lt.7)then
        fq(6)=0.0
      endif
      call blank(id1)
      call blank(id2)
      call blank(name)
      call blank(xlable1)
      call blank(ylable1)
      call blank(xlable2)
      call blank(ylable2)
      call csr(fil,jj,2)
      name(1:jj)=fil(1:jj)
      call csr(xlab1,jj,2)
      xlable1(11:jj+10)=xlab1(1:jj)
      call csr(xlab2,jj,2)
      xlable2(11:jj+10)=xlab2(1:jj)
      ylable1=ylab1
      ylable2=ylab2
      call csr(name,jj,2)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id1=name(1:jj+9)//tit1
      id2=name(1:jj+9)//tit2
      age=n
      np=nplot
      call blank(name)
      name=fil
c
      goto(1,2,3,4,5,6,7,8,9),itp
c
    1 call csr(name,jj,2)
      if(tit2.eq.' autoregressive outliers')then
         pen(2)=1  !change default pen(2) to a narrower width
         noplot=.true.
      endif
      name(jj+1:jj+8)='_raw/ind'
      xlow=year(1)
      xhigh=year(age)
      yhigh=-9999.0
      zhigh=yhigh
      ylow=0.0
      zlow=0.0
      do i=1,age
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
      enddo
      cnt1=0
      tzhigh=-9999.0
      do i=1,age
          if(crn2(i).gt.zhigh)zhigh=crn2(i)
          if(crv2(i).gt.tzhigh)tzhigh=crv2(i)
      end do
      if(tzhigh.gt.zhigh)zhigh=tzhigh
      if(zhigh.eq.1.0)then  !if crv2 is all ones then change zlow and zhigh
          zlow=ylow;zhigh=yhigh   !hmmmmm
      endif
	do i=1,age
	    ones(i)=1.0
	end do
      goto 10
    2 call csr(name,jj,2)
      name(jj+1:jj+8)='_raw/trn'
      xlow=year(1)
      xhigh=year(age)
      ylow=0.0
      zlow=0.0
      yhigh=-9999.0
      zhigh=yhigh
      cnt1=0
      do i=1,age
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
        if(crn2(i).gt.zhigh)zhigh=crn2(i)
        if(crn2(i).ne.0)cnt1=cnt1+1
c          write(*,'(2f8.4)')crn2(i),crv2(i)
      enddo
      goto 10
    3 call csr(name,jj,2)
      if(np.eq.1)then
        name(jj+1:jj+8)='_raw/std'
      elseif(np.eq.2)then
        name(jj+1:jj+8)='_res/ars'
      endif
      xlow=year(1)
      xhigh=year(age)
      ylow=0.0
      zlow=0.0
      yhigh=-9999.0
      zhigh=yhigh
      do i=1,age
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
        if(crn2(i).gt.zhigh)zhigh=crn2(i)
      enddo
	blow=9999.0
	bhigh=-9999.9
	do i=1,age
	  if(nss(i).gt.bhigh)bhigh=nss(i)
	  if(nss(i).lt.blow)blow=nss(i)
	end do
	if(bhigh.lt.100)then
	   yt1=amod(bhigh,10.0)
	   if(yt1.le.5.0)then
	     bhigh=bhigh+(5.0-yt1)	
	   else
	     bhigh=bhigh+((10.0-yt1))
	   endif
	elseif((bhigh.ge.100).and.(bhigh.lt.1000))then
	   yt1=amod(bhigh,100.0)
	   if(yt1.le.50.0)then
	     bhigh=bhigh+(50.0-yt1)	
	   else
	     bhigh=bhigh+((100.0-yt1))
	   endif
	endif
c	write(*,'(1x,''bhigh= '',f9.3,''yt1= '',f8.3)')bhigh,yt1
c	write(*,'(1x,''crnplt1 bhigh = '',f8.3)')bhigh
	span=bhigh-blow
	if(span.le.10.0)then
	  mxbtic=5
	  mnbtic=1
	else if(span.gt.10.0.and.span.le.50.0)then
	  mxbtic=10
	  mnbtic=4
	else if(span.gt.50.and.span.le.100.0)then
	  mxbtic=25
	  mnbtic=1
	else if(span.gt.100.and.span.le.500)then
	  mxbtic=100
	  mnbtic=5
	else if(span.gt.500.and.span.le.2000)then
	  mxbtic=500
	  mnbtic=4
	else if(span.gt.2000)then
	  mxbtic=1000
	  mnbtic=2
	end if
      goto 10
    4 call csr(name,jj,2)
      name(jj+1:jj+8)='_seg/age'
      xlow=year(1)
      xhigh=year(age)
      ylow=9999.0
      yhigh=-9999.0
      zlow=0.0
      zhigh=yhigh
      cnt1=0
      do i=1,age
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
        if(crn1(i).lt.ylow)ylow=crn1(i)
        if(crn2(i).gt.zhigh)zhigh=crn2(i)
        if(crn2(i).ne.0.0)cnt1=cnt1+1
      enddo
      goto 10
    5 call csr(name,jj,2)
      if(np.eq.3)then
        name(jj+1:jj+13)='_raw_rbar/eps'
      elseif(np.eq.4)then
        name(jj+1:jj+13)='_trn_rbar/eps'
      elseif(np.eq.5)then
        name(jj+1:jj+13)='_ind_rbar/eps'
      elseif(np.eq.6)then
        name(jj+1:jj+13)='_res_rbar/eps'
      endif
      do i=1,age
       crv1(i)=crn1(i)+2*crv2(i)               !upper rbar error bars
       crv2(i)=crn1(i)-2*crv2(i)               !lower rbar error bars cannot exceed 1.0
      enddo
      xlow=year(1)
      xhigh=year(age)
	  yhigh= 0.9     !1.0  new pjk
	  zhigh=yhigh
      ylow=0.0
      zlow=0.0
      goto 10
    6 call csr(name,jj,2)
      name(jj+1:jj+8)='_rcs/res'
      xlow=year(1)
      xhigh=year(age)
      yhigh=-9999.0
      ylow=9999.0
      zhigh=yhigh
      zlow=ylow
      do i=1,age
       if(crn1(i).gt.yhigh)yhigh=crn1(i)
       if(crn1(i).lt.ylow)ylow=crn1(i)
       if(crn2(i).gt.zhigh)zhigh=crn2(i)
       if(crn2(i).lt.zlow)zlow=crn2(i)
      enddo
      goto 10
    7 call csr(name,jj,2)
      pen(2)=1   !change default pen width
      colline(1)=9  !change default pen color
      if(np.eq.1)then
        name(jj+1:jj+11)='_ar_out_sum'
      elseif(np.eq.2)then
        name(jj+1:jj+10)='_endog_sum'
      endif
      cnt1=0
      xlow=year(1)
      xhigh=year(age)
      zhigh=-9999.0
      zlow=9999.0
      yhigh=zhigh
      ylow=zlow
      do i=1,age
        if(crn1(i).lt.ylow)ylow=crn1(i)
        if(crv1(i).gt.yhigh)yhigh=crv1(i)
        if(crn2(i).lt.zlow)zlow=crn2(i)
        if(crv2(i).gt.zhigh)zhigh=crv2(i)
        if(crv2(i).ne.0.0)cnt1=cnt1+1
      enddo
      goto 10
    8 call csr(name,jj,2)
      name(jj+1:jj+11)='_endog_outs'
      cnt1=0
      xlow=year(1)
      xhigh=year(age)
      ylow=9999.0
      yhigh=-9999.0
      zlow=ylow
      zhigh=yhigh
      do i=1,age
        if(crn1(i).lt.ylow)ylow=crn1(i)
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
        if(crv2(i).lt.zlow)zlow=crv2(i)
        if(crv2(i).gt.zhigh)zhigh=crv2(i)
        if(crv2(i).eq.1.0)cnt1=cnt1+1
      enddo
      if(cnt1.eq.age)then
        zlow=0.0;zhigh=2.0
        noplot=.true.  !use noplot to detect flat crv2
      endif
      goto 10
    9 call csr(name,jj,2)
      if(np.eq.1)then
        name(jj+1:jj+9)='_raw_boot'
      elseif(np.eq.2)then
        name(jj+1:jj+9)='_std_boot'
      elseif(np.eq.3)then
        name(jj+1:jj+9)='_ind_boot'
      elseif(np.eq.4)then
        name(jj+1:jj+9)='_ars_boot'
      endif
      xlow=year(1)
      xhigh=year(age)
      yhigh=-9999.0
      ylow=0.0;zlow=0.0
      do i=1,age
        if(wrk1(i).gt.yhigh)yhigh=wrk1(i)
      enddo
      zhigh=yhigh
c      if(zhigh.lt.1.0)noplot=.true.       !new 2/1/05 -pjk
  10  call csr(name,jj,2)
      savefile=name(1:jj)//'.plts'
c
c  find the nearest integer around xlow and xhigh ylow yhigh zlow zhigh
	xlow=xlow-amod(xlow,10.0)
	xhigh=xhigh+(10-amod(xhigh,10.0))
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
c
c
cdebugging lines -pjk
c	write(*,'(/1x,'' from crnplt1 itype = '',i4)')itp
c	write(*,'(/1x,''                jdt = '',i4)')jdt
c	write(*,'(1x,''noplot = '',b)')noplot	
c	write(*,'(1x,''xlow= '',f8.2,'' xhigh= '',f8.2)')xlow,xhigh
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
c	write(*,'(1x,''zlow= '',f8.2,'' zhigh= '',f8.2)')zlow,zhigh
c	write(*,'(1x,''blow= '',f8.2,'' bhigh= '',f8.2)')blow,bhigh
c	write(*,'(''mxbtic= '',f8.2,'' mnbtic= '',i2)')mxbtic,mnbtic
c	write(*,'(''mxxtic= '',f8.2,'' mxytic= '',f8.3,'' mxztic= '',f8.3)')mxxtic,mxytic,mxztic
c	write(*,'(''mnxtic= '',i4,'' mnytic= '',i4,'' mnztic= '',i4)')mnxtic,mnytic,mnztic
c	pause'crnplt1'
c
25	continue
c
	if(itp.eq.1)then
c		jdt=fq(7)
		if(noplot)then
		  title1=' '
		  goto 28
		endif
		if((jdt.gt.0.and.jdt.lt.4).and.fq(2).eq.0)jdt=4
        if(jdt.eq.-2)then
          title1='rcs growth curve'             !top plot title
        elseif(jdt.eq.-5)then
          title1='friedman super smoother'             !top plot title
        elseif(jdt.eq.-4)then
          title1='lowess robust smoother'             !top plot title
        elseif(jdt.eq.-3)then
          title1='median filter sharpener'             !top plot title        
        elseif(jdt.eq.1)then
          title1='negative exponential curve'             !top plot title
      	elseif(jdt.eq.2)then
      	     title1='negative exponential curve'             !top plot title
      	elseif(jdt.eq.3)then
      	     title1='negative exponential curve'             !top plot title
      	elseif(jdt.eq.4)then
      	     title1='linear regression curve'             !top plot title
      	elseif(jdt.eq.5)then
      	     title1='linear regression curve'             !top plot title
      	elseif(jdt.eq.6)then
      	     title1='horizontal mean curve'             !top plot title
      	elseif(jdt.eq.7)then
      	     title1='hugershoff curve'
      	elseif(jdt.eq.8)then
      	     title1='general exponential curve'
      	elseif(jdt.ge.10)then
      	     title1='cubic smoothing spline'
      	endif
28		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
		call lalign(title1)
		call lalign(title2)
		call lalign(id2)
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
c 		set background color must be called before plinit to work
		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 		initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot raw series
c 		set curve width
		call plwid(pen(2))
      		if(wrk2(1).ne.-999.0)then
      	   	  call plcol(9)
		   call plline(age,year,wrk2)	   !plot spline curve  ?????
      		endif
c 		set curve color
		call plcol(colline(2))  !color lines
		call plline(age,year,crv1)	          !plot spline curve
c 		set curve width
		call plwid(pen(1))
	      if(wrk2(1).ne.-999.0)then
	        call plcol(9)
              call plmtex('t',-.01,0.05,0,'first linearized fit')             !top plot title
              call plcol(1)
              call plmtex('t',-1.35,0.05,0,'final non-linear fit')             !top plot title
		endif
c		set lable color
		call plcol(coltext)   !color box and lables
		call plmtex('t',0.0,0.7,0.0,title1)
      	if(jdt.gt.0.and.jdt.lt.10)then
	      call blank(name)
	      name(1:33)='f(i)=a*t(i+p)**b*exp(-c*t(i+p))+k'
		  call plmtex('t',-1.8,0.6,0.0,name(1:33))
	      call blank(name)
	      name(1:30)='111111222222333333444444555555'
	      name(1:30)='   a     b     c     k    p   '
		  call plmtex('t',-3.5,0.63,0.0,name(1:30))
      	  call blank(name)
      	  write(name(1:6),'(f6.3)')fq(1)
      	  write(name(7:12),'(f6.3)')fq(2)
      	  write(name(13:18),'(f6.3)')fq(3)
      	  write(name(19:24),'(f6.2)')fq(5)
      	  ipo=ifix(fq(6))
      	  if(ipo.lt.10)write(name(25:27),'(i3)')ipo
      	  if(ipo.ge.10)write(name(25:28),'(i4)')ipo
		  call plmtex('t',-5.2,0.6,0.0,name(1:28))
      	elseif(jdt.ne.0)then
      	  call blank(name)
      	  if(jdt.eq.-2)then
      	    name(1:25)='                         '
      	  elseif(jdt.lt.-9.or.jdt.gt.9)then
      	    name(1:24)='     yr. low-pass filter'
      	  elseif(jdt.eq.-3)then
      	    name(1:22)='     yr. median filter'
      	  elseif(jdt.eq.-4)then
      	    name(1:22)='     yr. lowess smooth'
      	  elseif(jdt.eq.-5)then
      	    name(1:15)='       alpha = '
      	  endif
      	  if(jdt.eq.-2)then
      	    ipo=-2
      	  else
      	    ipo=ifix(fq(7))
      	    ipo=abs(ipo)
      	    if(jdt.ne.-5)then
      	      write(name(1:4),'(i4)')ipo
      	    else
      	      ipo=int(fq(5))
      	      write(name(16:16),'(i1)')ipo
      	    endif
      	  endif
		  call plmtex('t',-1.8,0.7,0.0,name(1:25))
      	endif
c	
c 		draw bottom plot
      	call pladv(0) 
      	call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
      	call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,zlow,'abinst',mxxtic,mnxtic,'abinstv',mxztic,mnztic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,ylable2,id2)
c		set line color
		call plcol(colline(1))  !color lines
      	if(crv2(1).ne.0)then
		   call plline(age,year,crn2)               !plot detrend series
c		   set curve color
		   call plcol(colline(2))
c 		   set curve width
		   call plwid(pen(2))
		   call plline(age,year,crv2)	                !plot spline curve
c 		   set curve width
		   call plwid(pen(1))
      	   do i=1,age
      	    ones(i)=1.0                                      !index means
      	   enddo
      	endif
		call plcol(colline(1))  !color lines
		if(noplot)call plcol(colline(2))
		call plline(age,year,ones)  	               !plot index means
c 		finish and close plplot window
		call plend()
c
	else if((itp.eq.2).or.(itp.eq.4).or.(itp.eq.7))then
c
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
		call lalign(id1)
		call lalign(id2)
c
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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 initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot raw series
c 		set curve width
		call plwid(pen(2))
c 		set curve color
		call plcol(colline(2))  !color lines
		call plline(age,year,crv1)	          !plot spline curve
		if(itp.eq.7)then
c 		  set curve width
		  call plwid(pen(1))
		  call plcol(colbox)
      	  do i=1,age
      	    ones(i)=0.0                                      !index means
      	  enddo
      	  call plline(age,year,ones)
      	endif
c
c 		draw bottom plot
		call plwid(pen(1))
      	call pladv(0) 
      	call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
      	call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,zlow,'abinst',mxxtic,mnxtic,'abinstv',mxztic,mnztic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,ylable2,id2)
c		set line color
		call plcol(colline(1))  !color lines
		if(cnt1.gt.0.and.cnt1.le.age)then
		   call plline(age,year,crn2)               !plot transformed series
		   call plcol(colline(2))
c 		   set curve width
		   call plwid(pen(2))
		   call plline(age,year,crv2)	         !plot spline curve
      	endif
		if(itp.eq.7)then
c 		  set curve width
		  call plwid(pen(1))
		  call plcol(colbox)
      	  call plline(age,year,ones)
      	endif
c 		finish bottom and close plplot window
		call plend()
c	
	else if(itp.eq.3)then	
c
		title2="arstan.v38c_trl-ldeo"
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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		initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,3)
		call plfontld(1)
		call plfont(1)
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.1,0.85)
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))  !line style
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot time series
c 		set curve width
		call plwid(pen(2))     !widen pen for curve
c 		set curve color
		call plcol(colline(2))  !color curve
		call plline(age,year,crv1)	          !plot spline curve
c 		set curve width
		call plwid(pen(1))   !return pen width
		call plcol(colline(1))  !color lines
c 		compute raw chronology series mean
      	if(np.eq.1)then
      	   xm=0.0
      	   do i=1,age
      	     xm=xm+crn1(i)                   !raw series mean
      	   enddo
      	   xm=xm/float(age)
      	endif
      	if(np.eq.2)xm=1.0
      	do i=1,age
      	  ones(i)=xm                          !raw or index means
      	enddo
		call plline(age,year,ones)            !plot series mean
c
c 		draw middle plot
      	call pladv(0) 
      	call plvpor(0.1,0.9,0.1,0.85)      !(0.1,0.9,0.2,0.9)	
	      call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,zlow,'abinst',mxxtic,mnxtic,'abinstv',mxztic,mnztic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable2,id2)
c		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn2)               !plot detrend series
		call plcol(colline(2))
c 		set curve width
		call plwid(pen(2))
		call plline(age,year,crv2)	         !plot spline curve
c		set line color
		call plcol(colline(1))  !color lines    
c 		set curve width
		call plwid(pen(1))
		do i=1,age
		   ones(i)=1.0
		end do
		call plline(age,year,ones)          !plot index means
c
c 		draw bottom plot
      	call pladv(0) 
	      call plvpor(0.1,0.9,0.2,0.9)	
      	call plwind(xlow,xhigh,blow,bhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,blow,'abinst',mxxtic,mnxtic,'abinstv',mxbtic,mnbtic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,'samples (z2)',' ')
c		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,nss)               !plot detrend series
		call plend()
c
	else if(itp.eq.5)then
c	
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
		call lalign(id1)
		call lalign(id2)
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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 initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)                    !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)                   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))
c 		set line color
		call plcol(colline(1))                 !color lines
		call plline(age,year,crn1)             !plot running rbar series
c 		set symbol color and error bar color
		call plcol(colsym(1))
c 		set length of error bars here.
		call plerry(age,year,crv2,crv1)        !plot rbar error bars 
		call plpoin(age,year,crn1,symbol(1))   !overlay dot symbols
c
c 		draw bottom plot
      		do i=1,age
      	   	   ones(i)=0.85                          !eps 0.85 threshold
      		enddo
      		call pladv(0) 
      		call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
      		call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)                     !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c		set lable color
		call plcol(coltext)                    !color box and lables
		call pllab(xlable2,ylable2,id2)
c		set line color
		call plcol(colline(1))                 !color lines black
		call plline(age,year,crn2)             !plot running eps series
		call plcol(colsym(1))                  !color symbols default=blue
		call plpoin(age,year,crn2,symbol(1))   !overlay dot symbols
		call plcol(colline(2))                  !color lines defautl=red
		call plline(age,year,ones)	           !plot 0.85 threshold
c 		finish bottom and close plplot window
		call plend()
c
	else if(itp.eq.6)then
c
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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 		initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))  !line style
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot time series
c 		set curve width
		call plwid(pen(2))     !widen pen for curve
c 		set curve color
		call plcol(colline(2))  !color curve
		call plline(age,year,crv1)	          !plot spline curve
c 		set curve width
		call plwid(pen(1))   !return pen width
		call plcol(colline(1))  !color lines
c
c 		draw bottom plot
	      	call pladv(0) 
	      	call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
	      	call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,ylable2,id2)
c		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn2)               !plot detrend series
		call plcol(colline(2))
c 		set curve width
		call plwid(pen(2))
		call plline(age,year,crv2)	         !plot spline curve
c		set line color
		call plcol(colline(1))  !color lines    
c 		set curve width
		call plwid(pen(1))
		do i=1,age
		   ones(i)=1.0
		end do
		call plline(age,year,ones)          !plot index means
c 		finish bottom and close plplot window
		call plend()
c	
	else if(itp.eq.8)then
c
		do i=1,age
		   ones(i)=1.0
		end do
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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		initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))  !line style
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot time series
c 		set curve width
		call plwid(pen(1))     !widen pen for curve
c 		set curve color
		call plcol(colline(2))  !color curve
		call plline(age,year,crv1)	          !plot spline curve
c 		set curve width
c		call plwid(pen(1))   !return pen width
		call plcol(colline(3))
		call plline(age,year,ones)          !plot index means
c
c 		draw bottom plot
	      	call pladv(0) 
	      	call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
	       call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,zlow,'abinst',mxxtic,mnxtic,'abinstv',mxztic,mnztic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,ylable2,id2)
c		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn2)               !plot detrend series
		call plcol(colline(2))
c		set curve width
c		call plwid(pen(2))
		call plline(age,year,crv2)	         !plot spline curve
c		set line color
		call plcol(colline(1))  !color lines    
c		set curve width
		call plwid(pen(1))
		call plcol(colline(3))    !color blue
		if(.not.noplot)call plline(age,year,ones)          !plot index means
c		finish bottom and close plplot window
		call plend()
c
	else if(itp.eq.9)then
c
		call lalign(xlable1)
		call lalign(ylable1)
		call lalign(xlable2)
		call lalign(ylable1)
		call lalign(id1)
		call lalign(id2)
c		compute raw chronology series mean
      	if(np.eq.1)then
      	  xm=0.0
      	  do i=1,age
         	    xm=xm+crn1(i)                   !raw series mean
       	  enddo
	        xm=xm/float(age)
       	endif
	      if(np.gt.1)xm=1.0
            do i=1,age
              ones(i)=xm                          !raw or index means
            enddo
c 		set up plplot window parameters for all plotting
c 		set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
		call plsdev(dev)
		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							       white is desired.
c 		initialize plplot
		call plinit()
c 		define the viewport one column by two rows
		call plssub(1,2)
		call plfontld(1)
		call plfont(1)
c
c 		draw top plot
		call pladv(0) 
		call plvpor(0.1,0.9,0.15,0.9)  !top plot window
		call plwind(xlow,xhigh,ylow,yhigh)
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c 		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(' ',ylable1,id1)
c 		set line style
		call pllsty(pen(1))  !line style
c 		set curve color
		call plcol(colline(2))  !color curve
		call plline(age,year,crv1)	          !plot 2.5 curve
		call plline(age,year,wrk1)	          !plot 97.5 curve
c 		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn1)            !plot time series
		call plcol(colsym(1))   !color lines blue
		call plline(age,year,ones)            !plot series mean
c
c 		draw bottom plot
      		call pladv(0) 
      		call plvpor(0.1,0.9,0.17,0.9)   !bottom plot window	
       	call plwind(xlow,xhigh,zlow,zhigh)
c 		set line style
		call pllsty(pen(1))
c 		set box color
		call plcol(colbox)   !color box and lables
		call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c		set lable color
		call plcol(coltext)   !color box and lables
		call pllab(xlable2,ylable2,id2)
		call plcol(colline(2))
		call plline(age,year,crv2)	         !plot 2.5 curve
		call plline(age,year,wrk2)	         !plot 97.5 curve
c		set line color
		call plcol(colline(1))  !color lines
		call plline(age,year,crn2)               !plot detrend series
		sum=0.0
		do i=1,age
		   sum=sum+crn2(i)
		end do
		sum=sum/age
		do i=1,age
		  ones(i)=sum
		end do
		call plcol(colsym(1))           !color lines blue	
		call plline(age,year,ones)          !plot index means 
c 		finish bottom and close plplot window
		call plend()
c		
	 end if			!endif itp = 1-9
c     
      ans='c '
	dev='win3'
	gopt=0
c50	open(unit=winu1,file='plotoptionwindow',access='window,290,522,26,388')
51	write(*,'(//15x,''|************* plot options menu **************|'')')
        write(*,'(15x,''| replot             [0]  minor ticks y   [11] |'')')
c	write(*,'(15x,''| background color   [1]  major ticks z   [12] |'')')
	write(*,'(15x,''|                         major ticks z   [12] |'')')  !Windows version cannot change background color to black yet
 	write(*,'(15x,''| frame color        [2]  minor ticks z   [13] |'')')
	write(*,'(15x,''| text color         [3]  max. x          [14] |'')')
	write(*,'(15x,''| line color         [4]  min. x          [15] |'')')
        write(*,'(15x,''| curve  color       [5]  max. y          [16] |'')')
        write(*,'(15x,''| line style         [6]  min. y          [17] |'')')
        write(*,'(15x,''| curve width        [7]  max. z          [18] |'')')
        write(*,'(15x,''| major ticks x      [8]  min. z          [19] |'')')
        write(*,'(15x,''| minor ticks x      [9]  symbol type     [20] |'')')
        write(*,'(15x,''| major ticks y     [10]  symbol color    [21] |'')')
      if(itp.eq.3)then
        write(*,'(15x,''| sample depth plot       max z2          [22] |'')')
        write(*,'(15x,''|                         min z2          [23] |'')')
      endif
	write(*,'(15x,''|                                              |'')')
	write(*,'(15x,''|              reset options  [99]             |'')')
	write(*,'(15x,''|----------------------------------------------|'')')
        write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots    |'')') 
        write(*,'(15x,''|______________________________________________|'')')
	write(*,'(/15x,'' enter option number > '',$)')
      read(*,'(a2)')ans
      if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
      elseif((ans.eq.'N ').or.(ans.eq.'n '))then
         iplt=0
c         close(winu1)
         return
      else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt then continue
      endif
      if((gopt.gt.0).and.(gopt.le.21))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
c         close(winu1)
         goto 51  !50
      else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
      elseif(gopt.eq.22)then
	   write(*,'(/15x,''change z2 axis max value from: '',f8.3)')bhigh
	   write(*,'(13x,''to > '',$)')
	   read(*,*)bhigh
	   goto 51
      elseif(gopt.eq.23)then
	   write(*,'(/15x,''change z2 axis min. value from: '',f8.3)')blow
	   write(*,'(13x,''to > '',$)')
	   read(*,*)blow
c	   close(winu1)
	   goto 51
      else if(gopt.eq.99)then
c         close(winu1)
         goto 20
      else
        write(*,'(/13x,''unknown option re-enter a valid request'')')
        goto 51
      end if
c
	end
*sbr crnplt3
*  replaces original crnplt3 and crnplt4 using plplot graphics instead of TSI graphics
c  this subroutine plots simple single axis, single plot graphs.
c  pjk 9/13/04
      subroutine crnplt3(tit,xlab,ylab,itype)
      integer itype
      character tit*(*),xlab*(*),ylab*(*)
c
c *** local variables
	  integer i,p,j,mxy,mxs,winu1
      parameter(mxy=5000,mxs=3000,winu1=69)
      real*4 year(mxy),crn1(mxy),tyt(mxy),tyb(mxy),ones(mxy)
      character dev*8,ans*2,tname*40             ! sets graphic output device required for plotstlye
      
c *** plotstyle variables
	integer*4 gopt,opt,mxvar
	parameter (mxvar=20)
	integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
	integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
	real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
	logical bg
c
c *** common block variables
c
	integer jems(30,5),ndd
       character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     *  q3*2,cvp,fil1*40,itrdb(3)*85
c
      real*4 x(mxy,mxs),crn(mxy)
      integer idate(mxs+2,10)
      character ident(mxs)*8
c
      integer nnc,ifm,jdate(mxs+2,2),idtt,ifz,ilz
      character id*80
      character*60 name,savefile,xlable,ylable
c
c *** common block declarations
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
c
      common /commands/ go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
	  common /icommands/ jems,ndd            !new pjk
c
      common /tsi1/ x,crn,idate,ident,nc
c
	  data ones/mxy*1.0/
c
cBegin Subroutine *******************************************
	do j=1,40
	  tname(j:j)=' '
	end do
	do j=1,40
	  if(fil1(j:j).eq.' ')goto 66
	end do
66	j=j-1
	i=20-(int(j/2))
	do p=1,i-1
	  tname(p:p)=' '
	end do
	do p=1,j
	  write(tname(i:i),'(a1)')fil1(p:p)
	  i=i+1
	end do
	  
	gopt=99
	
20    call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
      idt=jems(4,1)
      ird=jems(19,1)
c
      if(idt.ne.-2.or.itype.ne.5)then
        idtt=0
      else
        idtt=idt
      endif
c
      minyr=9999
      maxyr=-9999
      maxn=-9999
      do j=1,nc
        if(idtt.ne.-2)then
          if(idate(j,1).lt.minyr)minyr=idate(j,1)
          if(idate(j,2).gt.maxyr)maxyr=idate(j,2)
        else
          nyrs=idate(j,2)-idate(j,1)+1
          if(nyrs.gt.maxn)maxn=nyrs
        endif
      enddo
      madmax=idate(nc+1,2)-idate(nc+1,1)+1
      if(madmax.gt.maxn)maxn=madmax
      nnc=nc
      if(idtt.ne.-2)then
        ifm=minyr
        ifz=minyr
        ilz=maxyr
      else
        minyr=1
        maxyr=maxn
        ifm=minyr
        ifz=minyr
        ilz=maxyr
      endif
      nmax=maxyr-minyr+1
      nyrs=nmax
      ncnt=0
      do j=1,nnc
        if(idtt.ne.-2)then
          if((ifz.lt.idate(j,2)).or.(ilz.gt.idate(j,1)))then
            ncnt=ncnt+1
            if(ifz.gt.idate(j,1))then
              jdate(ncnt,1)=ifz
            else
              jdate(ncnt,1)=idate(j,1)
            endif
            if(ilz.lt.idate(j,2))then
              jdate(ncnt,2)=ilz
            else
              jdate(ncnt,2)=idate(j,2)
            endif
          endif
        else
          nobs=idate(j,2)-idate(j,1)+1
          if((ifz.lt.nobs).or.(ilz.gt.1))then
            ncnt=ncnt+1
            if(ifz.gt.1)then
              jdate(ncnt,1)=ifz
            else
              jdate(ncnt,1)=1
            endif
            if(ilz.lt.nobs)then
              jdate(ncnt,2)=ilz
            else
              jdate(ncnt,2)=nobs
            endif
          endif
        endif
      enddo
      xlow=ifz
      xhigh=ilz
      ncnt=0
      rmin=9999.0
      rmax=-9999.0
      do j=1,nnc
        if(idtt.ne.-2)then
          if((ifz.lt.idate(j,2)).or.(ilz.gt.idate(j,1)))then
            ncnt=ncnt+1
            nobs=jdate(ncnt,2)-jdate(ncnt,1)+1
            ist=jdate(ncnt,1)-minyr
            do i=1,nobs
              ii=i+ist
              if(x(ii,j).lt.rmin)rmin=x(ii,j)
              if(x(ii,j).gt.rmax)rmax=x(ii,j)
            enddo
          endif
        else
          nobs=idate(j,2)-idate(j,1)+1
          if((ifz.lt.nobs).or.(ilz.gt.1))then
            ncnt=ncnt+1
            ist=jdate(ncnt,1)-1
            ny=jdate(ncnt,2)
            do i=1,ny
              ii=i+ist
              if(x(ii,j).lt.rmin)rmin=x(ii,j)
              if(x(ii,j).gt.rmax)rmax=x(ii,j)
            enddo
          endif
        endif
      enddo
      nnc=ncnt
      if(rmin.gt.0)then
        ylow=rmin
      else
        ylow=0.0
      endif
      yhigh=rmax
      if(itype.eq.12)ylow=rmin   !this is not the best solution but works
c
      if(idtt.ne.-2)then
        ist=ifz-minyr
      else
        ist=ifz-1
      endif
      call blank(xlable)
      call blank(ylable)
      call csr(xlab,jj,2)
      xlable(11:jj+10)=xlab(1:jj)
      ylable=ylab
      call blank(name)
      name=fil1
      call csr(name,jj,2)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id=name(1:jj+10)//tit
      call blank(name)
      name=fil1
      goto(1,2,3,4,5,6,7,8,9,10,11,12,13),itype
    1 call csr(name,jj,2)
      name(jj+1:jj+9)='_RAW DATA'
      goto 100
    2 call csr(name,jj,2)
      name(jj+1:jj+9)='_TRN DATA'
      goto 100
    3 call csr(name,jj,2)
      name(jj+1:jj+9)='_STD DATA'
      goto 100
    4 call csr(name,jj,2)
      name(jj+1:jj+9)='_RES DATA'
      goto 100
    5 call csr(name,jj,2)
      name(jj+1:jj+9)='_RCS DATA'
      goto 100
    6 call csr(name,jj,2)
      name(jj+1:jj+9)='_1ST-DETR'
      goto 100
    7 call csr(name,jj,2)
      name(jj+1:jj+9)='_2ND-DETR'
      goto 100
    8 call csr(name,jj,2)
      name(jj+1:jj+9)='_RAW WGTS'
      goto 100
    9 call csr(name,jj,2)
      name(jj+1:jj+9)='_STD WGTS'
      goto 100
   10 call csr(name,jj,2)
      name(jj+1:jj+9)='_RES WGTS'
      goto 100
   11 call csr(name,jj,2)
      name(jj+1:jj+9)='_RCS WGTS'
      goto 100
   12 call csr(name,jj,2)
      name(jj+1:jj+8)='_AR_OUTS'
      goto 100
   13 call csr(name,jj,2)
      name(jj+1:jj+11)='_ENDOG_OUTS'
      goto 100
  100 call csr(name,jj,2)
      savefile=name(1:jj)//'.PLTS'
c
c find the nearest mutiple of ten around xlow and xhigh
	xlow=xlow-amod(xlow,10.0)
	xhigh=xhigh+(10-amod(xhigh,10.0))
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
c
c	write(*,'(1x,''crnplt3 itype= '',i2)')itype
c	write(*,'(1x,''xlow= '',f8.2,'' xhigh= '',f8.2)')xlow,xhigh
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
c	write(*,'(''mxxtic= '',f8.2,'' mxytic= '',f8.3)')mxxtic,mxytic
c	write(*,'(''mnxtic= '',i4,'' mnytic= '',i4)')mnxtic,mnytic
c	write(*,'(1x,''colbox= '',i4)')colbox
c	write(*,'(1x,''coltext= '',i4)')coltext
c	write(*,'(1x,''pen(1)= '',i4)')pen(1)
c	write(*,'(1x,''colline(1)= '',i4)')colline(1)
c	pause'crnplt3'
c
	call lalign(xlable)
	call lalign(ylable)
	call lalign(tit)
c
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25	call plsdev(dev)
	opt=1
	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    initialize plplot
	call plinit()
	call plfontld(1)
	call plfont(1)
c    define the viewport one column by one row
	call plssub(1,1)
	call pladv(0)
	call plvpor(0.12,0.95,0.2,0.8)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)   !color box and lables
	call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c	call plbox('ABCINTSN',mxxtic,mnxtic,'ABCINTS',mxytic,mnytic)
c set lable color
	call plcol(coltext)   !color box and lables
	call pllab(xlable,ylable,tit)
	
	    call plmtex('t',3.5,0.18,0.0,tname)

c set line style
	call pllsty(pen(1))
c set line color
	call plcol(colline(1))  !color lines
      ncnt=0
      do j=1,nnc    !plot all series in a file 
        if(idtt.ne.-2)then
          if((ifz.lt.idate(j,2)).or.(ilz.gt.idate(j,1)))then
            ncnt=ncnt+1
            ify=jdate(ncnt,1)
            ily=jdate(ncnt,2)
            nobs=jdate(ncnt,2)-jdate(ncnt,1)+1
            ist=jdate(ncnt,1)-ifm
            do i=1,nobs
              ii=i+ist
              year(i)=float(ify+i-1)
              crn1(i)=x(ii,j)
            enddo
            if((itype.eq.12).or.(itype.eq.13))then
              do p=1,nobs
                if(crn1(p).gt.1.0)then
                   tyt(p)=crn1(p)
                else
                   tyt(p)=1.0
                endif
                if(crn1(p).lt.1.0)then
                   tyb(p)=crn1(p)
                else
                   tyb(p)=1.0
                endif
              end do
              call plcol(colline(2))
              call plline(nobs,year,tyt)  
              call plcol(colline(3))
              call plline(nobs,year,tyb)
              call plcol(colline(1))
              call plline(nobs,year,ones)
            else
	       call plline(nobs,year,crn1)
            
            endif
          endif
        else
          nobs=idate(j,2)-idate(j,1)+1
          if((ifz.lt.nobs).or.(ilz.gt.1))then
            ncnt=ncnt+1
            ist=jdate(ncnt,1)-1
            ify=1
            ny=jdate(ncnt,2)
            do i=1,ny
              ii=i+ist
              year(i)=float(ify+i-1)
              crn1(i)=x(ii,j)
            enddo
            write(*,'(1x,''second'')')
	      call plline(ny,year,crn1)
          endif
        endif
      enddo
      if(crn(1).ge.0.0)then   ! is there is a "mean" to plot? (crn(1).ne.0)=yes
	    opt=2
        nobs=ilz-ifz+1        
c set curve width
	   call plwid(pen(2))
c set line color
	   call plcol(colline(2))  !color lines
       do i=1,nobs
          year(i)=float(ifz+i-1)
       enddo   
       ifmin=idate(nnc+1,1)
       ist=ifz-ifmin+1
c            write(*,'(1x,''third'')')
       call plline(nobs,year,crn(ist))			!plot mean series
      endif
	  call plend()
      ans='C '
	  dev='win3'
	  gopt=0
c50	open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51	  write(*,'(//15x,''|************* plot options menu *************|'')')
      write(*,'(15x,''| replot            [0]  minor ticks  y  [11] |'')')
	write(*,'(15x,''|                         major ticks z   [12] |'')')  !Windows version cannot change background color to black yet
c	  write(*,'(15x,''| background color  [1]  major ticks  z  [12] |'')')
 	  write(*,'(15x,''| frame color       [2]  minor ticks  z  [13] |'')')
	  write(*,'(15x,''| text color        [3]  max. x          [14] |'')')
	  write(*,'(15x,''| line color        [4]  min. x          [15] |'')')
      write(*,'(15x,''| curve  color      [5]  max. y          [16] |'')')
      write(*,'(15x,''| line style        [6]  min. y          [17] |'')')
      write(*,'(15x,''| curve width       [7]                  [  ] |'')')
      write(*,'(15x,''| major ticks  x    [8]                  [  ] |'')')
      write(*,'(15x,''| minor ticks  x    [9]                  [  ] |'')')
      write(*,'(15x,''| major ticks  y   [10]                  [  ] |'')')
	  write(*,'(15x,''|                                             |'')')
	  write(*,'(15x,''|           reset plot options  [99]          |'')')
	  write(*,'(15x,''|---------------------------------------------|'')')
      write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots   |'')') 
      write(*,'(15x,''|_____________________________________________|'')')
	  write(*,'(/15x,'' enter option number > '',$)')
      read(*,'(a2)')ans
      if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
      elseif((ans.eq.'N ').or.(ans.eq.'n '))then
c        what to do ??????
         iplt=0
c         close(winu1)
         return
      else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
      endif
      if((gopt.gt.0).and.(gopt.le.17))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
c         close(winu1)
         goto 51    !50
      else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
      else if(gopt.eq.99)then
c         close(winu1)
         goto 20
      else
        write(winu1,'(/13x,''Unknown option re-enter a valid request'')')
        goto 51
      end if
c
	end
*SBR CRNPLT5
*
      SUBROUTINE CRNPLT5(Y1,F1,N,IFY,FIL,TIT1,XLAB1,YLAB1,PIXELS,M1,MSY,IPLT)
      REAL*4 Y1(N),F1(N),gap1(1000),gap2(1000),gap3(1000)
      INTEGER MSY(500)
      CHARACTER FIL*(*),TIT1*(*),XLAB1*(*),YLAB1*(*),PIXELS
c
c *** local variables
      integer winu1,i,if1,il1
      parameter(winu1=69)
      character ans*2          
c *** plotstyle variables
      integer*4 gopt,opt,mxvar
      parameter (mxvar=20)
      integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
      integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
      real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      real*4 year(5000),crn1(5000),crv1(5000)
      integer age,jgap(500),ngap
      character*50 name,savefile,xlable1,ylable1
      character dev*8             ! sets graphic output device required for plotstlye
      character*60 id1
      logical bg
c
cBegin Subroutine *******************************************
	gopt=99
20    call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
      do i=1,n
        year(i)=i+ify-1
        crn1(i)=y1(i)
        crv1(i)=f1(i)
      enddo
      age=n
C
C *** IF FOUND, DETERMINE WHAT YEARS AND WRITE OUT RESULTS
C
      IF(M1.GT.0)THEN
        NGAP=0
        IF((MSY(M1)-MSY(1)+1).EQ.M1)THEN
          NGAP=1
          IFYR=MSY(1)
          ILYR=MSY(M1)
          JGAP((NGAP-1)*2+1)=IFYR
          JGAP((NGAP-1)*2+2)=ILYR    
        ELSE
          IFYR=MSY(1)
          DO I=2,M1
            NDIF=0
            NDIF=MSY(I)-MSY(I-1)
            IF(NDIF.GT.1.AND.I.LE.M1)THEN
              NGAP=NGAP+1
              ILYR=MSY(I-1)
              JGAP((NGAP-1)*2+1)=IFYR
              JGAP((NGAP-1)*2+2)=ILYR    
              IFYR=MSY(I)
              IF(NDIF.GT.1.AND.I.EQ.M1)THEN
                NGAP=NGAP+1
                IFYR=MSY(M1)
                ILYR=MSY(M1)
                JGAP((NGAP-1)*2+1)=IFYR
                JGAP((NGAP-1)*2+2)=ILYR  
              ENDIF
            ELSEIF(NDIF.EQ.0.OR.I.EQ.M1)THEN
              NGAP=NGAP+1
              ILYR=MSY(I)
              JGAP((NGAP-1)*2+1)=IFYR
              JGAP((NGAP-1)*2+2)=ILYR    
            ENDIF
          ENDDO
        ENDIF
      ENDIF
c
      call blank(id1)
      call blank(name)
      call blank(xlable1)
      call blank(ylable1)
      call csr(fil,jj,2)
      name(1:jj)=fil(1:jj)
      call csr(xlab1,jj,2)
      xlable1(11:jj+10)=xlab1(1:jj)
      ylable1=ylab1
      call csr(name,jj,2)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id1=name(1:jj+9)//tit1
      call blank(name)
      name=fil
    1 call csr(name,jj,2)
      name(jj+1:jj+8)='_FILL'
  100 call csr(name,jj,2)
      savefile=name(1:jj)//'.PLTS'
      ify=year(1)
      xlow=year(1)
      xhigh=year(age)
      yhigh=-999.0
      ylow=0.0   !-new 10/05
      do i=1,age
c        if(crn1(i).lt.ylow)ylow=crn1(i) -new 10/05
        if(crn1(i).gt.yhigh)yhigh=crn1(i)
      enddo
c      if(ylow.gt.0)ylow=0.0  -new 10/05
c
c find the nearest integer around xlow and xhigh ylow yhigh zlow zhigh
	xlow=xlow-amod(xlow,10.0)
	xhigh=xhigh+(10-amod(xhigh,10.0))
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
cdebugging lines -pjk
c	write(*,'(/1x,''crnplt5 '')')
c	write(*,'(1x,''xlow= '',f8.2,'' xhigh= '',f8.2)')xlow,xhigh
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
c	write(*,'(1x,''zlow= '',f8.2,'' zhigh= '',f8.2)')zlow,zhigh
c	write(*,'(''mxxtic= '',f8.2,'' mxytic= '',f8.3,'' mxztic= '',f8.3)')mxxtic,mxytic,mxztic
c	write(*,'(''mnxtic= '',i4,'' mnytic= '',i4,'' mnztic= '',i4)')mnxtic,mnytic,mnztic
c
	call lalign(xlable1)
	call lalign(ylable1)
	call lalign(id1)
c
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25    call plsdev(dev)
      opt=1
	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    initialize plplot
      call plinit()
	call plfontld(1)
	call plfont(1)
c    define the viewport one column by one row
      call plssub(1,1)
      call pladv(0)
      call plvpor(0.12,0.95,0.2,0.8)
      call plwind(xlow,xhigh,ylow,yhigh)
c set box color
      call plcol(colbox)   !color box and lables
	call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c      call plbox('ABCINTSN',mxxtic,mnxtic,'ABCINTS',mxytic,mnytic)
c set lable color
      call plcol(coltext)   !color box and lables
      call pllab(xlable1,ylable1,id1)
c set line style
      call pllsty(pen(1))
c set line color
      call plcol(colline(1))  !color lines
      call plline(age,year,crn1)                 !plot raw series
c set curve width
	call plwid(pen(2))     !widen pen for curve
      call plline(age,year,crv1)	                !plot spline curve
c set curve width
	call plwid(pen(1))     !widen pen for curve
       do j=1,ngap
        k1=(j-1)*2+1
        k2=k1+1
        if1=jgap(k1)
        il1=jgap(k2)
        ngp=il1-if1+1
        mgp=ngp+2
        do i=1,mgp
          gap1(i)=if1-2+i
          ii=if1-ify+i-1
          gap2(i)=crn1(ii)
          gap3(i)=crv1(ii)
        enddo
        call plwid(pen(2))
        call plcol(colline(2))    !red
        call plline(mgp,gap1,gap2)                 !plot raw series
        call plcol(colline(3))     !blue
        call plline(mgp,gap1,gap3)                 !plot raw series
        gap1(1)=real(if1)-1.0!0.5
        gap1(2)=real(if1)-1.0!0.5
        gap2(1)=0.0
        gap2(2)=yhigh !ymax
        call plcol(colline(1))
        call plwid(pen(1))
        call plline(2,gap1,gap2)                 !plot raw series
c        write(*,'(4(1x,f8.4))')tgap1(1),tgap1(2),tgap2(1),tgap2(2)
        gap1(1)=real(il1)+1!0.5
        gap1(2)=real(il1)+1!0.5
        gap2(1)=0.0
        gap2(2)=yhigh !ymax
        call plline(2,gap1,gap2)                 !plot raw series
c        write(*,'(4(1x,f8.4))')tgap1,tgap2
        do i=1,ngp+2!1
          gap1(i)=if1+i-2!0.5
          gap2(i)=yhigh  !ymax
        enddo
        call plline(ngp+2,gap1,gap2)                 !plot raw series
      enddo
      call plend()
      dev='win3'
c50    open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51	write(*,'(//15x,''|************* plot options menu **************|'')')
        write(*,'(15x,''| replot             [0]  minor ticks y   [11] |'')')
	write(*,'(15x,''|                         major ticks z   [12] |'')')  !Windows version cannot change background color to black yet
c	write(*,'(15x,''| background color   [1]  major ticks z   [12] |'')')
 	write(*,'(15x,''| frame color        [2]  minor ticks z   [13] |'')')
	write(*,'(15x,''| text color         [3]  max. x          [14] |'')')
	write(*,'(15x,''| line color         [4]  min. x          [15] |'')')
        write(*,'(15x,''| fit  color         [5]  max. y          [16] |'')')
        write(*,'(15x,''| line style         [6]  min. y          [17] |'')')
        write(*,'(15x,''| curve width        [7]                  [  ] |'')')
        write(*,'(15x,''| major ticks x      [8]                  [  ] |'')')
        write(*,'(15x,''| minor ticks x      [9]                  [  ] |'')')
        write(*,'(15x,''| major ticks y     [10]                  [  ] |'')')
	write(*,'(15x,''|                                              |'')')
	write(*,'(15x,''|            reset plot options  [99]          |'')')
	write(*,'(15x,''|----------------------------------------------|'')')
        write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots    |'')') 
        write(*,'(15x,''|______________________________________________|'')')
	write(*,'(/15x,'' enter option number > '',$)')
       read(*,'(a2)')ans
       if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
       elseif((ans.eq.'N ').or.(ans.eq.'n '))then
	  iplt=0
c         close(winu1)
         return
       else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
       endif
       if((gopt.gt.0).and.(gopt.le.17))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
c         close(winu1)
         goto 51     !50
       else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
       else if(gopt.eq.99)then
c         close(winu1)
         goto 20
       else
        write(*,'(/13x,''Unknown option re-enter a valid request'')')
        goto 51
       end if
c
	end
*sbr crnplt7
*  replaces original crnplt7 and crnplt8 using plplot graphics instead of TSI graphics
c  this subroutine plots simple single axis, single plot graphs.
c  pjk 9/13/04
      SUBROUTINE CRNPLT7(Y1,F1,F2,N,IFY,FIL,TIT1,XLAB1,YLAB1,PIXELS,ITYPE)
      REAL*4 Y1(N),F1(N),F2(N)
      CHARACTER FIL*(*),TIT1*(*),XLAB1*(*),YLAB1*(*),PIXELS
c
c *** local variables
	integer i,j,winu1
	parameter(winu1=69)
	character ans*2
c
      real*4 year(5000),crn1(5000),crv1(5000),crv2(5000)
      integer age
      character*50 name,savefile,xlable1,ylable1
      character*70 id1
      
c *** plotstyle variables
	integer*4 gopt,opt,mxvar
	parameter (mxvar=20)
	integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
	integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
	real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
       character*8 dev             ! sets graphic output device required for plotstlye
       logical bg
c
cBegin Subroutine *******************************************
      do i=1,n
        year(i)=i+ify-1
        crn1(i)=y1(i)
        crv1(i)=f1(i)
        crv2(i)=f2(i)
      enddo
      age=n
c
      call blank(id1)
      call blank(name)
      call blank(xlable1)
      call blank(ylable1)
      call csr(fil,jj,2)
      name(1:jj)=fil(1:jj)
      call csr(xlab1,jj,2)
      xlable1(11:jj+10)=xlab1(1:jj)
      ylable1=ylab1
      call csr(name,jj,2)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id1=name(1:jj+9)//tit1
      call blank(name)
      name=fil
      goto(1,2,3,4),itype
    1 call csr(name,jj,2)
      name(jj+1:jj+9)='_RAW_WGTS'
      goto 100
    2 call csr(name,jj,2)
      name(jj+1:jj+9)='_STD_WGTS'
      goto 100
    3 call csr(name,jj,2)
      name(jj+1:jj+9)='_RES_WGTS'
      goto 100
    4 call csr(name,jj,2)
      name(jj+1:jj+9)='_RCS_WGTS'
  100 call csr(name,jj,2)
       savefile=name(1:jj)//'.PLTS'
c
	gopt=99
20     call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
       xlow=year(1)
       xhigh=year(age)
       ylow=0.0
       yhigh=1.0
	xlow=xlow-amod(xlow,10.0)
	xhigh=xhigh+(10-amod(xhigh,10.0))
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
c
c	write(*,'(1x,''xlow= '',f8.2,'' xhigh= '',f8.2)')xlow,xhigh
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
c	write(*,'(''mxxtic= '',f8.2,'' mxytic= '',f8.3)')mxxtic,mxytic
c	write(*,'(''mnxtic= '',i4,'' mnytic= '',i4)')mnxtic,mnytic
c	write(*,'(1x,''colbox= '',i4)')colbox
c	write(*,'(1x,''coltext= '',i4)')coltext
c	write(*,'(1x,''pen(1)= '',i4)')pen(1)
c	write(*,'(1x,''colline(1)= '',i4)')colline(1)
c	pause'subplt7'
c
	call lalign(xlable1)
	call lalign(ylable1)
	call lalign(id1)
c
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25	call plsdev(dev)
	opt=1
	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    initialize plplot
	call plinit()
	call plfontld(1)
	call plfont(1)
c    define the viewport one column by one row
	call plssub(1,1)
	call pladv(0)
	call plvpor(0.12,0.95,0.2,0.8)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)   !color box and lables
	call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c	call plbox('ABCINTSN',mxxtic,mnxtic,'ABCINTS',mxytic,mnytic)
c set lable color
	call plcol(coltext)   !color box and lables
	call pllab(xlable1,ylable1,id1)
c set line style
	call pllsty(pen(1))
c set line color
	call plcol(colline(2))  !color lines
c set curve width
	call plwid(pen(2))
	call plline(age,year,crn1)    !plot raw series
c set line color
	call plcol(colline(1))  !color lines
c set curve width
	call plwid(pen(1))
       call plline(age,year,crv1)			!plot spline
       call plline(age,year,crv2)			!plot spline
	call plend()
	dev='win3'
c50	open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51	write(*,'(//15x,''|************* plot options menu **************|'')')
        write(*,'(15x,''| replot             [0]  minor ticks y   [11] |'')')
	write(*,'(15x,''|                         major ticks z   [12] |'')')  !Windows version cannot change background color to black yet
c	write(*,'(15x,''| background color   [1]  major ticks z   [12] |'')')
 	write(*,'(15x,''| frame color        [2]  minor ticks z   [13] |'')')
	write(*,'(15x,''| text color         [3]  max. x          [14] |'')')
	write(*,'(15x,''| line color         [4]  min. x          [15] |'')')
        write(*,'(15x,''| fit  color         [5]  max. y          [16] |'')')
        write(*,'(15x,''| line style         [6]  min. y          [17] |'')')
        write(*,'(15x,''| curve width        [7]                  [  ] |'')')
        write(*,'(15x,''| major ticks x      [8]                  [  ] |'')')
        write(*,'(15x,''| minor ticks x      [9]                  [  ] |'')')
        write(*,'(15x,''| major ticks y     [10]                  [  ] |'')')
	write(*,'(15x,''|                                              |'')')
	write(*,'(15x,''|           reset plot options  [99]           |'')')
	write(*,'(15x,''|----------------------------------------------|'')')
        write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots    |'')') 
        write(*,'(15x,''|______________________________________________|'')')
	write(*,'(/15x,'' enter option number > '',$)')
       read(*,'(a2)')ans
       if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
       elseif((ans.eq.'N ').or.(ans.eq.'n '))then
c        what to do ??????
         iplt=0
c         close(winu1)
         return
       else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
       endif
       if((gopt.gt.0).and.(gopt.le.17))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
c         close(winu1)
         goto 51   !50
       else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
       else if(gopt.eq.99)then
c         close(winu1)
         goto 20
       else
        write(*,'(/13x,''Unknown option re-enter a valid request'')')
        goto 51
       end if
c
	end
*sbr crnplt11
*
      subroutine crnplt11(data,xms1,see1,xms2,see2,pgc,ify,n,ncnt,nw,npg,nse,fil,
     *  tit1,tit2,xlab1,ylab1,xlab2,ylab2,iplt,mxy,jopt,bif)
      integer ify,n,ncnt,nw,npg,nse,iplt
      real*4 data(mxy),pgc(mxy),xms1(mxy),see1(mxy),xms2(mxy),see2(mxy)
      character fil*(*),tit1*(*),tit2*(*),bif
      character xlab1*(*),ylab1*(*),xlab2*(*),ylab2*(*)
c
c *** local variables for tsi graphics
c
      integer p,j,k,winu1,i,mxr
      parameter(mxr=5000,winu1=69)
      integer age,mcnt,mw,mpg,mse,iopt,lines,nrl
      real*4 yr1(mxr),yr2(mxr),x1(mxr),x2(mxr),x3(mxr),x4(mxr)
      real*4 x5(mxr),x6(mxr),x7(mxr),x8(mxr)
      real*4 rmx,rmn,y1,y2
      real*4 yr3(mxr)
      real*4 xrange(2),yrange(2)
      character iyor(100)*4
      character*1 biff
      character*2 ans
      character*70 id1,id2,lable
      character*60 name,savefile,xlable1,ylable1,xlable2,ylable2,title2
      logical noplot
c
c *** plotstyle variables
	integer*4 gopt,opt,mxvar
	parameter (mxvar=20)
	integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
	integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
	real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
       character*8 dev             ! sets graphic output device required for plotstlye
       logical bg
c
c
      gopt=99
20    call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
      noplot=.false.
      do i=1,ncnt
        yr1(i)=i+ify+nw-2
        x1(i)=xms1(i)
        x2(i)=see1(i)
        x3(i)=xms2(i)
        x4(i)=see2(i)
        x5(i)=pgc(i)
      enddo
      call moment(x5,ncnt,ave1,adev,sdev1,var,skew,curt,sens,ac)
      call moment(data,n,ave2,adev,sdev2,var,skew,curt,sens,ac)
      do i=1,n
        yr2(i)=i+ify-1
        x6(i)=data(i)
        x6(i)=(x6(i)-ave2)/sdev2
        x6(i)=x6(i)*sdev1+ave1
      enddo
      call blank(id1)
      call blank(id2)
      call blank(name)
      call blank(xlable1)
      call blank(ylable1)
      call blank(xlable2)
      call blank(ylable2)
      call csr(fil,jj,2)
      name(1:jj)=fil(1:jj)
      call csr(xlab1,jj,2)
      xlable1(11:jj+10)=xlab1(1:jj)
      call csr(xlab2,jj,2)
      xlable2(11:jj+10)=xlab2(1:jj)
      ylable1=ylab1
      ylable2=ylab2
      call csr(name,jj,2)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id1=name(1:jj+9)//tit1
      id2=name(1:jj+9)//tit2
      age=n
      mcnt=ncnt
      mw=nw
      mpg=npg
      mse=nse
      iopt=jopt
      biff=bif
      call blank(name)
      name=fil
      call csr(name,jj,2)
      name(jj+1:jj+13)='_nowacki'
  100 call csr(name,jj,2)
      savefile=name(1:jj)//'.plts'
c
      rmn=999.9
      rmx=-999.9
      do i=1,mcnt
        y1=x1(i)+mse*x2(i)
        y2=x3(i)+mse*x4(i)
        if(amax1(y1,y2).gt.rmx)rmx=amax1(y1,y2)
      enddo
      do i=1,mcnt
        x7(i)=x1(i)-mse*x2(i)                        	   !lower error bars
        x8(i)=x1(i)+mse*x2(i)                            !upper error bars
      enddo
c
      xrange(1)=yr2(1)
      xrange(2)=yr2(age)
      xlow=xrange(1)
      xhigh=xrange(2)
      rmx=rmx+0.5
      yrange(1)=rmx
      yrange(2)=0.0
      yhigh=yrange(1)
      ylow=yrange(2)
c
      zlow=999.9
      zhigh=-999.9
      do i=1,mcnt
        y1=x5(i)
        y2=x6(i)
        if(amin1(y1,y2).lt.zlow)zlow=amin1(y1,y2)
        if(amax1(y1,y2).gt.zhigh)zhigh=amax1(y1,y2)
      enddo
      rmx=rmx+0.5
      if(zlow.lt.-10.0.or.zhigh.gt.20.0)then
c         write(*,'(/1x,''zlow= '',e12.6,/1x,''zhigh= '',E12.6)')zlow,zhigh
        title2='Unable to display this plot'
        noplot=.true.
        zhigh=yhigh
        zlow=ylow
      endif
      xlow=xlow-amod(xlow,10.0)
      xhigh=xhigh+(10-amod(xhigh,10.0))
       call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
c	debugging lines -pjk
c	write(*,'(/1x,''crnplt11 top plot'')')
c	write(*,'(1x,''xrange(1)='',f5.0,'' xrange(2)='',f5.0)')xrange(1),xrange(2)
c	write(*,'(1x,''xlow= '',f8.2,'' xhigh= '',f8.2)')xlow,xhigh
c	write(*,'(1x,''ylow= '',f8.2,'' yhigh= '',f8.2)')ylow,yhigh
c	write(*,'(''mxxtic= '',f8.2,'' mxytic= '',f8.3,'' mxztic= '',f8.3)')mxxtic,mxytic,mxztic
c	write(*,'(''mnxtic= '',i4,'' mnytic= '',i4,'' mnztic= '',i4)')mnxtic,mnytic,mnztic
c
	call lalign(xlable1)
	call lalign(ylable1)
	call lalign(xlable2)
	call lalign(ylable1)
	call lalign(id1)
	call lalign(id2)

c 	set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25	call plsdev(dev)
	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	initialize plplot
	call plinit()
	call plfontld(1)
	call plfont(1)
c	define the viewport one column by two rows
	call plssub(1,2)
c
c	draw top plot
c
	call pladv(0) 
	call plvpor(0.1,0.9,0.15,0.86)
	call plwind(xlow,xhigh,ylow,yhigh)
c	set box color
	call plcol(colbox)   !color box and lables
	call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c	set lable color
	call plcol(coltext)   !color box and lables
	call pllab(' ',ylable1,id1)
c 	set line style
	call pllsty(pen(1))  !line style
c 	set line color
	call plcol(colline(3))  !color lines
	call plline(mcnt,yr1,x1)            !plot running rbar series
c
       do i=1,mcnt
        x1(i)=x1(i)+0.01
        yr3(i)=yr1(i)+0.2
       enddo
       ify=yr1(1)
       do i=1,mcnt
        xrange(1)=ify+i-1
        xrange(2)=ify+i-1
        yrange(1)=x7(i)
        yrange(2)=x8(i)
	 call plline(2,xrange,yrange)                 !plot running rbar series
       enddo
c       
       do i=1,mcnt
        x7(i)=x3(i)-mse*x4(i)                        !lower rbar error bars
        x8(i)=x3(i)+mse*x4(i)                        !upper rbar error bars
       enddo
       call plcol(colline(2))
	call plline(mcnt,yr1,x3)                 !plot running rbar series
       do i=1,mcnt
         x3(i)=x3(i)+0.005
       enddo
       do i=1,mcnt
        xrange(1)=ify+i-1
        xrange(2)=ify+i-1
        yrange(1)=x7(i)
        yrange(2)=x8(i)
	 call plline(2,xrange,yrange)                 !plot running rbar series
       enddo
       lable='rm:   yr.  pg:    %  se:    se  bf:  '
       write(lable(4:6),'(i3)')mw
       write(lable(16:18),'(i3)')mpg
       write(lable(25:27),'(i3)')mse
       write(lable(37:37),'(a1)')biff
c	write(*,'(1x,a)')lable
c      set lable color
	call plcol(coltext)   !color box and lables
c	make extra lable on top of plot
	call plmtex('t',-0.01,0.27,0.0,lable)
c
c 	finish top plot
c
c 	draw bottom plot
       call pladv(0) 
       call plvpor(0.1,0.9,0.2,0.75)	
       call plwind(xlow,xhigh,zlow,zhigh)
c 	set line style
	call pllsty(pen(1))
c 	set box color
	call plcol(colbox)   !color box and lables
	call plaxes (xlow,zlow,'abinst',mxxtic,mnxtic,'abinstv',mxztic,mnztic)
c	set lable color
	call plcol(coltext)   !color box and lables
	if(noplot)then
	   call pllab(xlable2,ylable2,title2)
	   goto 60
	else
	  call pllab(xlable2,ylable2,' ')
	endif
c	set line color
	call plcol(colline(3))  !color lines
	call plline(mcnt,yr1,x5)                    !plot percent growth change (pgc)
	call plcol(colline(2))
	call plline(age,yr2,x6)  	                   !plot original tree-ring series
       call findrl(x1,x2,x3,x4,x5,mcnt,ify,mw,mpg,mse,iopt,iyor,nrl,mxr)
       call plcol(colline(1))
       do i=1,nrl
         read(iyor(i),'(f4.0)')xrange(1)
         xrange(2)=xrange(1)
         yrange(2)=zlow     !new pjk
         yrange(1)=zhigh    !new pjk
	  call plline(2,xrange,yrange)                 !plot running rbar series
c	  write(*,'(1x,4f8.3)')xrange(1),yrange(1),xrange(2),yrange(2)
       enddo
c
       do i=1,mcnt
        x1(i)=float(mpg)/100.0
       enddo
       do i=1,age
        x4(i)=0.0
       enddo
	call plline(mcnt,yr1,x1)                   !percent growth change threshold
	call plline(age,yr2,x4)                    !zero line	
c	make extra lable on top of plot
	call plmtex('t',6.0,0.2,0.0,id2 )  !modified 2/2008 -pjk
c	set up to write lines of release dates
	if(nrl.lt.10)then
	   lines=1
	else
	   lines=int(nrl/10)
	   if(mod(nrl,10).gt.0)lines=lines+1
	endif
c	invoke extended character set
	call plfontld(1)
c	set font to script
	call plfont(1)
	call blank(lable)
	lable(1:14)='Release dates:'
	k=1
	j=9
	ytext=4.2
       do i=1,lines
         if(i.eq.1)then
            if(nrl.le.10)then
              write(lable(15:70),'(10a5)')(iyor(p),p=1,nrl)
            else
              write(lable(15:70),'(10a5)')(iyor(p),p=k,k+j)
            endif
            call plmtex('t',ytext,0.05,0.0,lable)
         else
            write(lable,'(10a5)')(iyor(p),p=k,k+j)
            call plmtex('t',ytext,0.22,0.0,lable)
         endif
         ytext=ytext-1.5
         k=k+10
         call blank(lable)
         if(k+j.gt.nrl)j=(nrl-k)
       end do   
       
c 	finish bottom and close plplot window
60	call plend()
c
      dev='win3'
c50    open(unit=winu1,file='plotoptionwindow',access='window,290,522,26,388')
51	write(*,'(//15x,''|************* plot options menu **************|'')')
        write(*,'(15x,''| replot             [0]  minor ticks y   [11] |'')')
	write(*,'(15x,''|                         major ticks z   [12] |'')')  !Windows version cannot change background color to black yet
c	write(*,'(15x,''| background color   [1]  major ticks z   [12] |'')')
 	write(*,'(15x,''| frame color        [2]  minor ticks z   [13] |'')')
	write(*,'(15x,''| text color         [3]  max. x          [14] |'')')
	write(*,'(15x,''| line color         [4]  min. x          [15] |'')')
        write(*,'(15x,''| gap fill  color    [5]  max. y          [16] |'')')
        write(*,'(15x,''| line style         [6]  min. y          [17] |'')')
        write(*,'(15x,''| curve width        [7]  max. z          [18] |'')')
        write(*,'(15x,''| major ticks x      [8]  min. z          [19] |'')')
        write(*,'(15x,''| minor ticks x      [9]                  [  ] |'')')
        write(*,'(15x,''| major ticks y     [10]                  [  ] |'')')
	write(*,'(15x,''|                                              |'')')
	write(*,'(15x,''|           reset plot options  [99]           |'')')
	write(*,'(15x,''|----------------------------------------------|'')')
        write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots    |'')') 
        write(*,'(15x,''|______________________________________________|'')')
	write(*,'(/15x,'' enter option number > '',$)')
       read(*,'(a2)')ans
       if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
       elseif((ans.eq.'N ').or.(ans.eq.'n '))then
c        what to do ??????
         iplt=0
c         close(winu1)
         return
       else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
       endif
       if((gopt.gt.0).and.(gopt.le.19))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)        
c         close(winu1)
         goto 51    !50
       else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
       else if(gopt.eq.99)then
c         close(winu1)
         goto 20
       else
        write(*,'(/13x,''unknown option re-enter a valid number'')')
        goto 51
       end if
c
	end
c
c subroutine lalign to left justify character strings
      subroutine lalign(string)
C      Suck up leading spaces
c
      implicit none
      integer i, j, k, max, len
      character*(*) string
c
      max = len(string)
c
      do i = 1, max
        if (string(i:i) .ne. ' ') then
          if (i .eq. 1) return
          k = 1
          do j = i, max
            string(k:k) = string(j:j)
            k = k + 1
          enddo
          do j = k, max
            string(j:j) = ' '
          enddo
          return
        endif
      enddo
      return
      end
*SBR POWER1
*
      subroutine power1(nc,fil,tit)
      integer nc
      character fil*(*),tit*(*)
c
c *** local variables
c
      integer numdata,winu1
      parameter(mxy=5000,mxs=3000,winu1=69)
      integer i,j
      real*4 x1(mxs),y2(mxs),zero(mxs)     
      real*4 x3(4),y3(4)
      character name*50,savefile*80,ans*2,text*50
ccc***      logical saveit,modit,printit
c *** plotstyle variables
      integer*4 gopt,opt,mxvar
      parameter (mxvar=20)
      integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
      integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
      real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      character dev*8
      logical bg
c
      real*4 y(mxy,16)    !was y1 in original power2.f
      common/tsi2/y
c
C Begin Subroutine
C
c
       dev='win3'
20     gopt=99
       call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)     
c                     
25     numdata=nc
       do i=1,nc
        x1(i)=i
        zero(i)=0.0
       enddo
       call blank(name)
       name=fil
       call csr(name,jj,2)
       name(jj+1:jj+9)='_TRN_DATA'
       call csr(name,jj,2)
       savefile=name(1:jj)//'.PLTS'
       xlow=1
       xhigh=numdata
	pinc=0.1	     
c
c set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
       call plgfnam(savefile)
	call plsdev(dev)
	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 initialize plplot
	call plinit()
	call plfontld(1)
	call plfont(1)
c Open a large page for writing a page title on
	call plssub(1,1)
	call pladv(0)
	call plvpor(0.1,0.9,0.1,0.9)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',2.3,0.3,0.0,'DATA TRANSFORM STATISTICS' )     !write page title here
C  Now divide the page into 2x2 plots
       call plssub(2,2)
c
c DRAW TOP_LEFT plot
c 
       ylow=0.0
       yhigh=-9999.0
       do i=1,numdata
        if(y(i,1).lt.ylow)ylow=y(i,1)
        if(y(i,1).gt.yhigh)yhigh=y(i,1)
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
       enddo
	call pladv(0) 
	call plvpor(0.18,0.96,0.15,0.75)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('SERIES','SKEW','BEFORE TRANSFORMATION SKEW')
	call plcol(colsym(1))
	call plpsty(3)
c plot shaded and colored polygons	
	do j=1,numdata
	    x3(1)=real(j)-pinc
	    x3(2)=x3(1)
	    x3(3)=real(j)+pinc
	    x3(4)=x3(3)
	    y3(1)= 0.0
	    y3(2)=y(j,1)
	    y3(3)=y3(2)
	    y3(4)=y3(1)   
	    call plfill(4,x3,y3)
	    call plline(4,x3,y3)
       end do
       CALL MFS(y(1,1),numdata,XMED,HH,HL,FSD,RMN,RMX)
       do i=1,numdata
        y2(i)=xmed
       enddo
       call plcol(colline(1))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,red)                 !plot raw series
       do i=1,numdata
        y2(i)=hh
       enddo
       call plcol(colline(2))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       do i=1,numdata
        y2(i)=hl
       enddo
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       call blank(text)
       text(1:7)='MEDIAN:'
       write(text(8:14),'(f7.2)')xmed
       call lalign(text)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',-0.05,0.36,0.0,text )
c
c Top_Right_plot
c
       ylow=0.0
       yhigh=-9999.0
       do i=1,numdata
        if(y(i,2).lt.ylow)ylow=y(i,2)
        if(y(i,2).gt.yhigh)yhigh=y(i,2)
       enddo
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
	call pladv(0) 
	call plvpor(0.18,0.96,0.15,0.75)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('SERIES','CORRELATION','SPREAD VS. LEVEL CORRELATION')
	call plpsty(3)
	call plcol(colsym(1))
c plot shaded and colored polygons	
	do j=1,numdata
	    x3(1)=real(j)-pinc
	    x3(2)=x3(1)
	    x3(3)=real(j)+pinc
	    x3(4)=x3(3)
	    y3(1)= 0.0
	    y3(2)=y(j,2)
	    y3(3)=y3(2)
	    y3(4)=y3(1)   
	    call plfill(4,x3,y3)
	    call plline(4,x3,y3)
       end do
       CALL MFS(y(1,2),numdata,XMED,HH,HL,FSD,RMN,RMX)
       do i=1,numdata
         y2(i)=xmed
       enddo
       call plcol(colline(1))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,red)                 !plot raw series
       do i=1,numdata
        y2(i)=hh
       enddo
       call plcol(colline(2))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       do i=1,numdata
        y2(i)=hl
       enddo
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       call blank(text)
       text(1:7)='MEDIAN:'
       write(text(8:14),'(f7.2)')xmed
       call lalign(text)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',-0.03,0.36,0.0,text )
c
c Bottom_Left_Plot
c
      ylow=9999.0
      yhigh=-9999.0
      do i=1,numdata
        if(y(i,4).lt.ylow)ylow=y(i,4)
        if(y(i,4).gt.yhigh)yhigh=y(i,4)
      enddo
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
	call pladv(0) 
	call plvpor(0.18,0.96,0.15,0.75)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('SERIES','SKEW','AFTER TRANSFORMATION SKEW')
	call plpsty(3)
       call plcol(colsym(1))
c plot shaded and colored polygons	
	do j=1,numdata
	    x3(1)=real(j)-pinc
	    x3(2)=x3(1)
	    x3(3)=real(j)+pinc
	    x3(4)=x3(3)
	    y3(1)= 0.0
	    y3(2)=y(j,4)
	    y3(3)=y3(2)
	    y3(4)=y3(1)   
	    call plfill(4,x3,y3)
	    call plline(4,x3,y3)
       end do
       call plline(numdata,x1,zero)
       CALL MFS(y(1,4),numdata,XMED,HH,HL,FSD,RMN,RMX)
       do i=1,numdata
        y2(i)=xmed
       enddo
       call plcol(colline(1))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,red)                 !plot raw series
       do i=1,numdata
        y2(i)=hh
       enddo
       call plcol(colline(2))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       do i=1,numdata
        y2(i)=hl
       enddo
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       call blank(text)
       text(1:7)='MEDIAN:'
       write(text(8:14),'(f7.2)')xmed
       call lalign(text)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',-0.02,0.36,0.0,text )
c
c Bottom_Right_plot
c       
       ylow=9999.0
       yhigh=-9999.0
       do i=1,numdata
         if(y(i,5).lt.ylow)ylow=y(i,5)
         if(y(i,5).gt.yhigh)yhigh=y(i,5)
       enddo
	call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
	call pladv(0) 
	call plvpor(0.18,0.96,0.15,0.75)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('SERIES','CORRELATION','SPREAD VS. LEVEL CORRELATION')
       call plcol(colsym(1))
	call plpsty(3)
c plot shaded and colored polygons	
	do j=1,numdata
	    x3(1)=real(j)-pinc
	    x3(2)=x3(1)
	    x3(3)=real(j)+pinc
	    x3(4)=x3(3)
	    y3(1)= 0.0
	    y3(2)=y(j,5)
	    y3(3)=y3(2)
	    y3(4)=y3(1)   
	    call plfill(4,x3,y3)
	    call plline(4,x3,y3)
       end do
       call plline(numdata,x1,zero)
       CALL MFS(y(1,5),numdata,XMED,HH,HL,FSD,RMN,RMX)
       do i=1,numdata
        y2(i)=xmed
       enddo
       call plcol(colline(1))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,red)                 !plot raw series
       do i=1,numdata
        y2(i)=hh
       enddo
       call plcol(colline(2))
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       do i=1,numdata
        y2(i)=hl
       enddo
       call plline(numdata,x1,y2)
ccc      CALL LinePlot(x1,y2,numdata,blue)                 !plot raw series
       call blank(text)
       text(1:7)='MEDIAN:'
       write(text(8:14),'(f7.2)')xmed
       call lalign(text)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',-0.01,0.36,0.0,text )
c
	call plend()
       dev='win3'
       ans='C '
c50     open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51     write(*,'(//15x,''|************** plot options menu *************|'')')
       write(*,'(15x,''| replot            [0] line color         [4] |'')')
       write(*,'(15x,''|                       bar fill  color   [21] |'')')
c       write(*,'(15x,''| background color  [1] bar fill  color   [21] |'')') !no background color change for windows yet
       write(*,'(15x,''| frame color       [2] curve style        [6] |'')')
       write(*,'(15x,''| text color        [3] curve width        [7] |'')')
       write(*,'(15x,''|                                              |'')')
       write(*,'(15x,''|           reset plot options   [99]          |'')')
       write(*,'(15x,''|----------------------------------------------|'')')
       write(*,'(15x,''|              [s]ave  [c]ontinue              |'')') 
       write(*,'(15x,''|______________________________________________|'')')
       write(*,'(/15x,'' enter option number > '',$)')
       read(*,'(a2)')ans
       if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
       else
         read(ans(1:2),'(i2)')gopt
       endif
      if((gopt.gt.0).and.(gopt.le.21))then
c         close(winu1)
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
         goto 51    !50
       else if(gopt.eq.99)then
c         close(winu1)
         goto 20
       else if(gopt.eq.0)then
c         close(winu1)
	  goto 25
	else
	  write(*,'(/13x,''Unknown option re-enter a valid number or letter'')')
	  goto 51
       end if
c
      END
c
c************************************************************************
c MODIFIED 12/06 to use routine scale for extra large x,y,z spans -PJK
	subroutine ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
c
c Argument declarations
	integer mnxtic,mnytic,mnztic
	real*4 xlow,xhigh,ylow,yhigh,zlow,zhigh,mxxtic,mxytic,mxztic
c Local
	integer span,ifault
	real*4 yt1,thigh,tlow
c
c Begin subroutine to define the major and minor tic mark intervals for plotting
c
	span=(xhigh-xlow)
c
c  set major and minor ticks depending on x, y and z range (span)
c xaxis scales


	if(span.le.50)then
	  mxxtic=10.0
	  mnxtic=10
	elseif(span.gt.50.and.span.le.100)then
	  mxxtic=20
	  mnxtic=5
	elseif((span.le.200.0).and.(span.gt.100))then
	  mxxtic=20.0
	  mnxtic=10
	else if(span.le.500.0.and.span.gt.200.0)then
 	  mxxtic=50.0
	  mnxtic=5
	else if(span.le.1000.0.and.span.gt.500.0)then
	  mxxtic=100.0
	  mnxtic=10
	else if(span.le.2000.0.and.span.gt.1000)then
	  mxxtic=250.0
	  mnxtic=5
	elseif(span.gt.2000)then
c determine optimum x scale axis parameters
	  call SCALE(xlow, xhigh, 10, tlow, mxxtic, thigh, IFAULT)
	  xlow=tlow;xhigh=thigh
	  mnxtic=5
	end if
c yaxis scales
c 	round yhigh up or down depending on scale
c	write(*,'(1x,''fromticit yhigh = '',f8.3)')yhigh
	if(yhigh.lt.10)then
	   yt1=amod(yhigh,1.0)
	   if(yt1.le.0.5)then
	    yhigh=yhigh+(0.5-yt1)	
	   else
	    yhigh=yhigh+((1.0-yt1))
	   endif	
	elseif((yhigh.ge.10).and.(yhigh.lt.100))then
	   yt1=amod(yhigh,10.0)
	   if(yt1.le.5.0)then
	     yhigh=yhigh+(5.0-yt1)	
	   else
	     yhigh=yhigh+((10.0-yt1))
	   endif
	elseif(yhigh.ge.100)then
	   yt1=amod(yhigh,100.0)
	   if(yt1.le.50.0)then
	     yhigh=yhigh+(50.0-yt1)	
	   else
	     yhigh=yhigh+((100.0-yt1))
	   endif
	endif
c	write(*,'(1x,''fromticit yt1 = '',f8.3)')yt1
c	write(*,'(1x,''fromticit new yhigh = '',f8.3)')yhigh
c
	if(ylow.ge.0)then
	   span=yhigh-ylow
	else
	   span=yhigh+abs(ylow)
	endif
c
	if(span.le.2.0)then
	  mxytic=0.5
	  mnytic=4
	else if(span.gt.2.0.and.span.le.4.0)then
	  mxytic=1.0
	  mnytic=4
	else if(span.gt.4.0.and.span.le.10.0)then
	  mxytic=2.0
	  mnytic=4
	else if(span.gt.10.0.and.span.le.50.0)then
	  mxytic=5.0
	  mnytic=5
	else if(span.gt.50.and.span.le.100.0)then
	  mxytic=10.0
	  mnytic=2
	else if(span.gt.100.and.span.le.500)then
	  mxytic=100.0
	  mnytic=5
	else if(span.gt.500)then
c determine optimum x scale axis parameters
	  call SCALE(ylow, yhigh, 10, tlow, mxytic, thigh, IFAULT)
	  ylow=tlow;yhigh=thigh
	  mnxtic=5
	end if
c
c zaxis scales
c 	round zhigh up or down depending on scale
c	write(*,'(1x,''fromticit zhigh = '',f8.3)')zhigh
	if(zhigh.lt.10)then
	   yt1=amod(zhigh,1.0)
	   if(yt1.le.0.5)then
	    zhigh=zhigh+(0.5-yt1)	
	   else
	    zhigh=zhigh+((1.0-yt1))
	   endif	
	elseif((zhigh.ge.10).and.(zhigh.lt.100))then
	   yt1=amod(zhigh,10.0)
	   if(yt1.le.5.0)then
	     zhigh=zhigh+(5.0-yt1)	
	   else
	     zhigh=zhigh+((10.0-yt1))
	   endif
	elseif(zhigh.ge.100)then
	   yt1=amod(zhigh,100.0)
	   if(yt1.le.50.0)then
	     zhigh=zhigh+(50.0-yt1)	
	   else
	     zhigh=zhigh+((100.0-yt1))
	   endif
	endif
c	write(*,'(1x,''fromticit yt1 = '',f8.3)')yt1
c	write(*,'(1x,''fromticit new zhigh = '',f8.3)')zhigh
c
	if(zlow.ge.0)then
	   span=zhigh-zlow
	else
	   span=zhigh+abs(zlow)
	endif
c
	if(span.le.2.0)then
	  mxztic=0.5
	  mnztic=4
	else if(span.gt.2.0.and.span.le.4.0)then
	  mxztic=1.0
	  mnztic=4
	else if(span.gt.4.0.and.span.le.10.0)then
	  mxztic=2.0
	  mnztic=4
	else if(span.gt.10.0.and.span.le.50.0)then
	  mxztic=5
	  mnztic=5
	else if(span.gt.50.and.span.le.100.0)then
	  mxztic=10.0
	  mnztic=2
	else if(span.gt.100.and.span.le.500)then
	  mxztic=100.0
	  mnztic=5
	else if(span.gt.500)then
c determine optimum x scale axis parameters
	  call SCALE(zlow, zhigh, 10, tlow, mxztic, thigh, IFAULT)
	  zlow=tlow;zhigh=thigh
	  mnztic=5
	end if
	return
	end


c***********************************************************************
      SUBROUTINE SCALE(FMN, FMX, N, VALMIN, STEP, VALMAX, IFAULT)
C
C     ALGORITHM AS 96  APPL. STATIST. (1976) VOL.25, NO.1
C
C     Given extreme values FMN, FMX, and the need for a scale with N
C     marks, calculates value for the lowest scale mark (VALMIN) and
C     step length (STEP) and highest scale mark (VALMAX).
C
      REAL FMN, FMX, VALMIN, STEP, VALMAX
      INTEGER N, IFAULT
C
C     Units for step lengths
C
      REAL UNIT(11)
C
C     Local variables
C
      INTEGER NUNIT, I, J
      REAL TOL, ZERO, HALF, ONE, TEN, BIAS, FMAX, FMIN, RN, X, S, RANGE
C
C     Array length unit()
C
      DATA NUNIT /11/
C
C     Local constant, defining effective equality of values.
C
      DATA TOL /5.0E-6/
      DATA ZERO /0.0/, HALF /0.5/, ONE /1.0/, TEN /10.0/
      DATA BIAS /1.0E-4/
      DATA UNIT /1.0, 1.2, 1.6, 2.0, 2.5, 3.0, 4.0, 5.0, 6.0, 8.0,
     *        10.0/
C
      FMAX = FMX
      FMIN = FMN
      IFAULT = 1
C
C     Test for valid parameter values
C
      IF (FMAX .LT. FMIN .OR. N .LE. 1) RETURN
      IFAULT = 0
      RN = N - 1
      X = ABS(FMAX)
      IF (X .EQ. ZERO) X = ONE
      IF ((FMAX - FMIN) / X .GT. TOL) GO TO 20
C
C     All values effectively equal
C
      IF (FMAX .LT. ZERO) THEN
        FMAX = ZERO
      ELSE IF (FMAX .EQ. ZERO) THEN
        FMAX = ONE
      ELSE
        FMIN = ZERO
      END IF
C
   20 STEP = (FMAX - FMIN) / RN
      S = STEP
C
C     Find power of 10
C
   25 IF (S .GE. ONE) GO TO 30
      S = S * TEN
      GO TO 25
   30 IF (S .LT. TEN) GO TO 35
      S = S / TEN
      GO TO 30
C
C     Calculate STEP
C
   35 X = S - BIAS
      DO 40 I = 1, NUNIT
        IF (X .LE. UNIT(I)) GO TO 45
   40 CONTINUE
   45 STEP = STEP * UNIT(I) / S
      RANGE = STEP * RN
C
C     Make first estimate of VALMIN
C
      X = HALF * (ONE + (FMIN + FMAX - RANGE) / STEP)
      J = X - BIAS
      IF (X .LT. ZERO) J = J - 1
      VALMIN = STEP * FLOAT(J)
C
C     Test if VALMIN could be zero
C
      IF (FMIN .GE. ZERO .AND. RANGE .GE. FMAX) VALMIN = ZERO
      VALMAX = VALMIN + RANGE
C
C     Test if VALMAX could be zero
C
      IF (FMAX .GT. ZERO .OR. RANGE .LT. -FMIN) RETURN
      VALMAX = ZERO
      VALMIN = -RANGE
      RETURN
      END



*sbr loads1 *********************************************************************
*
c plots pc loadings and varimax factors for each individual series.  makes four plots
c per page god help you if your file contains thousands or series.  -pjk 9/05
      subroutine loads1(ty,nc,np,fil,tit,ird,tmxs,itp,pct,ytp)
      integer tmxs,nc,itp,np,ytp
      real*4 ty(tmxs,7),pct(4)
      character fil*(*),tit*(*)
c
c *** local variables
      integer i,p,j,jj
      real*4 x(500),zeros(500),px(4),py(4),pxinc
      character name*50,savefile*50,title*65,ans*2,text*17
c
c *** plotstyle variables
      integer*4 gopt,opt,mxvar
      parameter (mxvar=20)
      integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
      integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
      real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      character*8 dev
      logical bg
C
C Begin Subroutine
C
      ylow=9999.0;yhigh=-9999.0
c	  write(*,'(1x,''from loads1'')')
c	  write(*,'(1x,''nc= '',i5,/,'' pct= '',4(1x,f6.2))')nc,(pct(i),i=1,4)
c	  write(*,'(1x,''y vals are:'')')
      do i=1,nc
c         write(*,'(1x,i2,2x,7(1x,f8.3))')i,(ty(i,j),j=1,7)
         do j=1,4
          if(ty(i,j).lt.ylow)ylow=ty(i,j)
          if(ty(i,j).gt.yhigh)yhigh=ty(i,j)
         enddo
      enddo
c
      zlow=0.0;zhigh=10.0
      xlow=0.0
      xhigh=real(nc)
c    find the nearest integer around xlow and xhigh ylow yhigh zlow zhigh
      call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
      j=0
      do i=1,nc+1
        x(i)=j
        zeros(i)=0.0
        j=j+1
      enddo
c
      if(itp.eq.2)then
        ylow=-0.5
        yhigh=1.0
        mxytic=0.5
        mnytic=1
      endif
c      write(*,'(/1x,''mxxtic= '',f8.2,'' mnxtic= '',i5,/)')mxxtic,mnxtic
      dev='win3'
      gopt=99
20    call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
	  pen(2)=1
c
      if(np.gt.4)np=4
      call blank(title)
      title=tit
      call blank(name)
      call csr(fil,jj,3)
      name(2:jj+1)=fil(1:jj)
      call blank(title)
      title=name(1:jj+1)//tit
      if(tit(2:4).eq.'raw')then
        if(itp.eq.1)name(jj+1:jj+9)='_raw pcs'
        if(itp.eq.2)name(jj+1:jj+9)='_raw vfs'
      elseif(tit(2:4).eq.'tra')then
        if(itp.eq.1)name(jj+1:jj+9)='_trn pcs'
        if(itp.eq.2)name(jj+1:jj+9)='_trn vfs'
      elseif(tit(2:4).eq.'det')then
        if(itp.eq.1)name(jj+1:jj+9)='_det pcs'
        if(itp.eq.2)name(jj+1:jj+9)='_det vfs'
      elseif(tit(2:4).eq.'res')then
        if(itp.eq.1)name(jj+1:jj+9)='_res pcs'
        if(itp.eq.2)name(jj+1:jj+9)='_res vfs'
      endif
      call csr(name,jj,3)
      savefile=name(1:jj)//'.plts'
c      
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25    call plsdev(dev)
	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   initialize plplot
	  call plinit()
	  call plfontld(1)
	  call plfont(1)
	  call plssub(1,1)
	  call pladv(0)
	  call plvpor(0.1,0.9,0.1,0.9)          !left, right, bottom, top
	  call plcol(coltext)                   !color box and lables
	  call plmtex('t',2.8,0.05,0.0,tit) !2.3
C    Divide page into 2x2 plots
      call plssub(2,2)
      pxinc=xhigh/nc
c
c    make all four plots beginning with the upper left, then upper right, 
c    then lower left then lower right.
c
c	  do p = 1, 4       ! loop to make all four plots
c DRAW Top_left plot	
	  p=1
	  call pladv(0) 
c	    call plsvpa(30.0,165.0,20.0,90.0)    !millimeters from viewport origin lowerleft
	  call plvpor(0.2,0.9,0.1,0.75)
	  call plwind(xlow,xhigh,ylow,yhigh)
c    set box color
	  call plcol(colbox)                    !color box and lables
        if(nc.le.10)then
           mxxtic=1.0
           mnxtic=0
	       call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
	    else
	       call plaxes (xlow,ylow,'abitnrs',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
        endif
c    set lable color
	  call plcol(coltext)                   !color box and lables
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')p
        write(text(6:11),'(f5.1)')pct(p)
        text(11:11)='%'
	  call pllab(' ','loadings',text)
	  call plcol(colline(2))
	  call plpsty(3)
c    define x coordinates for making equal sized polygons y high
        px(1)=0.0
        px(2)=0.0
        px(3)=pxinc  
        px(4)=px(3) 
	  do j=1,nc
	      py(1)=0.0
	      py(2)=ty(j,p)
	      py(3)=py(2)
	      py(4)=py(1)
c	      write(*,'(1x,4(1x,i4,1x,4f8.4))')j,(px(i),i=1,4)
	      call plfill(4,px,py)
	      call plline(4,px,py)
	      px(1)=px(4)
	      px(2)=px(4)
	      px(3)=px(4)+pxinc
	      px(4)=px(3)
        end do  
        call plcol(colline(1))
        call plwid(pen(2))
        call pllsty(pen(1))
        call plline(nc+1,x,zeros)
	    call plcol(colline(2))
        call plwid(1)
        call pllsty(1)
c
c Top_Right_plot
c
	  p=2
	  call pladv(0) 
c	    call plsvpa(30.0,165.0,20.0,90.0)    !millimeters from viewport origin lowerleft
	  call plvpor(0.2,0.9,0.1,0.75)
	  call plwind(xlow,xhigh,ylow,yhigh)
c    set box color
	  call plcol(colbox)                    !color box and lables
        if(nc.le.10)then
           mxxtic=1.0
           mnxtic=0
	       call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
	    else
	       call plaxes (xlow,ylow,'abitnrs',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
        endif
c    set lable color
	  call plcol(coltext)                   !color box and lables
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')p
        write(text(6:11),'(f5.1)')pct(p)
        text(11:11)='%'
	  call pllab(' ','loadings',text)
	  call plcol(colline(2))
	  call plpsty(3)
c    define x coordinates for making equal sized polygons y high
        px(1)=0.0
        px(2)=0.0
        px(3)=pxinc  
        px(4)=px(3) 
	  do j=1,nc
	      py(1)=0.0
	      py(2)=ty(j,p)
	      py(3)=py(2)
	      py(4)=py(1)
c	      write(*,'(1x,4(1x,i4,1x,4f8.4))')j,(px(i),i=1,4)
	      call plfill(4,px,py)
	      call plline(4,px,py)
	      px(1)=px(4)
	      px(2)=px(4)
	      px(3)=px(4)+pxinc
	      px(4)=px(3)
        end do  
        call plcol(colline(1))
        call plwid(pen(2))
        call pllsty(pen(1))
        call plline(nc+1,x,zeros)
	    call plcol(colline(2))
        call plwid(1)
        call pllsty(1)
c
c Bottom_Left_Plot
c
	  p=3
	  call pladv(0) 
c	    call plsvpa(30.0,165.0,20.0,90.0)    !millimeters from viewport origin lowerleft
	  call plvpor(0.2,0.9,0.2,0.85)
	  call plwind(xlow,xhigh,ylow,yhigh)
c    set box color
	  call plcol(colbox)                    !color box and lables
        if(nc.le.10)then
           mxxtic=1.0
           mnxtic=0
	       call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
	    else
	       call plaxes (xlow,ylow,'abitnrs',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
        endif
c    set lable color
	  call plcol(coltext)                   !color box and lables
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')p
        write(text(6:11),'(f5.1)')pct(p)
        text(11:11)='%'
	  call pllab('series','loadings',text)
	  call plcol(colline(2))
	  call plpsty(3)
c    define x coordinates for making equal sized polygons y high
        px(1)=0.0
        px(2)=0.0
        px(3)=pxinc  
        px(4)=px(3) 
	  do j=1,nc
	      py(1)=0.0
	      py(2)=ty(j,p)
	      py(3)=py(2)
	      py(4)=py(1)
c	      write(*,'(1x,4(1x,i4,1x,4f8.4))')j,(px(i),i=1,4)
	      call plfill(4,px,py)
	      call plline(4,px,py)
	      px(1)=px(4)
	      px(2)=px(4)
	      px(3)=px(4)+pxinc
	      px(4)=px(3)
        end do  
        call plcol(colline(1))
        call plwid(pen(2))
        call pllsty(pen(1))
        call plline(nc+1,x,zeros)
	    call plcol(colline(2))
        call plwid(1)
        call pllsty(1)
c
c Bottom_Right_plot
c
	  p=4
	  call pladv(0) 
c	    call plsvpa(30.0,165.0,20.0,90.0)    !millimeters from viewport origin lowerleft
	  call plvpor(0.2,0.9,0.2,0.85)
	  call plwind(xlow,xhigh,ylow,yhigh)
c    set box color
	  call plcol(colbox)                    !color box and lables
        if(nc.le.10)then
           mxxtic=1.0
           mnxtic=0
	       call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
	    else
	       call plaxes (xlow,ylow,'abitnrs',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
        endif
c    set lable color
	  call plcol(coltext)                   !color box and lables
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')p
        write(text(6:11),'(f5.1)')pct(p)
        text(11:11)='%'
	  call pllab('series','loadings',text)
	  call plcol(colline(2))
	  call plpsty(3)
c    define x coordinates for making equal sized polygons y high
        px(1)=0.0
        px(2)=0.0
        px(3)=pxinc  
        px(4)=px(3) 
	  do j=1,nc
	      py(1)=0.0
	      py(2)=ty(j,p)
	      py(3)=py(2)
	      py(4)=py(1)
c	      write(*,'(1x,4(1x,i4,1x,4f8.4))')j,(px(i),i=1,4)
	      call plfill(4,px,py)
	      call plline(4,px,py)
	      px(1)=px(4)
	      px(2)=px(4)
	      px(3)=px(4)+pxinc
	      px(4)=px(3)
        end do  
        call plcol(colline(1))
        call plwid(pen(2))
        call pllsty(pen(1))
        call plline(nc+1,x,zeros)
	    call plcol(colline(2))
        call plwid(1)
        call pllsty(1)
c
c	  end do    ! p=1,4
c
	  call plend()
c
      ans='C '
	dev='win3'
	gopt=0
c50    open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51    write(*,'(//15x,''|************* plot options menu ***************|'')')
      write(*,'(15x,''| replot             [0] line color         [4] |'')')
      write(*,'(15x,''|                        bar fill  color    [5] |'')')
c      write(*,'(15x,''| background color   [1] bar fill  color    [5] |'')')
      write(*,'(15x,''| frame color        [2] curve style        [6] |'')')
      write(*,'(15x,''| text color         [3] curve width        [7] |'')')
      write(*,'(15x,''|                                               |'')')
      write(*,'(15x,''|              reset options  [99]              |'')')
      write(*,'(15x,''|-----------------------------------------------|'')')
      write(*,'(15x,''|             [s]ave   <[c]ontinue>             |'')') 
      write(*,'(15x,''|_______________________________________________|'')')
      write(*,'(/15x,'' enter option number > '',$)')
      read(*,'(a2)')ans
      if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *       (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
      elseif((ans.eq.'N ').or.(ans.eq.'n '))then
         if(ird.le.5)ird=0
         if(ird.eq.6)ird=5
c         close(winu1)
         return
      else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
      endif
      if((gopt.gt.0).and.(gopt.le.7))then
c         close(winu1)
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
         goto 51    !50
      else if(gopt.eq.99)then
c         close(winu1)
         goto 20
      else if(gopt.eq.0)then
c        close(winu1)
         goto 25
      else
	     write(*,'(/13x,''Unknown option '',a,'' re-enter a valid choise'')')ans
         goto 51
      end if
c
      end
c      
*sbr scores1 ************************************************************************
*
      subroutine scores1(x,idate,nc,fil,tit,ird,mxy,mxs,pct,itp,ytp)
c
c    plots principle components and varimax scores from times series data
c    using plplot.  pjk_9/2005
c
c    argument declarations
      integer idate(2),mxy,mxs,nc,ird,itp,ytp
      real*4 x(mxy,mxs),pct(4)
      character fil*(*),tit*(*)
c	  
c    local declarations
      integer nyr,j,i,jj,kk
      real*4 xm,crn(5000),year(5000)
      character name*50,savefile*50,id*65
      character ans*2,text*17      !text*23
c
c    plotstyle variables
      integer*4 gopt,opt,mxvar
      parameter (mxvar=20)
      integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
      integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
      real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      character*8 dev
      logical bg
c
c
c ********************************************************************
c
c	  write(*,'(1x,''from scores1'')')
c	  write(*,'(1x,''nc= '',i5,/,'' pct= '',4(1x,f6.2))')nc,(pct(i),i=1,4)
      xlow=idate(1); xhigh=idate(2)
      nyr=idate(2)-idate(1)+1
c
      do i=1,nyr
        year(i)=idate(1)+i-1
      enddo
c
      call blank(name)
c      name=fil
      call csr(name,jj,3)
      do j=1,jj
        kk=jj-j+1
        name(kk+9:kk+9)=name(kk:kk)
      enddo
      do j=1,9
        name(j:j)=' '
      enddo
      id=name(1:jj+10)//tit
      call blank(name)
      name=fil
      goto(1,2,3,4),itp
    1 call csr(name,jj,3)
      name(jj+1:jj+9)='_raw data'
      goto 10
    2 call csr(name,jj,3)
      name(jj+1:jj+9)='_trn data'
      goto 10
    3 call csr(name,jj,3)
      name(jj+1:jj+9)='_std data'
      goto 10
    4 call csr(name,jj,3)
      name(jj+1:jj+9)='_res data'
10	  call csr(name,jj,3)
      savefile=name(1:jj)//'.plts'
c
c	  start plotting 
20	  dev='win3'
	  gopt=99
      call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)   
      pen(2)=1                       
c
      ylow=0.0; yhigh=10.0
      zlow=0.0; zhigh=10.0
	  call ticit(xlow,xhigh,ylow,yhigh,zlow,zhigh,mnxtic,mnytic,mnztic,
     *                    mxxtic,mxytic,mxztic)
      ylow=-3.0; yhigh=3.0
      mnytic=2; mxytic=1.0
c
c    set up plplot window parameters for all plotting
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
c    set device: dev='win3' WindowsPCs
c    set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25    call plsdev(dev)
	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						      white is desired.
c    initialize plplot
      call plinit()
      call plfontld(1)
      call plfont(1)
      call plssub(1,1)
      call pladv(0)
      call plvpor(0.1,0.9,0.1,0.9)
      call plcol(coltext)                   !color box and lables
      call plmtex('t',3.1,-0.06,0.0,id )
c    divide plot window into 1x4 frames
      call plssub(1,4)
c
      j=1 !draw top plot
      call pladv(0) 
	  call plvpor(0.07,0.95,0.185,0.86)
c      call plsvpa(30.0,330.0,14.0,48.5)    !millimeters from viewport origin lowerleft
      call plwind(xlow,xhigh,ylow,yhigh)
      call blank(text)
      if(ytp.eq.1)text(1:3)='PC_'
      if(ytp.eq.2)text(1:3)='VF_'
      write(text(4:4),'(i1)')j
      write(text(5:11),'(f5.1)')pct(j)
      text(10:10)="%"
c    set box color
	 call plcol(colbox)   !color box and lables
	 call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c    set lable color
	 call plcol(coltext)   !color box and lables
	 call pllab(' ',text,' ')          ! lable x and y axis and plot title
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
	 xm=0.0
	 do i=1,nyr
          crn(i)=x(i,j)
          xm=xm+crn(i)                        !sum y's
        enddo
        call plline(nyr,year,crn)                !plot raw series
        xm=xm/float(nyr)
        do i=1,nyr
          crn(i)=xm
        enddo
c    set curve width
        call plwid(pen(2))     !widen pen for mean curve
c    set curve color
	 call plcol(colline(2))  !color mean curve
        call plline(nyr,year,crn)                !plot mean series
c    set line width
	 call plwid(pen(1))
c    set line color
	  call plcol(colline(1))  !color lines
c
      j=2 !draw middle top plot
        call pladv(0) 
        call plvpor(0.07,0.95,0.25,0.92)
c	    call plsvpa(30.0,330.0,14.0,48.5)    !millimeters from viewport origin lowerleft
        call plwind(xlow,xhigh,ylow,yhigh)
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')j
        write(text(5:11),'(f5.1)')pct(j)
        text(10:10)="%"
c    set box color
	 call plcol(colbox)   !color box and lables
	 call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c    set lable color
	 call plcol(coltext)   !color box and lables
	 call pllab(' ',text,' ')          ! lable x and y axis and plot title
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
	 xm=0.0
	 do i=1,nyr
          crn(i)=x(i,j)
          xm=xm+crn(i)                        !sum y's
        enddo
        call plline(nyr,year,crn)                !plot raw series
        xm=xm/float(nyr)
        do i=1,nyr
          crn(i)=xm
        enddo
c    set curve width
        call plwid(pen(2))     !widen pen for mean curve
c    set curve color
	 call plcol(colline(2))  !color mean curve
        call plline(nyr,year,crn)                !plot mean series
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
c
	 j=3 !draw middle bottom
        call pladv(0) 
        call plvpor(0.07,0.95,0.25,0.96)
c        call plsvpa(30.0,330.0,14.0,48.5)    !millimeters from viewport origin lowerleft
        call plwind(xlow,xhigh,ylow,yhigh)
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')j
        write(text(5:11),'(f5.1)')pct(j)
        text(10:10)="%"
c    set box color
	 call plcol(colbox)   !color box and lables
	 call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c    set lable color
	 call plcol(coltext)   !color box and lables
	 call pllab(' ',text,' ')          ! lable x and y axis and plot title
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
	 xm=0.0
	 do i=1,nyr
          crn(i)=x(i,j)
          xm=xm+crn(i)                        !sum y's
        enddo
        call plline(nyr,year,crn)                !plot raw series
        xm=xm/float(nyr)
        do i=1,nyr
          crn(i)=xm
        enddo
c    set curve width
        call plwid(pen(2))     !widen pen for mean curve
c    set curve color
	 call plcol(colline(2))  !color mean curve
        call plline(nyr,year,crn)                !plot mean series
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
c
	 j=4 !draw bottom
        call pladv(0) 
        call plvpor(0.07,0.95,0.25,0.96)
c        call plsvpa(30.0,330.0,14.0,48.5)    !millimeters from viewport origin lowerleft
        call plwind(xlow,xhigh,ylow,yhigh)
        call blank(text)
        if(ytp.eq.1)text(1:3)='PC_'
        if(ytp.eq.2)text(1:3)='VF_'
        write(text(4:4),'(i1)')j
        write(text(5:11),'(f5.1)')pct(j)
        text(10:10)="%"
c    set box color
	 call plcol(colbox)   !color box and lables
	 call plaxes (xlow,ylow,'abinst',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c    set lable color
	 call plcol(coltext)   !color box and lables
	 call pllab('year',text,' ')          ! lable x and y axis and plot title
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
	 xm=0.0
	 do i=1,nyr
          crn(i)=x(i,j)
          xm=xm+crn(i)                        !sum y's
        enddo
        call plline(nyr,year,crn)                !plot raw series
        xm=xm/float(nyr)
        do i=1,nyr
          crn(i)=xm
        enddo
c    set curve width
        call plwid(pen(2))     !widen pen for mean curve
c    set curve color
	 call plcol(colline(2))  !color mean curve
        call plline(nyr,year,crn)                !plot mean series
c    set line width
	 call plwid(pen(1))
c    set line color
	 call plcol(colline(1))  !color lines
c
c      enddo
c
      call plend()
c
      ans='c '
      dev='win3'
      gopt=0
c50	open(unit=winu1,file='plotoptionwindow',access='window,290,522,26,388')
51    write(*,'(//15x,''|************* plot options menu **************|'')')
      write(*,'(15x,''| replot             [0]  minor ticks y   [11] |'')')
c      write(*,'(15x,''| background color   [1]  max. x          [14] |'')')
      write(*,'(15x,''|                         max. x          [14] |'')')
      write(*,'(15x,''| frame color        [2]  min. x          [15] |'')')
      write(*,'(15x,''| text color         [3]  max. y          [16] |'')')
      write(*,'(15x,''| line color         [4]  min. y          [17] |'')')
      write(*,'(15x,''| curve  color       [5]                       |'')')
      write(*,'(15x,''| line style         [6]                       |'')')
      write(*,'(15x,''| curve width        [7]                       |'')')
      write(*,'(15x,''| major ticks x      [8]                       |'')')
      write(*,'(15x,''| minor ticks x      [9]                       |'')')
      write(*,'(15x,''| major ticks y     [10]                       |'')')
      write(*,'(15x,''|                                              |'')')
      write(*,'(15x,''|              reset options  [99]             |'')')
      write(*,'(15x,''|----------------------------------------------|'')')
      write(*,'(15x,''|    [s]ave   <[c]ontinue>  [n]o more plots    |'')') 
      write(*,'(15x,''|______________________________________________|'')')
	  write(*,'(/15x,'' enter option number > '',$)')
      read(*,'(a2)')ans
      if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
      elseif((ans.eq.'N ').or.(ans.eq.'n '))then
         if(ird.le.5)ird=0
         if(ird.eq.6)ird=5
         return
      else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt then continue
      endif
      if((gopt.gt.0).and.(gopt.le.17))then
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
c         close(winu1)
         goto 51  !50
      else if(gopt.eq.0)then
c         close(winu1)
         goto 25    !replot
      else if(gopt.eq.99)then
c         close(winu1)
         goto 20
      else
        write(*,'(/13x,''unknown option. please enter a valid request'')')
        goto 51
      end if
c
	return
	end
*SBR ARHIST1
*
      subroutine arhist1(x,nlv,ipr,fil1,maxn,ird)
      integer nlv,ipr,maxn,ird
      real*4 x(nlv,4)
      character fil1*40
c
c *** local variables 
      real*4 x2(10),y2(11),seac(11)
      integer i,j,k,numdata,jpr,winu1
      parameter(winu1=69)
      real*4 x1(11),y1(11,4),xrange(2),yrange(2),rnt
      real*4 px(4),py(4),pinc
      character name*40,savefile*60,id*65,dev*8,ans*2
c *** plotstyle variables
      integer*4 gopt,opt,mxvar
      parameter (mxvar=20)
      integer*4 red,green,blue,pen(mxvar),colline(mxvar),coltext,colbox
      integer*4 mnxtic,mnytic,mnztic,symbol(mxvar),colsym(mxvar)
      real*4 mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,zhigh,zlow
      logical bg
c
C Begin Subroutine
C
      dev='win3'
      gopt=99
20    call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                          
c
      numdata=nlv
      jpr=ipr
      rnt=maxn
      do i=1,11
        x1(i)=real(i-1)
      enddo
      rmax=-999.0
      rmin=999.0
      do j=1,4
        do i=1,11
          y1(i,j)=0.0
          y1(i,j)=x(i,j)
          if(y1(i,j).gt.rmax)rmax=y1(i,j)
          if(y1(i,j).lt.rmin)rmin=y1(i,j)
        enddo
      enddo
      xrange(1)=0.0
      xrange(2)=10
      yrange(1)=rmin
      yrange(2)=rmax
      if(yrange(2).gt.1.0)yrange(2)=1.0
      call blank(name)
      name=fil1
      call csr(name,jj,2)
      id=name(1:jj+6)//'POOLED AUTOREGRESSION RESULTS'
      name(jj+1:jj+9)='_ACF_DATA'
      call csr(name,jj,2)
      savefile=name(1:jj)//'.PLTS'
c
	xlow=0.0
	xhigh=10.5
	ylow=-0.5
	yhigh=1.0
	mxxtic=1.0
	mxytic=0.5
	mnxtic=0
	mnytic=0
	colline(1)=1
	colline(2)=9
c
c set device: dev='win3'(terminal), dev='psc'(color postscript), dev='ps'(monochrome ps)
25	call plsdev(dev)
	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							white is desired.
c initialize plplot
	call plinit()
	call plfontld(1)
	call plfont(1)
	call plssub(1,1)
	call pladv(0)
	call plvpor(0.1,0.9,0.1,0.9)
	call plcol(coltext)                   !color box and lables
	call plmtex('t',2.3,0.05,0.0,id )
C      Divide page into 2x2 plots
       call plssub(2,2)
c
c DRAW TOP_LEFT plot
c
	px(1)=0.0
	px(2)=0.0
	px(3)=0.40
	px(4)=0.40
	pinc=0.75
	call pladv(0) 
	call plvpor(0.2,0.9,0.1,0.75)

	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
c	call plmtex('b',6.5,0.36,0.0,title2 )
	call pllab(' ','coeffs','autocorrelations')
	call plcol(colline(2))
	call plpsty(3)
	do j=1,11
	  py(1)=0.0
	  py(2)=y1(j,1)
	  py(3)=py(2)
	  py(4)=py(1)
	  call plfill(4,px,py)
	  call plline(4,px,py)
	  if(j.eq.1)then
	     px(1)=px(4)+0.25
	  else
	     do i=1,4
	       px(i)=px(i)+0.25
	     end do
	     px(1)=px(1)+pinc
	  endif
	  px(2)=px(1)
	  px(3)=px(1)+pinc
	  px(4)=px(3)
	end do  
c
       seac(1)=2.0/sqrt(rnt)
       pseac=seac(1)
       do i=2,11
	  sm=0.
	  k=i-1
	  DO j=1,k
	    sm=sm+y1(i,1)*y1(i,1)
         enddo
   	  seac(i)=sqrt(1.0+2.0*sm)*2.0/sqrt(rnt)
         x2(i-1)=i-1
       enddo
       call plcol(colline(1))
       call plwid(pen(2))
       call pllsty(pen(1))
       call plline(10,x2,seac)                 !plot raw series
       do i=1,11
        y2(i)=0.0
        seac(i)=-seac(i)
       enddo
       call plline(10,x2,seac)                 !plot raw series
       call plcol(15)
       call plwid(1)
       call pllsty(1)
       call plline(numdata,x1,y2)                 !plot raw series
c
c Top_Right_plot
c
	px(1)=0.0
	px(2)=0.0
	px(3)=0.40
	px(4)=0.40
	call pladv(0) 
	call plvpor(0.2,0.9,0.1,0.75)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab(' ','coeffs',' partial autocorrelations')
	call plpsty(3)
	call plcol(colline(2))
	do j=1,11
	  py(1)=0.0
	  py(2)=y1(j,2)
	  py(3)=py(2)
	  py(4)=py(1)
	  call plfill(4,px,py)
	  call plline(4,px,py)
	  if(j.eq.1)then
	     px(1)=px(4)+0.25
	  else
	     do i=1,4
	       px(i)=px(i)+0.25
	     end do
	     px(1)=px(1)+pinc
	  endif
	  px(2)=px(1)
	  px(3)=px(1)+pinc
	  px(4)=px(3)
	end do  
c
       DO I=1,11
   	    seac(I)=pseac
       enddo
       call plcol(colline(1))
       call plwid(pen(2))
       call pllsty(pen(1))
       CALL plline(10,x2,seac)                 !plot raw series
       DO I=1,11
   	    seac(I)=-pseac
       enddo
       CALL plline(10,x2,seac)                 !plot raw series
       call plwid(1)
       call pllsty(1)
       call plcol(15)
       CALL plline(11,x1,y2)                 !plot raw series
c
c Bottom_Left_Plot
c
	px(1)=0.0
	px(2)=0.0
	px(3)=0.40
	px(4)=0.40
	call pladv(0) 
	call plvpor(0.2,0.9,0.2,0.85)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('lags','coeffs','autoregressive model')
	call plpsty(3)
       call plcol(colline(2))
	do j=1,11
	  py(1)=0.0
	  py(2)=y1(j,3)
	  py(3)=py(2)
	  py(4)=py(1)
	  call plfill(4,px,py)
	  call plline(4,px,py)
	  if(j.eq.1)then
	     px(1)=px(4)+0.25
	  else
	     do i=1,4
	       px(i)=px(i)+0.25
	     end do
	     px(1)=px(1)+pinc
	  endif
	  px(2)=px(1)
	  px(3)=px(1)+pinc
	  px(4)=px(3)
	end do  
       call plcol(15)
       call plline(11,x1,y2)                 !plot raw series
c
c Bottom_Right_plot
	px(1)=0.0
	px(2)=0.0
	px(3)=0.40
	px(4)=0.40
	call pladv(0) 
	call plvpor(0.2,0.9,0.2,0.85)
	call plwind(xlow,xhigh,ylow,yhigh)
c set box color
	call plcol(colbox)                    !color box and lables
	call plaxes (xlow,ylow,'abitnr',mxxtic,mnxtic,'abinstv',mxytic,mnytic)
c set lable color
	call plcol(coltext)                   !color box and lables
	call pllab('lags','coeffs','impulse response function')
	call plpsty(3)
       call plcol(colline(2))
	do j=1,11
	  py(1)=0.0
	  py(2)=y1(j,4)
	  py(3)=py(2)
	  py(4)=py(1)
	  call plfill(4,px,py)
	  call plline(4,px,py)
	  if(j.eq.1)then
	     px(1)=px(4)+0.25
	  else
	     do i=1,4
	       px(i)=px(i)+0.25
	     end do
	     px(1)=px(1)+pinc
	  endif
	  px(2)=px(1)
	  px(3)=px(1)+pinc
	  px(4)=px(3)
	end do  
       call plcol(15)
       call plline(11,x1,y2)                 !plot raw series
	call plend()
       ans='C '
	dev='win3'
	gopt=0
c50    open(unit=winu1,file='PlotOptionWindow',ACCESS='window,290,522,26,388')
51    write(*,'(//15x,''|************* plot options menu ***************|'')')
      write(*,'(15x,''| replot             [0] line color         [4] |'')')
      write(*,'(15x,''|                        bar fill  color    [5] |'')')
c      write(*,'(15x,''| background color   [1] bar fill  color    [5] |'')')
      write(*,'(15x,''| frame color        [2] curve style        [6] |'')')
      write(*,'(15x,''| text color         [3] curve width        [7] |'')')
      write(*,'(15x,''|                                               |'')')
      write(*,'(15x,''|              reset options  [99]              |'')')
      write(*,'(15x,''|-----------------------------------------------|'')')
      write(*,'(15x,''|             [s]ave   <[c]ontinue>             |'')') 
      write(*,'(15x,''|_______________________________________________|'')')
      write(*,'(/15x,'' enter option number > '',$)')
      read(*,'(a2)')ans
      if((ans.eq.'S ').or.(ans.eq.'s '))then
         dev='psc'
         call plgfnam(savefile)
c         close(winu1)
         goto 25
      elseif((ans.eq.'C ').or.(ans.eq.'c ').or.(ans.eq.'  ').or.
     *                             (ans.eq.'Y ').or.(ans.eq.'y '))then
c         close(winu1)
         return
      elseif((ans.eq.'N ').or.(ans.eq.'n '))then
c        what to do ??????
c         close(winu1)
         return
      else
         read(ans(1:2),'(i2)')gopt     !convert ans to gopt
      endif
      if((gopt.gt.0).and.(gopt.le.7))then
c         close(winu1)
         call arspltstyle(dev,gopt,opt,mxvar,red,green,blue,pen,colline,
     *       coltext,colbox,mnxtic,mnytic,mnztic,symbol,colsym,
     *       mxxtic,mxytic,mxztic,xhigh,xlow,yhigh,ylow,
     *       zhigh,zlow,bg)                         
         goto 51    !50
      else if(gopt.eq.99)then
c         close(winu1)
         goto 20
      else if(gopt.eq.0)then
c         close(winu1)
         goto 25
      else
	 write(*,'(/13x,''Unknown option '',a,'' re-enter a valid choise'')')ans
        goto 51
      end if
c
	end
c
*sbr robsum
*
c MODIFIED 12/06 ERC to fix the problem in robsum that caused the biwgt plots to choke
c occasionally when there is a true gap in the chronology.
c
	subroutine robsum(ns,y2,y3,z,wrk1,wrk2,wrk3,wrk4,wrk5,gmn,
     *rbar,ct,bierr,shl,shh)
	parameter(mxy=5000,mxs=3000)
	real*4 z(mxy),y2(mxy),y3(mxy),rmeta(20)
	real*4 wrk1(mxy),wrk2(mxy),wrk3(mxy),wrk4(mxy),wrk5(mxy)
	real*4 cfs(3,10,4),bierr(mxy),acr(12),pac(12),seac(12)
	real*4 wgt(mxs),swgts(mxs),shl(mxy),shh(mxy),mcconf(8)
	real*4 crnsave(mxy)
	integer ns(mxy),nss(mxy),keep(mxs)
	character iout(32),ct,tag*3,fil*40,tit*85
c
c *** common block variables
c
	integer jems(30,5),ndd
       character go,cpm*8,cpm1*8,pixels,bd,bf,q*2,qq*2,
     * q3*2,cvp,fil1*40,itrdb(3)*85
c
c *** common block chunks
c
      common/logunits/iu9,iu10,iu11,iu12,iu13,iu14,iu15,iu16,
     *     iu17,iu18,iu19,iu20,iu21,iu30,iu31,iu32,iu33,iu34,
     *     iu35,iu36,iu37,iu38,iu39
      common/commands/go,cpm,cpm1,pixels,bd,bf,
     *     q,qq,q3,cvp,fil1,itrdb
      common/icommands/jems,ndd
c
c *** tsi graphics stuff
c
      real*4 x(mxy,mxs),crn(mxy)
      integer idate(mxs+2,10)
      character ident(mxs)*8
      common/tsi1/x,crn,idate,ident,nc
c
      common /rand/ ix,iy,iz
      ix=12848
      iy=13079
      iz=22085
c
      idt=jems(4,1)
      krb1=jems(12,1)
      krb2=jems(12,2)
      krb3=jems(12,3)
      isb=jems(13,1)
      ipo=jems(17,1)
      ics=jems(18,1)
      ird=jems(19,1)
      if(krb1.eq.1)then
        if(ct.eq.'n')then
          write(*,'(/1x,''calculate the gaussian raw data '',
     *      ''chronology'')')
        elseif(ct.eq.'s')then
          write(*,'(/1x,''calculate the gaussian standard tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'r')then
          write(*,'(/1x,''calculate the gaussian residual tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'b')then
          write(*,'(/1x,''calculate the gaussian age-aligned rcs '',
     *      ''chronology'')')
        endif
      elseif(krb1.eq.2)then
        if(ct.eq.'n')then
          write(*,'(/1x,''calculate the robust raw data '',
     *      ''chronology'')')
        elseif(ct.eq.'s')then
          write(*,'(/1x,''calculate the robust standard tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'r')then
          write(*,'(/1x,''calculate the robust residual tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'b')then
          write(*,'(/1x,''calculate the robust age-aligned rcs '',
     *      ''chronology'')')
        endif
      elseif(krb1.lt.0)then
        if(ct.eq.'n')then
          write(*,'(/1x,''calculate the quantile raw data '',
     *      ''chronology'')')
        elseif(ct.eq.'s')then
          write(*,'(/1x,''calculate the quantile standard tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'r')then
          write(*,'(/1x,''calculate the quantile residual tree-ring '',
     *      ''chronology'')')
        elseif(ct.eq.'b')then
          write(*,'(/1x,''calculate the quantile age-aligned rcs '',
     *      ''chronology'')')
        endif
      endif
      if(ct.ne.'b')then
        ifmny=idate(nc+1,1)
        ilmxy=idate(nc+1,2)
        maxn=ilmxy-ifmny+1
      else
        ifmny=idate(nc+2,1)
        ilmxy=idate(nc+2,2)
        maxn=ilmxy-ifmny+1
      endif
      if(ipo.ge.3)then
        if(krb1.eq.1)then
          if(ct.eq.'n')then
            write(iu11,'(/t10,''gaussian mean raw data '',
     *        ''chronology'')')
          elseif(ct.eq.'s')then
            write(iu11,'(/t10,''gaussian mean standard '',
     *        ''chronology'')')
          elseif(ct.eq.'r')then
            write(iu11,'(/t10,''gaussian mean residual '',
     *        ''chronology'')')
          elseif(ct.eq.'b')then
            write(iu11,'(/t10,''gaussian mean age-aligned ''
     *        ''chronology'')')
          endif
        elseif(krb1.eq.2)then
          if(ct.eq.'n')then
            write(iu11,'(/t11,''robust mean raw data '',
     *        ''chronology'')')
          elseif(ct.eq.'s')then
            write(iu11,'(/t11,''robust mean standard chronology'')')
          elseif(ct.eq.'r')then
            write(iu11,'(/t11,''robust mean residual chronology'')')
          elseif(ct.eq.'b')then
            write(iu11,'(/t11,''robust mean age-aligned chronology'')')
          endif
        elseif(krb1.lt.0)then
          if(ct.eq.'n')then
            write(iu11,'(/t11,i3,''th quantile raw data chronology'')')
     *        iabs(krb1)
          elseif(ct.eq.'s')then
            write(iu11,'(/t11,i3,''th quantile standard chronology'')')
     *        iabs(krb1)
          elseif(ct.eq.'r')then
            write(iu11,'(/t11,i3,''th quantile residual chronology'')')
     *        iabs(krb1)
          elseif(ct.eq.'b')then
            write(iu11,'(/t11,i3,''th quantile age-aligned '',
     *        ''chronology'')')iabs(krb1)
          endif
        endif
        if(ct.eq.'n'.or.ct.eq.'b')then
          write(iu11,'(t57,''    measurement units'')')      
        else
          write(iu11,'(t57,''       indices'')')
        endif
        if((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.0.20)then
          write(iu11,'(t2,'' year   cores   mean   std dev   '',
     *      ''std err    eff  iter  0-------0.1-------0.2--->'')')
        elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.0.50)then
          write(iu11,'(t2,'' year   cores   mean   std dev   '',
     *      ''std err    eff  iter  0----:---1/2---:----1--->'')')
        elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.1.0)then
          write(iu11,'(t2,'' year   cores   mean   std dev   '',
     *      ''std err    eff  iter  0----:----1----:----2--->'')')
        elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.gt.2.0)then
          write(iu11,'(t2,'' year   cores   mean   std dev   '',
     *      ''std err    eff  iter  0----1----2----3----4--->'')')
        else
          write(iu11,'(t2,'' year   cores   mean   std dev   '',
     *      ''std err    eff  iter  0----:----1----:----2--->'')')
        endif
      endif
      neff=0
      meff=0
      if((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.0.20)then
        units=0.30/31.0
        jp4=nint(0.0/units+1.5)
        jp5=nint(0.10/units+1.5)
        jp6=nint(0.20/units+1.5)
      elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.0.50)then
        units=1.5/31.0
        jp4=nint(0.0/units+1.5)
        jp5=nint(0.5/units+1.5)
        jp6=nint(1.0/units+1.5)
      elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.le.1.0)then
        units=3.0/31.0
        jp4=nint(0.0/units+1.5)
        jp5=nint(1.0/units+1.5)
        jp6=nint(2.0/units+1.5)
      elseif((q(1:1).eq.'n'.or.q(1:1).eq.'b').and.gmn.gt.2.0)then
        units=6.0/31.0
        jp4=nint(0.0/units+1.5)
        jp5=nint(0.5/units+1.5)
        jp6=nint(1.0/units+1.5)
      else
        units=3.0/31.0
        jp4=nint(0.0/units+1.5)
        jp5=nint(1.0/units+1.5)
        jp6=nint(2.0/units+1.5)
      endif
      amin=0.0
ccc      if(krb1.eq.2.and.krb2.eq.1)then
ccc      if(idt.ne.-2.and.krb1.eq.2)then
      if((krb1.eq.2).and.(ird.eq.2.or.ird.eq.3.or.ics.gt.0))then
        open(iu14,file='biwgts.dat',status='unknown')
        close(iu14,status='delete')
        open(iu14,file='biwgts.dat',status='unknown')
ccc        endif
      endif
      mnw=0
      mxcnt=0
      do i=1,maxn
        do jj=1,32
          iout(jj)=' '
        enddo
        if(maxn.le.100)then
          if(i.eq.1.or.mod(ifmny+i-1,10).eq.0.or.i.eq.maxn)then
            write(*,'(t5,''year: '',i6)')ifmny+i-1
          endif
        elseif(maxn.le.1000)then
          if(i.eq.1.or.mod(ifmny+i-1,100).eq.0.or.i.eq.maxn)then
            write(*,'(t5,''year: '',i6)')ifmny+i-1
          endif
        elseif(maxn.le.2000)then
          if(i.eq.1.or.mod(ifmny+i-1,200).eq.0.or.i.eq.maxn)then
            write(*,'(t5,''year: '',i6)')ifmny+i-1
          endif
        else
          if(i.eq.1.or.mod(ifmny+i-1,500).eq.0.or.i.eq.maxn)then
            write(*,'(t5,''year: '',i6)')ifmny+i-1
          endif
        endif
        ncnt=0
        y2(i)=0.0
        y3(i)=0.0
        iyr=ifmny+i-1
        do j=1,nc
          if(x(i,j).ne.-9.99)then
            y2(i)=y2(i)+float((idate(j,2)-idate(j,1)+1))
            y3(i)=y3(i)+float(iyr-idate(j,1)+1)
            ncnt=ncnt+1
            wrk4(ncnt)=x(i,j)
            wrk1(ncnt)=wrk4(ncnt)
          endif
          wgt(j)=1.0
          swgts(j)=-9.99
        enddo
        ns(i)=ncnt
        if(ncnt.eq.0)then
          if(q(1:1).eq.'n')then
            bimn=0.0
          else
            bimn=1.0
          endif
          bisg=0.0
          bise=0.0
ccc          do j=1,nc
ccc            wgt(j)=1.0
ccc            swgts(j)=-9.99
ccc          enddo
          if(ird.eq.2.or.ird.eq.3.or.ics.gt.0)then
            write(iu14,'(i6,5000f8.4)')ifmny+i-1,(swgts(j),j=1,nc)
          endif
        else
          y2(i)=y2(i)/float(ncnt)
          y3(i)=y3(i)/float(ncnt)
          c=7.5
ccc          do j=1,nc
ccc            wgt(j)=1.0
ccc            swgts(j)=-9.99
ccc          enddo
          call biwgt(wrk4,wrk5,c,ncnt,bimn,bisg,bise,eff,iter,wgt)
c
          if(krb3.eq.1)then
            if(ncnt.gt.5)then
              mboot=1000
              if(ncnt.eq.6)then
                mboot=700
              endif
              do j=1,mboot
                do k=1,ncnt
                  u=random(ll)
                  l=int(u*ncnt)+1
                  wrk4(k)=wrk1(l)
                enddo
                if(ncnt.gt.5)then
                  call biwgt(wrk4,wrk5,c,ncnt,bbimn,bbisg,bbise,eff,iter,wgt)
ccc                  if(iter.ge.30)then
ccc                    write(*,'(i6,<ncnt>f7.3,f7.3)')ifmny+i-1,(wrk4(k),k=1,ncnt)
ccc                    stop' *** no convergence in biwgt ***'
ccc                  endif
                  wrk2(j)=bbimn
                endif
              enddo
ccc              write(*,'(1x,''bootyear before mccon: '',i5)')iyr
              call mccon(wrk1,wrk4,wrk5,ncnt,95.0,bimn,mcconf,mboot,wrk2,mxy)
ccc              write(*,'(1x,''bootyear after mccon: '',i5)')iyr
              shl(i)=mcconf(7)
              shh(i)=mcconf(8)
c              if(shl(i).ge.bimn)then
c                if(iyr.eq.1930)write(*,'(1x,i5,11f8.3)')ifmny+i-1,bimn,shl(i),shh(i),(mcconf(j),j=1,8)
c              elseif(shh(i).le.bimn)then
c                write(*,'(1x,i5,11f8.3)')ifmny+i-1,bimn,shl(i),shh(i),(mcconf(j),j=1,8)
c                pause
c              endif
            else
              shl(i)=bimn
              shh(i)=bimn
            endif
          endif
c
          if(ncnt.gt.mxcnt)mxcnt=ncnt
          if(bimn.lt.0)bimn=0.0
          nwgts=0
          if(nc.le.5000)then
            do j=1,nc
              if(x(i,j).ne.-9.99)then
                nwgts=nwgts+1
                if(nc.ge.6)then
                  swgts(j)=wgt(nwgts)
                else
                  swgts(j)=1.0
                endif
              endif
            enddo
            if(ird.eq.2.or.ird.eq.3.or.ics.gt.0)then
              write(iu14,'(i6,5000f8.4)')ifmny+i-1,(swgts(j),j=1,nc)
            endif
            if(nwgts.gt.mnw)mnw=nwgts
          endif
        endif
        if(ipo.ge.3)then
          if(q(1:1).ne.'n')then
            iout(jp4)=':'
            iout(jp5)=':'
            iout(jp6)=':'
          endif
          jp2=nint(((bimn-amin)+bisg)/units+1.5)
          jp2=max0(jp2,1)
          jp2=min0(jp2,32)
          jp3=nint(((bimn-amin)-bisg)/units+1.5)
          jp3=max0(jp3,1)
          jp3=min0(jp3,32)
          jp1=nint((bimn-amin)/units+1.5)
          jp1=min0(jp1,32)
          ii=mod(ifmny+i-1,10)
          write(iout(jp1),'(i1)')iabs(ii)
          if(q(1:1).eq.'n'.or.q(1:1).eq.'b')then
            if(jp1.gt.1)then
              do jj=2,jp1-1
                iout(jj)='-'
              enddo
              if(jp1.gt.jp4)iout(jp4)=':'
            endif
          else
            if(jp1.lt.jp5)then
              do jj=jp1+1,jp5-1
                iout(jj)='-'
              enddo
            else
              do jj=jp5+1,jp1-1
                iout(jj)='-'
              enddo
            endif
          endif
          write(iu11,'(t2,i5,i7,f8.3,f9.3,f10.3,f8.3,i5,2x,32a1)')
     *      ifmny+i-1,ncnt,bimn,bisg,bise,eff,iter,iout
        endif
        if(eff.gt.1.0)then
          neff=neff+1
          wrk1(neff)=eff
        else
          meff=meff+1
          wrk2(meff)=eff
        endif
        z(i)=bimn
        wrk3(i)=bisg
        bierr(i)=bise
cccc
c        if(iyr.eq.1930)write(*,'(t2,i5,i7,2f8.3,f9.3,f10.3,f8.3,i5)')
c     *    ifmny+i-1,ncnt,bimn,z(i),bisg,bise,eff,iter
        crnsave(i)=z(i)
cccc
      enddo
      if(q(1:1).ne.'n'.and.isb.ne.0)then
        if(maxn.le.100)then
          li=5
        elseif(maxn.gt.100.and.maxn.le.500)then
          li=10
        elseif(maxn.gt.500.and.maxn.le.1000)then
          li=20
        elseif(maxn.gt.1000.and.maxn.le.2000)then
          li=50
        else
          li=100
        endif
        do i=1,maxn
          wrk4(i)=z(i)
          wrk5(i)=1.0
        enddo
        if(ipo.ge.1)then
          if(isb.eq.1.and.rbar.ge.0)then
            write(iu11,'(/t12,''*** variance stabilized with '',
     *        ''briffa rbar-weighted method ***'')')
          elseif(isb.eq.1.and.rbar.lt.0)then
            write(iu11,'(/t11,''*** briffa rbar-weighted '',
     *        ''stabilization not done: rbar.lt.0 ***'')')
          else
            write(iu11,'(/t18,''*** variance stabilized with '',
     *        ''spline curve fit ***'')')
          endif
        endif
        if(ipo.gt.3)then
          write(iu11,'(/t19,
     *      ''*** series before variance stabilization ***'')')
          do i=1,maxn
            wrk5(i)=1.0
          enddo
          call pltdec1(wrk4,wrk5,z,maxn,ifmny,li,iu11,4,ido)
        endif
        if(isb.eq.1.or.isb.eq.2)then
          if(rbar.ge.0)then
            do i=1,maxn
              wrk5(i)=1.0
            enddo
            call stabbm(wrk4,ns,ifmny,ilmxy,maxn,ifmny,ilmxy,
     *        rbar,z,wrk5)
          endif
ccc          call agecor(y3,wrk4,maxn)
        else
          ls=isb
          call stabit1(wrk4,wrk5,z,ns,maxn,ls,mxy)
        endif
        if(ipo.gt.3)then
          write(iu11,'(//t14,''*** curve fit and series after '',
     *      ''variance stabilization ***'')')
          if(isb.eq.1)then
            do i=1,maxn
              wrk5(i)=1.0
            enddo
          else
            write(iu11,'(t25,''spline curve fit used: '',i5,
     *        ''  years'')')ls
          endif
          call pltdec1(wrk4,wrk5,z,maxn,ifmny,li,iu11,4,ido)
        endif
      endif
c
c *** plot out the bisquare weights
c
        if(krb1.eq.2.and.mxcnt.le.5)then
          close(iu14,status='delete')
ccc      if(krb2.eq.1.and.mxcnt.le.5)close(iu14,status='delete')
ccc      if(krb1.eq.2.and.krb2.eq.1.and.mxcnt.ge.6)then
ccc      if(idt.ne.-2.and.krb1.eq.2)then
        elseif(krb1.eq.2.and.mxcnt.ge.6.and.(ird.eq.2.or.ird.eq.3.or.ics.gt.0))then
          open(iu16,file='rob.tmp',status='unknown')
          do i=1,maxn
            write(iu16,'(i6,1000f8.4)')ifmny+i-1,(x(i,j),j=1,nc)
          enddo
          rewind(iu14)
          do i=1,maxn
            read(iu14,'(6x,1000f8.4)')(x(i,j),j=1,nc)
          enddo
          close(iu14,status='delete')
c
          if(ics.gt.0)then
            ll=len(fil1)
            jj=0
            do j=1,ll
              jj=ll-j+1
              if(fil1(jj:jj).ne.' ')goto 16
            enddo
   16       ll=jj
            call blank(fil)
            fil=fil1
            if(ct.eq.'n')then
              fil(ll+1:ll+10)='_raw_wgts '
              tag='raw'
            elseif(ct.eq.'s')then
              fil(ll+1:ll+10)='_ind_wgts '
              tag='ind'
            elseif(ct.eq.'r')then
              fil(ll+1:ll+10)='_res_wgts '
              tag='res'
            elseif(ct.eq.'b')then
              fil(ll+1:ll+10)='_rcs_wgts '
              tag='rcs'
            endif
            open(iu14,file=fil,status='unknown')
            close(iu14,status='delete')
            open(iu14,file=fil,status='unknown')
            if(ics.le.3)then
              do j=1,3
                itrdb(j)(81:85)=' wgts'
                write(iu14,'(a)')itrdb(j)
              enddo
            endif
            call sis(x,crn,nc,idate,ident,nss,keep,tit,mxy,mxs,tag)
            close(iu14)
          endif
c
          do i=1,maxn
            iyr=ifmny+i-1
            ncnt=0
            do j=1,nc
              if(x(i,j).ne.-9.99)then
                ncnt=ncnt+1
                wgt(ncnt)=x(i,j)
              endif
            enddo
            if(ncnt.gt.0)then
              call mfs(wgt,ncnt,xmed,hh,hl,fsd,rmn,rmx)
              crn(i)=xmed
              x(i,1)=hl
              x(i,2)=hh
            else
              crn(i)=-9.99
              x(i,1)=-9.99
              x(i,2)=-9.99
            endif
          enddo
          if(ird.eq.2.or.ird.eq.3)then
            if(ct.eq.'n')then
              call crnplt7(crn,x(1,1),x(1,2),maxn,ifmny,fil1,
     *          ' raw data biweights (median & hinges)','years',
     *          'weights',pixels,1)
            elseif(ct.eq.'s')then
              call crnplt7(crn,x(1,1),x(1,2),maxn,ifmny,fil1,
     *          ' index data biweights (median & hinges)','years',
     *          'weights',pixels,2)
            elseif(ct.eq.'r')then
              call crnplt7(crn,x(1,1),x(1,2),maxn,ifmny,fil1,
     *          ' residual data biweights (median & hinges)','years',
     *          'weights',pixels,3)
            elseif(ct.eq.'b')then
              call crnplt7(crn,x(1,1),x(1,2),maxn,ifmny,fil1,
     *          ' rcs data biweights (median & hinges)','years',
     *          'weights',pixels,4)
            endif
          endif
          rewind(iu16)
          do i=1,maxn
            read(iu16,'(6x,1000f8.4)')(x(i,j),j=1,nc)
          enddo
          close(iu16,status='delete')
ccc        endif
        endif
        do i=1,maxn
cccc
          dif=z(i)-crnsave(i)
          dif1=shl(i)+dif
          dif2=shh(i)+dif
c          if(ifmny+i-1.eq.1930)write(*,'(t2,i5,7f8.3)')ifmny+i-1,crnsave(i),shl(i),shh(i),dif,z(i),dif1,dif2
          if(dif.ne.0)then
            shl(i)=dif1
            shh(i)=dif2
          endif
        enddo
c
      call moment1(z,ns,maxn,ave,adev,sdev,var,skew,curt,sens,ac1)
c
ccccc      if(ct.ne.'n'.and.ct.ne.'b')then
ccccc        do i=1,maxn
cccc
ccccc          if(ifmny+i-1.eq.1930)write(*,'(t2,i5,f8.3)')ifmny+i-1,z(i)
ccccc          z(i)=z(i)-ave+1.0
cccc
ccccc          if(ifmny+i-1.eq.1930)write(*,'(t2,i5,f8.3)')ifmny+i-1,z(i)
ccccc        enddo
ccccc        call moment1(z,ns,maxn,ave,adev,sdev,var,skew,curt,sens,ac1)
ccccc      endif
c
      if(krb1.eq.1)then
        if(ct.eq.'n')then
          write(iu11,'(/t2,''|---------------- gaussian mean raw '',
     *      ''data chronology statistics ----------------|'')')
        elseif(ct.eq.'s')then
          write(iu11,'(/t2,''|---------------- gaussian mean standard '',
     *      ''chronology statistics ----------------|'')')
        elseif(ct.eq.'r')then
          write(iu11,'(/t2,''|---------------- gaussian mean residual '',
     *      ''chronology statistics ----------------|'')')
        elseif(ct.eq.'b')then
          write(iu11,'(/t2,''|-------------- gaussian mean age-'',
     *      ''aligned chronology statistics ---------------|'')')
        endif
      elseif(krb1.eq.2)then
        if(ct.eq.'n')then
          write(iu11,'(/t2,''|----------------- robust mean raw '',
     *      ''data chronology statistics -----------------|'')')
        elseif(ct.eq.'s')then
          write(iu11,'(/t2,''|----------------- robust mean standard '',
     *      ''chronology statistics -----------------|'')')
        elseif(ct.eq.'r')then
          write(iu11,'(/t2,''|----------------- robust mean residual '',
     *      ''chronology statistics -----------------|'')')
        elseif(ct.eq.'b')then
          write(iu11,'(/t2,''|--------------- robust mean age-aligned '',
     *      ''chronology statistics ----------------|'')')
        endif
      elseif(krb1.lt.0)then
        if(ct.eq.'n')then
          write(iu11,'(/t2,''|--------------- '',i3,''th quantile '',
     *      ''raw data chronology statistics ----------------|'')')
     *      iabs(krb1)
        elseif(ct.eq.'s')then
          write(iu11,'(/t2,''|--------------- '',i3,''th quantile '',
     *      ''standard chronology statistics ----------------|'')')
     *      iabs(krb1)
        elseif(ct.eq.'r')then
          write(iu11,'(/t2,''|--------------- '',i3,''th quantile '',
     *      ''residual chronology statistics ----------------|'')')
     *      iabs(krb1)
        elseif(ct.eq.'b')then
          write(iu11,'(/t2,''|--------------- '',i3,''th quantile '',
     *      ''age-aligned chronology statistics --------------|'')')
     *      iabs(krb1)
        endif
      endif
      write(iu11,'(/t3,
     *  ''first    last    total    mean    stdrd    skew    '',
     *  ''kurtosis    mean    serial''/t4,
     *  ''year    year    years   index     dev     coeff     '',
     *  ''coeff     sens     corr'')')
      if(maxn.lt.1000)then
        write(iu11,'(i7,i8,i8,1x,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *    ifmny,ilmxy,maxn,ave,sdev,skew,curt,sens,ac1
      else
        write(iu11,'(i7,i8,i9,2f8.3,f9.3,f11.3,f9.3,f9.3)')
     *    ifmny,ilmxy,maxn,ave,sdev,skew,curt,sens,ac1
      endif
      rmeta(1)=ave
      rmeta(2)=sdev
      rmeta(3)=skew
      rmeta(4)=curt
      rmeta(5)=sens
      rmeta(6)=ac1
      if(nc.gt.1)then
        call pearsn1(z,wrk3,ns,maxn,r,a,b)
      else
        r=0.0
        a=0.0
        b=0.0
      endif
      if(krb1.eq.1)then
        write(iu11,'(/t3,''mean indices vs their standard deviations'',
     *    ''       robust mean efficiency results''/
     *    t2,''     correlation    slope    intercept'',13x,
     *    ''# improved    # unimproved'')')
        write(iu11,'(f13.3,f13.3,f11.3,i23,i15)')r,b,a,neff,meff
      elseif(krb1.eq.2)then
        call mfs(wrk1,neff,emedp,ehhp,ehlp,efsdp,emnp,emxp)
        if(emxp.gt.9999.00)emxp=9999.00
        call mfs(wrk2,meff,emedm,ehhm,ehlm,efsdm,emnm,emxm)
        write(iu11,'(/t3,''mean indices vs their standard deviations'',
     *    ''       robust mean efficiency results''/
     *    t2,''     correlation    slope    intercept'',13x,
     *    ''# improved    # unimproved'')')
        write(iu11,'(f13.3,f13.3,f11.3,i23,i15)')r,b,a,neff,meff
        write(iu11,'(/t2,
     *    ''|---------------- robust mean efficiency gain and loss '',
     *    ''results ----------------|''//t4,
     *    ''median      interquartile      minimum       lower       '',
     *    ''upper       maximum''/t4,
     *    '' gain           range            gain        hinge       '',
     *    ''hinge         gain'')')
        write(iu11,'(f8.2,f16.2,f16.2,f13.2,f12.2,f13.2)')
     *    emedp,efsdp,emnp,ehlp,ehhp,emxp
        write(iu11,'(/t4,
     *    ''median      interquartile      minimum       lower       '',
     *    ''upper       maximum''/t4,
     *    '' loss           range            loss        hinge       '',
     *    ''hinge         loss'')')
        write(iu11,'(f8.2,f16.2,f16.2,f13.2,f12.2,f13.2)')
     *    emedm,efsdm,emnm,ehlm,ehhm,emxm
      endif
      if(ct.eq.'b')return
      do j=1,nc
        wrk5(j)=idate(j,2)-idate(j,1)+1
      enddo
      if(q(1:1).eq.'n')then
        call mfs(wrk5,nc,smed1,shh1,shl1,sfsd1,smn1,smx1)
        write(iu11,'(/t2,
     *    ''|--------------------- segment length summary statistics '',
     *    ''----------------------|''//t4,
     *    ''median      interquartile      minimum       lower       '',
     *    ''upper       maximum''/t4,
     *    ''length          range           length       hinge       '',
     *    ''hinge        length'')')
        write(iu11,'(f9.0,f15.0,f16.0,f13.0,f12.0,f14.0)')
     *    smed1,sfsd1,smn1,shl1,shh1,smx1
c        rmeta(9)=smed
c        rmeta(10)=sfsd
      endif
      call acf1(z,ns,maxn,10,acr,pac,seac)
      if(ct.eq.'n')then 
        write(iu11,'(/t2,''|----------- raw data chronology '',
     *    ''auto and partial autocorrelations ------------|'')')
      elseif(ct.eq.'s')then 
        write(iu11,'(/t2,''|----------- standard chronology '',
     *    ''auto and partial autocorrelations ------------|'')')
      elseif(ct.eq.'r')then
        write(iu11,'(/t2,''|----------- residual chronology '',
     *    ''auto and partial autocorrelations ------------|'')')
      endif
      write(iu11,'(/t2,''lag'',t16,''t-1    t-2    t-3    t-4    '',
     *  ''t-5    t-6    t-7    t-8    t-9   t-10'')')
      write(iu11,'(t2,''acf'',t12,10f7.3)')(acr(j),j=1,10)
      write(iu11,'(t2,''pacf'',t12,10f7.3)')(pac(j),j=1,10)
      write(iu11,'(t2,''95% c.l.'',t12,10f7.3)')(seac(j),j=1,10)
      if(ct.eq.'n')then 
        do j=1,10
          cfs(1,j,1)=wrk3(j)
          cfs(2,j,1)=wrk4(j)
          cfs(3,j,1)=wrk5(j)
        enddo
      elseif(ct.eq.'s')then 
        do j=1,10
          cfs(1,j,2)=wrk3(j)
          cfs(2,j,2)=wrk4(j)
          cfs(3,j,2)=wrk5(j)
        enddo
      elseif(ct.eq.'r')then
        do j=1,10
          cfs(1,j,3)=wrk3(j)
          cfs(2,j,3)=wrk4(j)
          cfs(3,j,3)=wrk5(j)
        enddo
      endif
      call memcof1(z,ns,maxn,11,ip,pm,wrk4,0,wrk1,wrk2,wrk5)
      if(q(1:1).eq.'n')then
        write(iu11,'(/t2,''|------------------ raw data chronology '',
     *    ''autoregressive model ------------------|'')')
      elseif(q(1:1).eq.'s')then
        write(iu11,'(/t2,''|------------------ standard chronology '',
     *    ''autoregressive model ------------------|'')')
      elseif(q(1:1).eq.'r')then
        write(iu11,'(/t2,''|------------------ residual chronology '',
     *    ''autoregressive model ------------------|'')')
      endif
      write(iu11,'(/t2,''ord    rsq    t-1    t-2    t-3    t-4    '',
     *  ''t-5    t-6    t-7    t-8    t-9   t-10'')')
      write(iu11,'(t2,i2,1x,11f7.3)')ip,pm,(wrk4(j),j=1,ip)
c      if(ct.ne.'n')then
        rmeta(7)=ip
        rmeta(8)=pm
        do j=1,ip
          rmeta(j+8)=wrk4(j)
        enddo
c      endif
cccc
c      do i=1,maxn
c        if(ifmny+i-1.eq.1930)write(*,'(t2,i5,3f8.3)')ifmny+i-1,z(i),shl(i),shh(i)
c        if(ifmny+i-1.eq.2003)write(*,'(t2,i5,3f8.3)')ifmny+i-1,z(i),shl(i),shh(i)
c      enddo
      return
      end

