1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
|
SUBROUTINE FERRET_DISPATCH( command, rtn_flags, nflags,
. rtn_chars, nchars, nerrlines )
*
*
* This software was developed by the Thermal Modeling and Analysis
* Project(TMAP) of the National Oceanographic and Atmospheric
* Administration's (NOAA) Pacific Marine Environmental Lab(PMEL),
* hereafter referred to as NOAA/PMEL/TMAP.
*
* Access and use of this software shall impose the following
* obligations and understandings on the user. The user is granted the
* right, without any fee or cost, to use, copy, modify, alter, enhance
* and distribute this software, and any derivative works thereof, and
* its supporting documentation for any purpose whatsoever, provided
* that this entire notice appears in all copies of the software,
* derivative works and supporting documentation. Further, the user
* agrees to credit NOAA/PMEL/TMAP in any publications that result from
* the use of this software or in any product that includes this
* software. The names TMAP, NOAA and/or PMEL, however, may not be used
* in any advertising or publicity to endorse or promote any products
* or commercial entity unless specific written permission is obtained
* from NOAA/PMEL/TMAP. The user also understands that NOAA/PMEL/TMAP
* is not obligated to provide the user with any support, consulting,
* training or assistance of any kind with regard to the use, operation
* and performance of this software nor to provide the user with any
* updates, revisions, new versions or "bug fixes".
*
* THIS SOFTWARE IS PROVIDED BY NOAA/PMEL/TMAP "AS IS" AND ANY EXPRESS
* OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
* WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
* ARE DISCLAIMED. IN NO EVENT SHALL NOAA/PMEL/TMAP BE LIABLE FOR ANY SPECIAL,
* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER
* RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF
* CONTRACT, NEGLIGENCE OR OTHER TORTUOUS ACTION, ARISING OUT OF OR IN
* CONNECTION WITH THE ACCESS, USE OR PERFORMANCE OF THIS SOFTWARE.
*
*
* Execute a FERRET command
* WHILE MODE GUI is "CANCELLED" control will remain inside this routine
* If "command" contains text that command will be executed immediately
* (formatted as a c-style, null-terminated string)
* programmer - steve hankin
* NOAA/PMEL, Seattle, WA - Tropical Modeling and Analysis Program
* FERRET program history:
* initially tailored to output format and content of the Philander/Seigel
* model from GFDL
* revision 0.0 - 4/3/86
* revision 1.0 - 11/17/86 - first "official" release
* revision 2.0 - 10/23/87 - "official" release
* revision 2.01(temporary) - 10/23/87 - smaller memory size, bug fixes,
* 2 typos in XVARIABLES_DATA, ^C added, ZT planes added
* revision 2.02 - ?????
* revision 2.10 - 5/6/88 - "final" release - /NODEBUG version
* FERRET 1.00 - 6/10/88 - rename of GFDL 2.10
* FERRET 1.10 - 8/2/88 - numerous bug fixes and enhancements
* FERRET 1.20 - 2/17/89 - numerous bug fixes and enhancements
* FERRET 1.21 - 4/19/89 - minor bug fixes
* FERRET 2.00 - 5/??/89 - internal re-write: 4D grids and "object oriented"
* transformations
* FERRET 3.00 - 1/29/93 - revision 2.2-->2.3 changes became so extensive
* and prolonged it made sense to rename to V3.0
* FERRET 3.10 - 4/94 - official release using XGKS
* FERRET 3.11 - 5/94 - added FILE/ORDER=/FORMAT=STREAM
* FERRET 3.12 - 5/94 - restructured to be "dynamic memory" (C main routine)
* former MAIN became FERRET_DISPATCH routine
* FERRET_DISPATCH routine history
* as MAIN program unit:
* revision 1.1 - 4/29/87 - added FRAME and REPEAT commands
* revision 1.2 - 7/7/87 - added PLOT command for line plots
* revision 1.3 - 9/9/87 - added LOAD command
* revision 1.4 - 9/23/87 - added DEFINE command
* revision 2.0 - 10/23/87 - changed DATA stmt rev. level to 2.00
* and added EXTERNAL statement
* revision 2.1 - 3/25/88 - added STATISTICS command
* revision 2.2 - 4/20/88 - ADDED &UNITS AND &DSET_PARMS TO EXTERNALS 2.02-->2.10
* revision 2.3 - 6/10/88 - renamed to Program FERRET
* revision 2.4 - 8/2/88 - for FERRET 1.10 - added SHADE and SPAWN commands
* revision 2.5 - 12/12/88- eliminated XGRID_DATA to new TMAP library
* V200: 1/21/90 - added user-definable command USER
* 5/2/90 - added externals for BOX_BOUNDS and CK_GKS_ACTIVE which are
* called from PLOT+ routines
* Unix/RISC port: pulled xrevision information fully into main program
* 7/12/91 - added note not to distribute
* 10/17/91 - added external for viewport sizing
* V230: 6/8/92 - added WIRE command
* V300 1/93 - new version (includes animations, etc.)
* added xgt_grid_data - forced from xcalc_vars_data.F by
* DEC f77 3.2
* 6/93 - added QUERY command, and EXTERNAL XGUI_DATA
* These changes happened concurrent to the restructure for V320:
* V311: 5/17/94 added FILE/ORDER and FILE/FORMAT=STREAM
* V312: 6/17/94 metafile bug fix in XGKS (hangs and crashes with color plots)
* as FERRET_DISPATCH routine (formerly MAIN routine ferret.F):
* V320: 5/19/94 (also removed xrevision.cmn DATA stmts to xrevision_data.F
* for AIX compatibility)
* 2/28/95 - error message buffer for GUI moved to TMAP COMMON
* - send "synch" message to GUI if new window is created
* V400: 3/20/95 - pass "memory" to get_command for preliminary pass in which
* grave accent expressions are evaluated
* 6/20/95 - send "synch" for window destruction, too
* V411: 9/13/95 - Ultrix port: CHAR(integer*1) is illegal although CHAR(byte)
* is allowed ... go figger
* V420: 4/23/96 - added new commands IF, ELSE, ELIF, ENDIF
* Linux Port *kob* 1/97 - Added external for XWINDOW_STATE_DATA block data
* V450: 7/7/97 - added external for XGRID_CHG_FCNS block data
* V500: 2/99 *sh* - added POLYGON command
* V530: 10/00 *sh* - added external declaration for new xez_info_data
* V553: 9/03 *acm*- Loop 2 ran to 200; change to cmnd_buff_len
* (came up when implementing the -script command-line option)
* V63 *acm* 10/09 Changes for gfortran build
* V664 *kms* 8/10 Add second alternate return from XEQ_EXIT to exit the dispatch
* loop but just re-enter the loop if not under pyferret
* *acm* 3/12 removing use USER command
* V685 *acm* 11/13 Issue an ERROR not a NOTE if USER command is tried.
* V695 *acm* 6/16 New ANNOTATE command.
* V702 *sh* 2/17 dynamic memory management - no return for SET MEMORY
IMPLICIT NONE
include 'tmap_dims.parm'
include 'xalt_messages.cmn_text'
include 'ferret.parm'
include 'errmsg.parm'
include 'gui.parm'
include 'command.parm'
include 'xprog_state.cmn'
include 'xvariables.cmn'
include 'xgui.cmn'
include 'xplot_state.cmn'
* EXTERNAL references to force the LINKER to look for BLOCK DATA SUBROUTINES
EXTERNAL
. XALGEBRA_DATA,
. XCOMMAND_DATA,
. XCONTEXT_DATA,
. XCONTROL_DATA,
. XERRMSG_TEXT_DATA,
. XGFDL_MASKS_DATA,
. XONEDIM_DATA,
. XPLOT_SETUP_DATA,
. XPLOT_STATE_DATA,
. XPROG_STATE_DATA,
. XTEXT_INFO_DATA,
. XVARIABLES_DATA,
. XFR_GRID_DATA,
. XGKS_DEVICES_DATA,
. XGUI_DATA,
. XREVISION_DATA
EXTERNAL XGT_GRID_DATA ! 2/93
EXTERNAL BOX_BOUNDS, CK_GKS_ACTIVE, GET_VIEW_SIZE,
. FERRET_PLOT_COMPLETE
* kob 1/97
EXTERNAL XWINDOW_STATE_DATA
* sh 7/97
EXTERNAL XGRID_CHG_FCNS_DATA,
. XEZ_INFO_DATA
* temporarily we simply declare the "memory" array right here
* calling argument declarations
INTEGER nflags, nchars, rtn_flags(nflags), nerrlines
#ifdef NEED_BYTE
BYTE command(*), rtn_chars(nchars)
#else
# ifdef ultrix
BYTE command(*), rtn_chars(nchars) ! 9/95 Ultrix, only
# else
INTEGER*1 command(*), rtn_chars(nchars)
# endif
#endif
* local variable declarations:
INTEGER TM_LENSTR1,
. cmnd_stack_level, reconfig, status, i, gui_action,
. insert_pt
* local parameter declarations
INTEGER slash_msg_continue
PARAMETER ( slash_msg_continue = 1)
* transfer the c-style string into a FORTRAN string
cmnd_buff = ' '
c DO 2 i = 1, 200
DO i = 1, cmnd_buff_len
IF ( command(i) .EQ. 0 ) GOTO 5
cmnd_buff(i:i) = CHAR( command(i) )
END DO
5 CALL GET_FER_COMMAND( cmnd_buff, status, *300 )
GOTO ( 10, 20, 30, 40, 50, 60, 70, 80, 90,100,
. 110,120,130,140,150,160,170,180,190,200,
. 210,220,230,240,250,260,270,280 ) cmnd_num
10 CALL XEQ_SET
GOTO 300
20 CALL XEQ_SHOW
GOTO 300
30 CALL XEQ_CANCEL
GOTO 300
40 CALL XEQ_CONTOUR ! after rev 1.00 1/5/87
GOTO 300
50 CALL XEQ_LIST
GOTO 300
60 CALL XEQ_PLOT
GOTO 300
70 CALL XEQ_GO
GOTO 300
80 CALL XEQ_HELP
GOTO 300
90 CALL XEQ_LOAD
GOTO 300
100 CALL XEQ_DEFINE
GOTO 300
110 CALL XEQ_EXIT( *500, *450 )
GOTO 300 ! command file xit or error
120 CALL XEQ_MESSAGE
GOTO 300
130 CALL XEQ_VECTOR
GOTO 300
140 CALL XEQ_PPLUS
GOTO 300
150 CALL XEQ_FRAME
GOTO 300
160 CALL XEQ_REPEAT
GOTO 300
170 CALL XEQ_STAT
GOTO 300
180 CALL XEQ_SHADE
GOTO 300
190 CALL XEQ_SPAWN
GOTO 300
200 CONTINUE! CALL XEQ_USER_COMMAND
CALL ERRMSG(ferr_syntax, status,
. 'USER command not available in this Ferret version ', *300)
210 CALL XEQ_WIRE
GOTO 300
220 CALL XEQ_QUERY
GOTO 300
230 CALL XEQ_IF
GOTO 300
240 CALL XEQ_ELSE
GOTO 300
250 CALL XEQ_ELIF
GOTO 300
260 CALL XEQ_ENDIF
GOTO 300
270 CALL XEQ_POLYGON
GOTO 300
280 CALL XEQ_ANNOTATE
GOTO 300
* finished a single command
300 gui_action = factn_no_action ! default
IF ( (cmnd_num .EQ. cmnd_set
. .AND. subcmnd_num .EQ. subcmnd_set_data)
. .OR. (cmnd_num .EQ. cmnd_cancel
. .AND. subcmnd_num .EQ. subcmnd_canc_data) ) THEN
* ... need to synchronize data sets with GUI
gui_action = factn_synch_set_data
ELSEIF ( cmnd_num .EQ. cmnd_message
. .AND. qual_given(slash_msg_continue) .EQ. 0 ) THEN
gui_action = factn_pause
ELSE
* ... need to synchronize output window creation/destruction with GUI
* ... creation may be from any (initial) plot command or from SET WINDOW
DO 302 i = 1, max_windows
IF ( wn_open(i) .NEQV. gui_window_reported(i) ) THEN
gui_action = factn_synch_window
rtn_flags(frtn_idata1) = i
IF (wn_open(i)) THEN
rtn_flags(frtn_idata2) = 1 ! 1 means "creation"
gui_window_reported(i) = .TRUE.
ELSE
rtn_flags(frtn_idata2) = -1 ! -1 means "destruction"
gui_window_reported(i) = .FALSE.
ENDIF
ENDIF
302 CONTINUE
ENDIF
* ... prepare error buffer to pass back to calling (GUI?) program
IF ( mode_gui .AND. gui_status .NE. ferr_ok ) THEN
gui_action = factn_display_error
insert_pt = 1
DO 310 i = 1, alt_nlines
nerrlines = i
CALL CSTRING_INSERT(alt_text(i), TM_LENSTR1(alt_text(i)),
. rtn_chars, nchars, insert_pt )
IF ( insert_pt .GT. nchars ) GOTO 320
310 CONTINUE
ELSE
nerrlines = 0
ENDIF
320 alt_nlines = 0
CALL CLEANUP_LAST_CMND( cmnd_stack_level )
IF ( .NOT.mode_gui ) THEN
IF ( one_cmnd_mode .AND. (cmnd_stack_level .EQ. 0) ) THEN
GOTO 450
ENDIF
GOTO 5
ELSEIF ( cmnd_stack_level .GT. 0 ) THEN
rtn_flags(frtn_control) = fctrl_in_ferret ! command not yet finished
rtn_flags(frtn_status) = gui_status
rtn_flags(frtn_action) = gui_action
RETURN
ELSE
rtn_flags(frtn_control) = fctrl_back_to_gui
rtn_flags(frtn_status) = gui_status
rtn_flags(frtn_action) = gui_action
RETURN
ENDIF
* exit the dispatch loop - if from PyFerret, return control to python
* if from Ferret, just re-enter the dispatch loop
450 rtn_flags(frtn_control) = fctrl_in_ferret
rtn_flags(frtn_status) = gui_status
rtn_flags(frtn_action) = factn_no_action
RETURN
* exit the program
500 rtn_flags(frtn_control) = fctrl_back_to_gui
rtn_flags(frtn_status) = gui_status
rtn_flags(frtn_action) = factn_exit
RETURN
END
*
* Routine to set the one_cmnd_mode in FERRET_DISPATCH
* The following only applies if gui_mode is .FALSE.
* If new_mode_int is zero, FERRET_DISPATCH will return only
* on memory resizes and exit (original behavior)
* If new_mode_int is non-zero, FERRET_DISPATCH will return
* after each submitted command is complete
*
SUBROUTINE SET_ONE_CMND_MODE(new_mode_int)
IMPLICIT NONE
include 'tmap_dims.parm'
INCLUDE 'xprog_state.cmn'
INTEGER new_mode_int
one_cmnd_mode = (new_mode_int .NE. 0)
RETURN
END
|
