|
|
@@ -0,0 +1,343 @@
|
|
|
+ SUBROUTINE SPECIAL_SYMBOL( isym, name, value, slen )
|
|
|
+
|
|
|
+* 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.
|
|
|
+*
|
|
|
+* this routine is 2-in-1 to handle "special" (internally defined) symbols
|
|
|
+* it acts like an encapsulated special symbol "object" (FORTRAN ...)
|
|
|
+* if isym=0 on input then this is a request to translate the passed "name"
|
|
|
+* if the given name is the name of a special symbol return its definition
|
|
|
+* in value and its length in slen. Else return slen=0
|
|
|
+* if slen is a positive integer then return the name of that symbol
|
|
|
+* or a blank name if the integer is larger than the number of symbols
|
|
|
+
|
|
|
+* programmer - steve hankin
|
|
|
+* NOAA/PMEL, Seattle, WA - Tropical Modeling and Analysis Program
|
|
|
+
|
|
|
+* V522 7/00 *sh* - extracted from symbol_command.F
|
|
|
+* V530 8/00 *sh* - bug (feature) fix so that SHOW SYM doesn't eveluate
|
|
|
+* PPL$XPIXEL
|
|
|
+* 12/00 *sh* - added symbols SESSION_DATE and SESSION_TIME
|
|
|
+* 10/01 *kob*- add symbol FERRET_PLATFORM to display the platform
|
|
|
+* the executable was built on.
|
|
|
+* 8/05 *acm*- Allow more digits in xrevision number
|
|
|
+* V62 4/09 *acm*- Add new symbol DELTA_CPU. When it is evaluated,
|
|
|
+* calls the intrinsic fcn Dtime and sets the value to that new
|
|
|
+* delta-time since the last call. Initialized in initizlize.F
|
|
|
+* V62 4/09 *acm*- Add new symbol CLOCK_SECS. When it is evaluated, calls the
|
|
|
+* intrinsic SYSTEM_CLOCK and sets the value to the delta-time
|
|
|
+* in seconds since Ferret was initialized.
|
|
|
+* V62 4/09 *acm*- Add new symbols CURRENT_DATE, CURRENT_TIME. These get formatted
|
|
|
+* date and time, unlike SESSION_DATE, SESSION_TIME which remain
|
|
|
+* fixed at the start time of the Ferret session.
|
|
|
+* V62 5/09 *acm*- make FERRET_MEMORY a special symbol.
|
|
|
+* V65 1/10 *acm*- New special symbol N_OPEN_DSETS, counts the number of open datasets
|
|
|
+* V65 2/10 *acm*- Call CPU_TIME rather than DTIME for clock symbols. Works
|
|
|
+* with gfortran as well as g77.
|
|
|
+* V68 *acm* 1/12 ifdef double_p for double-precision ferret.
|
|
|
+* V68 1/12 *acm*- Symbol FERRET_PRECISION is single or double.
|
|
|
+* V68 3/12 *acm*- Symbol SESSION_PID for the process ID
|
|
|
+* V68 2/13 *kms*- Symbol PROGRAM_NAME = Ferret or PyFerret
|
|
|
+* V702 3/17 *sh* - Dynamic memory calculation change for FERRET_MEMORY symbol
|
|
|
+* - added PEAK_MEMORY and SPAWN_STATUS
|
|
|
+* v720 7/17 *acm* ticket 2552 Make SPAWN_STATUS return the return status, so 0=succcess
|
|
|
+* SPAWN_OK -> SPAWN_OK, so 1=succcess, 0=failure
|
|
|
+* SPAWN_STATUS returns the status value
|
|
|
+
|
|
|
+ IMPLICIT NONE
|
|
|
+* calling argument declarations:
|
|
|
+ INTEGER isym, slen
|
|
|
+ CHARACTER name*(*), value*(*)
|
|
|
+
|
|
|
+* internal parameter declaration
|
|
|
+ INTEGER nspecial
|
|
|
+ PARAMETER (nspecial = 20)
|
|
|
+
|
|
|
+* internal variable declarations:
|
|
|
+ LOGICAL IS_SECURE
|
|
|
+ INTEGER STR_UPCASE, TM_LENSTR, i, i1, ierr, wsid,
|
|
|
+ . nxpix, nypix, llen, icount, irate, imax, iset
|
|
|
+c REAL DTIME
|
|
|
+ REAL TArray(2), dtime_res, clock_secs, count, cputime_now, rstatus
|
|
|
+ CHARACTER special(nspecial)*16, upname*16
|
|
|
+ CHARACTER LEFINT*16, TM_FMT*12, NF_INQ_LIBVERS*80, NF_INQ_LIBVERS_*80,
|
|
|
+ . LEFINT8*16
|
|
|
+ CHARACTER*10 current_date, current_time, zone
|
|
|
+ INTEGER itimes(8)
|
|
|
+
|
|
|
+* names of special symbols (must be upper case)
|
|
|
+ DATA special(1)/ 'PPL$XPIXEL' /,
|
|
|
+ . special(2)/ 'PPL$YPIXEL' /,
|
|
|
+ . special(3)/ 'BYTEORDER' /,
|
|
|
+ . special(4)/ 'FERRET_VERSION' /,
|
|
|
+ . special(5)/ 'FERRET_PLATFORM' /,
|
|
|
+ . special(6)/ 'FERRET_PRECISION' /,
|
|
|
+ . special(7)/ 'NETCDF_VERSION' /,
|
|
|
+ . special(8)/ 'FERRET_MEMORY' /,
|
|
|
+ . special(9)/ 'SESSION_DATE' /,
|
|
|
+ . special(10)/ 'SESSION_TIME' /,
|
|
|
+ . special(11)/ 'SESSION_PID' /,
|
|
|
+ . special(12)/ 'DELTA_CPU' /,
|
|
|
+ . special(13)/ 'CLOCK_SECS' /,
|
|
|
+ . special(14)/ 'CURRENT_DATE' /,
|
|
|
+ . special(15)/ 'CURRENT_TIME' /,
|
|
|
+ . special(16)/ 'N_OPEN_DSETS' /,
|
|
|
+ . special(17)/ 'PROGRAM_NAME' /,
|
|
|
+ . special(18)/ 'PEAK_MEMORY' /,
|
|
|
+ . special(19)/ 'SPAWN_OK' /,
|
|
|
+ . special(20)/ 'SPAWN_STATUS' /
|
|
|
+
|
|
|
+ include 'tmap_dims.parm'
|
|
|
+ include 'ferret.parm'
|
|
|
+ include 'xplot_state.cmn' ! for PPL$XPIXEL
|
|
|
+ include 'xrevision.cmn'
|
|
|
+ include 'xtoday.cmn'
|
|
|
+ include 'xplatform_type.cmn'
|
|
|
+ include 'xvariables.cmn'
|
|
|
+# include "tmap_dset.parm"
|
|
|
+ include 'xdset_info.cmn_text'
|
|
|
+ include 'xprog_state.cmn' ! for spawn_status
|
|
|
+
|
|
|
+* #ifdef for endianness info.
|
|
|
+#ifdef sun
|
|
|
+ include 'xmachine_byte.cmn'
|
|
|
+#else
|
|
|
+ include 'xmachine_int1.cmn'
|
|
|
+#endif
|
|
|
+
|
|
|
+* is this a query by integer or by name?
|
|
|
+ IF (isym .GE. 1) THEN
|
|
|
+* ***** QUERY BY INTEGER ******
|
|
|
+ IF (isym.GT.nspecial) THEN
|
|
|
+ name = ' '
|
|
|
+ RETURN
|
|
|
+ ENDIF
|
|
|
+ name = special(isym)
|
|
|
+ RETURN
|
|
|
+ ENDIF
|
|
|
+
|
|
|
+* ***** QUERY BY NAME *****
|
|
|
+* identify the given name
|
|
|
+ ierr = STR_UPCASE( upname, name )
|
|
|
+ DO 100 i = 1, nspecial
|
|
|
+ IF (upname .EQ. special(i)) GOTO 200
|
|
|
+ 100 CONTINUE
|
|
|
+
|
|
|
+* not a recognized special symbol
|
|
|
+ slen = 0
|
|
|
+ RETURN
|
|
|
+
|
|
|
+ 200 GOTO (1100, 1200, 1300, 1400, 1500, 1600, 1700, 1800,
|
|
|
+ . 1900, 2000, 2100, 2200, 2300, 2400, 2500, 2600,
|
|
|
+ . 2700, 2800, 2900, 3000 ) i
|
|
|
+
|
|
|
+* PPL$XPIXEL, PPL$YPIXEL
|
|
|
+ 1100 CONTINUE
|
|
|
+* ... determine the current output window (GKS wkstn ID, that is)
|
|
|
+ 1200 DO 1230 wsid = 1, max_windows
|
|
|
+ IF ( wn_active(wsid) ) GOTO 1240
|
|
|
+ 1230 CONTINUE
|
|
|
+* ... no currently active window
|
|
|
+ value = '0'
|
|
|
+ slen = 1
|
|
|
+ RETURN
|
|
|
+ 1240 CALL GET_WINDOW_PIXELS(wsid, nxpix, nypix)
|
|
|
+ IF ( i.EQ.1 ) THEN
|
|
|
+ value = LEFINT(nxpix,slen)
|
|
|
+ ELSE
|
|
|
+ value = LEFINT(nypix,slen)
|
|
|
+ ENDIF
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* BYTEORDER - get byteorder of this architecture
|
|
|
+ 1300 IF (active_cpu .EQ. cptype_sun) THEN
|
|
|
+ value = 'BIG'
|
|
|
+ slen = 3
|
|
|
+ ELSE
|
|
|
+ value = 'LITTLE'
|
|
|
+ slen = 6
|
|
|
+ ENDIF
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* FERRET_VERSION
|
|
|
+ 1400 value = ' '
|
|
|
+ value = TM_FMT(revision_level, 5, 12, llen)
|
|
|
+ slen = llen
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* PLATFORM_TYPE *kob* 10/01
|
|
|
+ 1500 value = platform_type
|
|
|
+ slen = TM_LENSTR(platform_type)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* FERRET_PRECISION
|
|
|
+ 1600 CONTINUE
|
|
|
+#ifdef double_p
|
|
|
+ value = 'double'
|
|
|
+#else
|
|
|
+ value = 'single'
|
|
|
+#endif
|
|
|
+ slen = TM_LENSTR(value)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* NETCDF_VERSION
|
|
|
+ 1700 CONTINUE
|
|
|
+ value = NF_INQ_LIBVERS()
|
|
|
+ slen = TM_LENSTR(value)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* FERRET_MEMORY
|
|
|
+ 1800 value = TM_FMT(max_mem_allowed/1.E6,3,12,llen)
|
|
|
+ slen = llen
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* SESSION_DATE
|
|
|
+ 1900 value = today_date
|
|
|
+ slen = 9
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* SESSION_TIME
|
|
|
+ 2000 value = today_time
|
|
|
+ slen = 5
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* SESSION_PID
|
|
|
+ 2100 CONTINUE
|
|
|
+ i1 = GETPID()
|
|
|
+ count = i1
|
|
|
+ value = TM_FMT(count, 10, 10, slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+
|
|
|
+* DELTA_CPU
|
|
|
+ 2200 CONTINUE
|
|
|
+c CALL DTIME(TArray)
|
|
|
+ CALL CPU_TIME(cputime_now)
|
|
|
+ dtime_res = cputime_now - cpu_last
|
|
|
+ cpu_last = cputime_now
|
|
|
+ value = ' '
|
|
|
+ value = TM_FMT(dtime_res, 6, 8, slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* CLOCK_SECS
|
|
|
+ 2300 CALL SYSTEM_CLOCK(icount, irate, imax)
|
|
|
+ clock_secs = FLOAT(icount-clock_start_count)/FLOAT(irate)
|
|
|
+ IF (clock_secs .LT. 0) THEN
|
|
|
+ CALL WARN('Evaluating CLOCK_SECS, call to '//
|
|
|
+ . 'SYSTEM_CLOCK. Count has exceeded its max and reset.')
|
|
|
+ CALL WARN( 'This value of CLOCK_SECS is invalid. '//
|
|
|
+ . 'Resetting to new initial value.')
|
|
|
+ clock_secs = 0.
|
|
|
+ clock_start_count = FLOAT(icount)/FLOAT(irate)
|
|
|
+ ENDIF
|
|
|
+ value = ' '
|
|
|
+ value = TM_FMT(clock_secs, 6, 8, slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* CURRENT_DATE
|
|
|
+ 2400 CONTINUE
|
|
|
+
|
|
|
+#ifdef AIX_XLF
|
|
|
+ CALL AIX_DATE( current_date )
|
|
|
+#elif F90_DATE_TIME
|
|
|
+ CALL FDATE(current_date)
|
|
|
+#else
|
|
|
+ CALL GET_DATE_AND_TIME (current_date, current_time)
|
|
|
+#endif
|
|
|
+ value = current_date
|
|
|
+ slen = 9
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* CURRENT_TIME
|
|
|
+ 2500 CONTINUE
|
|
|
+
|
|
|
+#ifdef AIX_XLF
|
|
|
+ CALL AIX_TIME( current_time )
|
|
|
+#elif F90_DATE_TIME
|
|
|
+ CALL FTIME(current_time)
|
|
|
+#else
|
|
|
+ CALL GET_DATE_AND_TIME (current_date, current_time) ! doesnt get seconds
|
|
|
+
|
|
|
+ CALL Date_and_Time(current_date, current_time, Zone, itimes)
|
|
|
+ WRITE (current_time,1000) itimes(5), itimes(6), itimes(7)
|
|
|
+ 1000 FORMAT (2(I2.2,":"), I2.2)
|
|
|
+
|
|
|
+#endif
|
|
|
+ value = current_time
|
|
|
+ slen = 8
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* N_OPEN_DSETS
|
|
|
+ 2600 CONTINUE
|
|
|
+
|
|
|
+ count = 0.
|
|
|
+ DO 2690 iset = 1, maxdsets
|
|
|
+ IF ( ds_name(iset) .NE. char_init2048) count = count + 1.
|
|
|
+ 2690 CONTINUE
|
|
|
+
|
|
|
+ value = TM_FMT(count, 10, 10, slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* PROGRAM_NAME
|
|
|
+ 2700 CONTINUE
|
|
|
+
|
|
|
+ value = 'Ferret'
|
|
|
+ slen = 6
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* PEAK_MEMORY
|
|
|
+ 2800 value = LEFINT8(peak_mem,slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* SPAWN_OK
|
|
|
+ 2900 IF (IS_SECURE()) THEN
|
|
|
+ rstatus = 0.
|
|
|
+ ELSEIF (spawn_status .EQ. 0.) THEN
|
|
|
+ rstatus = 1.
|
|
|
+ ELSE
|
|
|
+ rstatus = 0.
|
|
|
+ ENDIF
|
|
|
+ value = TM_FMT(rstatus, 10, 10, slen)
|
|
|
+ RETURN
|
|
|
+
|
|
|
+* SPAWN_STATUS
|
|
|
+ 3000 IF (IS_SECURE()) THEN
|
|
|
+ value = 'secure: spawn not allowed'
|
|
|
+ slen = 25
|
|
|
+ ELSE
|
|
|
+ rstatus = spawn_status
|
|
|
+ value = TM_FMT(rstatus, 10, 10, slen)
|
|
|
+ ENDIf
|
|
|
+ RETURN
|
|
|
+
|
|
|
+ END
|
|
|
+
|
