← Back to branch summary

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

« back to all changes in this revision

Viewing changes to contrib/geotest/src/waves.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/geotest/src/waves.for
 
1
C @(#)waves.for 19.1 (ES0-DMD) 02/25/03 13:24:48
 
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
        PROGRAM WAVES
 
30
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
31
C
 
32
C.IDENTIFICATION
 
33
C
 
34
C  Program WAVE            version 1.00       860706
 
35
C                          version 2.00       890424 (pMIDAS)
 
36
C  F. Murtagh              STECF                
 
37
C  M. Peron                IPG             890901 add include files
 
38
C  P. Ballester            IPG             910313 Compil. option -u
 
39
C                                                 and more
 
40
C
 
41
C.KEYWORDS
 
42
C  Simulated images, test images.
 
43
C
 
44
C.PURPOSE
 
45
C  Create background "wave" image, given the amplitude, period, and
 
46
C  dimensions of the image.
 
47
C
 
48
C.OUTPUT
 
49
C
 
50
C  Keys:  OUT_A/C/1/60       output data array
 
51
C         INPUTR/R/1/1       amplitude
 
52
C         INPUTR/R/1/1       period
 
53
C         INPUTI/I/2/1       frame dimensions
 
54
C
 
55
C-----------------------------------------------------------
 
56
C
 
57
C
 
58
        IMPLICIT NONE
 
59
C
 
60
        REAL                    RMIN,RMAX
 
61
        REAL                    STEPO(3),STARTO(3),CUTS(4)
 
62
        DOUBLE PRECISION        DSTEP(3), DSTART(3)
 
63
        INTEGER                 NPIXO(3),MADRID,KUN,KNUL
 
64
        CHARACTER*60            OUTIMA
 
65
        CHARACTER*72            IDENTO
 
66
        CHARACTER*80            CUNITO
 
67
C
 
68
        INTEGER                 IACT,ISTAT,IDIM,NDIMO
 
69
        INTEGER*8               JPNTR
 
70
        INTEGER                 IMNO,KUNIT
 
71
        REAL                    AMPL,PERIOD
 
72
C
 
73
        INCLUDE                 'MID_INCLUDE:ST_DEF.INC/NOLIST'
 
74
        COMMON                  /VMR/MADRID(1)
 
75
        INCLUDE                 'MID_INCLUDE:ST_DAT.INC/NOLIST'
 
76
 
 
77
C
 
78
C
 
79
C ... get into MIDAS
 
80
C
 
81
        CALL STSPRO('WAVES')
 
82
C
 
83
C ... get name of output frame
 
84
C
 
85
        CALL STKRDC('OUT_A',1,1,60,IACT,OUTIMA,KUN,KNUL,ISTAT)
 
86
C
 
87
C ... get amplitude, period, and frame dimensions.
 
88
C
 
89
        CALL STKRDR('INPUTR',1,1,IACT,AMPL,KUN,KNUL,ISTAT)
 
90
        CALL STKRDR('INPUTR',2,1,IACT,PERIOD,KUN,KNUL,ISTAT)
 
91
        CALL STKRDI('INPUTI',1,1,IACT,IDIM,KUN,KNUL,ISTAT)
 
92
C
 
93
C ... map output image
 
94
C
 
95
        NDIMO = 2
 
96
        NPIXO(1)  = IDIM
 
97
        NPIXO(2)  = IDIM
 
98
        STARTO(1) = 1
 
99
        STARTO(2) = 1
 
100
        STEPO(1)  = 1.0
 
101
        STEPO(2)  = 1.0 
 
102
        CUNITO    = ' NONE'
 
103
        IDENTO    = ' ARTIFICIAL BACKGROUND WAVE IMAGE' 
 
104
        DSTEP(1)  = STEPO(1)
 
105
        DSTART(1) = STEPO(1)
 
106
        CALL STIPUT(OUTIMA,D_R4_FORMAT,F_O_MODE,F_IMA_TYPE,
 
107
     .                   NDIMO,NPIXO,DSTART,
 
108
     .                   DSTEP,IDENTO,CUNITO,JPNTR,IMNO,ISTAT)
 
109
C
 
110
C ... now do the work
 
111
C
 
112
        CALL PATTERN(MADRID(JPNTR),RMIN,RMAX,AMPL,PERIOD,IDIM,ISTAT)
 
113
C
 
114
C ... write cuts
 
115
C
 
116
        CUTS(1) = RMIN
 
117
        CUTS(2) = RMAX
 
118
        CUTS(3) = RMIN
 
119
        CUTS(4) = RMAX
 
120
        CALL STDWRR(IMNO,'LHCUTS',CUTS,1,4,KUNIT,ISTAT)
 
121
C
 
122
C ... end
 
123
C
 
124
        CALL STFCLO(IMNO,ISTAT)
 
125
        CALL STSEPI
 
126
        END
 
127
 
 
128
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
129
C
 
130
C.IDENTIFICATION
 
131
C
 
132
C  Program PATTERN    
 
133
C  F. MURTAGH                                 ST-ECF  Version 1.0 860411
 
134
C
 
135
C.KEYWORDS
 
136
C
 
137
C  Test patterns, simulated images.
 
138
C
 
139
C
 
140
C.OUTPUT PARAMETERS
 
141
C 
 
142
C  ARR  = the frame,
 
143
C  RMIN, RMAX = cut values (max. and min. flux values).
 
144
C
 
145
C----------------------------------------------------------------------
 
146
        SUBROUTINE PATTERN(ARR,RMIN,RMAX,AMPL,PERIOD,IDIM,ISTAT)
 
147
C
 
148
        IMPLICIT NONE
 
149
C
 
150
C
 
151
        INTEGER              IDIM,ISTAT,NDIM1,NDIM2,I,J
 
152
        REAL                 ARR(IDIM,IDIM)
 
153
        REAL                 RMIN,RMAX,AMPL,PERIOD,ANGLE,PHASE
 
154
C
 
155
C
 
156
C
 
157
        NDIM1 = IDIM
 
158
        NDIM2 = IDIM
 
159
        PHASE = 0.0
 
160
C
 
161
C  (Mean, over one period, is 0 flux units per pixel.)
 
162
C
 
163
        DO I = 1, NDIM1
 
164
           DO J = 1, NDIM2
 
165
              ANGLE = (2*3.1415926/PERIOD)*FLOAT(I) - PHASE
 
166
              ARR(I,J) = AMPL*SIN(ANGLE)
 
167
           ENDDO
 
168
        ENDDO
 
169
C
 
170
C ------DETERMINE CUTS (I.E. MAX AND MIN VALUES)---------------------
 
171
C
 
172
        RMIN = 1000000.
 
173
        RMAX = -100000.
 
174
        DO I = 1, NDIM1
 
175
           DO J = 1, NDIM2
 
176
              IF (ARR(I,J).LT.RMIN) RMIN = ARR(I,J)
 
177
              IF (ARR(I,J).GT.RMAX) RMAX = ARR(I,J)
 
178
           ENDDO
 
179
        ENDDO
 
180
C
 
181
C
 
182
        RETURN
 
183
C
 
184
        END