c[====================================================================]o
c[====================================================================]o
c[                                                                    ]o
c[-----------------------> QUEST <------------------------------------]o
c[                                                                    ]o
c[ ensemble des subroutines servant a faciliter les entrees           ]o
c[ interactive avec gestion des defauts.                              ]o
c[ fortran standart. aucun appel systeme.                             ]o
c[                                                                    ]o
c[  Attention ces routines utilises l'unites 76       (voir ludef)    ]o
c[                                                                    ]o
c[                                                                    ]o
c[ L.WEBER    Observatoire de GENEVE                                  ]o
c[                                                                    ]o
c[ NOVEMBRE 1988                                                      ]o
c[                                                                    ]o
c[====================================================================]o
c[====================================================================]o
C
C
C----> LISTE DES SUBROUTINES <------------------------------------------
C
c     qrn,qr1,qr2,qr3,qr4    ->> real*4
c     qin,qi1,qi2,qi3,qi4    ->> integer*4
c     qdn,qd1,qd2,qd3,qd4    ->> real*8
c     qln,ql1,ql2,ql3,ql4    ->> logical
c     qc1                    ->> character*(*)
c     savdef()
C
C
      subroutine opedef(name)

      implicit none
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C 
      character*(*) name
      logical       opn
      integer       i,ios

      if(name.eq.' ')name = 'DEFAUTS.DEF'
      ludef = 76
      inquire (unit=ludef,opened=opn)
      if(.not.opn)then
        open(unit            = ludef,
     .       file            = name,
     .       status          = 'UNKNOWN')
        do 1000 i=1,nbmax
          if(mod(i,2).eq.1)then
            read(ludef,'(I8,1X,A)',iostat=ios)defcod(i),defstr(i)
          else
            read(ludef,'(A)',iostat=ios)defstr(i)
          endif
          if(ios.ne.0)return
          nbcrt = i
1000    continue
      endif
      return
      end
C
C
      subroutine seadef(texte,pnt)

      implicit none
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C 
      character*(*) texte
      integer*4     pnt,i
      integer*4     code

      call cript(texte,code)
      pnt = 0
      do 1000 i=1,nbcrt,2
        if(defcod(i).eq.code)then
          if(texte .eq. defstr(i))then
            pnt = i+1
            return
          endif
        endif
1000  continue
      return
      end
C
C
      subroutine texit(tempo)

      implicit none
      character*(*)      tempo
      character*5        string
      integer            il

      il = 5
      string = tempo(1:il)
      call minmaj(string,il)
      if(string(1:5) .eq. 'EXIT ')  goto 9998
      if(string(1:3) .eq. 'EX ')    goto 9998
      if(string(1:5) .eq. 'QUIT ')  goto 9999
      if(string(1:2) .eq. 'Q ')     goto 9999
      return
9998  call savdef()
      stop 'Programme interrompu, defauts sauves'
9999  stop 'Programme interrompu, defauts perdus'
      end
C
C
      subroutine cript(string,code)

      implicit none
      character*(*) string
      integer*4     code,tempo,i

      code = 0
      do 1000 i=1,min(40,len(string))
        if(string(i:i).ne.' ')then
          tempo = ichar(string(i:i))
          code  = code + i*tempo
        endif
1000  continue
      return
      end
C
C
      subroutine savdef()

      implicit none
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt

      logical          opn
      integer          i

      inquire (unit=ludef,opened=opn)
      if(.not.opn)return
      rewind (ludef)
      do 800 i=1,nbcrt
        if(mod(i,2).eq.1)then
          write(ludef,1000)defcod(i),defstr(i)
        else
          write(ludef,1001)defstr(i)
        endif
1000    format(i8,1x,a)
1001    format(a)
800   continue
      close(ludef)
      return
      end
C
C
      subroutine stodef(texte,tempo,pnt)

      implicit none
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C 
      character*(*)  tempo,texte
      integer*4      pnt
      integer*4      code

      if(pnt.eq.0)then
        if(nbcrt.lt.nbmax-1)then
          call cript(texte,code)
          defstr(nbcrt+1) = texte
          defcod(nbcrt+1) = code
          defstr(nbcrt+2) = tempo
          nbcrt = nbcrt+2
        endif
      else
        defstr(pnt)   = tempo
      endif
      return
      end
C
C
      subroutine qrn(texte,name,ntab,vtab)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C
      integer               nval,lf,lfmt,ls
      parameter             (nval=15,lf=9,lfmt=2+nval*lf,ls=14*nval)
      character*(*)         texte,name
      integer               ntab
      real                  defaut(nval),vtab(ntab)
      character*(ncmax)     tempo
      integer*4             pnt,i,i1,ilen,ios
      character*(lfmt)      fmt
      character*(ls)        string
C      
      if(ntab.gt.nval)stop 'Trop de valeurs demandees'
      call opedef(name)
      call seadef(texte,pnt)
      do 100 i=1,ntab
        defaut(i) = 0
100   continue
      if(pnt.ne.0)read(defstr(pnt),*,iostat=ios)
     .                 (defaut(i),i=1,ntab)
C
      fmt(1:1) = '('
      i1 = 2
      do 200 i=1,ntab
        fmt(i1:i1+lf-1) = '1X,G13.7,'
        i1 = i1+lf
200   continue
      fmt(i1-1:) = ')'

1000  write(string,fmt)(defaut(i),i=1,ntab)
      call compac(string,ilen)
      write(*,'(1X,A,$)')texte//'(Defaut='//string(1:ilen)//') '
C
      read (*,'(A)',end=1000,err=1000)tempo

      call texit(tempo)
      if((tempo(1:1).gt.'A').and.(tempo(1:1).lt.'z'))goto 1000
      if(tempo .eq. ' ')then
        do 300 i=1,ntab
          vtab(i) = defaut(i)
300     continue
      else
        read(tempo,*,err=1000,end=1000) (vtab(i),i=1,ntab)
      endif
      write(tempo,*)(vtab(i),i=1,ntab)
      call stodef(texte,tempo,pnt)
      return
      end
C
C
      subroutine qr1(texte,name,v1)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real                  v1
      integer*4             ntab

      ntab = 1
      call qrn(texte,name,ntab,v1)

      return
      end
C
C
      subroutine qr2(texte,name,v1,v2)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real                  tempo(2),v1,v2
      integer*4             ntab

      ntab = 2
      call qrn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)

      return
      end
C
C
      subroutine qr3(texte,name,v1,v2,v3)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real                  tempo(3),v1,v2,v3
      integer*4             ntab

      ntab = 3
      call qrn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)

      return
      end
C
C
      subroutine qr4(texte,name,v1,v2,v3,v4)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real                  tempo(4),v1,v2,v3,v4
      integer*4             ntab

      ntab = 4
      call qrn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)
      v4 = tempo(4)

      return
      end
C
C
      subroutine qin(texte,name,ntab,vtab)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C
      integer               nval,lf,lfmt,ls,ntab
      parameter             (nval=15,lf=6,lfmt=27+nval*lf,ls=nval*9)
      character*(*)         texte,name
      integer*4             defaut(nval),vtab(ntab)
      character*(ncmax)     tempo
      integer*4             pnt,i,i1,ilen,ios
      character*(lfmt)      fmt
      character*(ls)        string
C      
      if(ntab.gt.nval)stop 'Trop de valeurs demandees'
      call opedef(name)
      call seadef(texte,pnt)
      do 100 i=1,ntab
        defaut(i) = 0
100   continue
      if(pnt.ne.0)read(defstr(pnt),*,iostat=ios)
     .                 (defaut(i),i=1,ntab)
C
      fmt(1:1) = '('
      i1 = 2
      do 200 i=1,ntab
        fmt(i1:i1+lf-1) = '1X,I8,'
        i1 = i1+lf
200   continue
      fmt(i1-1:) = ')'

1000  write(string,fmt)(defaut(i),i=1,ntab)
      call compac(string,ilen)
      write(*,'(1X,A,$)')texte//'(Defaut='//string(1:ilen)//') '
C
      read (*,'(A)',end=1000,err=1000)tempo

      call texit(tempo)
      if((tempo(1:1).gt.'A').and.(tempo(1:1).lt.'z'))goto 1000
      if(tempo .eq. ' ')then
        do 300 i=1,ntab
          vtab(i) = defaut(i)
300     continue
      else
        read(tempo,*,err=1000,end=1000) (vtab(i),i=1,ntab)
      endif
      write(tempo,*)(vtab(i),i=1,ntab)
      call stodef(texte,tempo,pnt)
      return
      end
C
C
      subroutine qi1(texte,name,v1)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      integer*4             v1
      integer*4             ntab

      ntab = 1
      call qin(texte,name,ntab,v1)

      return
      end
C
C
      subroutine qi2(texte,name,v1,v2)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      integer*4             tempo(2),v1,v2
      integer*4             ntab

      ntab = 2
      call qin(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)

      return
      end
C
C
      subroutine qi3(texte,name,v1,v2,v3)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      integer*4             tempo(3),v1,v2,v3
      integer*4             ntab

      ntab = 3
      call qin(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)

      return
      end
C
C
      subroutine qi4(texte,name,v1,v2,v3,v4)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      integer*4             tempo(4),v1,v2,v3,v4
      integer*4             ntab

      ntab = 4
      call qin(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)
      v4 = tempo(4)

      return
      end
C
C
      subroutine qdn(texte,name,ntab,vtab)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C
      integer               nval,lf,lfmt,ls,ntab
      parameter             (nval=15,lf=9,lfmt=27+nval*lf,ls=nval*16)
      character*(*)         texte,name
      real*8                defaut(nval),vtab(ntab)
      integer*4             pnt,i,i1,ilen,ios
      character*(ncmax)     tempo
      character*(lfmt)      fmt
      character*(ls)        string
C      
      if(ntab.gt.nval)stop 'Trop de valeurs demandees'
      call opedef(name)
      call seadef(texte,pnt)
      do 100 i=1,ntab
        defaut(i) = 0
100   continue
      if(pnt.ne.0)read(defstr(pnt),*,iostat=ios)
     .                 (defaut(i),i=1,ntab)
C
      fmt(1:1) = '('
      i1 = 2
      do 200 i=1,ntab
        fmt(i1:i1+lf-1) = '1X,D15.8,'
        i1 = i1+lf
200   continue
      fmt(i1-1:) = ')'

1000  write(string,fmt)(defaut(i),i=1,ntab)
      call compac(string,ilen)
      write(*,'(1X,A,$)')texte//'(Defaut='//string(1:ilen)//') '
C
      read (*,'(A)',end=1000,err=1000)tempo

      call texit(tempo)
      if((tempo(1:1).gt.'A').and.(tempo(1:1).lt.'z'))goto 1000
      if(tempo .eq. ' ')then
        do 300 i=1,ntab
          vtab(i) = defaut(i)
300     continue
      else
        read(tempo,*,err=1000,end=1000) (vtab(i),i=1,ntab)
      endif
      write(tempo,*)(vtab(i),i=1,ntab)
      call stodef(texte,tempo,pnt)
      return
      end
C
C
      subroutine qd1(texte,name,v1)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real*8                v1
      integer*4             ntab

      ntab = 1
      call qdn(texte,name,ntab,v1)

      return
      end
C
C
      subroutine qd2(texte,name,v1,v2)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real*8                tempo(2),v1,v2
      integer*4             ntab

      ntab = 2
      call qdn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)

      return
      end
C
C
      subroutine qd3(texte,name,v1,v2,v3)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real*8                tempo(3),v1,v2,v3
      integer*4             ntab

      ntab = 3
      call qdn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)

      return
      end
C
C
      subroutine qd4(texte,name,v1,v2,v3,v4)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      real*8                tempo(4),v1,v2,v3,v4
      integer*4             ntab

      ntab = 4
      call qdn(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)
      v4 = tempo(4)

      return
      end
C
C-----------------------------------------------------------------------
C
      subroutine qc1(texte,name,valeur)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C
      character*(*)       texte,valeur,name
      character*(ncmax)   defaut
      integer*4           pnt,ilen


      call opedef(name)
      call seadef(texte,pnt)
      defaut = ' '
      if(pnt.ne.0)defaut = defstr(pnt)

      call slen(defaut,ilen)
1000  write(*,1001)texte,defaut(1:ilen)
1001  format(1x,a,'(Defaut= ',a,')  ',$)
      read (*,'(A)',end=1000,err=1000)valeur
      call texit(valeur)

      if(valeur .eq. ' ')valeur = defaut

      call stodef(texte,valeur,pnt)

      return
      end
C
C
      subroutine slen (string,ilen)

      implicit none
      character*(*) string
      integer       ilen,jlen
C
      jlen = len(string)
      do 200  ilen=jlen,1,-1
        if(string(ilen:ilen).ne.' ') goto 9999
200   continue
9999  return
      end
C
C
      subroutine minmaj(lgncmd,ilen)

      implicit none
      character*(*) lgncmd
      integer       ilen,i,ivar

      do 700 i=1,ilen
        ivar         = ichar(lgncmd(i:i))
        if( (ivar.ge.ichar('a')) .and. (ivar.le.ichar('z')) )then
C         rem: 223 = 337(octal)
          ivar        = and (ivar,223)
          lgncmd(i:i) = char(ivar)
        endif
700   continue
      return
      end
C
C
      subroutine compac(string,ilen)

      implicit none
      character*(*) string
C
C     FM = flag mantisse
C     FS = flag space
C
      logical fm,fs
      integer ilen,lsave,i

      fs    = .false.
      fm    = .false.
      ilen  = 0
      lsave = ilen
      do 100 i=1,len(string)
        if(string(i:i).eq.' ')then
          if(fm)ilen = lsave
          fm   = .false.
          if(fs)goto 100
          fs = .true.
        else if(string(i:i).le.'9' .and. string(i:i).ge.'0')then
          fs = .false.
          if(fm .and. string(i:i).ne.'0')lsave = ilen+1
        else
          fs = .false.
          if(string(i:i).eq.'.')then
            fm    = .true.
            lsave = ilen+1
          else
            if(fm)ilen = lsave
            fm         = .false.
          endif
        endif
        ilen = ilen+1
        string(ilen:ilen) = string(i:i)
100   continue

      ilen = ilen-1
      return
      end
C
C
      subroutine qln(texte,name,ntab,vtab)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C
C.....declaration du common
C
      integer          nbmax,ncmax
      parameter        (nbmax=1000,ncmax=120)
      integer*4        ludef,defcod(nbmax)
      integer*4        nbcrt
      character*(ncmax)  defstr(nbmax)
      common /defcom/ludef,defstr,defcod,nbcrt
C
C.....variables
C
      integer               nval,lf,lfmt,ls,ntab
      parameter             (nval=15,lf=6,lfmt=27+nval*lf,ls=nval*9)
      character*(*)         texte,name
      logical               defaut(nval),vtab(ntab)
      character*(ncmax)     tempo
      integer*4             pnt,i,i1,ilen,ios
      character*(lfmt)      fmt
      character*(ls)        string
C      
      if(ntab.gt.nval)stop 'Trop de valeurs demandees'
      call opedef(name)
      call seadef(texte,pnt)
      do 100 i=1,ntab
        defaut(i) = 0
100   continue
      if(pnt.ne.0)read(defstr(pnt),*,iostat=ios)
     .                 (defaut(i),i=1,ntab)
C
      fmt(1:1) = '('
      i1 = 2
      do 200 i=1,ntab
        fmt(i1:i1+lf-1) = '1X,L1,'
        i1 = i1+lf
200   continue
      fmt(i1-1:) = ')'

1000  write(string,fmt)(defaut(i),i=1,ntab)
      call compac(string,ilen)
      write(*,'(1X,A,$)')texte//'(Defaut='//string(1:ilen)//') '
C
      read (*,'(A)',end=1000,err=1000)tempo

      call texit(tempo)
      if(tempo .eq. ' ')then
        do 300 i=1,ntab
          vtab(i) = defaut(i)
300     continue
      else
        read(tempo,*,err=1000,end=1000) (vtab(i),i=1,ntab)
      endif
      write(tempo,*)(vtab(i),i=1,ntab)
      call stodef(texte,tempo,pnt)
      return
      end
C
C
      subroutine ql1(texte,name,v1)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      logical               v1
      integer*4             ntab

      ntab = 1
      call qln(texte,name,ntab,v1)

      return
      end
C
C
      subroutine ql2(texte,name,v1,v2)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      logical               tempo(2),v1,v2
      integer*4             ntab

      ntab = 2
      call qln(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)

      return
      end
C
C
      subroutine ql3(texte,name,v1,v2,v3)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      logical               tempo(3),v1,v2,v3
      integer*4             ntab

      ntab = 3
      call qln(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)

      return
      end
C
C
      subroutine ql4(texte,name,v1,v2,v3,v4)

      implicit none
C
C     pose une Qion en precisant la valeur de defaut et la donne
C     la valeur si l'utilisateur tape return.
C
C.....variables
C
      character*(*)         texte,name
      logical               tempo(4),v1,v2,v3,v4
      integer*4             ntab

      ntab = 4
      call qln(texte,name,ntab,tempo)
      v1 = tempo(1)
      v2 = tempo(2)
      v3 = tempo(3)
      v4 = tempo(4)

      return
      end