← Back to branch summary

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

« back to all changes in this revision

Viewing changes to stdred/optopus/src/holesid.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/optopus/src/holesid.for
 
1
C===========================================================================
 
2
C Copyright (C) 1995-2010 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
      PROGRAM HOLESID
 
29
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
30
C.IDENTIFICATION: HOLESID.FOR
 
31
C.PURPOSE:   Draw identification of holes to be drilled on OPTOPUS plate.
 
32
C.ALGORITHM: Use the routines of the AGL library
 
33
C.AUTHOR:    Alessandra Gemmo            Padova Department of Astronomy
 
34
C.VERSION:   050691 AG Creation
 
35
C 
 
36
C 100616        last modif
 
37
C------------------------------------------------------------------------------
 
38
 
 
39
      IMPLICIT NONE
 
40
C
 
41
      INTEGER    MADRID,TID,KUN,KNUL
 
42
      INTEGER    NPAR,ISTAT,ILEN,ILAB
 
43
      INTEGER    I,NACT
 
44
      INTEGER    NCOLUM,NCOL,NROW,NSC
 
45
      INTEGER    NLAB
 
46
      INTEGER    COL(4)
 
47
      INTEGER    PARNEV
 
48
      INTEGER    DTYPE,NACOL,NAROW
 
49
      INTEGER    IIDENT, PLMODE, ACCESS
 
50
C
 
51
C ***
 
52
      REAL       VX,VY,RIDENT
 
53
      REAL       X(1000),Y(1000)
 
54
      REAL       XMIN,XMAX,YMIN,YMAX
 
55
C
 
56
C ***
 
57
      DOUBLE PRECISION    DIDENT
 
58
C
 
59
C ***
 
60
      CHARACTER*64  TABLE
 
61
      CHARACTER*80  TEXT
 
62
      CHARACTER*17  COLUMN(4)
 
63
      CHARACTER*8   AFORM
 
64
      CHARACTER*16  FORM
 
65
      CHARACTER*20  IDENT1 
 
66
      CHARACTER*20  IDENT, CTEST
 
67
C
 
68
C ***
 
69
      LOGICAL NULL1,NULL2,NULL3,ISEL
 
70
C
 
71
C ***
 
72
      INCLUDE    'MID_INCLUDE:TABLES.INC/NOLIST'
 
73
      COMMON     /VMR/MADRID(1)
 
74
      INCLUDE    'MID_INCLUDE:TABLED.INC/NOLIST'
 
75
C
 
76
C ***
 
77
      DATA        PARNEV/5/
 
78
      DATA        ACCESS/1/
 
79
      DATA        PLMODE/1/
 
80
C
 
81
C *** start the code
 
82
C
 
83
      CALL STSPRO('HOLESID')
 
84
C
 
85
C *** read parameters
 
86
      CALL TDPGET(PARNEV,NPAR,ISTAT)
 
87
      IF(ISTAT.NE.0)THEN
 
88
        TEXT = '*** FATAL: Problems with parameters input table'
 
89
        CALL STETER(9,TEXT)
 
90
      ENDIF
 
91
C
 
92
      TABLE     = TPARBF(1)
 
93
      COLUMN(1) = TPARBF(2)
 
94
      COLUMN(2) = TPARBF(3)
 
95
      COLUMN(3) = TPARBF(4)
 
96
      NCOLUM    = 3
 
97
C
 
98
C
 
99
C
 
100
C *** read table
 
101
      CALL TBTOPN(TABLE,F_I_MODE,TID,ISTAT)
 
102
      IF(ISTAT.NE.0)THEN
 
103
        TEXT = '*** FATAL: Failed to open table: '//TABLE
 
104
        CALL STETER(9,TEXT)
 
105
      ENDIF
 
106
C
 
107
      CALL TBIGET(TID,NCOL,NROW,NSC,NACOL,NAROW,ISTAT)
 
108
      IF(ISTAT.NE.0)THEN
 
109
        TEXT = '*** FATAL: Failed to get table info '//TABLE
 
110
        CALL STETER(9,TEXT)
 
111
      ENDIF
 
112
C
 
113
C *** get column adresses
 
114
      DO I = 1,NCOLUM
 
115
          CALL TBCSER(TID,COLUMN(I),COL(I),ISTAT)
 
116
          IF(ISTAT.NE.0)THEN
 
117
            TEXT = '*** FATAL: Failed to get table column'
 
118
            CALL STETER(9,TEXT)
 
119
          ENDIF
 
120
C
 
121
          IF(COL(I).EQ.-1)THEN
 
122
            TEXT = '*** FATAL: Failed to get table column'
 
123
            CALL STETER(9,TEXT)
 
124
          ENDIF
 
125
      ENDDO
 
126
C
 
127
      CALL TBFGET(TID,COL(3),AFORM,ILEN,DTYPE,ISTAT)
 
128
      CALL LENBUF(AFORM,I)
 
129
      FORM   = '('//AFORM(1:I)//')'
 
130
C
 
131
C ... plot - AGL window
 
132
      CALL PTOPEN(' ','none',ACCESS,PLMODE)
 
133
      CALL AGSSET('LFRG')
 
134
      CALL AGSSET('CHSM')
 
135
C
 
136
C *** first iteration to find label positions
 
137
      NLAB=0
 
138
      DO I=1,NROW
 
139
         CALL TBSGET(TID,I,ISEL,ISTAT)
 
140
         IF(ISEL)THEN
 
141
           CALL TBERDR(TID,I,COL(1),VX,NULL1,ISTAT)
 
142
           CALL TBERDR(TID,I,COL(2),VY,NULL2,ISTAT)
 
143
           CALL STKRDR('PLRSTAT',11,1,NACT,XMIN,KUN,KNUL,ISTAT)
 
144
           CALL STKRDR('PLRSTAT',12,1,NACT,XMAX,KUN,KNUL,ISTAT)
 
145
           CALL STKRDR('PLRSTAT',15,1,NACT,YMIN,KUN,KNUL,ISTAT)
 
146
           CALL STKRDR('PLRSTAT',16,1,NACT,YMAX,KUN,KNUL,ISTAT)
 
147
           IF(.NOT.NULL1)THEN
 
148
            IF(.NOT.NULL2)THEN
 
149
             NLAB = NLAB+1
 
150
             X(NLAB) = VX 
 
151
             Y(NLAB) = VY
 
152
            ENDIF
 
153
           ENDIF
 
154
          ENDIF
 
155
       ENDDO
 
156
C
 
157
C *** second iteration to plot labels
 
158
       ILAB=0
 
159
       DO I=1,NROW
 
160
          CALL TBSGET(TID,I,ISEL,ISTAT)
 
161
          IF (ISEL)THEN
 
162
             CALL TBERDR(TID,I,COL(1),VX,NULL1,ISTAT)
 
163
             CALL TBERDR(TID,I,COL(2),VY,NULL2,ISTAT)
 
164
             IF (.NOT.NULL1) THEN
 
165
                IF (.NOT.NULL2) THEN
 
166
                   IF (DTYPE.EQ.D_C_FORMAT) THEN
 
167
                      CALL TBERDC(TID,I,COL(3),CTEST,NULL3,ISTAT)
 
168
                      CALL FT_EOS(CTEST,20,IDENT,ISTAT)
 
169
 
 
170
                   ELSE IF (DTYPE.EQ.D_I4_FORMAT) THEN
 
171
 
 
172
                      CALL TBERDI(TID,I,COL(3),IIDENT,NULL3,ISTAT)
 
173
                      IF (.NOT.NULL3) THEN
 
174
C                        WRITE(IDENT,FORM,ERR=30) IIDENT
 
175
                         WRITE(IDENT,FORM) IIDENT
 
176
                      ENDIF  
 
177
 
 
178
                   ELSE IF (DTYPE.EQ.D_R4_FORMAT) THEN
 
179
                      CALL TBERDR(TID,I,COL(3),RIDENT,NULL3,ISTAT)
 
180
                      IF (.NOT.NULL3) THEN
 
181
C                        WRITE(IDENT,FORM,ERR=30) RIDENT
 
182
                         WRITE(IDENT,FORM) RIDENT
 
183
                      ENDIF
 
184
 
 
185
                   ELSE IF (DTYPE.EQ.D_R8_FORMAT) THEN
 
186
                       CALL TBERDD(TID,I,COL(3),DIDENT,NULL3,ISTAT)
 
187
                      IF (.NOT.NULL3) THEN
 
188
C                        WRITE(IDENT,FORM,ERR=30) DIDENT
 
189
                         WRITE(IDENT,FORM) DIDENT
 
190
                      ENDIF   
 
191
                   ENDIF
 
192
                ENDIF
 
193
             ENDIF
 
194
C
 
195
 30          CONTINUE
 
196
             ILAB = ILAB+1
 
197
             IDENT1 = '~_~_'//IDENT
 
198
             CALL LENBUF(IDENT1,ILEN)
 
199
             CALL AGGTXT(X(ILAB),Y(ILAB),IDENT1(1:ILEN),22)
 
200
          ENDIF
 
201
       ENDDO
 
202
C
 
203
C *** over and out
 
204
      CALL TBTCLO(TID,ISTAT)
 
205
      CALL PTCLOS()
 
206
      CALL STSEPI
 
207
      END
 
208
 
 
209