C @(#)prm.for 14.2 (ES0-DMD) 02/23/00 10:49:54 C=========================================================================== C Copyright (C) 1995 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 Massachusetss Ave, Cambridge, C MA 02139, USA. C C Corresponding 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 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 EQUIVALENCE (LABJ,HELP) INCLUDE 'MID_INCLUDE:st_def.inc' COMMON /VMR/ MADRID INCLUDE 'MID_INCLUDE:st_dat.inc' JDIAG=0 LOCA=0 C WRITE (*,8000) CC-----NAME OF THE FILE CONTAINING THE DATA C 165 WRITE(*,8210) 165 CONTINUE C READ(*,9030) FNAMEA C FNAMEA = 'parabol.tbl' CALL STKRDC('IN_A',1,1,80,ACTS,FNAMEA,KUN,KNUL,STATUS) C ---- OPEN THE TABLE C OPEN(LUA,FILE=FNAMEA) 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 C WRITE (*,14) C 14 FORMAT(/' DO YOU WANT A CONSTANT TERM IN THE REGRESSION?'/ C 1 ' ANSWER YES OR NO : ',$) 20 CONTINUE C get YN from keyword C 20 READ (*,9000) YN C YN = 'Y' CALL STKRDC('ACTION',1,1,80,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 C WRITE(*,8060) 30 CONTINUE C 30 READ(*,*,ERR=30)JVARS 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 C 50 WRITE(*,8090) C READ(*,9010) LABJ CALL STKRDC('INPUTC',1,1,20,ACTS,LABJ,KUN,KNUL,STATUS) LAB(NDXX)=LABJ CC-----WHICH VARIABLE WILL BE TAKEN AS THE RESPONSE VARIABLE C WRITE(*,8080) JVARS 40 CONTINUE C 40 READ(*,*,ERR=40)JPLACE(NDXX) 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 C WRITE(*,8100) JWR 60 CONTINUE C 60 READ(*,*,ERR=60)NVAR C CALL STTPUT('STKRDI starts now',ISTAT) 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 C CALL STTPUT('Locate explanatory columns',ISTAT) 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 MOVES DEPENDENT VARIABLE TO POSITION NVAR+1 80 IF (JCST.EQ.1) NVAR=NVAR+1 100 NVAD=NVAR+1 JPLACE(NVAD)=JPLACE(NDXX) LAB(NVAD)=LAB(NDXX) 130 CONTINUE 110 CONTINUE CC-----HOW MUCH OUTPUT? C 140 WRITE (*,8170) 140 CONTINUE 150 CONTINUE C 150 READ (*,9000) YN 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? C IF (LOCA.NE.1) THEN C WRITE(*,8180) C ELSE C WRITE (*,8190) C ENDIF C 160 READ (*,9000) YN 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 C WRITE(*,8200) C READ (*,9000) YN 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 C 170 READ(*,9000) YNSAVE 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 175 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 C 185 WRITE(*,8260) C READ(*,9030) FNAMEB C FNAMEB = 'parabol.out2' 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 C WRITE (*,8270) C READ (*,9040) JHEAD JHEAD = ' ' NVSB=NVAR-1 ANVAR=NVAR CC-----DO YOU WANT TO READ THE DATA IN FREE FORMAT C WRITE (*,8280) 180 CONTINUE C 180 READ (*,9000) YN 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 C WRITE(*,8300) 190 CONTINUE C 190 READ(*,9000) ALGO 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 C CALL STTPUT('Add here the treatment of missing values',ISTAT) C IF (LOCA.NE.1) THEN C WRITE (*,8310) C ELSE C WRITE (*,8320) C ENDIF 200 CONTINUE C 200 READ (*,9000) YNOK 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' C 210 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 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) 226 READ(*,*,ERR=226)CODE 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) 231 READ(*,*,ERR=231)VALMS(J) 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 C C CALL STTPUT('Now TBSGET reads row selection flag',ISTAT) C 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) C use CALL TBERDR() instead C CALL TBERDR(LUA,NSEL,JH,AW(JH),NULL,STATUS) C READ(LUA,*)(AW(J),J=1,JVARS) 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 C CALL STTPUT('IF JCST.EQ.1',ISTAT) C CALL STTPUT('With constant term',ISTAT) X(NVAR,JNC)=1.0 IF (YN.EQ.'Y') THEN C CALL STTPUT('data in free format',ISTAT) 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) C write(6,*) 'position: ',J,JNC,'Value: ',AW(JH) ENDIF 280 CONTINUE IF (YNSAVE.EQ.'Y') WRITE(LUC,*)(AW(J),J=1,JVARS) ELSE C READ(LUA,JFMT)(AW(J),J=1,JVARS) 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 CALL STTPUT('Only formats will follow',ISTAT) CC-----FORMATS 8000 FORMAT(/////////////////30X,19('*')/ 1 30X,'* P R O G R E S S *'/30X,19('*')///////) 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 : ',$) 8060 FORMAT(/' WHAT IS THE TOTAL NUMBER OF VARIABLES IN YOUR', 1 ' DATA SET?'/1X,56('-')/ 1 ' PLEASE GIVE A NUMBER BETWEEN 1 AND 50 : ',$) 8070 FORMAT(/' THE PROBLEM IS REDUCED TO ESTIMATING A LOCATION', 1 ' PARAMETER.') 8080 FORMAT(/' WHICH VARIABLE DO YOU CHOOSE AS RESPONSE VARIABLE?'/ 1 1X,50('-')/' OUT OF THESE ',I4,' GIVE ITS POSITION : ',$) 8090 FORMAT(/' GIVE A LABEL FOR THIS VARIABLE', 1 ' (AT MOST 10 CHARACTERS) : ',$) 8100 FORMAT(/' HOW MANY EXPLANATORY VARIABLES DO YOU WANT TO USE', 1 ' IN THE ANALYSIS?'/1X,66('-')/ 1 ' (AT MOST ',I4,' ) : ',$) 8110 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.') 8115 FORMAT(//' THERE ARE TOO MANY COEFFICIENTS (AT MOST',I3,' )', 1 ' ACCORDING TO THE LIMITS'/' OF THE ARRAYS IN THE PROGRAM.', 1 ' THE USER HAS TO ADAPT THESE'/' LIMITS SUCH THAT THE', 1 ' CONCERNING LIMITS ARE GREATER THAN OR'/ 1 ' EQUAL TO THE NUMBER OF COEFFICIENTS IN THE MODEL.'//) 8120 FORMAT(' (INCLUDING THE CONSTANT TERM!)') 8130 FORMAT(//' EXPLANATORY VARIABLES : POSITION', 1 ' LABEL (AT MOST 10 CHARACTERS)'/ 1 1X,32('-'),4(' '),6('-'),10(' '),19('-')) 8140 FORMAT(' NUMBER ',I4,15X,':',4X,I4,6X,$) 8150 FORMAT(' NUMBER ',I4,15X,':',4X,$) 8160 FORMAT(/' THIS POSITION HAS ALREADY BEEN CHOOSEN FOR ANOTHER', 1 ' VARIABLE.'/' ENTER THE RIGHT POSITION PLEASE : ') 8170 FORMAT(/' HOW MUCH OUTPUT DO YOU WANT?'/1X,29('-')/ 1 ' 0 = SMALL OUTPUT',7X,': LIMITED TO BASIC RESULTS'/ 1 ' 1 = MEDIUM-SIZED OUTPUT:', 1 ' ALSO INCLUDES A TABLE WITH THE OBSERVED VALUES OF Y,'/ 1 25X,' THE ESTIMATES OF Y, THE RESIDUALS AND THE WEIGHTS'/ 1 ' 2 = LARGE OUTPUT',7X, 1 ': ALSO INCLUDES THE RAW AND STANDARDIZED DATA'/ 1 ' ENTER YOUR CHOICE : ',$) 8180 FORMAT(/' DO YOU WANT TO LOOK AT THE RESIDUALS?'/1X,38('-')/ 1 ' 0 = NO RESIDUAL PLOTS'/ 1 ' 1 = PLOT OF STANDARDIZED RESIDUALS VERSUS THE ESTIMATED', 1 ' VALUE OF Y'/' 2 = PLOT OF THE STANDARDIZED RESIDUALS', 1 ' VERSUS THE INDEX OF THE OBSERVATION'/' 3 = PERFORMS', 1 ' BOTH TYPES OF RESIDUAL PLOTS'/' ENTER YOUR CHOICE : ',$) 8190 FORMAT(/' DO YOU WANT TO LOOK AT THE RESIDUALS?'/1X,38('-')/ 1 ' 0 = NO RESIDUAL PLOTS'/ 1 ' 1 = PLOT OF THE STANDARDIZED RESIDUALS', 1 ' VERSUS THE INDEX OF THE OBSERVATION'/ 1 ' ENTER YOUR CHOICE : ',$) 8200 FORMAT(/' DO YOU WANT TO COMPUTE OUTLIER DIAGNOSTICS ?', 1 /' YES OR NO : ',$) 8210 FORMAT(/' GIVE THE NAME OF THE FILE CONTAINING THE DATA', 1 ' (e.g. TYPE A:EXAMPLE.DAT ),'/' or TYPE', 1 ' KEY IF YOU PREFER TO ENTER THE DATA BY KEYBOARD.'/ 1 ' WHAT DO YOU CHOOSE ? ',$) 8220 FORMAT(/' THIS FILE DOES NOT EXIST, PLEASE ENTER ANOTHER ONE.') 8230 FORMAT(/' FORTRAN ERROR CODE : ',I8/) 8240 FORMAT(/' DO YOU WANT TO SAVE YOUR DATA IN A FILE ?'/ 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 : ',$) 8260 FORMAT(/' WHERE DO YOU WANT YOUR OUTPUT?'/1X,31('-')/ 1 ' TYPE CON IF YOU WANT IT ON THE SCREEN'/ 1 ' or TYPE PRN IF YOU WANT IT ON THE PRINTER'/ 1 ' or TYPE THE NAME OF A FILE (e.g. B:EXAMPLE.OUT)'/ 1 ' (WARNING : IF THERE ALREADY EXISTS A FILE WITH THE SAME', 1' NAME',/11X,' THEN THE OLD FILE WILL BE OVERWRITTEN.)'/ 1 ' WHAT DO YOU CHOOSE ? ',$) 8270 FORMAT(/' PLEASE ENTER A TITLE FOR THE OUTPUT', 1 ' (AT MOST 60 CHARACTERS).'/1X,60('-')/1X,$) 8280 FORMAT(/' DO YOU WANT TO READ THE DATA IN FREE FORMAT?'/ 1 1X,44('-')/' THIS MEANS THAT YOU ONLY HAVE TO INSERT BLANK(S)', 1 ' BETWEEN NUMBERS.'/' (WE ADVISE USERS WITHOUT', 1 ' KNOWLEDGE OF FORTRAN FORMATS TO ANSWER YES.)'/ 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) )') 8300 FORMAT(/' WHICH VERSION OF THE ALGORITHM WOULD YOU LIKE', 1' TO USE?'/1X,53('-')/' Q = QUICK VERSION'/ 1 ' E = EXTENSIVE SEARCH '/ 1 ' ENTER YOUR CHOICE PLEASE (Q OR E) : ',$) 8310 FORMAT(/' CHOOSE AN OPTION FOR THE TREATMENT OF MISSING VALUES'/ 1 1X,53('-')/' 0 = THERE ARE NO MISSING VALUES IN THE DATA'/ 1 ' 1 = ELIMINATION OF THE CASES FOR WHICH AT LEAST ONE', 1 ' VARIABLE IS MISSING'/' 2 = ESTIMATES ARE FILLED IN FOR', 1 ' UNOBSERVED VALUES'/' ENTER YOUR CHOICE : ',$) 8320 FORMAT(/' CHOOSE AN OPTION FOR THE TREATMENT OF MISSING VALUES'/ 1 1X,53('-')/' 0 = THERE ARE NO MISSING VALUES IN THE DATA'/ 1 ' 1 = ELIMINATION OF THE CASES FOR WHICH THE', 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.'//) 8620 FORMAT(1X,' THE DATA FOR CASE NUMBER ',I4,' : ',$) 8630 FORMAT(' THE DATA FOR CASE NUMBER ',I4,' : ',$) 9000 FORMAT(A1) 9010 FORMAT(A10) 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 10 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 C IF (AA(NVAD).GT.PREC.AND.JKEUS.NE.2) C 1 WRITE(LUB,8040) YJ,AW(JNC),BBB,NMVAL(JNC),RESDU(JNC) C IF (AA(NVAD).LE.PREC) C 1 WRITE(LUB,8050) YJ,AW(JNC),BBB,NMVAL(JNC) C IF (AA(NVAD).GT.PREC.AND.JKEUS.EQ.2) C 1 WRITE(LUB,8040) YJ,AW(JNC),BBB,NMVAL(JNC),RESDU(JNC), C 1 WEIGHTS(JNC) CC-----UPDATES MIDAS TABLE C write(6,*) 'Writing to table:',AW(JNC),BBB CALL TBEWRR(LUA,NSEL,OUTN1,AW(JNC),STATUS) CALL TBEWRR(LUA,NSEL,OUTN2,BBB,STATUS) GOTO 20 80 CONTINUE C 80 IF (JKEUS.NE.2) WRITE(LUB,8060) Y(JNC),BBB,JNC,RESDU(JNC) C IF (JKEUS.EQ.2) WRITE(LUB,8060) Y(JNC),BBB,JNC,RESDU(JNC), C 1 WEIGHTS(JNC) ELSE CALL TBEWRD(LUA,NSEL,OUTN1,DNUL,STATUS) CALL TBEWRD(LUA,NSEL,OUTN2,DNUL,STATUS) ENDIF 20 CONTINUE 90 CONTINUE 8000 FORMAT(//11X,'OBSERVED',12X,'RESIDUAL', 1 ' NO',' RES/SC'/9X,A10/) 8010 FORMAT(//11X,'OBSERVED',12X,'RESIDUAL', 1 ' NO',' RES/SC',' WEIGHT'/9X,A10/) 8020 FORMAT(//11X,'OBSERVED',11X,'ESTIMATED',12X,'RESIDUAL', 1 3X,'NO',' RES/SC'/9X,A10,10X,A10/) 8030 FORMAT(//11X,'OBSERVED',11X,'ESTIMATED',12X,'RESIDUAL', 1 3X,'NO',' RES/SC',' WEIGHT'/9X,A10,10X,A10/) 8040 FORMAT(1X,F18.5,2(1X,F19.5),I5,1X,F7.2,F6.1) 8050 FORMAT(1X,F18.5,2(1X,F19.5),I5,' *****') 8060 FORMAT(1X,F18.5,1X,F19.5,I5,1X,F7.2,F6.1) RETURN END