      program affine
c-----------------------------------------------------------------------
c
c                    Affine Change of Variance
c                    *************************
c
c
c
c-----------------------------------------------------------------------
      parameter(MAXLEN=132,VERSION=1.000)
c
c Dimensioning:
c
      real      var(50)
      character datafl*40,outfl*40,str*132
      logical   testfl
      data      lin/1/,lout/2/
c
c Note VERSION number before anything else:
c
      write(*,9999) VERSION
 9999 format(/' AFFINE Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      write(*,*) 'Which parameter file do you want to use?'
      read (*,'(a40)') str(1:40)
      if(str(1:1).eq.' ')str='affine.par                              '
      inquire(file=str(1:40),exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'affine.par          ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str(1:40),status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a40)',end=98) str(1:40)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      read(lin,'(a40)',err=98) datafl
      call chknam(datafl,40)
      write(*,*) ' data file = ',datafl

      read(lin,*,err=98) ivr,iwt
      write(*,*) ' columns = ',ivr,iwt

      read(lin,*,err=98) tmin,tmax
      write(*,*) ' trimming limits = ',tmin,tmax

      read(lin,*,err=98) varred,xm
      write(*,*) ' variance reduction = ',varred,xm
      varred = sqrt(varred)

      read(lin,'(a40)',err=98) outfl
      call chknam(outfl,40)
      write(*,*) ' file for output = ',outfl

      close(lin)
c
c Make sure the file exists:
c
      inquire(file=datafl,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR: ',datafl,' does not exist'
            stop
      endif
c
c Prepare the input/output files:
c
      open(lin,file=datafl, status='OLD')
      open(lout,file=outfl, status='UNKNOWN')
      read(lin,'(a40)',err=99) str(1:40)
      write(lout,100)          str(1:40)
      read(lin,*,err=99)       nvari
      write(lout,'(i2)')       nvari+1
      do i=1,nvari
            read(lin,'(a40)',err=99) str(1:40)
            write(lout,'(a40)')      str(1:40)
      end do
      write(lout,101)
 100  format('Affine Corrected:',a40)
 101  format('Variance Corrected Value')
c
c Read and write all the data until the end of the file:
c
      id = 0
 7    read(lin,*,end=9) (var(i),i=1,nvari)
c
c Variance corrected value:
c
      if(var(ivr).lt.tmin.or.var(ivr).ge.tmax) then
            vrg = -999.
      else
            vrg = varred*(var(ivr)-xm)+xm
      endif
c
c Write out the results:
c
      backspace lin
      read(lin,'(a)') str
      call strlen(str,MAXLEN,lostr)
      write(lout,'(a,1x,f12.5)') str(1:lostr),real(vrg)
      go to 7
 9    continue
c
c Finished:
c
      close(lin)
      close(lout)
      write(*,9998) VERSION
 9998 format(/' AFFINE Version: ',f5.3, ' Finished'/)
      stop
 98   stop ' ERROR in parameter file'
 99   stop ' ERROR in data file'
      end



      subroutine chknam(str,len)
c-----------------------------------------------------------------------
c
c                   Check for a Valid File Name
c                   ***************************
c
c This subroutine takes the character string "str" of length "len" and
c removes all leading blanks and blanks out all characters after the
c first blank found in the string (leading blanks are removed first).
c
c
c
c Author: C.V. Deutsch                                Date: January 1993
c-----------------------------------------------------------------------
      parameter (MAXLEN=132)
      character str(MAXLEN)*1
c
c Remove leading blanks:
c
      do i=1,len-1
            if(str(i).ne.' ') then
                  if(i.eq.1) go to 1
                  do j=1,len-i+1
                        k = j + i - 1
                        str(j) = str(k)
                  end do
                  do j=len,len-i+2,-1
                        str(j) = ' '
                  end do
                  go to 1
            end if
      end do
 1    continue
c
c Find first blank and blank out the remaining characters:
c
      do i=1,len-1
            if(str(i).eq.' ') then
                  do j=i+1,len
                        str(j) = ' '
                  end do
                  go to 2
            end if
      end do
 2    continue
c
c Return with modified file name:
c
      return
      end
      subroutine strlen(str,MAXLEN,lostr)
c-----------------------------------------------------------------------
c
c      Determine the length of the string minus trailing blanks
c
c
c
c Author: C.V. Deutsch                                   Date: July 1992
c-----------------------------------------------------------------------
      character str*132
      lostr = MAXLEN
      do i=1,MAXLEN
            j = MAXLEN - i + 1
            if(str(j:j).ne.' ') return
            lostr = lostr - 1
      end do
      return
      end



      subroutine makepar
c-----------------------------------------------------------------------
c
c                      Write a Parameter File
c                      **********************
c
c
c
c-----------------------------------------------------------------------
      lun = 99
      open(lun,file='affine.par')
      write(lun,10)
 10   format('                  Parameters for AFFINE',/,
     +       '                  *********************',/,/,
     +       'START OF PARAMETERS:')

      write(lun,11)
 11   format('data.dat                  ',
     +       '-file with data')
      write(lun,12)
 12   format('3   5                     ',
     +       '-  columns for variable and weight')
      write(lun,13)
 13   format('-1.0e21   1.0e21          ',
     +       '-  trimming limits')
      write(lun,14)
 14   format('0.668   1.00              ',
     +       '-reduction factor f and mean')
      write(lun,15)
 15   format('data.scl                  ',
     +       '-file for output')

      close(lun)
      return
      end
