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