← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to stdred/spec/libsrc/pre.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
stdred/spec/libsrc/pre.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2005 European Southern Observatory (ESO)
 
3
C
 
4
C This program is free software; you can redistribute it and/or 
 
5
C modify it under the terms of the GNU General Public License as 
 
6
C published by the Free Software Foundation; either version 2 of 
 
7
C the License, or (at your option) any later version.
 
8
C
 
9
C This program is distributed in the hope that it will be useful,
 
10
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
C GNU General Public License for more details.
 
13
C
 
14
C You should have received a copy of the GNU General Public 
 
15
C License along with this program; if not, write to the Free 
 
16
C Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
C MA 02139, USA.
 
18
C
 
19
C Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
C       Internet e-mail: midas@eso.org
 
21
C       Postal address: European Southern Observatory
 
22
C                       Data Management Division 
 
23
C                       Karl-Schwarzschild-Strasse 2
 
24
C                       D 85748 Garching bei Muenchen 
 
25
C                       GERMANY
 
26
C===========================================================================
 
27
C
 
28
CC
 
29
CC  *LSL* : CALCULATES THE (REWEIGHTED) LS WHEN 'NVAR' EQUALS 1
 
30
CC          AND 'JCST'=0.
 
31
CC
 
32
       SUBROUTINE LSL(NCAS,NDXY,X,Y,RESDU,A,FCKW,H,NMXV,NDXX)
 
33
 
 
34
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
35
 
 
36
       DOUBLE PRECISION H(NMXV,NDXX)
 
37
       DIMENSION A(NMXV),X(NDXX,NDXY),Y(NDXY),RESDU(NDXY)
 
38
 
 
39
       AL=NCAS
 
40
       SXY=0.0
 
41
       SX2=0.0
 
42
       DO 10 JNC=1,NCAS
 
43
       SXY=SXY+X(1,JNC)*Y(JNC)*RESDU(JNC)
 
44
       SX2=SX2+(X(1,JNC)**2)*RESDU(JNC)
 
45
 10    CONTINUE
 
46
       A(1)=SXY/SX2
 
47
       FCKW=0.0
 
48
       DO 20 JNC=1,NCAS
 
49
 20    FCKW=FCKW+( (Y(JNC)-X(1,JNC)*A(1))**2 )*RESDU(JNC)
 
50
       H(1,1)=DBLE((FCKW/(AL-1.0))/SX2)
 
51
       RETURN
 
52
       END
 
53
CC
 
54
CC  *FCN* : PUTS A ROW OF THE MATRIX X IN A VECTOR.
 
55
CC
 
56
       SUBROUTINE FCN(K,M,F,X,JFLAG)
 
57
 
 
58
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
59
 
 
60
       DIMENSION F(K),X(M)
 
61
 
 
62
       DO 10 J=1,K
 
63
       F(J)=X(J)
 
64
 10    CONTINUE
 
65
       RETURN
 
66
       END
 
67
CC
 
68
CC  *LSREG* : CALCULATES THE LEAST SQUARES REGRESSION ESTIMATES.
 
69
CC
 
70
      SUBROUTINE LSREG(NDXX,NDXY,NMXV,K,N,M,F,X,Y,W,DA,
 
71
     1 H,FCKW,HVEC,JDMB,JNDEX)
 
72
 
 
73
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
74
 
 
75
      DIMENSION X(NDXX,NDXY),F(K),Y(N),W(N),H(NMXV,NDXX),DA(K)
 
76
      DIMENSION HVEC(JDMB),JNDEX(NDXX)
 
77
      DOUBLE PRECISION H,HVEC,DTEM,DFCKW,DFACT
 
78
      DOUBLE PRECISION DWJNC,DYJ,DFKA
 
79
 
 
80
      KPLUS=K+1
 
81
      DO 10 JNC=1,K
 
82
      DO 20 J=1,KPLUS
 
83
      H(JNC,J) = 0.D0
 
84
 20   CONTINUE
 
85
 10   CONTINUE
 
86
      JFLAG=1
 
87
      ANUL=0.0
 
88
      DO 30 JNC=1,N
 
89
      CALL FCN(K,M,F,X(1,JNC),JFLAG)
 
90
      JFLAG=4
 
91
      DWJNC = DBLE(W(JNC))
 
92
      ANUL=ANUL+W(JNC)
 
93
      DYJ = DBLE(Y(JNC))
 
94
      DO 40 KA=1,K
 
95
      DFKA = DBLE(F(KA))
 
96
      H(KA,K+1) = H(KA,K+1) + DWJNC*DFKA*DYJ
 
97
      DO 50 L=1,KA
 
98
      H(KA,L) = H(KA,L) + DWJNC*DFKA*DBLE(F(L))
 
99
 50   CONTINUE
 
100
 40   CONTINUE
 
101
 30   CONTINUE
 
102
      DO 60 J=1,K
 
103
      DO 70 JNC=1,J
 
104
      H(JNC,J)=H(J,JNC)
 
105
 70   CONTINUE
 
106
 60   CONTINUE
 
107
      CALL MATNV(H,NMXV,NDXX,HVEC,JDMB,K,1,NERR,DTEM,JNDEX)
 
108
      MM=K+1
 
109
      FCKW = QLSRG(K,N,M,NDXX,NDXY,NMXV,F,X,Y,W,DA,H,MM)
 
110
      DO 80 JNC=1,K
 
111
      F(JNC)=H(JNC,K+1)
 
112
 80   CONTINUE
 
113
      DFCKW=DBLE(FCKW)
 
114
      ANK=ANUL-K
 
115
      DFACT=DBLE(ANK)
 
116
      DFACT=DFCKW/DFACT
 
117
      DO 90 JNC=1,K
 
118
      DO 100 J=1,K
 
119
      H(JNC,J)=H(JNC,J)*DFACT
 
120
 100  CONTINUE
 
121
 90   CONTINUE
 
122
      DO 110 JNC=1,K
 
123
      HDA=H(JNC,JNC)
 
124
      DA(JNC)=SQRT(HDA)
 
125
 110  CONTINUE
 
126
      RETURN
 
127
      END
 
128
CC
 
129
CC  *QLSRG* : EVALUATES THE OBJECTIVE FUNCTION FOR LS REGRESSION.
 
130
CC
 
131
      FUNCTION QLSRG(K,N,M,NDXX,NDXY,NMXV,F,X,Y,W,DA,H,MM)
 
132
 
 
133
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
134
 
 
135
      DIMENSION F(K),X(NDXX,NDXY),DA(K),H(NMXV,NDXX),Y(N),W(N)
 
136
      DOUBLE PRECISION H,Q,HSUM
 
137
 
 
138
      JFLAG = 4
 
139
      Q=0.
 
140
      DO 30 JNC=1,N
 
141
      CALL FCN(K,M,F,X(1,JNC),JFLAG)
 
142
      HSUM=0.
 
143
      DO 20 JNCB=1,K
 
144
 20   HSUM=H(JNCB,MM)*F(JNCB)+HSUM
 
145
 30   Q=(HSUM-Y(JNC))*(HSUM-Y(JNC))*W(JNC)+Q
 
146
      QLSRG = Q
 
147
      RETURN
 
148
      END
 
149
CC
 
150
CC  *MATNV* : PERFORMS A MATRIX INVERSION.
 
151
CC
 
152
      SUBROUTINE MATNV(AM,NMXV,NDXX,HVEC,JDMB,NA,NB,NERR,DTEM,JNDEX)
 
153
 
 
154
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
155
 
 
156
      DOUBLE PRECISION AM,HVEC,DTEM,DETER,TURN,SWAP
 
157
      DIMENSION HVEC(JDMB),JNDEX(NDXX),AM(NMXV,NDXX)
 
158
 
 
159
      DETER=1.0D0
 
160
      N=NA
 
161
      NPNB=N+NB
 
162
      JNK=0
 
163
      DO 10 J=1,NPNB
 
164
      JNK=(J-1)*NMXV
 
165
      DO 10 NC=1,NMXV
 
166
      JNK=JNK+1
 
167
      HVEC(JNK)=AM(NC,J)
 
168
 10   CONTINUE
 
169
      JDM=NMXV
 
170
      NMA=N-1
 
171
      JDELC=1-JDM
 
172
      DO 130 JHFD=1,N
 
173
      TURN=0.0D0
 
174
      JDELC=JDELC+JDM
 
175
      JDLA=JDELC+JHFD-1
 
176
      JDLB=JDELC +NMA
 
177
      DO 40 JNCB=JDLA,JDLB
 
178
      IF(DABS(HVEC(JNCB))-DABS(TURN)) 40,40,30
 
179
 30   TURN=HVEC(JNCB)
 
180
      LDEL=JNCB
 
181
 40   CONTINUE
 
182
      IF(TURN) 50,170,50
 
183
 50   JPAAL=LDEL-JDELC+1
 
184
      JNDEX(JHFD)=JPAAL
 
185
      IF(JPAAL-JHFD) 80,80,60
 
186
 60   DETER=-DETER
 
187
      JPAAL=JPAAL-JDM
 
188
      JNCD=JHFD-JDM
 
189
      DO 70 JNC=1,NPNB
 
190
      JPAAL=JPAAL+JDM
 
191
      JNCD=JNCD+JDM
 
192
      SWAP=HVEC(JNCD)
 
193
      HVEC(JNCD)=HVEC(JPAAL)
 
194
 70   HVEC(JPAAL)=SWAP
 
195
 80   DETER=DETER*TURN
 
196
      TURN=1./TURN
 
197
      JNCD=JDELC+NMA
 
198
      DO 90 JNC=JDELC,JNCD
 
199
 90   HVEC(JNC)=-HVEC(JNC)*TURN
 
200
      HVEC(JDLA)=TURN
 
201
      JNCB=JHFD-JDM
 
202
      JPAAL=1-JDM
 
203
      DO 120 JNC=1,NPNB
 
204
      JPAAL=JPAAL+JDM
 
205
      JNCB=JNCB+JDM
 
206
      IF(JNC-JHFD) 100,120,100
 
207
 100  JCL=JPAAL+NMA
 
208
      SWAP=HVEC(JNCB)
 
209
      JNCD=JDELC-1
 
210
      DO 110 JNCC=JPAAL,JCL
 
211
      JNCD=JNCD+1
 
212
 110  HVEC(JNCC)=HVEC(JNCC)+SWAP*HVEC(JNCD)
 
213
      HVEC(JNCB)=SWAP*TURN
 
214
 120  CONTINUE
 
215
 130  CONTINUE
 
216
      DO 160 JNCB=1,N
 
217
      JHFD=N+1-JNCB
 
218
      LDEL=JNDEX(JHFD)
 
219
      IF(LDEL-JHFD) 140,160,140
 
220
 140  JPAAL=(LDEL-1)*JDM+1
 
221
      JCL=JPAAL+NMA
 
222
      JDELC=(JHFD-1)*JDM+1-JPAAL
 
223
      DO 150 JNCC=JPAAL,JCL
 
224
      JNCD=JNCC+JDELC
 
225
      SWAP=HVEC(JNCC)
 
226
      HVEC(JNCC)=HVEC(JNCD)
 
227
 150  HVEC(JNCD)=SWAP
 
228
 160  CONTINUE
 
229
      DTEM=DETER
 
230
      NERR=0
 
231
      GOTO 180
 
232
 170  NERR=JHFD
 
233
      DTEM=DETER
 
234
 180  JNK=0
 
235
      DO 190 J=1,NPNB
 
236
      DO 190 NC=1,NMXV
 
237
      JNK=JNK+1
 
238
      AM(NC,J)=HVEC(JNK)
 
239
 190  CONTINUE
 
240
      RETURN
 
241
      END
 
242
CC
 
243
CC  *LCAT* : CALCULATES LOCATION ESTIMATES.
 
244
CC
 
245
       SUBROUTINE LCAT(NCAS,NVAR,JCST,JPRT,NVAD,X,Y,RESDU,WEIGHTS,PREC,
 
246
     1 XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,NDXX,NDXY,MVAL,LUA,LUB,LUC,
 
247
     1 JREG,JHEAD,FNAMEA,FNAMEB,FNAMEC,YNSAVE,LAB,JFMT,JVARS,YN,JPLACE)
 
248
 
 
249
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
250
 
 
251
       DIMENSION A(11),X(NDXX,NDXY),Y(NDXY),RESDU(NDXY),WEIGHTS(NDXY)
 
252
       DIMENSION XMED(NDXX),XMAD(NDXX),AW(NDXY),NMVAL(NDXY),JPLACE(NDXX)
 
253
       CHARACTER YN,YNSAVE
 
254
       CHARACTER*10 LAB(NDXX)
 
255
       CHARACTER*30 FNAMEA,FNAMEB,FNAMEC
 
256
       CHARACTER*60 JFMT,JHEAD
 
257
       CHARACTER*80 CBUF
 
258
       INTEGER      ISTAT
 
259
       LOGICAL      NULL
 
260
       INTEGER      STATUS
 
261
 
 
262
 10    WRITE(LUB,8000) NCAS
 
263
       WRITE(LUB,8010) JHEAD
 
264
       IF (JPRT.EQ.0) THEN
 
265
          WRITE(LUB,8020)
 
266
       ELSEIF (JPRT.EQ.1) THEN
 
267
          WRITE(LUB,8030)
 
268
       ELSEIF (JPRT.EQ.2) THEN
 
269
          WRITE(LUB,8040)
 
270
       ENDIF  
 
271
       IF (JPLT.NE.0) WRITE(LUB,8050)
 
272
       DO 5 J=1,11
 
273
 5     A(J)=0.0
 
274
       IF (NCAS.LE.2) THEN
 
275
          WRITE(CBUF,8070) NCAS
 
276
          CALL STTPUT(CBUF,ISTAT)
 
277
          STOP
 
278
       ENDIF
 
279
       IF (FNAMEA.EQ.'CON') THEN
 
280
          WRITE(CBUF,8060)
 
281
          CALL STTPUT(CBUF,ISTAT)
 
282
       ENDIF      
 
283
       DO 40 JNC=1,NCAS
 
284
       NMVAL(JNC)=JNC
 
285
       IF (FNAMEA.EQ.'CON'.AND.JNC.EQ.1) THEN
 
286
           WRITE(CBUF,8080) JNC
 
287
           CALL STTPUT(CBUF,ISTAT)
 
288
       ENDIF   
 
289
       IF (FNAMEA.EQ.'CON'.AND.JNC.NE.1) THEN
 
290
           WRITE(CBUF,8090) JNC
 
291
           CALL STTPUT(CBUF,ISTAT)
 
292
       ENDIF
 
293
       IF (YN.NE.'Y') GOTO 30
 
294
C       READ(LUA,*) (AW(J),J=1,JVARS)
 
295
       JH=JPLACE(NVAD)
 
296
 
 
297
       CALL TBERDR(LUA,JNC,JH,AW(JH),NULL,STATUS)
 
298
       CALL STTPUT('Module PRE.F/LCAT: Beware the selection flag',
 
299
     1 ISTAT) 
 
300
 
 
301
       Y(JNC)=AW(JH)
 
302
       IF (YNSAVE.EQ.'Y') WRITE(LUC,*) Y(JNC)
 
303
       GOTO 40
 
304
 30    READ(LUA,JFMT) (AW(J),J=1,JVARS)
 
305
       JH=JPLACE(NVAD)
 
306
       Y(JNC)=AW(JH)
 
307
       IF (YNSAVE.EQ.'Y') WRITE(LUC,JFMT) Y(JNC)
 
308
 40    X(1,JNC)=Y(JNC)
 
309
       IF (YNSAVE.EQ.'Y') CLOSE(LUC,STATUS='KEEP')
 
310
       IF (MVAL.NE.0) CALL SMISLOC(NCAS,NDXX,NDXY,X,Y,NMVAL,NSTOP)
 
311
       IF (NCAS.LE.2) THEN
 
312
          WRITE(CBUF,8070) NCAS
 
313
          CALL STTPUT(CBUF,ISTAT)
 
314
          STOP
 
315
       ENDIF
 
316
       IF (NSTOP.EQ.1) STOP
 
317
       AL=NCAS
 
318
       ANVAR=NVAR
 
319
       JQU=INT(AL/2.0)+INT((ANVAR+1.0)/2.0)
 
320
       IF (JPRT.EQ.0) GOTO 60
 
321
       WRITE(LUB,8100)
 
322
       DO 50 JNC=1,NCAS
 
323
 50    WRITE(LUB,8110) JNC,Y(JNC)
 
324
 60    XMED(1)=AMDAN(AW,NDXY,Y,NCAS)
 
325
       DO 70 JNC=1,NCAS
 
326
       RESDU(JNC)=ABS(Y(JNC)-XMED(1))
 
327
 70    A(1)=A(1)+Y(JNC)
 
328
       XMAD(1)=AMDAN(AW,NDXY,RESDU,NCAS)
 
329
       XMAD(2)=XMAD(1)*1.4826
 
330
       WRITE(LUB,8120) XMED(1),XMAD(2)
 
331
       IF (ABS(XMAD(1)).LE.1.0E-12) THEN
 
332
          WRITE(LUB,8125)
 
333
          STOP
 
334
       ENDIF
 
335
       WRITE(LUB,8130)
 
336
       A(1)=A(1)/AL
 
337
       DO 80 JNC=1,NCAS
 
338
 80    A(2)=A(2)+(Y(JNC)-A(1))**2
 
339
       A(2)=SQRT(A(2)/(AL-1.0))
 
340
       WRITE(LUB,8140) A(1),A(2)
 
341
       JREG=1
 
342
       CALL RDUAL(A,0,NVAD,NCAS,NVAR,JCST,JPRT,NVAD,LUB,PREC,JREG,
 
343
     1 X,Y,RESDU,WEIGHTS,XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,
 
344
     1 NDXX,NDXY,JHEAD,LAB)
 
345
 90    WRITE(LUB,8130)
 
346
       CALL RANGS(Y,NCAS)
 
347
       CALL SHHLF(Y,NCAS,JQU,SLUTN,BSTD,PREC)
 
348
       BSTD=BSTD*1.4826*(5.0/(AL-ANVAR)+1.0)
 
349
       WRITE(LUB,8150) SLUTN,BSTD
 
350
       A(1)=SLUTN
 
351
       A(2)=BSTD
 
352
CC-----DETERMINATION OF THE WEIGHTS
 
353
       NZWE=0
 
354
       DO 100 JNC=1,NCAS
 
355
       Y(JNC)=X(1,JNC)
 
356
       RESDU(JNC)=(Y(JNC)-A(1))/A(2)
 
357
       IF (ABS(RESDU(JNC)).LT.2.5) THEN
 
358
          WEIGHTS(JNC)=1.0
 
359
          NZWE=NZWE+1
 
360
                                   ELSE
 
361
          WEIGHTS(JNC)=0.0
 
362
       ENDIF
 
363
       write(CBUF,*) jnc,y(jnc),resdu(jnc),nzwe,weights(jnc)
 
364
       CALL STTPUT(CBUF,ISTAT)
 
365
 100   CONTINUE
 
366
       AVW=(NZWE*1.0)/AL
 
367
       AL=NZWE
 
368
       JREG=2
 
369
       CALL RDUAL(A,1,NVAD,NCAS,NVAR,JCST,JPRT,NVAD,LUB,PREC,JREG,
 
370
     1 X,Y,RESDU,WEIGHTS,XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,
 
371
     1 NDXX,NDXY,JHEAD,LAB)
 
372
       WRITE(LUB,8130)
 
373
       WRITE(LUB,8160)
 
374
       IF (NZWE.LE.2) THEN
 
375
          WRITE(CBUF,8170) NZWE
 
376
          CALL STTPUT(CBUF,ISTAT)
 
377
          STOP
 
378
       ENDIF
 
379
       A(1)=0.0
 
380
       A(2)=0.0
 
381
       DO 110 JNC=1,NCAS
 
382
 110   A(1)=A(1)+Y(JNC)*WEIGHTS(JNC)
 
383
       A(1)=A(1)/AL
 
384
       DO 120 JNC=1,NCAS
 
385
 120   A(2)=A(2)+((Y(JNC)-A(1))**2)*WEIGHTS(JNC)
 
386
       A(2)=SQRT(A(2)/(AL-1.0))
 
387
       WRITE(LUB,8180) A(1),A(2)
 
388
       WRITE(LUB,8190) NZWE
 
389
       WRITE(LUB,8200) AVW
 
390
       JREG=3
 
391
       CALL RDUAL(A,2,NVAD,NCAS,NVAR,JCST,JPRT,NVAD,LUB,PREC,JREG,
 
392
     1 X,Y,RESDU,WEIGHTS,XMED,XMAD,NZWE,AVW,JPLT,AW,NMVAL,
 
393
     1 NDXX,NDXY,JHEAD,LAB)
 
394
 130   WRITE (LUB,8130)
 
395
       WRITE(CBUF,8210)
 
396
       CALL STTPUT(CBUF,ISTAT)
 
397
       IF (YNSAVE.EQ.'Y') THEN
 
398
          WRITE(CBUF,8220) FNAMEC
 
399
          CALL STTPUT(CBUF,ISTAT)
 
400
       ENDIF   
 
401
       IF (FNAMEA.NE.'CON') THEN
 
402
          WRITE(CBUF,8230) FNAMEA
 
403
          CALL STTPUT(CBUF,ISTAT)
 
404
       ENDIF      
 
405
       IF (FNAMEB.NE.'CON'.AND.FNAMEB.NE.'PRN') THEN
 
406
          WRITE(CBUF,8240) FNAMEB
 
407
          CALL STTPUT(CBUF,ISTAT)
 
408
       ENDIF       
 
409
       IF (JPRT.NE.10) STOP
 
410
 8000  FORMAT(1X,34('*')/' * ROBUST ESTIMATION OF LOCATION. *'/
 
411
     1 1X,34('*')///' NUMBER OF CASES = ',I5//)
 
412
 8010  FORMAT(' DATA SET = ',A60/)
 
413
 8020  FORMAT(/' THE DESIRED OUTPUT IS SMALL.'/)
 
414
 8030  FORMAT(/' THE DESIRED OUTPUT IS MEDIUM-SIZED.'/)
 
415
 8040  FORMAT(/' THE DESIRED OUTPUT IS LARGE.'/)
 
416
 8050  FORMAT(/' AN INDEX PLOT WILL BE DRAWN.'/)
 
417
 8070  FORMAT(/' THERE ARE ONLY ',I4,' CASES. THE ANALYSIS MUST',
 
418
     1 ' BE STOPPED.'/)
 
419
 8060  FORMAT(//' PLEASE ENTER YOUR DATA.'/)
 
420
 8080  FORMAT(1X,' THE DATA FOR CASE NUMBER ',I4,' : ',$)
 
421
 8090  FORMAT(' THE DATA FOR CASE NUMBER ',I4,' : ',$)
 
422
 8100  FORMAT(' THE OBSERVATIONS ARE:'/)
 
423
 8110  FORMAT(I5,2X,F10.4)
 
424
 8120  FORMAT(//' THE MEDIAN',12X,'= ',F11.4,2X,
 
425
     1 ' THE MAD (X 1.4826)',4X,'= ',F11.4/)
 
426
 8125  FORMAT(/' MORE THAN HALF OF THE DATA ARE EQUAL.'//)
 
427
 8130  FORMAT(/1X,78('*')/)
 
428
 8140  FORMAT(//' THE MEAN',14X,'= ',F11.4,2X,
 
429
     1 ' STANDARD DEVIATION',4X,'= ',F11.4//)
 
430
 8150  FORMAT(//' LMS',19X,'= ',F11.4,3X,
 
431
     1 'CORRESPONDING SCALE',3X,'= ',F11.4//)
 
432
 8160  FORMAT(/' REWEIGHTING USING THE WEIGHTS BASED ON THE LMS.'/
 
433
     1 1X,47('*')/)
 
434
 8170  FORMAT(/' THERE ARE ONLY ',I4,' CASES WITH NON-ZERO WEIGHT.'/
 
435
     1 ' THE ANALYSIS MUST BE STOPPED.'/)
 
436
 8180  FORMAT(//' WEIGHTED MEAN',9X,'= ',F11.4,2X,
 
437
     1 ' WEIGHTED STAND. DEV.  = ',F11.4//)
 
438
 8190  FORMAT(/' THERE ARE',2X,I4,' POINTS WITH NON-ZERO WEIGHT. ')
 
439
 8200  FORMAT(/' AVERAGE WEIGHT',13X,'= ',F20.6//)
 
440
 8210  FORMAT(////' THE RUN HAS SUCCESSFULLY BEEN EXECUTED . '//)
 
441
 8220  FORMAT(' THE DATA IS SAVED IN FILE : ',A30)
 
442
 8230  FORMAT(' THE DATA HAS BEEN READ FROM FILE : ',A30)
 
443
 8240  FORMAT(' THE OUTPUT HAS BEEN WRITTEN IN FILE : ',A30)
 
444
       RETURN
 
445
       END
 
446
CC
 
447
CC   *SMISLOC* : handling of missing values in the case of location
 
448
CC
 
449
       SUBROUTINE SMISLOC(NCAS,NDXX,NDXY,X,Y,NMVAL,NSTOP)
 
450
 
 
451
       INCLUDE 'MID_REL_INCL:implicit.inc'
 
452
 
 
453
       DIMENSION X(NDXX,NDXY),Y(NDXY),NMVAL(NDXY)
 
454
       CHARACTER*80 CBUF
 
455
       INTEGER      ISTAT
 
456
 
 
457
       MAXM=(NCAS*4)/5
 
458
       JND=0
 
459
       JCAS=0
 
460
CC-----GIVE THE MISSING VALUE CODE
 
461
       WRITE(CBUF,8000)
 
462
       CALL STTPUT(CBUF,ISTAT)
 
463
  5    READ(*,*,ERR=50)CODE
 
464
       DO 10 JNC=1,NCAS
 
465
       IF (Y(JNC).EQ.CODE) THEN
 
466
          JND=JND+1
 
467
                           ELSE
 
468
          JCAS=JCAS+1
 
469
          X(1,JCAS)=Y(JNC)
 
470
          NMVAL(JCAS)=JNC
 
471
       ENDIF
 
472
 10    CONTINUE
 
473
       NCAS=JCAS
 
474
       WRITE(CBUF,8010) NCAS
 
475
       CALL STTPUT(CBUF,ISTAT)
 
476
       IF (JND.GT.MAXM) THEN
 
477
           CALL STTPUT('More than 80 percent of the cases had to 
 
478
     1   be deleted because of the missing values.',ISTAT) 
 
479
           CALL STTPUT('The analysis will be stopped.',ISTAT)
 
480
          NSTOP=1
 
481
          RETURN
 
482
       ENDIF
 
483
       DO 20 JNC=1,NCAS
 
484
             Y(JNC)=X(1,JNC)
 
485
 20    CONTINUE
 
486
       RETURN
 
487
 50    CALL STETER('Error reading input!')
 
488
       RETURN
 
489
 
 
490
 8000  FORMAT(/' Please enter the value of this variable which'/
 
491
     1 ' has to be interpreted as the missing value code : ',$)
 
492
 8010  FORMAT(/' There are ',I4,' cases staying in the analysis.'/)
 
493
       END