← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/mva/src/cmdsif.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:
contrib/mva/src/cmdsif.for
 
1
C @(#)cmdsif.for        19.1 (ES0-DMD) 02/25/03 13:27:32
 
2
C===========================================================================
 
3
C Copyright (C) 1995 European Southern Observatory (ESO)
 
4
C
 
5
C This program is free software; you can redistribute it and/or 
 
6
C modify it under the terms of the GNU General Public License as 
 
7
C published by the Free Software Foundation; either version 2 of 
 
8
C the License, or (at your option) any later version.
 
9
C
 
10
C This program is distributed in the hope that it will be useful,
 
11
C but WITHOUT ANY WARRANTY; without even the implied warranty of
 
12
C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
13
C GNU General Public License for more details.
 
14
C
 
15
C You should have received a copy of the GNU General Public 
 
16
C License along with this program; if not, write to the Free 
 
17
C Software Foundation, Inc., 675 Massachusetss Ave, Cambridge, 
 
18
C MA 02139, USA.
 
19
C
 
20
C Corresponding concerning ESO-MIDAS should be addressed as follows:
 
21
C       Internet e-mail: midas@eso.org
 
22
C       Postal address: European Southern Observatory
 
23
C                       Data Management Division 
 
24
C                       Karl-Schwarzschild-Strasse 2
 
25
C                       D 85748 Garching bei Muenchen 
 
26
C                       GERMANY
 
27
C===========================================================================
 
28
C
 
29
C-----------------------------------------------------------------------
 
30
C
 
31
C.IDENTIFICATION
 
32
C
 
33
C  Program CMDSIF
 
34
C
 
35
C.AUTHOR
 
36
C
 
37
C  F. Murtagh, ST-ECF, Garching.             Version 1.0  17 June 1986
 
38
C  F. Murtagh                                Version 2.0  Oct. 1988
 
39
C                                            (New std. ifs.)
 
40
C
 
41
C.PURPOSE
 
42
C
 
43
C  Pass parameters to, and execute, CMDS
 
44
C  (Classical - Torgerson's, Gower's - Multidimensional Scaling,
 
45
C  Factor Analysis of a Distances Matrix, Principal Coordinates Analysis).
 
46
C
 
47
C.INPUT/OUTPUT
 
48
C
 
49
C  P1 - P3 contain parameters; these are: input table name, output
 
50
C  table name, number of principal coordinates wanted (optional, - default
 
51
C  = 3).
 
52
C
 
53
C.ALGORITHM
 
54
C
 
55
C . uses Midas Table interface routines;
 
56
C . input table is assumed to contain entries in single precision;
 
57
C . no select or null values 
 
58
C . all input table is sent to the CMDS routine;
 
59
C . description of the CMDS routine is in the corresponding program;
 
60
C . the output produced consists of a table, and descriptors associated
 
61
C   with this (eigenvalues): view with
 
62
C   READ/DESC outtable.TBL *
 
63
C . storage is limited only by the Midas Table system, and by the
 
64
C   overall system limitations;
 
65
C
 
66
C.MODIFICATIONS
 
67
C   NEW STANDARD INTERFACES, F. MURTAGH, AUG. 88
 
68
C   New Table File System,   M. Peron , SEP91
 
69
C
 
70
C-----------------------------------------------------------------------
 
71
        PROGRAM CMDSIF
 
72
C
 
73
        CHARACTER*60     NAMEIN, NAMEOUT
 
74
        CHARACTER*6     FORM 
 
75
        CHARACTER*16    UNIT, LABEL, LABEL2
 
76
        INTEGER         MADRID, KUN, KNUL, DTYPE
 
77
        INTEGER         NACTV,ISTAT,TID1,NROW,NCOL,NSORTC
 
78
        INTEGER         NAC,NAR,IPTR,I,LEN,NSEL,NTOT,INULL
 
79
        INTEGER         IACTV,NCOLOUT,TID,IPTROUT
 
80
        INTEGER         IADD0,IADD1,IADD2,IADD3,KUNIT
 
81
        INCLUDE         'MID_INCLUDE:TABLES.INC/NOLIST'
 
82
        COMMON          /VMR/MADRID(1)
 
83
        INCLUDE         'MID_INCLUDE:TABLED.INC/NOLIST'
 
84
        DATA            FORM/'G14.6'/, UNIT/' '/
 
85
C
 
86
C ...   Assuming this is our first action ...
 
87
C
 
88
        CALL STSPRO('CMDSIF')
 
89
        DTYPE = D_R4_FORMAT
 
90
C
 
91
C ...   Get table name as a keyword passed in the command line.
 
92
C
 
93
        CALL STKRDC('P1',1,1,60,NACTV,NAMEIN,KUN,KNUL,ISTAT)
 
94
C
 
95
C ...   Read input table.
 
96
C
 
97
        CALL TBTOPN(NAMEIN,0,TID1,ISTAT)
 
98
        CALL TBIGET(TID1,NCOL,NROW,NSORTC,NAC,NAR,ISTAT)
 
99
        CALL TBCMAP(TID1,0,IPTR,ISTAT)
 
100
C
 
101
C ...   Some error checking on input.
 
102
C
 
103
        IF (NROW.LT.1.OR.NCOL.LT.1) THEN
 
104
           CALL STTPUT(' Nos. of rows/columns are less than 1.',ISTAT)
 
105
           CALL STTPUT(' What sort of a table is this ??',ISTAT)
 
106
           STOP
 
107
        ENDIF
 
108
C
 
109
        DO I = 1, NCOL
 
110
           CALL TBFGET(TID1,I,FORM,LEN,DTYPE,ISTAT)
 
111
           IF (DTYPE.NE.D_R4_FORMAT) THEN
 
112
              CALL STTPUT(' Illegal format:',ISTAT)
 
113
              CALL STTPUT(' Only R*4 column type allowed.',ISTAT)
 
114
              STOP
 
115
           ENDIF
 
116
        ENDDO
 
117
C
 
118
        CALL CHSEL(MADRID(IPTR),NROW,NSEL)
 
119
        IF (NSEL.NE.NROW) THEN
 
120
           CALL STTPUT(' Not all rows are SELECTed. ',ISTAT)
 
121
           CALL STTPUT(' In current implementation, MUST select all.',
 
122
     X                                                     ISTAT)
 
123
           STOP
 
124
        ENDIF
 
125
C
 
126
        CALL TBCMAP(TID1,1,IPTR,ISTAT)
 
127
        NTOT = NROW*NCOL
 
128
        CALL CHNULL(MADRID(IPTR),NTOT,INULL)
 
129
        IF (INULL.NE.0) THEN
 
130
           CALL STTPUT
 
131
     X     (' Null entries in the table are not allowed.',ISTAT)
 
132
           CALL STTPUT
 
133
     X     (' Use SELECT, and then construct another table.',
 
134
     X                                                    ISTAT)
 
135
           STOP
 
136
        ENDIF
 
137
C
 
138
C ...   OUTPUT TABLE - PREPARE
 
139
C
 
140
C ...   First get the output table name and no. cols. via keywords.
 
141
C
 
142
        CALL STKRDC('P2',1,1,60,IACTV,NAMEOUT,KUN,KNUL,ISTAT)
 
143
        CALL STKRDI('INPUTI',1,1,IACTV,NCOLOUT,KUN,KNUL,ISTAT)
 
144
C
 
145
C ...   Now create the table.
 
146
C
 
147
        CALL TBTINI(NAMEOUT,F_TRANS,17,NCOLOUT,NROW,TID,ISTAT)
 
148
        LABEL = 'NEW00'
 
149
        LABEL2 = '10001'
 
150
        DO I = 1, NCOLOUT
 
151
           WRITE (LABEL2(1:5),100) I+10000
 
152
           LABEL(4:5) = LABEL2(4:5)
 
153
           CALL TBCINI(TID,DTYPE,1,FORM,UNIT,LABEL,NSORTC,ISTAT)
 
154
        ENDDO
 
155
  100   FORMAT(I5)
 
156
C
 
157
        CALL TBCMAP(TID,1,IPTROUT,ISTAT)
 
158
C
 
159
C ...   ALLOCATE STORAGE
 
160
C
 
161
        CALL GETSTOR(NROW*NROW,IADD0)
 
162
        CALL GETSTOR(NROW*NROW,IADD1)
 
163
        CALL GETSTOR(NROW,IADD2)
 
164
        CALL GETSTOR(NROW,IADD3)
 
165
C
 
166
C ...   DO THE WORK
 
167
C
 
168
        CALL APPL(NROW,NCOL,NCOLOUT,MADRID(IPTR),MADRID(IPTROUT),
 
169
     X  MADRID(IADD0),MADRID(IADD1),MADRID(IADD2),MADRID(IADD3))
 
170
C
 
171
C ...   WRITE DESCRIPTORS
 
172
C
 
173
        CALL DSCROUT(NAMEOUT,NROW,MADRID(IADD2),TID,KUNIT)
 
174
C
 
175
C ...   FINISH UP
 
176
C
 
177
C
 
178
        CALL RELSTOR(NROW*NROW,IADD0)
 
179
        CALL RELSTOR(NROW*NROW,IADD1)
 
180
        CALL RELSTOR(NROW,IADD2)
 
181
        CALL RELSTOR(NROW,IADD3)
 
182
C
 
183
        CALL TBTCLO(TID1,ISTAT)
 
184
C
 
185
        CALL TBIPUT(TID,NCOLOUT,NROW,ISTAT)
 
186
        CALL TBSINI(TID,ISTAT)
 
187
        CALL TBTCLO(TID,ISTAT)
 
188
C
 
189
        CALL STSEPI
 
190
C
 
191
        END
 
192
C----------------------------------------------------------------------
 
193
        SUBROUTINE APPL(NR,NC1,NC2,AIN,AOUT,ACREA,A,W1,W2)
 
194
        INTEGER NR,NC1,NC2,IERR,IPRINT,I,J,ISTAT
 
195
        REAL*4  AIN(NR,NC1), AOUT(NR,NC2), ACREA(NR,NR),A(NR,NR),
 
196
     X                  W1(NR),W2(NR)
 
197
        IERR = 0
 
198
        IPRINT = 1
 
199
        DO I = 1, NR
 
200
           DO J = 1, NC1
 
201
              ACREA(I,J) = AIN(I,J)
 
202
           ENDDO
 
203
        ENDDO
 
204
C
 
205
        IF (NR.NE.NC1) THEN
 
206
           CALL STTPUT
 
207
     X          (' A symmetric distances matrix is expected.',ISTAT)
 
208
           CALL STTPUT(' The input matrix is not symmetric !',ISTAT)
 
209
           STOP
 
210
        ENDIF
 
211
C
 
212
        CALL CMDS(NR,ACREA,IPRINT,W1,W2,A,IERR)
 
213
C
 
214
        IF (IERR.NE.0) THEN
 
215
           CALL STTPUT(' IERR not 0 on return from CMDS.',ISTAT)
 
216
           STOP
 
217
        ENDIF
 
218
C
 
219
        DO I = 1, NR
 
220
           DO J = 1, NC2
 
221
              AOUT(I,J) = ACREA(I,J)
 
222
           ENDDO
 
223
        ENDDO
 
224
C
 
225
        RETURN
 
226
        END
 
227
C-------------------------------------------------------------------------
 
228
        SUBROUTINE CHSEL(MASK,NROW,NSEL)
 
229
C ...   Count table rows which are SELECTed.
 
230
        INTEGER I,NSEL,NROW
 
231
        REAL*4  MASK(NROW),TBLSEL
 
232
        DOUBLE PRECISION TDTRUE,TDFALS
 
233
        CALL TBMCON(TBLSEL,TDTRUE,TDFALS)
 
234
        NSEL = 0
 
235
        DO I = 1, NROW
 
236
           IF (MASK(I).EQ.TBLSEL) NSEL = NSEL + 1
 
237
        ENDDO
 
238
        RETURN
 
239
        END
 
240
C-------------------------------------------------------------------------
 
241
        SUBROUTINE CHNULL(X,NT,NULL)
 
242
C ...   Check if null values are present.
 
243
        INTEGER I,NULL,NT
 
244
        REAL*4  X(NT), TRNULL
 
245
        INTEGER TINULL
 
246
        DOUBLE PRECISION TDNULL
 
247
        CALL TBMNUL(TINULL,TRNULL,TDNULL)
 
248
        NULL = 0
 
249
        DO I = 1, NT
 
250
           IF (X(I).EQ.TRNULL) NULL = NULL + 1
 
251
           IF (NULL.GT.0) RETURN
 
252
        ENDDO
 
253
        RETURN
 
254
        END
 
255
C---------------------------------------------------------------------
 
256
        SUBROUTINE GETSTOR(NVALS,IPTR)
 
257
C ...   Allocate storage space for NVALS real values.
 
258
        INTEGER NVALS,IPTR,ISTAT
 
259
        CALL TDMGET(4*NVALS,IPTR,ISTAT)
 
260
        RETURN
 
261
        END
 
262
C---------------------------------------------------------------------
 
263
        SUBROUTINE RELSTOR(NVALS,IPTR)
 
264
C ...   Release storage space of NVALS real values.
 
265
        INTEGER NVALS,IPTR,ISTAT
 
266
        CALL TDMFRE(4*NVALS,IPTR,ISTAT)
 
267
        RETURN
 
268
        END
 
269
C---------------------------------------------------------------------
 
270
        SUBROUTINE DSCROUT(TAB,N,VALS,TID,KUNIT)
 
271
C ...   Output descriptors, with table.
 
272
        INTEGER I,N,TID,KUNIT,INDX,ISTAT
 
273
        REAL*4 VALS(N),V
 
274
        CHARACTER*8  TAB 
 
275
        CHARACTER*12 TABNAME
 
276
C
 
277
        DO I = 1,(N-1)/2
 
278
           V = VALS(I)
 
279
           VALS(I) = VALS(N-I)
 
280
           VALS(N-I) = V
 
281
        ENDDO
 
282
        INDX = INDEX(TAB//' ',' ')-1
 
283
        TABNAME = TAB(1:INDX)//'.TBL'
 
284
        CALL STDWRR(TID,'EIGENVALUES',VALS,1,N-1,KUNIT,ISTAT)
 
285
        RETURN
 
286
        END