← Back to branch summary

~ubuntu-branches/ubuntu/wily/eso-midas/wily-proposed

« back to all changes in this revision

Viewing changes to contrib/daophot/libsrc/irasubs.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/daophot/libsrc/irasubs.for
 
1
C @(#)irasubs.for       19.1 (ES0-DMD) 02/25/03 13:23:49
 
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
      character*(*) function object (text)
 
30
      character*132 line
 
31
      character*(*) text
 
32
      common /imid/ imdata, imcopy, dtype
 
33
      if ((text(1:1) .eq. 'd') .or. (text(1:1) .eq. 'D')) then
 
34
         i = imdata
 
35
      else if ((text(1:1) .eq. 'c') .or. (text(1:1) .eq. 'C')) then
 
36
         i = imcopy
 
37
      else
 
38
         object = ' '
 
39
         return
 
40
      end if
 
41
      call imgkwc (i, 'title', line, ier)
 
42
      if (ier .ne. 0) then
 
43
         call imgkwc (imdata, 'OBJECT', line, ier)
 
44
      end if
 
45
      if (ier .ne. 0) then
 
46
         call imgkwc (i, 'COMMENT', line, ier)
 
47
      end if
 
48
      if (ier .ne. 0) then
 
49
         object = ' '
 
50
         return
 
51
      end if
 
52
      do i=1,132
 
53
         if (line(i:i) .ne. ' ') then
 
54
            object = line(i:132)
 
55
            return
 
56
         end if
 
57
      end do
 
58
      object = ' '
 
59
      return
 
60
      end
 
61
c
 
62
c
 
63
c
 
64
      subroutine attach (image, open)
 
65
      character expand*100, message*64, object*64
 
66
      character*30 image, coofil, magfil, psffil, profil,
 
67
     .     grpfil, switch, extend
 
68
      integer axlen(7), dtype
 
69
      logical*1 open
 
70
      common /filnam/ coofil, magfil, psffil, profil, grpfil
 
71
      common /imid/ imdata, imcopy, dtype
 
72
      common /size/ ncol, nrow
 
73
      call imopen (expand(extend(image,'imh')), 1, imdata, ier)
 
74
      if (ier .eq. 0) then
 
75
         open = .true.
 
76
         call imgkwc (imdata, 'title', object, ier)
 
77
         if (ier .ne. 0) then
 
78
            call imgkwc (imdata, 'OBJECT', object, ier)
 
79
         end if
 
80
         if (ier .ne. 0) then
 
81
            call imgkwc (imdata, 'COMMENT', object, ier)
 
82
         end if
 
83
         if (ier .eq. 0) then
 
84
            write (6,601) object
 
85
  601       format (/10x, a/)
 
86
         end if
 
87
         call imgsiz (imdata, axlen, naxis, dtype, ier)
 
88
         if (ier .ne. 0) then
 
89
            call stupid (message(ier))
 
90
            open = .false.
 
91
            return
 
92
         else if (naxis .eq. 1) then
 
93
            ncol = axlen(1)
 
94
            nrow = 1
 
95
         else
 
96
            ncol = axlen(1)
 
97
            nrow = axlen(2)
 
98
         end if
 
99
         write (6,611) ncol, nrow
 
100
  611    format (38x, 'Picture size: ', 2i5)
 
101
         coofil = switch(image, '.coo')
 
102
         magfil = switch(image, '.ap')
 
103
         psffil = switch(image, '.psf')
 
104
         profil = switch(image, '.nst')
 
105
         grpfil = switch(image, '.grp')
 
106
      else
 
107
         open = .false.
 
108
         call stupid (message(ier))
 
109
      end if
 
110
      return
 
111
      end
 
112
c
 
113
c
 
114
c
 
115
      character*80 function message (ier)
 
116
      character*80 error
 
117
      call imemsg (ier,error)
 
118
      message = error
 
119
      return
 
120
      end
 
121
c
 
122
c
 
123
c
 
124
      subroutine crepic (picture, type, ncol, nrow, ier)
 
125
      character*100 expand
 
126
      character*80 message
 
127
      character*30 picture, extend
 
128
d     character*30 new
 
129
      character*6 type
 
130
      integer*4 len(7)
 
131
      common /imid/ imdata, imcopy, idtype
 
132
      call imopen (expand(extend(picture, 'imh')), 1, imcopy, ier)
 
133
      if (ier .eq. 0) then
 
134
d        call stupid ('Output image already exists')
 
135
d        new = 'OVERWRITE'
 
136
d        call getname ('New output file name:', new)
 
137
d        if (new .eq. 'OVERWRITE') then
 
138
            call imdele (picture, ier)
 
139
d        else
 
140
d           picture = new
 
141
d        end if
 
142
d        call tblank
 
143
      end if
 
144
c
 
145
      len(1) = ncol
 
146
      len(2) = nrow
 
147
      if ((type(1:1) .eq. 'R') .or. (type(1:1) .eq. 'r')) 
 
148
     .     idtype = 6
 
149
      call imcrea (picture, len, 2, idtype, ier)
 
150
      if (ier .ne. 0) call stupid (message(ier))
 
151
      call imopen (picture, 3, imcopy, ier)
 
152
      if (ier .ne. 0) call stupid (message(ier))
 
153
      call imhcpy (imdata, imcopy, ier)
 
154
      if (ier .ne. 0) call stupid (message(ier))
 
155
      return
 
156
      end
 
157
c
 
158
c
 
159
c
 
160
      subroutine coppic (picture, pix, ncol, nrow, ier)
 
161
      character*80 message
 
162
      character*30 picture
 
163
d     character*30 new
 
164
      real*4 pix(ncol)
 
165
      common /imid/ imdata, imcopy, idtype
 
166
c
 
167
      call imopen (picture, 3, j, ier)
 
168
      if (ier .eq. 0) then
 
169
d        call stupid ('Output image already exists')
 
170
d        new = 'OVERWRITE'
 
171
d        call getname ('New output file name:', new)
 
172
d        if (new .eq. 'OVERWRITE') then
 
173
            call imdele (picture, ier)
 
174
d        else
 
175
d           picture = new
 
176
d        end if
 
177
d        call tblank
 
178
      end if
 
179
c
 
180
      call imopnc (picture, imdata, imcopy, ier)
 
181
      if (ier .ne. 0) call stupid(message(ier))
 
182
      do j = 1,nrow
 
183
         call imgl2r (imdata, pix, j, ier)
 
184
         if (ier .ne. 0) call stupid(message(ier))
 
185
         call impl2r (imcopy, pix, j, ier)
 
186
         if (ier .ne. 0) call stupid(message(ier))
 
187
      end do
 
188
      return
 
189
      end
 
190
c
 
191
c
 
192
c
 
193
      subroutine rdaray (text, lx, ly, mx, my, nx, func, ier)
 
194
      character*80 message
 
195
      character*4 text
 
196
      real*4 func(nx,*)
 
197
      common /size/ ncol, nrow
 
198
      common /imid/ imdata, imcopy, idtype
 
199
      if (text .eq. 'DATA') then
 
200
         id = imdata
 
201
      else
 
202
         id = imcopy
 
203
      end if
 
204
      mx = lx+mx-1
 
205
      my = ly+my-1
 
206
      lx = max(1,lx)
 
207
      ly = max(1,ly)
 
208
      mx = min(ncol,mx)
 
209
      my = min(nrow,my)
 
210
      my = my-ly+1
 
211
      do j=1,my
 
212
         jy = ly+j-1
 
213
         call imgs2r (id, func(1,j), lx, mx, jy, jy, ier)
 
214
         if (ier .ne. 0) then 
 
215
            call stupid(message(ier))
 
216
            write (6,*) 'rdaray:  x =', lx, ' to', mx, 
 
217
     .           '  y =', jy
 
218
         end if
 
219
      end do
 
220
      mx = mx-lx+1
 
221
      return
 
222
      end
 
223
c
 
224
c
 
225
c
 
226
      subroutine wraray (text, lx, ly, mx, my, maxx, func, ier)
 
227
      character*80 message
 
228
      character*4 text
 
229
      real*4 func(maxx,*), row(4096)
 
230
      common /size/ ncol, nrow
 
231
      common /imid/ imdata, imcopy, idtype
 
232
      if (text .eq. 'DATA') then
 
233
         id = imdata
 
234
      else
 
235
         id = imcopy
 
236
      end if
 
237
      mx = lx+mx-1
 
238
      my = ly+my-1
 
239
      lx = max(1,lx)
 
240
      ly = max(1,ly)
 
241
      mx = min(ncol, mx)
 
242
      my = min(nrow, my)
 
243
      nx = mx-lx+1
 
244
      ny = my-ly+1
 
245
      do j=1,ny
 
246
         jy = ly+j-1
 
247
         do i=1,nx
 
248
            if (idtype .le. 3) then
 
249
               row(i) = max(-32768., min(32767., func(i,j)))
 
250
            else
 
251
               row(i) = func(i,j)
 
252
            end if
 
253
            if (idtype .le. 5) then
 
254
               row(i) = anint(row(i))
 
255
            end if
 
256
         end do
 
257
         call imps2r (id, row, lx, mx, jy, jy, ier)
 
258
         if (ier .ne. 0) then
 
259
            call stupid(message(ier))
 
260
            write (6,*) 'wraray:  x =', lx, ' to', mx, 
 
261
     .           ' y =', jy
 
262
         end if
 
263
      end do
 
264
      mx = nx
 
265
      my = ny
 
266
      return
 
267
      end
 
268
c
 
269
c
 
270
c
 
271
      subroutine clpic (text)
 
272
      character*4 text
 
273
      common /imid/ imdata, imcopy, idtype
 
274
      if (text .eq. 'DATA') then
 
275
         id = imdata
 
276
      else
 
277
         id = imcopy
 
278
      end if
 
279
      call imclos (id, ier)
 
280
      return
 
281
      end
 
282
c
 
283
c
 
284
c
 
285
      subroutine delpic (image, ier)
 
286
      character*30 image
 
287
      call imdele (image, ier)
 
288
      return
 
289
      end
 
290
c
 
291
c
 
292
c
 
293
      subroutine  writem  (picture, label, type, string)
 
294
      real*8 double
 
295
c     real*4 single
 
296
c     integer*4 long
 
297
c     integer*2 short
 
298
      integer*4 dtype
 
299
      character expand*100, picture*30, extend*30, 
 
300
     .     label*8, type*1, string*(*)
 
301
      common /imid/ imdata, imcopy, dtype
 
302
      call imopen (expand(extend(picture,'imh')), 3, imdata, istat)
 
303
      if (istat .ne. 0) then
 
304
         call stupid ('Error opening image.')
 
305
         write (6,*) istat
 
306
         call oops
 
307
      end if
 
308
c
 
309
      if ((type .eq. 'D') .or. (type .eq. 'd')) then
 
310
         read (string,*,iostat=istat) double
 
311
         if (istat .ne. 0) then
 
312
            call stupid ('Error reading datum from string:')
 
313
            write (6,*) string
 
314
            call oops
 
315
         end if
 
316
         call imakwd (imdata, label, double, ' ', istat)
 
317
         if (istat .ne. 0) then
 
318
            call stupid ('Error writing header item:')
 
319
            write (6,*) label, '= ', double
 
320
         end if
 
321
      end if
 
322
      call imclos (imdata, istat)
 
323
      return
 
324
      end
 
325
C
 
326
C
 
327
C
 
328
      SUBROUTINE LIST (FILE)
 
329
      CHARACTER*30 FILE
 
330
      CALL TBLANK
 
331
      WRITE (6,*) 'Image file = ', FILE
 
332
      CALL TBLANK
 
333
      RETURN
 
334
      END