C===========================================================================
C Copyright (C) 1995-2011 European Southern Observatory (ESO)
C
C This program is free software; you can redistribute it and/or 
C modify it under the terms of the GNU General Public License as 
C published by the Free Software Foundation; either version 2 of 
C the License, or (at your option) any later version.
C
C This program is distributed in the hope that it will be useful,
C but WITHOUT ANY WARRANTY; without even the implied warranty of
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
C GNU General Public License for more details.
C
C You should have received a copy of the GNU General Public 
C License along with this program; if not, write to the Free 
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
C MA 02139, USA.
C
C Correspondence concerning ESO-MIDAS should be addressed as follows:
C	Internet e-mail: midas@eso.org
C	Postal address: European Southern Observatory
C			Data Management Division 
C			Karl-Schwarzschild-Strasse 2
C			D 85748 Garching bei Muenchen 
C			GERMANY
C===========================================================================
C
CC     ---------------------------------------------------------------------
CC     *RMIDAT*: READ DATA AND OPTIONS
C
C 110427	last modif
C 
CC     ---------------------------------------------------------------------

       SUBROUTINE RMIDAT(NCAS,NVAR,JCST,JPRT,NVSB,NVAD,VALMS,
     1  X,Y,JPLT,JNDEX,PREC,JPLACE,LAB,XMED,XMAD,AW,NMVAL,
     1  RESDU,WEIGHTS,NDXX,NDXY,MVAL,NMXV,LUA,LUB,LUC,JHEAD,
     1  YNSAVE,JDIAG,ALGO,NSTOP,FNAMEA,FNAMEB,FNAMEC,OUTN1,OUTN2)

       INCLUDE 'MID_REL_INCL:implicit.inc'

       DIMENSION X(NDXX,NDXY),Y(NDXY),JNDEX(NDXX)
       DIMENSION AW(NDXY),NMVAL(NDXY),RESDU(NDXY),WEIGHTS(NDXY)
       DIMENSION XMED(NDXX),XMAD(NDXX),JPLACE(NDXX),VALMS(NDXX)
       CHARACTER YN,YNOK,YNSAVE,YNM,ALGO
       CHARACTER*30 FNAMEA,FNAMEB,FNAMEC
       CHARACTER*20 LAB(NDXX)
       CHARACTER*60 JFMT,JHEAD
       CHARACTER*20 LABJ
       CHARACTER    HELP(20)
       LOGICAL NULL,VALUE
       CHARACTER*17 OUTC1,OUTC2
       CHARACTER*100 CBUF
       INTEGER      ISTAT
       INTEGER STATUS,ACTS,KUN,KNUL,OUTN1,OUTN2
       INTEGER FINDEX, LINDEX, L, POSITION(20)
       INTEGER COLUMN,ROW,NSC,ACOL,AROW,NSEL

       INCLUDE 'MID_INCLUDE:st_def.inc'
       COMMON  /VMR/ MADRID
       EQUIVALENCE (LABJ,HELP)

       INCLUDE 'MID_INCLUDE:st_dat.inc'

       LOCA=0
C       WRITE (*,8000)

CC-----NAME OF THE FILE CONTAINING THE DATA
C       FNAMEA = 'parabol.tbl'
       CALL STKRDC('IN_A',1,1,80,ACTS,FNAMEA,KUN,KNUL,STATUS)

C ----  OPEN THE TABLE
       CALL TBTOPN(FNAMEA, F_IO_MODE, LUA, STATUS)
       CALL TBIGET(LUA,COLUMN,ROW,NSC,ACOL,AROW,STATUS)

CC-----GIVE THE NUMBER OF CASES
       NSEL = 0
       DO 10 J=1,ROW
          CALL TBSGET(LUA,J,VALUE,STATUS)
          IF (VALUE) NSEL = NSEL + 1
 10     CONTINUE   
 11     CONTINUE
       NCAS = NSEL

       IF (NCAS.GT.NDXY.OR.NCAS.LE.1) THEN
         IF (NCAS.GT.NDXY) THEN
            WRITE (CBUF,8020) NDXY
            CALL STTPUT(CBUF,ISTAT)
         ELSEIF (NCAS.LE.1) THEN
            WRITE(CBUF,8030)
            CALL STTPUT(CBUF,ISTAT)
         ENDIF   
         CALL STETER(9,'Buffer Overflow')
       ENDIF


CC-----CONSTANT TERM OR NOT

20     CONTINUE
C      get YN from keyword
C      e.g.  YN = 'Y'
       CALL STKRDC('ACTION',1,1,1,ACTS,YN,KUN,KNUL,STATUS)        

       IF (YN.EQ.'y') YN='Y'
       IF (YN.EQ.'n') YN='N'
       IF (YN.NE.'Y'.AND.YN.NE.'N') THEN
         WRITE (CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 20
       ELSE
         IF (YN.EQ.'Y') JCST=1
         IF (YN.EQ.'N') JCST=0
       ENDIF

CC-----TOTAL NUMBER OF VARIABLES IN THE DATA SET
  30    CONTINUE
       JVARS = COLUMN

       IF (JVARS.LT.1.OR.JVARS.GT.50) THEN
         WRITE(CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 30
       ENDIF

CC-----GIVE A LABEL FOR THE RESPONSE VARIABLE
       CALL STKRDC('INPUTC',1,1,20,ACTS,LABJ,KUN,KNUL,STATUS)
       LAB(NDXX)=LABJ

CC-----WHICH VARIABLE WILL BE TAKEN AS THE RESPONSE VARIABLE
        CALL TBCSER(LUA,LAB(NDXX),JPLACE(NDXX),STATUS)
        WRITE(CBUF,*) 'Dependent Column : ',LAB(NDXX),JPLACE(NDXX)
          CALL STTPUT(CBUF,ISTAT)
       IF (JPLACE(NDXX).LT.0) CALL STETER(9,'Wrong dependent variable')

       IF (JCST.EQ.0) THEN
         CALL STTPUT('JCST=0, no constant term',ISTAT)
CC-----JWR = MAXIMAL NUMBER OF EXPLANATORY VARIABLES POSSIBLE         
         CALL STTPUT('Max. number of explanatory variables ',ISTAT)
         JWR=NMXV
         IF((JVARS-1).LT.NMXV) JWR=JVARS-1
       ELSE
         CALL STTPUT ('JCST=1, constant term',ISTAT)
         JWR=NMXV-1
         IF ((JVARS-1).LT.NMXV) JWR=JVARS-1
       ENDIF

CC-----HOW MANY EXPLANATORY VARIABLES DO YOU WANT TO USE
       CALL STKRDI('INPUTI',1,20,ACTS,POSITION,KUN,KNUL,STATUS)
       NVAR = POSITION(1)

       DO 67 L=1,NVAR

          IF (L.EQ.1)    THEN
              FINDEX = 1
          ELSE
              FINDEX = POSITION(L) + 1
          ENDIF

          IF (L.EQ.NVAR) THEN
              LINDEX = POSITION(NVAR+1) 
          ELSE
              LINDEX = POSITION(L+1) - 1
          ENDIF

          LINDEX = LINDEX - FINDEX + 1
          CALL STKRDC('IN_B',1,FINDEX,LINDEX,ACTS,LAB(L),KUN,
     +                KNUL,STATUS)

 67     CONTINUE

CC-----LOCATE EXPLANATORY COLUMNS
       DO 177 J=1,NVAR
             CALL TBCSER(LUA,LAB(J),JPLACE(J),STATUS)
             IF (JPLACE(J) .LT. 0) CALL STETER(9,'Wrong column name')
             WRITE(CBUF,*) 'Label: ',LAB(J)
             CALL STTPUT(CBUF,ISTAT)	     
             WRITE(CBUF,*) ' Position: ',JPLACE(J)
             CALL STTPUT(CBUF,ISTAT)     
  177  CONTINUE

CC-----MOVE STRINGS TO THE RIGHT 

       DO 70 J=1,NVAR
C          write(6,*) 'Index, LAB(J)', J, ':',LAB(J),':',' (before)'
          LABJ   = LAB(J)
          CALL MOVE(HELP)
          LAB(J) = LABJ
C          write(6,*) 'After: ',LAB(J)
 70    CONTINUE

CC-----ADD A VARIABLE IF CST TERM IS SELECTED AND
CC     MOVE DEPENDENT VARIABLE TO POSITION NVAR+1

       IF (JCST.EQ.1) NVAR=NVAR+1
       NVAD=NVAR+1
       JPLACE(NVAD)=JPLACE(NDXX)
       LAB(NVAD)=LAB(NDXX)

CC-----HOW MUCH OUTPUT?
  150   CONTINUE
C
C       CALL STTPUT('Default is 1 = medium-sized output',ISTAT)
       YN = '1'

       IF(.NOT.(YN.EQ.'0'.OR.YN.EQ.'1'.OR.YN.EQ.'2')) THEN
         WRITE (CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 150
       ENDIF
       JPRT=JNTGR(YN)

CC-----DO YOU WANT TO LOOK AT THE RESIDUALS?
  160   CONTINUE
       YN = '3'

       IF(.NOT.(YN.EQ.'0'.OR.YN.EQ.'1'.OR.(YN.EQ.'2'.AND.LOCA.NE.1)
     1               .OR.(YN.EQ.'3'.AND.LOCA.NE.1) ) ) THEN
         WRITE (CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 160
       ENDIF
       JPLT=JNTGR(YN)
       IF (JCST.EQ.1.AND.NVAR.EQ.1.AND.JPLT.NE.0) JPLT=2

CC-----DO YOU WANT TO COMPUTE OUTLIER DIAGNOSTICS
       IF (LOCA.NE.1) THEN
          YN = 'Y'

          IF (YN.EQ.'y'.OR.YN.EQ.'Y') THEN
                                        JDIAG=1
                                                          ELSE
                                        JDIAG=0
          ENDIF
       ENDIF

       IF (FNAMEA.EQ.'CON') THEN
CC-----DO YOU WANT TO SAVE THE DATA
  170    CONTINUE
         YNSAVE = 'N'

         IF (YNSAVE.EQ.'y') YNSAVE='Y'
         IF (YNSAVE.EQ.'n') YNSAVE='N'
         IF (YNSAVE.NE.'Y'.AND.YNSAVE.NE.'N') THEN
            WRITE(CBUF,8050)
            CALL STTPUT(CBUF,ISTAT)
            GOTO 170
         ENDIF
         IF (YNSAVE.EQ.'Y') THEN
            WRITE(CBUF,8250)
            CALL STTPUT(CBUF,ISTAT)
            READ(*,9030) FNAMEC
            OPEN(LUC,FILE=FNAMEC,STATUS='NEW')
         ENDIF
       ENDIF

CC-----READ OUTPUT COLUMNS NAMES AND CREATE THEM
       CALL STKRDC('OUTPUTC',1,1,17,ACTS,OUTC1,KUN,KNUL,STATUS)
       CALL STKRDC('OUTPUTC',1,18,17,ACTS,OUTC2,KUN,KNUL,STATUS)
       CALL TBCSER(LUA,OUTC1,OUTN1,STATUS)
       IF (OUTN1.LT.0) THEN
          CALL TBCINI(LUA,D_R8_FORMAT,1,'F12.6','Units',OUTC1,
     +             OUTN1,STATUS)
       ENDIF

       CALL TBCSER(LUA,OUTC2,OUTN2,STATUS)
       IF (OUTN2.LT.0) THEN
           CALL TBCINI(LUA,D_R8_FORMAT,1,'F12.6','Units',OUTC2,
     +             OUTN2,STATUS)
       ENDIF

CC-----WHERE DO YOU WANT THE OUTPUT
       CALL STKRDC('OUT_A',1,1,80,ACTS,FNAMEB,KUN,KNUL,STATUS)


       IF (FNAMEB.EQ.'con'.OR.FNAMEB.EQ.'Con') FNAMEB='CON'
       IF (FNAMEB.EQ.'prn'.OR.FNAMEB.EQ.'Prn') FNAMEB='PRN'
       IF (FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN')
     +     OPEN(LUB,FILE=FNAMEB,STATUS='UNKNOWN')
       IF (.NOT.(FNAMEB.EQ.'CON'.OR.FNAMEB.EQ.'PRN'))
     1     OPEN(LUB,FILE=FNAMEB,STATUS='UNKNOWN')

CC-----PLEASE ENTER A TITLE FOR THE OUTPUT
       JHEAD = ' ' 

       NVSB=NVAR-1
       ANVAR=NVAR

CC-----DO YOU WANT TO READ THE DATA IN FREE FORMAT
  180   CONTINUE
       YN = 'Y'

       IF (YN.EQ.'y') YN='Y'
       IF (YN.EQ.'n') YN='N'
       IF (YN.NE.'Y'.AND.YN.NE.'N') THEN
         WRITE(CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 180
       ENDIF
       IF (YN.NE.'Y') THEN
CC-----READ FORMAT FOR THE INPUT
         WRITE(CBUF,8290)
         CALL STTPUT(CBUF,ISTAT)
         READ (*,9040) JFMT
       ENDIF
       IF (LOCA.NE.1) THEN

CC-----  WHICH ALGORITHM
  190    CONTINUE
         ALGO = 'E'

         IF (ALGO.EQ.'e') ALGO='E'
         IF (ALGO.EQ.'q') ALGO='Q'
         IF (ALGO.NE.'Q'.AND.ALGO.NE.'E') THEN
            WRITE(CBUF,8050)
            CALL STTPUT(CBUF,ISTAT)
            GOTO 190
         ENDIF
       ENDIF

CC-----OPTION FOR THE TREATMENT OF MISSING VALUE
  200   CONTINUE
       YNOK = '0'

       IF (.NOT.(YNOK.EQ.'0'.OR.YNOK.EQ.'1'.OR.
     1                  (YNOK.EQ.'2'.AND.LOCA.NE.1) ) ) THEN
         WRITE (CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 200
       ENDIF
       MVAL=JNTGR(YNOK)
       
CC-----ABSTRACT OF ALL THE OPTIONS
       IF (LOCA.EQ.1) THEN
         WRITE(CBUF,8330) LAB(NVAD),NCAS
         CALL STTPUT(CBUF,ISTAT)
                      ELSE
         IF (JCST.EQ.0) THEN
           CALL STTPUT('****************************************',ISTAT)
           CALL STTPUT('             P R O G R E S S            ',ISTAT)
           CALL STTPUT('WILL PERFORM A REGRESSION WITHOUT CONSTANT TERM'
     1 ,ISTAT)
           CALL STTPUT('****************************************',ISTAT)
           WRITE(CBUF,202) NCAS
  202      FORMAT(' THE NUMBER OF CASES EQUALS',17X,I5)
           CALL STTPUT(CBUF,ISTAT)
           WRITE(CBUF,204) NVAR
  204      FORMAT(' THE NUMBER OF EXPLANATORY VARIABLES EQUALS ',I5)
           CALL STTPUT(CBUF,ISTAT)
   
         ELSEIF (JCST.EQ.1) THEN
            CALL STTPUT('***************************************',ISTAT)
            CALL STTPUT('*           P R O G R E S S           *',ISTAT)
            CALL STTPUT('*WILL PERFORM A REGRESSION WITH CONSTANT TERM*'
     1 ,ISTAT)
            CALL STTPUT('***************************************',ISTAT)            
            WRITE(CBUF,205) NCAS 	
  205       FORMAT(' THE NUMBER OF CASES EQUALS',19X,I5)
            CALL STTPUT(CBUF,ISTAT)
            WRITE(CBUF,207) NVSB 
  207       FORMAT('THE NUMBER OF EXPLANATORY VARIABLES EQUALS',3X,I5)
            CALL STTPUT(CBUF,ISTAT)
         ENDIF   
         WRITE(CBUF,8360) LAB(NVAD)
         CALL STTPUT(CBUF,ISTAT)
       ENDIF
       IF (FNAMEA.NE.'CON') THEN
           WRITE(CBUF,8370) FNAMEA
           CALL STTPUT(CBUF,ISTAT)
       ELSEIF (FNAMEA.EQ.'CON') THEN
           WRITE(CBUF,8380)
           CALL STTPUT(CBUF,ISTAT)
       ENDIF 
       IF (YNSAVE.EQ.'Y') THEN
          WRITE(CBUF,8390) FNAMEC
          CALL STTPUT(CBUF,ISTAT)
       ENDIF  
       WRITE(CBUF,8400) JHEAD
       CALL STTPUT(CBUF,ISTAT)
       IF (YN.EQ.'Y') THEN
          WRITE(CBUF,8410)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (YN.EQ.'N') THEN
          WRITE(CBUF,8420) JFMT
          CALL STTPUT(CBUF,ISTAT)
       ENDIF  
       IF (JPRT.EQ.0) THEN
           WRITE (CBUF,8430)
           CALL STTPUT(CBUF,ISTAT)   
       ELSEIF (JPRT.EQ.1) THEN
           WRITE (CBUF,8440)
           CALL STTPUT(CBUF,ISTAT)
       ELSEIF (JPRT.EQ.2) THEN
           WRITE (CBUF,8450)
           CALL STTPUT(CBUF,ISTAT)
       ENDIF
       IF (JPLT.EQ.0) THEN
          WRITE(CBUF,8460)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (JPLT.EQ.1) THEN
          WRITE(CBUF,8470)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (JPLT.EQ.2) THEN
          WRITE(CBUF,8480)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (JPLT.EQ.3) THEN
          WRITE(CBUF,8490)
          CALL STTPUT(CBUF,ISTAT)
       ENDIF
       IF (LOCA.NE.1) THEN
         IF (ALGO.EQ.'Q') THEN
           WRITE(CBUF,8500)
           CALL STTPUT(CBUF,ISTAT)
         ELSEIF (ALGO.EQ.'E') THEN 
            WRITE(CBUF,8510)
            CALL STTPUT(CBUF,ISTAT)
         ENDIF   
       ENDIF
       IF (MVAL.EQ.0) THEN
          WRITE(CBUF,8520)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (MVAL.EQ.1.AND.LOCA.NE.1) THEN
          WRITE(CBUF,8530)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (MVAL.EQ.1.AND.LOCA.EQ.1) THEN
          WRITE(CBUF,8535)
          CALL STTPUT(CBUF,ISTAT)
       ELSEIF (MVAL.EQ.2) THEN
          WRITE(CBUF,8540)
          CALL STTPUT(CBUF,ISTAT)
       ENDIF
       WRITE(CBUF,8550) FNAMEB
       CALL STTPUT(CBUF,ISTAT)
       WRITE (CBUF,8560)
       CALL STTPUT(CBUF,ISTAT)

 210   CONTINUE
       YNOK = 'Y'

       IF (YNOK.EQ.'y') YNOK='Y'
       IF (YNOK.EQ.'n') YNOK='N'
       IF (YNOK.NE.'Y'.AND.YNOK.NE.'N') THEN
         WRITE (CBUF,8050)
         CALL STTPUT(CBUF,ISTAT)
         GOTO 210
       ENDIF
       IF (YNOK.NE.'Y') GOTO 11

C       CALL STTPUT('If LOCA=1, LCAT starts',ISTAT)
       IF (LOCA.EQ.1)       
     1 CALL LCAT(NCAS,NVAR,JCST,JPRT,NVAD,X,Y,RESDU,WEIGHTS,PREC,
     2 XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,NDXX,NDXY,MVAL,LUA,LUB,LUC,
     3 JREG,JHEAD,FNAMEA,FNAMEB,FNAMEC,YNSAVE,LAB,JFMT,JVARS,YN,JPLACE)

       IF (MVAL.NE.0) THEN
         DO 220 J=1,NVAD
         IF (J.EQ.1) THEN
           WRITE (CBUF,8570)
           CALL STTPUT(CBUF,ISTAT)
 225           READ (*,9000) YNM
           IF (YNM.EQ.'y') YNM='Y'
           IF (YNM.EQ.'n') YNM='N'
           IF (YNM.NE.'Y'.AND.YNM.NE.'N') THEN
              WRITE(CBUF,8050)
              CALL STTPUT(CBUF,ISTAT)
              GOTO 225
           ENDIF
           IF (YNM.EQ.'Y'.OR.YNM.EQ.'y') THEN
              YNM='Y'
              WRITE (CBUF,8580)
              CALL STTPUT(CBUF,ISTAT)
              READ(*,*,ERR=226)CODE
226           CONTINUE
           ENDIF
         ENDIF
         IF (YNM.NE.'Y') THEN
           IF (J.EQ.NVAR.AND.JCST.EQ.1) GOTO 220
           IF (J.NE.NVAD) THEN
              WRITE (CBUF,8590) LAB(J)
              CALL STTPUT(CBUF,ISTAT)
           ELSEIF (J.EQ.NVAD) THEN
              WRITE (CBUF,8600)
              CALL STTPUT(CBUF,ISTAT)
           ENDIF
 230       READ (*,9000) YNOK
           IF (YNOK.EQ.'y') YNOK='Y'
           IF (YNOK.EQ.'n') YNOK='N'
           IF (YNOK.NE.'Y'.AND.YNOK.NE.'N') THEN
             WRITE (CBUF,8050)
             CALL STTPUT(CBUF,ISTAT)
             GOTO 230
           ENDIF
                         ELSE
           YNOK='Y'
         ENDIF
         IF (YNOK.NE.'Y') THEN
            JNDEX(J)=0
                          ELSE
            JNDEX(J)=1
CC-----READ THE VALUE WHICH HAS TO BE INTERPRETED AS THE MISSING VALUE CODE
            IF (YNM.NE.'Y')  THEN
               WRITE(CBUF,8610)
               CALL STTPUT(CBUF,ISTAT)
               READ(*,*,ERR=231)VALMS(J)
231            CONTINUE
            ELSE
               VALMS(J)=CODE
            ENDIF
         ENDIF
 220   CONTINUE
       ENDIF
CC-----ENTER THE DATA FOR EACH CASE
       IF (FNAMEA.EQ.'CON') THEN
          WRITE(CBUF,8615)
          CALL STTPUT(CBUF,ISTAT)
       ENDIF  

       JNC = 0
       DO 250 NSEL=1,ROW
       CALL TBSGET(LUA,NSEL,VALUE,STATUS)
       IF (VALUE) THEN

       JNC = JNC + 1
       NMVAL(JNC)=JNC

C--------------------------------------------------------        
       IF (JCST.EQ.0) THEN
         CALL STTPUT('Without constant term',ISTAT)
         IF (YN.EQ.'Y') THEN
            CALL STTPUT('Data in free format (default).',ISTAT)	 

            DO 260 J=1,NVAD
            JH=JPLACE(J)
            CALL TBERDR(LUA,NSEL,JH,AW(JH),NULL,STATUS)
            X(J,JNC)=AW(JH)
 260            CONTINUE
            IF (YNSAVE.EQ.'Y') WRITE(LUC,*)(AW(J),J=1,JVARS)
         ELSE
            CALL STTPUT('Data is not in free format',ISTAT)
            READ(LUA,JFMT)(AW(J),J=1,JVARS)
            DO 270 J=1,NVAD
            JH=JPLACE(J)
            X(J,JNC)=AW(JH)
 270            CONTINUE
            IF (YNSAVE.EQ.'Y') WRITE(LUC,*)(AW(J),J=1,JVARS)
         ENDIF

       ELSE
         X(NVAR,JNC)=1.0
         IF (YN.EQ.'Y') THEN
           DO 280 J=1,NVAD
           IF (.NOT.(J.EQ.NVAR.AND.JCST.EQ.1)) THEN
             JH=JPLACE(J)
             CALL TBERDR(LUA,NSEL,JH,AW(JH),NULL,STATUS)
             X(J,JNC)=AW(JH)
           ENDIF
 280           CONTINUE
           IF (YNSAVE.EQ.'Y') WRITE(LUC,*)(AW(J),J=1,JVARS)
         ELSE
           DO 290 J=1,NVAD
           IF (.NOT.(J.EQ.NVAR.AND.JCST.EQ.1)) THEN
             JH=JPLACE(J)
             CALL TBERDR(LUA,NSEL,JH,AW(JH),NULL,STATUS)
             X(J,JNC)=AW(JH)
           ENDIF
 290           CONTINUE
           IF (YNSAVE.EQ.'Y') WRITE(LUC,*) (AW(J),J=1,JVARS)
         ENDIF
       ENDIF
C--------------------------------------------------------

       ENDIF
 250   CONTINUE

       IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP')
       IF (YNSAVE.EQ.'Y') THEN
         WRITE(CBUF,8395) FNAMEC
         CALL STTPUT(CBUF,ISTAT)
       ENDIF 
C
C     
CC-----FORMATS
CK 8000  FORMAT(/////////////////30X,19('*')/
CK     1 30X,'* P R O G R E S S *'/30X,19('*')///////)
CK 8010  FORMAT(/' ENTER THE NUMBER OF CASES PLEASE : ',$)
 8020  FORMAT(/' THERE ARE TOO MANY CASES (AT MOST',I5,' )',
     1 ' ACCORDING TO THE LIMITS'
     1 /' OF THE ARRAYS IN THE PROGRAM. THE USER HAS TO ADAPT THESE'
     1 /' LIMITS SUCH THAT THE CONCERNING LIMITS ARE GREATER THAN OR'
     1 /' EQUAL TO THE NUMBER OF CASES IN HIS DATA SET OR'
     1 /' ANOTHER REGRESSION CAN BE PERFORMED.'//)
 8030  FORMAT(/' THERE ARE NOT ENOUGH CASES'
     1 ' (AT LEAST 2 ARE REQUIRED).'//)
 8050  FORMAT(' NOT ALLOWED !  ENTER YOUR CHOICE AGAIN : ',$)
CK 8060  FORMAT(/' WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR',
CK     1 ' DATA SET?'/1X,56('-')/
CK     1 ' PLEASE GIVE A NUMBER BETWEEN 1 AND 50 : ',$)
CK 8070  FORMAT(/' THE PROBLEM IS REDUCED TO ESTIMATING A LOCATION',
CK     1 ' PARAMETER.')
CK 8080  FORMAT(/' WHICH VARIABLE DO YOU CHOOSE AS RESPONSE VARIABLE?'/
CK     1 1X,50('-')/' OUT OF THESE ',I4,' GIVE ITS POSITION : ',$)
CK 8090  FORMAT(/' GIVE A LABEL FOR THIS VARIABLE',
CK     1 ' (AT MOST 10 CHARACTERS) : ',$)
CK 8100  FORMAT(/' HOW MANY EXPLANATORY VARIABLES DO YOU WANT TO USE',
CK     1 ' IN THE ANALYSIS?'/1X,66('-')/
CK     1 ' (AT MOST ',I4,' ) : ',$)
CK 8110  FORMAT(//' TOO MANY COEFFICIENTS ACCORDING TO THE NUMBER',
CK     1 ' OF CASES.'//' NUMBER OF CASES',8X,'= ',I5/
CK     1 ' NUMBER OF COEFFICIENTS = ',I5/' THE NUMBER OF CASES MUST',
CK     1 ' BE TWICE THE NUMBER OF COEFFICIENTS.')
CK 8115  FORMAT(//' THERE ARE TOO MANY COEFFICIENTS (AT MOST',I3,'  )',
CK     1 ' ACCORDING TO THE LIMITS'/' OF THE ARRAYS IN THE PROGRAM.',
CK     1 ' THE USER HAS TO ADAPT THESE'/' LIMITS SUCH THAT THE',
CK     1 ' CONCERNING LIMITS ARE GREATER THAN OR'/
CK     1 ' EQUAL TO THE NUMBER OF COEFFICIENTS IN THE MODEL.'//)
CK 8120  FORMAT(' (INCLUDING THE CONSTANT TERM!)')
CK 8130  FORMAT(//' EXPLANATORY VARIABLES      :   POSITION',
CK     1 '   LABEL (AT MOST 10 CHARACTERS)'/
CK     1 1X,32('-'),4(' '),6('-'),10(' '),19('-'))
CK 8140  FORMAT(' NUMBER  ',I4,15X,':',4X,I4,6X,$)
CK 8150  FORMAT(' NUMBER  ',I4,15X,':',4X,$)
CK 8160  FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOOSEN FOR ANOTHER',
CK     1 ' VARIABLE.'/' ENTER THE RIGHT POSITION PLEASE : ')
CK 8170  FORMAT(/' HOW MUCH OUTPUT DO YOU WANT?'/1X,29('-')/
CK     1 ' 0 = SMALL OUTPUT',7X,': LIMITED TO BASIC RESULTS'/
CK     1 ' 1 = MEDIUM-SIZED OUTPUT:',
CK     1 ' ALSO INCLUDES A TABLE WITH THE OBSERVED VALUES OF Y,'/
CK     1 25X,' THE ESTIMATES OF Y, THE RESIDUALS AND THE WEIGHTS'/
CK     1 ' 2 = LARGE OUTPUT',7X,
CK     1 ': ALSO INCLUDES THE RAW AND STANDARDIZED DATA'/
CK     1 ' ENTER YOUR CHOICE : ',$)
CK 8180  FORMAT(/' DO YOU WANT TO LOOK AT THE RESIDUALS?'/1X,38('-')/
CK     1 ' 0 = NO RESIDUAL PLOTS'/
CK     1 ' 1 = PLOT OF STANDARDIZED RESIDUALS VERSUS THE ESTIMATED',
CK     1 ' VALUE OF Y'/' 2 = PLOT OF THE STANDARDIZED RESIDUALS',
CK     1 ' VERSUS THE INDEX OF THE OBSERVATION'/' 3 = PERFORMS',
CK     1 ' BOTH TYPES OF RESIDUAL PLOTS'/' ENTER YOUR CHOICE : ',$)
CK 8190  FORMAT(/' DO YOU WANT TO LOOK AT THE RESIDUALS?'/1X,38('-')/
CK     1 ' 0 = NO RESIDUAL PLOTS'/
CK     1 ' 1 = PLOT OF THE STANDARDIZED RESIDUALS',
CK     1 ' VERSUS THE INDEX OF THE OBSERVATION'/
CK     1 ' ENTER YOUR CHOICE : ',$)
CK 8200  FORMAT(/' DO YOU WANT TO COMPUTE OUTLIER DIAGNOSTICS ?',
CK     1 /' YES OR NO : ',$)
CK 8210  FORMAT(/' GIVE THE NAME OF THE FILE CONTAINING THE DATA',
CK     1 ' (e.g. TYPE  A:EXAMPLE.DAT ),'/' or TYPE',
CK     1 '  KEY  IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/
CK     1 ' WHAT DO YOU CHOOSE ? ',$)
CK 8220  FORMAT(/' THIS FILE DOES NOT EXIST, PLEASE ENTER ANOTHER ONE.')
CK 8230  FORMAT(/' FORTRAN ERROR CODE : ',I8/)
CK 8240  FORMAT(/' DO YOU WANT TO SAVE YOUR DATA IN A FILE ?'/
CK     1 ' ANSWER YES OR NO : ',$)
8250  FORMAT(/' IN WHICH FILE DO YOU WANT TO SAVE YOUR DATA?'/
     1 ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME',
     1 ' NAME,'/11X,' THEN THE OLD FILE WILL BE OVERWRITTEN.)'/
     1 ' TYPE e.g.  B:SAVE.DAT  : ',$)
CK 8260  FORMAT(/' WHERE DO YOU WANT YOUR OUTPUT?'/1X,31('-')/
CK     1 '    TYPE  CON  IF YOU WANT IT ON THE SCREEN'/
CK     1 ' or TYPE  PRN  IF YOU WANT IT ON THE PRINTER'/
CK     1 ' or TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/
CK     1 ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME',
CK     1' NAME',/11X,' THEN THE OLD FILE WILL BE OVERWRITTEN.)'/
CK     1 ' WHAT DO YOU CHOOSE ?  ',$)
CK 8270  FORMAT(/' PLEASE ENTER A TITLE FOR THE OUTPUT',
CK     1 ' (AT MOST 60 CHARACTERS).'/1X,60('-')/1X,$)
CK 8280  FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT?'/
CK     1 1X,44('-')/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)',
CK     1 ' BETWEEN NUMBERS.'/' (WE ADVISE USERS WITHOUT',
CK     1 ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/
CK     1 ' MAKE YOUR CHOICE (YES/NO): ',$)
 8290  FORMAT(/' YOUR DESIRED FORTRAN FORMAT IS :'/
     1 ' (BETWEEN BRACKETS AND',
     1 ' AT MOST 60 CHARACTERS, e.g. (2F3.0,F1.0) )')
CK 8300  FORMAT(/' WHICH VERSION OF THE ALGORITHM WOULD YOU LIKE',
CK     1' TO USE?'/1X,53('-')/' Q = QUICK VERSION'/
CK     1 ' E = EXTENSIVE SEARCH '/
CK     1 ' ENTER YOUR CHOICE PLEASE (Q OR E) : ',$)
CK 8310  FORMAT(/' CHOOSE AN OPTION FOR THE TREATMENT OF MISSING VALUES'/
CK     1 1X,53('-')/' 0 = THERE ARE NO MISSING VALUES IN THE DATA'/
CK     1 ' 1 = ELIMINATION OF THE CASES FOR WHICH AT LEAST ONE',
CK     1 ' VARIABLE IS MISSING'/' 2 = ESTIMATES ARE FILLED IN FOR',
CK     1 ' UNOBSERVED VALUES'/' ENTER YOUR CHOICE : ',$)
CK 8320  FORMAT(/' CHOOSE AN OPTION FOR THE TREATMENT OF MISSING VALUES'/
CK     1 1X,53('-')/' 0 = THERE ARE NO MISSING VALUES IN THE DATA'/
CK     1 ' 1 = ELIMINATION OF THE CASES FOR WHICH THE',
CK     1 ' VARIABLE IS MISSING'/' ENTER YOUR CHOICE : ',$)
 8330  FORMAT(//////////8X,63('*')/8X,
     1 '* P R O G R E S S  WILL PERFORM A LOCATION AND SCALE',
     1 ' ANALYSIS *'/8X,63('*')//
     1 1X,A10,' IS THE LABEL OF THE VARIABLE.'/
     1 ' THE NUMBER OF CASES EQUALS',13X,I5/)
C 8340  FORMAT(/////////6X,68('*')/6X,
C     1 '* P R O G R E S S  WILL PERFORM A REGRESSION WITHOUT CONSTANT',
C     1' TERM *'/6X,68('*')//' THE NUMBER OF CASES EQUALS',17X,I5/
C     1 ' THE NUMBER OF EXPLANATORY VARIABLES EQUALS ',I5)
C 8350  FORMAT(/////////8X,65('*')/8X,
C     1 '* P R O G R E S S  WILL PERFORM A REGRESSION WITH CONSTANT',
C     1 ' TERM *'/8X,65('*')//' THE NUMBER OF CASES EQUALS',19X,I5/
C     1 ' THE NUMBER OF EXPLANATORY VARIABLES EQUALS',3X,I5)
 8360  FORMAT(1X,A10,' IS THE RESPONSE VARIABLE.')
 8370  FORMAT(' YOUR DATA RESIDE IN FILE',7X,': ',A30)
 8380  FORMAT(' THE DATA WILL BE READ FROM THE KEYBOARD.')
 8390  FORMAT(' THE DATA WILL BE SAVED IN FILE : ',A30)
 8395  FORMAT(//' THE DATA WILL BE SAVED IN FILE : ',A30//)
 8400  FORMAT(' TITLE FOR OUTPUT : ',A60)
 8410  FORMAT(' THE DATA WILL BE READ IN FREE FORMAT.')
 8420  FORMAT(' DATA INPUT FORMAT :'/5X,A60)
 8430  FORMAT(' SMALL OUTPUT IS WANTED.')
 8440  FORMAT(' MEDIUM-SIZED OUTPUT IS WANTED.')
 8450  FORMAT(' LARGE OUTPUT IS WANTED.')
 8460  FORMAT(' NO RESIDUAL PLOTS ARE WANTED.')
 8470  FORMAT(' A PLOT OF STANDARDIZED RESIDUALS VERSUS',
     1 ' ESTIMATED Y IS WANTED.')
 8480  FORMAT(' AN INDEX PLOT IS WANTED.')
 8490  FORMAT(' BOTH TYPES OF RESIDUAL PLOTS ARE WANTED.')
 8500  FORMAT(' THE QUICK VERSION OF THE ALGORITHM WILL BE USED.')
 8510  FORMAT(' THE EXTENSIVE SEARCH VERSION WILL BE USED.')
 8520  FORMAT(' THERE ARE NO MISSING VALUES.')
 8530  FORMAT(' TREATMENT OF MISSING VALUES IN OPTION 1:',
     1 ' THIS MEANS THAT A CASE WITH A'/' MISSING VALUE',
     1 ' FOR AT LEAST ONE VARIABLE WILL BE DELETED.'/)
 8535  FORMAT(' TREATMENT OF MISSING VALUES :',
     1 ' A CASE WITH A'/' MISSING VALUE',
     1 ' FOR THE VARIABLE WILL BE DELETED.'/)
 8540  FORMAT(' TREATMENT OF MISSING VALUES IN OPTION 2:'/
     1 ' FIRST, A CASE WITH A MISSING VALUE FOR THE RESPONSE VARIABLE'
     1 /' OR FOR ALL EXPLANATORY VARIABLES WILL BE DELETED.'/
     1 ' THEN, A MISSING VALUE FOR A VARIABLE WILL BE REPLACED BY'/
     1 ' THE MEDIAN OF THE NON-MISSING VALUES .'/)
 8550  FORMAT(' YOUR OUTPUT WILL BE WRITTEN ON : ',A30)
 8560  FORMAT(' ARE ALL THESE OPTIONS OK ?',' YES OR NO : ')
 8570  FORMAT(/' IS THERE A UNIQUE VALUE WHICH IS TO BE',
     1 ' INTERPRETED'/' AS A MISSING MEASUREMENT FOR ANY VARIABLE?'/
     1 ' ANSWER YES OR NO : ',$)
 8580  FORMAT(/' PLEASE ENTER THIS VALUE : ',$)
 8590  FORMAT(' DOES VARIABLE ',A10,
     1 ' CONTAIN MISSING VALUE(S)?'/' ANSWER YES OR NO : ',$)
 8600  FORMAT(' DOES THE RESPONSE VARIABLE CONTAIN MISSING VALUE(S)?'/
     1 ' ANSWER YES OR NO : ',$)
 8610  FORMAT(' ENTER THE VALUE OF THIS VARIABLE',
     1 ' WHICH HAS TO BE INTERPRETED AS'/
     1 ' THE MISSING VALUE CODE : ',$)
 8615  FORMAT(//' ENTER YOUR DATA FOR EACH CASE.'//)
CK 8620  FORMAT(1X,' THE DATA FOR CASE NUMBER ',I4,' : ',$)
CK 8630  FORMAT(' THE DATA FOR CASE NUMBER ',I4,' : ',$)
 9000  FORMAT(A1)
CK 9010  FORMAT(A10)
CK 9020  FORMAT(BN,I4,6X,A10)
 9030  FORMAT(A30)
 9040  FORMAT(A60)
       RETURN
       END

CC     ------------------------------------------------------------------------
CC     *JNTGR*: SUBROUTINE FOR TRANSFORMING A CHARACTER INTO AN INTEGER
CC     ------------------------------------------------------------------------
       FUNCTION JNTGR(KAR)

       INCLUDE 'MID_REL_INCL:implicit.inc'

       CHARACTER*1 KAR
       IF (KAR.EQ.'0') JNTGR=0
       IF (KAR.EQ.'1') JNTGR=1
       IF (KAR.EQ.'2') JNTGR=2
       IF (KAR.EQ.'3') JNTGR=3
       RETURN
       END
CC     ------------------------------------------------------------------------
CC     *SMISSING*: SUBROUTINE FOR HANDLING MISSING VALUES
CC     ------------------------------------------------------------------------
       SUBROUTINE SMISSING(NVAR,NCAS,NDXX,NDXY,JCST,X,Y,AW,NMVAL,
     1 MVAL,JNDEX,JNDVC,VALMS,NSTOP,LAB,JPRT,LUB)

       INCLUDE 'MID_REL_INCL:implicit.inc'

       DIMENSION X(NDXX,NDXY),Y(NDXY),AW(NDXY)
       DIMENSION NMVAL(NDXY),VALMS(NDXX),JNDVC(NDXX),JNDEX(NDXX)
       CHARACTER*10 LAB(NDXX)
       CHARACTER*80 OUTEXT
       INTEGER      ISTAT
       NVSB=NVAR-1
       NVAD=NVAR+1
       JHALT=0
       JHLT=0
       MAXM=(NCAS*4)/5
       DO 10 J=1,NVAD
       JNDVC(J)=0
       IF (.NOT.((J.EQ.NVAR.AND.JCST.EQ.1).OR.(JNDEX(J).EQ.0)))THEN
          DO 20 JNC=1,NCAS
          IF (X(J,JNC).EQ.VALMS(J)) THEN
             JNDVC(J)=JNDVC(J)+1
             NMVAL(JNC)=0
          ENDIF
 20          CONTINUE
          IF (JNDVC(J).GT.MAXM) JHALT=JHALT+1
          IF (MVAL.EQ.1.AND.JPRT.NE.0) WRITE(LUB,8000) LAB(J),JNDVC(J)
       ENDIF
 10    CONTINUE
       IF(JHALT.EQ.0) GOTO 30
       WRITE(LUB,8010) JHALT,MAXM
       NSTOP=1
       RETURN
 30    NCASM=NCAS
       MAXM=NCAS-MAXM
       JL=0
       JHALT=0
       DO 50 JNC=1,NCASM
       IF (NMVAL(JNC).NE.0) GOTO 65
       IF(JHALT.EQ.1.OR.MVAL.EQ.2) GOTO 60
       IF (JPRT.NE.0) WRITE(LUB,8020) NVAD
       JHALT=1
 60    JTVAR=0
       DO 70 J=1,NVAD
       IF(((JCST.EQ.1.AND.J.EQ.NVAR).OR.(JNDEX(J).EQ.0)).OR.
     1 (X(J,JNC).NE.VALMS(J))) GOTO 70
       JTVAR=JTVAR+1
       JNDVC(JTVAR)=J
 70    CONTINUE
       IF (JTVAR.EQ.0) GOTO 65
       IF (MVAL.EQ.1.OR.JHLT.EQ.1) GOTO 80
       IF (JPRT.NE.0) WRITE(LUB,8030)
       JHLT=1
 80    IF (MVAL.EQ.1.AND.JPRT.NE.0) THEN
          IF (JTVAR.GT.10) GOTO 90
          WRITE(LUB,8040) JNC,(JNDVC(J),J=1,JTVAR)
          GOTO 100
 90          WRITE(LUB,8040) JNC,(JNDVC(J),J=1,10)
          WRITE(LUB,8050) (JNDVC(J),J=11,JTVAR)
       ENDIF
 100   IF (MVAL.EQ.2.AND.X(NVAD,JNC).EQ.VALMS(NVAD)) THEN
          IF (JPRT.NE.0) WRITE(LUB,8060) JNC
          JTVAR=JTVAR-1
       ENDIF
       IF (JCST.EQ.1) JTVAR=JTVAR+1
       IF(MVAL.EQ.2.AND.JTVAR.EQ.NVAR.AND.JPRT.NE.0) WRITE(LUB,8070) JNC
       IF (.NOT.(MVAL.EQ.2.AND.JTVAR.LT.NVAR.AND.X(NVAD,JNC).
     1 NE.VALMS(NVAD))) GOTO 50
 65    JL=JL+1
       DO 110 J=1,NVAD
 110   X(J,JL)=X(J,JNC)
       NMVAL(JL)=JNC
 50    CONTINUE
       NCAS=JL
       WRITE(LUB,8080) NCAS
       IF (NCAS.LE.(NVAR*1.75)) THEN
          WRITE (OUTEXT,8090) NCAS,NVAR
          CALL STTPUT(OUTEXT,ISTAT)
          IF (JCST.EQ.1) THEN
             WRITE(OUTEXT,8100)
             CALL STTPUT(OUTEXT,ISTAT)
          ENDIF   
          NSTOP=1
          RETURN
       ENDIF
       IF (NCAS.LE.MAXM) THEN
          WRITE(LUB,8110)
          NSTOP=1
          RETURN
       ENDIF
       IF (MVAL.NE.1) THEN
         DO 150 J=1,NVAR
         IF ((JCST.EQ.1.AND.J.EQ.NVAR).OR.
     1         (JNDEX(J).EQ.0)) GOTO 150
         JJ=0
         NCASM=NCAS
         JPLUS=0
         DO 160 JNC=1,NCAS
         JPLUS=JPLUS+1
         AW(JPLUS)=X(J,JNC)
         IF (X(J,JNC).EQ.VALMS(J)) THEN
            NCASM=NCASM-1
            JJ=JJ+1
            JPLUS=JPLUS-1
            Y(JJ)=JNC
         ENDIF
 160         CONTINUE
         IF (JJ.EQ.0) THEN
            IF (JPRT.NE.0) WRITE(LUB,8120) LAB(J)
                      ELSE
            NCASM=NCAS-JJ
            AMED=AMDAN(AW,NDXY,AW,NCASM)
            DO 180 J2=1,JJ
            JY=Y(J2)+0.2
 180            X(J,JY)=AMED
            IF (JPRT.NE.0) WRITE(LUB,8130) LAB(J),JJ
            DO 190 J2=1,JJ
            J2Y=Y(J2)+0.2
 190            IF (JPRT.NE.0) WRITE(LUB,8140) NMVAL(J2Y)
         ENDIF
 150   CONTINUE
       ENDIF
 8000  FORMAT(' VARIABLE ',A10,' HAS A MISSING VALUE FOR',
     1 I4,' CASES.')
 8010  FORMAT(' THERE ARE(IS) ',I4,' VARIABLE(S),WHICH CONTAIN(S)'/
     1 ' MORE THAN 80 PERCENT (=',I4,' ) CASES WITH MISSING VALUE.')
 8020  FORMAT(/' CASE HAS A MISSING VALUE FOR VARIABLES',
     1 ' (VARIABLE NUMBER ',I4,' IS THE RESPONSE)'/1X,
     1 4('-'),25X,9('-'))
 8030  FORMAT(' THE FOLLOWING CASES HAVE BEEN DELETED.'/)
 8040  FORMAT(1X,I4,23X,10I4)
 8050  FORMAT(28X,10I4)
 8060  FORMAT(' CASE ',I4,' HAS A MISSING VALUE FOR',
     1 ' THE RESPONSE VARIABLE.')
 8070  FORMAT(' CASE ',I4,' HAS A MISSING VALUE FOR ALL THE',
     1 ' EXPLANATORY VARIABLES.')
 8080  FORMAT(/' THERE ARE ',I4,' CASES STAYING IN THE ANALYSIS.'/)
 8090  FORMAT(/' TOO MANY COEFFICIENTS ACCORDING TO THE NUMBER',
     1 ' OF CASES.'//' NUMBER OF CASES',8X,'= ',I5/
     1 ' NUMBER OF COEFFICIENTS = ',I5/' THE NUMBER OF CASES MUST',
     1 ' BE TWICE THE NUMBER OF COEFFICIENTS.')
 8100  FORMAT(' (INCLUDING THE CONSTANT TERM!)')
 8110  FORMAT(' MORE THAN 80 PERCENT OF THE CASES HAD TO BE DELETED'/
     1 ' BECAUSE OF THE MISSING VALUES. THE ANALYSIS WILL BE STOPPED.')
 8120  FORMAT(' VARIABLE ',A10,' CONTAINS NO MISSING VALUES.')
 8130  FORMAT(' THE VALUES OF ',A10,' WILL BE REPLACED',
     1 ' BY THE MEDIAN FOR',I5,' CASES NAMELY')
 8140  FORMAT(30X,'CASE NUMBER',I6)
       RETURN
       END
CC     ------------------------------------------------------------------------
CC     SUBROUTINE FOR CALCULATING THE NUMBER OF REPLICATIONS IN THE
CC     LMS ALGORITHM
CC     ------------------------------------------------------------------------
       SUBROUTINE SUBREP(NVAR,NCAS,NDXX,ALGO,JNDVC,JREP)

       INCLUDE 'MID_REL_INCL:implicit.inc'

       DIMENSION JNDVC(NDXX)
       CHARACTER ALGO
       NVSB=NVAR-1
       NVAD=NVAR+1
CC-----JNDVC(NVAD) IS SET EQUAL TO 11 IF ONE HAS TO CONSIDER ALL
CC-----            COMBINATIONS OF P POINTS OUT OF N INSTEAD OF
CC-----            RANDOM SELECTION
       IF (NVAR.NE.1) GOTO 20
       IF (ALGO.EQ.'E') JREP=500
       IF (ALGO.EQ.'Q') JREP=150
       IF((NCAS.LE.500.AND.ALGO.EQ.'E').OR.(NCAS.LE.150.AND.
     1 ALGO.EQ.'Q'))JNDVC(NVAD)=11
       GOTO 70
 20    IF (NVAR.NE.2) GOTO 30
       IF (ALGO.EQ.'E') JREP=1000
       IF (ALGO.EQ.'Q') JREP=300
       IF((NCAS.LE.50.AND.ALGO.EQ.'E').OR.(NCAS.LE.25.AND.
     1 ALGO.EQ.'Q'))JNDVC(NVAD)=11
       GOTO 70
 30    IF (NVAR.NE.3) GOTO 40
       IF (ALGO.EQ.'E') JREP=1500
       IF (ALGO.EQ.'Q') JREP=400
       IF((NCAS.LE.22.AND.ALGO.EQ.'E').OR.(NCAS.LE.15.AND.
     1 ALGO.EQ.'Q'))JNDVC(NVAD)=11
       GOTO 70
 40    IF (NVAR.NE.4) GOTO 50
       IF (ALGO.EQ.'E') JREP=2000
       IF (ALGO.EQ.'Q') JREP=500
       IF((NCAS.LE.17.AND.ALGO.EQ.'E').OR.(NCAS.LE.12.AND.
     1 ALGO.EQ.'Q'))JNDVC(NVAD)=11
       GOTO 70
 50    IF (NVAR.NE.5) GOTO 60
       IF (ALGO.EQ.'E') JREP=2500
       IF (ALGO.EQ.'Q') JREP=600
       IF((NCAS.LE.15.AND.ALGO.EQ.'E').OR.(NCAS.LE.11.AND.
     1 ALGO.EQ.'Q'))JNDVC(NVAD)=11
       GOTO 70
 60    IF (ALGO.EQ.'Q') GOTO 80
       JREP=3000
       IF((NCAS.LE.14).AND.(NVAR.EQ.6)) JNDVC(NVAD)=11
       GOTO 70
 80    IF (NVAR.EQ.6) JREP=700
       IF (NVAR.EQ.7) JREP=850
       IF (NVAR.EQ.8) JREP=1250
       IF (NVAR.GE.9) JREP=1500
 70    IF( .NOT.((NVAR.GE.7).OR.(JNDVC(NVAD).NE.11)))THEN
CC-----CALCULATION OF THE NUMBER OF COMBINATION OF P POINTS OUT OF N
       JTLLR=NCAS
       JNEM=NVAR
       IF (NVAR.EQ.1) GOTO 100
       DO 90 JNP=1,NVSB
       JTLLR=JTLLR*(NCAS-JNP)
       JNEM=JNEM*(NVAR-JNP)
 90    CONTINUE
 100   NCMB=JTLLR/JNEM
       JNDVC(NVAD)=11
       JREP=NCMB
       ENDIF
       RETURN
       END

CC
CC  *MIDUAL* : CALCULATES THE RESIDUALS OF ALL CASES
CC
       SUBROUTINE MIDUAL(AA,JKEUS,JDA,NCAS,NVAR,JCST,JPRT,NVAD,LUB,PREC,
     1 JREG,X,Y,RESDU,WEIGHTS,XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,
     1 NDXX,NDXY,JHEAD,LAB,LUA,OUTN1,OUTN2)

       INCLUDE 'MID_REL_INCL:implicit.inc'

       DIMENSION AA(JDA),X(NDXX,NDXY),Y(NDXY),RESDU(NDXY),WEIGHTS(NDXY)
       DIMENSION XMED(NDXX),XMAD(NDXX),AW(NDXY),NMVAL(NDXY)
       CHARACTER*10 LAB(NDXX)
       CHARACTER*60 JHEAD
       INTEGER      LUA,OUTN1,OUTN2,STATUS,NSEL
       INTEGER      COLUMN,ROW,NSC,ACOL,AROW
       LOGICAL       VALUE
       INTEGER       INUL
       REAL          RNUL
       DOUBLE PRECISION DNUL


       CALL TBIGET(LUA,COLUMN,ROW,NSC,ACOL,AROW,STATUS)
       CALL TBMNUL(INUL,RNUL,DNUL)

       JPL2=1
       AL=NCAS

       JNC = 0
       DO 20 NSEL=1,ROW
       CALL TBSGET(LUA,NSEL,VALUE,STATUS)
       IF (VALUE) THEN
       JNC = JNC + 1
       IF (.NOT.(NVAR.EQ.1.AND.JCST.EQ.1)) GOTO 40
       BBB=Y(JNC)-AA(1)
       GOTO 60
 40    AW(JNC)=0.0
       DO 30 J=1,NVAR
 30    AW(JNC)=AW(JNC)+AA(J)*(X(J,JNC)*XMAD(J)+XMED(J))
       YJ=Y(JNC)*XMAD(NVAD)+XMED(NVAD)
       BBB=YJ-AW(JNC)
 60    IF (AA(NVAD).GT.PREC) GOTO 70
       IF (ABS(BBB).LT.PREC) BBB=0.0
       RESDU(JNC)=BBB
       GOTO 50
 70    RESDU(JNC)=BBB/AA(NVAD)
 50    IF (JPRT.EQ.0) GOTO 20
       IF (NVAR.EQ.1.AND.JCST.EQ.1) GOTO 80

CC-----UPDATES MIDAS TABLE
        CALL TBEWRR(LUA,NSEL,OUTN1,AW(JNC),STATUS)
        CALL TBEWRR(LUA,NSEL,OUTN2,BBB,STATUS)

        GOTO 20
   80   CONTINUE
       ELSE
        CALL TBEWRD(LUA,NSEL,OUTN1,DNUL,STATUS)
        CALL TBEWRD(LUA,NSEL,OUTN2,DNUL,STATUS)
       ENDIF

 20    CONTINUE
CC 90    CONTINUE
CC 8000  FORMAT(//11X,'OBSERVED',12X,'RESIDUAL',
CC     1 '   NO',' RES/SC'/9X,A10/)
CC 8010  FORMAT(//11X,'OBSERVED',12X,'RESIDUAL',
CC     1 '   NO','  RES/SC',' WEIGHT'/9X,A10/)
CC 8020  FORMAT(//11X,'OBSERVED',11X,'ESTIMATED',12X,'RESIDUAL',
CC     1 3X,'NO',' RES/SC'/9X,A10,10X,A10/)
CC 8030  FORMAT(//11X,'OBSERVED',11X,'ESTIMATED',12X,'RESIDUAL',
CC     1 3X,'NO',' RES/SC',' WEIGHT'/9X,A10,10X,A10/)
CC 8040  FORMAT(1X,F18.5,2(1X,F19.5),I5,1X,F7.2,F6.1)
CC 8050  FORMAT(1X,F18.5,2(1X,F19.5),I5,'  *****')
C 
       RETURN
       END
