aboutsummaryrefslogtreecommitdiff
path: root/sys/gio/nspp/sysint
diff options
context:
space:
mode:
Diffstat (limited to 'sys/gio/nspp/sysint')
-rw-r--r--sys/gio/nspp/sysint/README1
-rw-r--r--sys/gio/nspp/sysint/encd.f78
-rw-r--r--sys/gio/nspp/sysint/encode.f15
-rw-r--r--sys/gio/nspp/sysint/erprt77.f441
-rw-r--r--sys/gio/nspp/sysint/fencode.x79
-rw-r--r--sys/gio/nspp/sysint/fulib.x29
-rw-r--r--sys/gio/nspp/sysint/intt.x16
-rw-r--r--sys/gio/nspp/sysint/ishift.x55
-rw-r--r--sys/gio/nspp/sysint/loc.x23
-rw-r--r--sys/gio/nspp/sysint/mcswap.x17
-rw-r--r--sys/gio/nspp/sysint/mkpkg24
-rw-r--r--sys/gio/nspp/sysint/ncgchr.x22
-rw-r--r--sys/gio/nspp/sysint/ncpchr.x20
-rw-r--r--sys/gio/nspp/sysint/nspp.com40
-rw-r--r--sys/gio/nspp/sysint/packum.x43
-rw-r--r--sys/gio/nspp/sysint/perror.x9
-rw-r--r--sys/gio/nspp/sysint/q8qst4.f24
-rw-r--r--sys/gio/nspp/sysint/uliber.f14
18 files changed, 950 insertions, 0 deletions
diff --git a/sys/gio/nspp/sysint/README b/sys/gio/nspp/sysint/README
new file mode 100644
index 00000000..64537d9d
--- /dev/null
+++ b/sys/gio/nspp/sysint/README
@@ -0,0 +1 @@
+SYSINT -- System interface for the Ncar System Plot Package (NSPP)
diff --git a/sys/gio/nspp/sysint/encd.f b/sys/gio/nspp/sysint/encd.f
new file mode 100644
index 00000000..1dba902b
--- /dev/null
+++ b/sys/gio/nspp/sysint/encd.f
@@ -0,0 +1,78 @@
+ SUBROUTINE ENCD (VALU,ASH,IOUT,NC,IOFFD)
+C
+C
+C
+C
+C ON INPUT VALU FLOATING POINT NUMBER FROM WHICH THE LABEL IS
+C TO BE CREATED.
+C ASH SEE IOFFD.
+C IOFFD IF IOFFD .EQ. 0, A LABEL WHICH REFLECTS THE
+C MAGNITUDE OF VALU IS TO BE CREATED.
+C .1 .LE. ABS(VALU) .LE. 99999.49999...
+C OR VALUE .EQ. 0.0. THE LABEL CREATED
+C SHOULD HAVE 3 TO 5 CHARACTERS DEPENDING
+C ON THE MAGNITUDE OF VALU. SEE IOUT.
+C IF IOFFD .NE. 0, A LABEL WHICH DOES NOT REFLECT
+C THE MAGNITUDE OF VALU IS TO BE CREATED.
+C ASH IS USED AS THE NORMALIZATION FACTOR.
+C 1. .LE. ASH*ABS(VALU) .LT. 1000. OR
+C VALU .EQ. 0.0. THE LABEL CREATED SHOULD
+C HAVE 1 TO 3 CHARACTERS, DEPENDING ON THE
+C MAGNITUDE OF ASH*VALU. SEE IOUT.
+C ON OUTPUT IOUT CONTAINS THE LABEL CREATED. IT SHOULD HAVE NO
+C LEADING BLANKS. SEE NC.
+C NC THE NUMBERS IN THE LABEL IN IOUT. SHOULD BE
+C 1 TO 5.
+C
+ SAVE
+ CHARACTER*11 IFMT, IOUT
+C
+C IFMT MUST HOLD 11 CHARACTERS
+C
+ VAL = VALU
+ IF (IOFFD .NE. 0) GO TO 103
+ IF (VAL) 101,104,101
+ 101 LOG = IFIX((ALOG10(ABS(VAL))+.00001)+5000.)-5000
+ V = VAL
+ NS = MAX0(4,MIN0(6,LOG+2))
+ ND = MIN0(3,MAX0(0,2-LOG))
+c IF (VAL.LT.0) NS = NS + 1
+c +noao: replacing ftn i/o for iraf implementation
+c 102 WRITE (IFMT,'(A2,I2,A1,I1,A1)') '(F',NS,'.',ND,')'
+ 102 continue
+c if (len (char (ns + ichar ('0'))) .eq. 2) then
+c ifmt(1:7) = '(f . )'
+c ifmt(3:4) = char (ns + ichar ('0'))
+c ifmt(6:6) = char (nd + ichar ('0'))
+c else
+c ifmt(1:6) = '(f . )'
+c ifmt(3:3) = char (ns + ichar ('0'))
+c ifmt(5:5) = char (nd + ichar ('0'))
+c endif
+c WRITE (IOUT,IFMT) V
+ call encode (ns, ifmt, iout, v)
+ NC = NS
+c +noao
+c The following statement was making 5 digit labels (+4800) come out
+c truncated (+480) and it has been commented out.
+c IF (LOG.GE.3) NC = NC - 1
+c -noao
+ RETURN
+ 103 NS = 4
+ IF (VAL.LT.0.) NS=5
+ IF (VAL.EQ.0.) NS=2
+ ND = 0
+ V = VAL*ASH
+ LOG = 100
+ GO TO 102
+ 104 iout(1:3) = '0.0'
+ nc = 3
+c 104 NS = 3
+c ND = 1
+c LOG = -100
+c V = 0.
+c GO TO 102
+C
+C1001 FORMAT('(F',I2,'.',I1,',1H',A1,')')
+C
+ END
diff --git a/sys/gio/nspp/sysint/encode.f b/sys/gio/nspp/sysint/encode.f
new file mode 100644
index 00000000..e6417bee
--- /dev/null
+++ b/sys/gio/nspp/sysint/encode.f
@@ -0,0 +1,15 @@
+ subroutine encode (nchars, ftnfmt, ftnout, rval)
+
+ character*11 ftnfmt, ftnout
+ integer*2 sppfmt(12), sppout(12)
+ integer SZFMT
+ parameter (SZFMT=11)
+
+c unpack the fortran character string, call fencd to actually encode the
+c output string, then pack the output string into a fortran string for return
+c
+ call f77upk (ftnfmt, sppfmt, SZFMT)
+ call fencd (nchars, sppfmt, sppout, rval)
+ call f77pak (sppout, ftnout, SZFMT)
+
+ end
diff --git a/sys/gio/nspp/sysint/erprt77.f b/sys/gio/nspp/sysint/erprt77.f
new file mode 100644
index 00000000..a4f60e1d
--- /dev/null
+++ b/sys/gio/nspp/sysint/erprt77.f
@@ -0,0 +1,441 @@
+C PACKAGE ERPRT77 DESCRIPTION OF INDIVIDUAL USER ENTRIES
+C FOLLOWS THIS PACKAGE DESCRIPTION.
+C
+C LATEST REVISION FEBRUARY 1985
+C
+C PURPOSE TO PROVIDE A PORTABLE, FORTRAN 77 ERROR
+C HANDLING PACKAGE.
+C
+C USAGE THESE ROUTINES ARE INTENDED TO BE USED IN
+C THE SAME MANNER AS THEIR SIMILARLY NAMED
+C COUNTERPARTS ON THE PORT LIBRARY. EXCEPT
+C FOR ROUTINE SETER, THE CALLING SEQUENCES
+C OF THESE ROUTINES ARE THE SAME AS FOR
+C THEIR PORT COUNTERPARTS.
+C ERPRT77 ENTRY PORT ENTRY
+C ------------- ----------
+C ENTSR ENTSRC
+C RETSR RETSRC
+C NERRO NERROR
+C ERROF ERROFF
+C SETER SETERR
+C EPRIN EPRINT
+C FDUM FDUMP
+C
+C I/O SOME OF THE ROUTINES PRINT ERROR MESSAGES.
+C
+C PRECISION NOT APPLICABLE
+C
+C REQUIRED LIBRARY MACHCR, WHICH IS LOADED BY DEFAULT ON
+C FILES NCAR'S CRAY MACHINES.
+C
+C LANGUAGE FORTRAN 77
+C
+C HISTORY DEVELOPED OCTOBER, 1984 AT NCAR IN BOULDER,
+C COLORADO BY FRED CLARE OF THE SCIENTIFIC
+C COMPUTING DIVISION BY ADAPTING THE NON-
+C PROPRIETARY, ERROR HANDLING ROUTINES
+C FROM THE PORT LIBRARY OF BELL LABS.
+C
+C PORTABILITY FULLY PORTABLE
+C
+C REFERENCES SEE THE MANUAL
+C PORT MATHEMATICAL SUBROUTINE LIBRARY
+C ESPECIALLY "ERROR HANDLING" IN SECTION 2
+C OF THE INTRODUCTION, AND THE VARIOUS
+C SUBROUTINE DESCRIPTIONS.
+C ******************************************************************
+C
+C SUBBROUTINE ENTSR(IROLD,IRNEW)
+C
+C PURPOSE SAVES THE CURRENT RECOVERY MODE STATUS AND
+C SETS A NEW ONE. IT ALSO CHECKS THE ERROR
+C STATE, AND IF THERE IS AN ACTIVE ERROR
+C STATE A MESSAGE IS PRINTED.
+C
+C USAGE CALL ENTSR(IROLD,IRNEW)
+C
+C ARGUMENTS
+C
+C ON INPUT IRNEW
+C VALUE SPECIFIED BY USER FOR ERROR
+C RECOVERY
+C = 0 LEAVES RECOVERY UNCHANGED
+C = 1 GIVES RECOVERY
+C = 2 TURNS RECOVERY OFF
+C
+C ON OUTPUT IROLD
+C RECEIVES THE CURRENT VALUE OF THE ERROR
+C RECOVERY MODE
+C
+C SPECIAL CONDITIONS IF THERE IS AN ACTIVE ERROR STATE, THE
+C MESSAGE IS PRINTED AND EXECUTION STOPS.
+C
+C ERROR STATES -
+C 1 - ILLEGAL VALUE OF IRNEW.
+C 2 - CALLED WHILE IN AN ERROR STATE.
+C ******************************************************************
+C
+C SUBROUTINE RETSR(IROLD)
+C
+C PURPOSE SETS THE RECOVERY MODE TO THE STATUS GIVEN
+C BY THE INPUT ARGUMENT. A TEST IS THEN MADE
+C TO SEE IF A CURRENT ERROR STATE EXISTS WHICH
+C IS UNRECOVERABLE; IF SO, RETSR PRINTS AN
+C ERROR MESSAGE AND TERMINATES THE RUN.
+C
+C BY CONVENTION, RETSR IS USED UPON EXIT
+C FROM A SUBROUTINE TO RESTORE THE PREVIOUS
+C RECOVERY MODE STATUS STORED BY ROUTINE
+C ENTSR IN IROLD.
+C
+C USAGE CALL RETSR(IROLD)
+C
+C ARGUMENTS
+C
+C ON INPUT IROLD
+C = 1 SETS FOR RECOVERY
+C = 2 SETS FOR NONRECOVERY
+C
+C ON OUTPUT NONE
+C
+C SPECIAL CONDITIONS IF THE CURRENT ERROR BECOMES UNRECOVERABLE,
+C THE MESSAGE IS PRINTED AND EXECUTION STOPS.
+C
+C ERROR STATES -
+C 1 - ILLEGAL VALUE OF IROLD.
+C ******************************************************************
+C
+C INTEGER FUNCTION NERRO(NERR)
+C
+C PURPOSE PROVIDES THE CURRENT ERROR NUMBER (IF ANY)
+C OR ZERO IF THE PROGRAM IS NOT IN THE
+C ERROR STATE.
+C
+C USAGE N = NERRO(NERR)
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NERR
+C CURRENT VALUE OF THE ERROR NUMBER
+C ******************************************************************
+C SUBROUTINE ERROF
+C
+C PURPOSE TURNS OFF THE ERROR STATE BY SETTING THE
+C ERROR NUMBER TO ZERO
+C
+C USAGE CALL ERROF
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+C
+C SUBROUTINE SETER(MESSG,NERR,IOPT)
+C
+C PURPOSE SETS THE ERROR INDICATOR AND, DEPENDING
+C ON THE OPTIONS STATED BELOW, PRINTS A
+C MESSAGE AND PROVIDES A DUMP.
+C
+C
+C USAGE CALL SETER(MESSG,NERR,IOPT)
+C
+C ARGUMENTS
+C
+C ON INPUT MESSG
+C HOLLERITH STRING CONTAINING THE MESSAGE
+C ASSOCIATED WITH THE ERROR
+C
+C NERR
+C THE NUMBER TO ASSIGN TO THE ERROR
+C
+C IOPT
+C = 1 FOR A RECOVERABLE ERROR
+C = 2 FOR A FATAL ERROR
+C
+C IF IOPT = 1 AND THE USER IS IN ERROR
+C RECOVERY MODE, SETERR SIMPLY REMEMBERS
+C THE ERROR MESSAGE, SETS THE ERROR NUMBER
+C TO NERR, AND RETURNS.
+C
+C IF IOPT = 1 AND THE USER IS NOT IN ERROR
+C RECOVERY MODE, SETERR PRINTS THE ERROR
+C MESSAGE AND TERMINATES THE RUN.
+C
+C IF IOPT = 2 SETERR ALWAYS PRINTS THE ERROR
+C MESSAGE, CALLS FDUM, AND TERMINATES THE RUN.
+C
+C ON OUTPUT NONE
+C
+C SPECIAL CONDITIONS CANNOT ASSIGN NERR = 0, AND CANNOT SET IOPT
+C TO ANY VALUE OTHER THAN 1 OR 2.
+C ******************************************************************
+C
+C SUBROUTINE EPRIN
+C
+C PURPOSE PRINTS THE CURRENT ERROR MESSAGE IF THE
+C PROGRAM IS IN THE ERROR STATE; OTHERWISE
+C NOTHING IS PRINTED.
+C
+C USAGE CALL EPRIN
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+C
+C SUBROUTINE FDUM
+C
+C PURPOSE TO PROVIDE A DUMMY ROUTINE WHICH SERVES
+C AS A PLACEHOLDER FOR A SYMBOLIC DUMP
+C ROUTINE, SHOULD IMPLEMENTORS DECIDE TO
+C PROVIDE SUCH A ROUTINE.
+C
+C USAGE CALL EPRIN
+C
+C ARGUMENTS
+C
+C ON INPUT NONE
+C
+C ON OUTPUT NONE
+C ******************************************************************
+ SUBROUTINE ENTSR(IROLD,IRNEW)
+C
+ LOGICAL TEMP
+ IF (IRNEW.LT.0 .OR. IRNEW.GT.2)
+ 1 CALL SETER(' ENTSR - ILLEGAL VALUE OF IRNEW',1,2)
+C
+ TEMP = IRNEW.NE.0
+ IROLD = I8SAV(2,IRNEW,TEMP)
+C
+C IF HAVE AN ERROR STATE, STOP EXECUTION.
+C
+ IF (I8SAV(1,0,.FALSE.) .NE. 0) CALL SETER
+ 1 (' ENTSR - CALLED WHILE IN AN ERROR STATE',2,2)
+C
+ RETURN
+C
+ END
+ SUBROUTINE RETSR(IROLD)
+C
+ IF (IROLD.LT.1 .OR. IROLD.GT.2)
+ 1 CALL SETER(' RETSR - ILLEGAL VALUE OF IROLD',1,2)
+C
+ ITEMP=I8SAV(2,IROLD,.TRUE.)
+C
+C IF THE CURRENT ERROR IS NOW UNRECOVERABLE, PRINT AND STOP.
+C
+ IF (IROLD.EQ.1 .OR. I8SAV(1,0,.FALSE.).EQ.0) RETURN
+C
+ CALL EPRIN
+ CALL FDUM
+c STOP
+C
+ END
+ INTEGER FUNCTION NERRO(NERR)
+C
+ NERRO=I8SAV(1,0,.FALSE.)
+ NERR=NERRO
+ RETURN
+C
+ END
+ SUBROUTINE ERROF
+C
+ I=I8SAV(1,0,.TRUE.)
+ RETURN
+C
+ END
+ SUBROUTINE SETER(MESSG,NERR,IOPT)
+C
+ CHARACTER*(*) MESSG
+ COMMON /UERRF/IERF
+C
+C THE UNIT FOR ERROR MESSAGES IS I1MACH(4)
+C
+c +noao: blockdata uerrbd changed to runtime initialization subroutine
+C FORCE LOAD OF BLOCKDATA
+C
+c EXTERNAL UERRBD
+ call uerrbd
+c -noao
+ IF (IERF .EQ. 0) THEN
+ IERF = I1MACH(4)
+ ENDIF
+C
+ NMESSG = LEN(MESSG)
+ IF (NMESSG.GE.1) GO TO 10
+C
+C A MESSAGE OF NON-POSITIVE LENGTH IS FATAL.
+C
+c +noao: FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9000)
+c9000 FORMAT(' ERROR 1 IN SETER - MESSAGE LENGTH NOT POSITIVE.')
+ call uliber (1,' SETER - MESSAGE LENGTH NOT POSITIVE.', 80)
+c -noao
+ GO TO 60
+C
+ 10 CONTINUE
+ IF (NERR.NE.0) GO TO 20
+C
+C CANNOT TURN THE ERROR STATE OFF USING SETER.
+C
+c +noao: FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9001)
+c9001 FORMAT(' ERROR 2 IN SETER - CANNOT HAVE NERR=0'/
+c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'/)
+ call uliber (2, ' SETER - CANNOT HAVE NERR=0', 80)
+ call uliber (2, ' SETER - THE CURRENT ERROR MSG FOLLOWS', 80)
+c -noao
+ CALL E9RIN(MESSG,NERR,.TRUE.)
+ ITEMP=I8SAV(1,1,.TRUE.)
+ GO TO 50
+C
+C SET LERROR AND TEST FOR A PREVIOUS UNRECOVERED ERROR.
+C
+ 20 CONTINUE
+ IF (I8SAV(1,NERR,.TRUE.).EQ.0) GO TO 30
+C
+c +noao: FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9002)
+c9002 FORMAT(' ERROR 3 IN SETER -',
+c 1 ' AN UNRECOVERED ERROR FOLLOWED BY ANOTHER ERROR.'//
+c 2 ' THE PREVIOUS AND CURRENT ERROR MESSAGES FOLLOW.'///)
+ call uliber (3,' SETER - A SECOND UNRECOV ERROR SEEN.', 80)
+ call uliber (3,' SETER - THE ERROR MESSAGES FOLLOW.', 80)
+c -noao
+ CALL EPRIN
+ CALL E9RIN(MESSG,NERR,.TRUE.)
+ GO TO 50
+C
+C SAVE THIS MESSAGE IN CASE IT IS NOT RECOVERED FROM PROPERLY.
+C
+ 30 CALL E9RIN(MESSG,NERR,.TRUE.)
+C
+ IF (IOPT.EQ.1 .OR. IOPT.EQ.2) GO TO 40
+C
+C MUST HAVE IOPT = 1 OR 2.
+C
+c +noao: FTN writes rewritten as calls to uliber for IRAF
+c WRITE(IERF,9003)
+c9003 FORMAT(' ERROR 4 IN SETER - BAD VALUE FOR IOPT'//
+c 1 ' THE CURRENT ERROR MESSAGE FOLLOWS'///)
+ call uliber (4, ' SETER - BAD VALUE FOR IOPT', 80)
+ call uliber (4, ' SETER - THE CURRENT ERR MSG FOLLOWS', 80)
+c -noao
+ GO TO 50
+C
+C TEST FOR RECOVERY.
+C
+ 40 CONTINUE
+ IF (IOPT.EQ.2) GO TO 50
+C
+ IF (I8SAV(2,0,.FALSE.).EQ.1) RETURN
+C
+ CALL EPRIN
+ CALL FDUM
+c STOP
+C
+ 50 CALL EPRIN
+ 60 CALL FDUM
+c STOP
+C
+ END
+ SUBROUTINE EPRIN
+C
+ CHARACTER*1 MESSG
+C
+ CALL E9RIN(MESSG,1,.FALSE.)
+ RETURN
+C
+ END
+ SUBROUTINE E9RIN(MESSG,NERR,SAVE)
+C
+C THIS ROUTINE STORES THE CURRENT ERROR MESSAGE OR PRINTS THE OLD ONE,
+C IF ANY, DEPENDING ON WHETHER OR NOT SAVE = .TRUE. .
+C
+ CHARACTER*(*) MESSG
+ CHARACTER*113 MESSGP
+ LOGICAL SAVE
+ COMMON /UERRF/IERF
+C
+C MESSGP STORES THE FIRST 113 CHARACTERS OF THE PREVIOUS MESSAGE
+C
+C
+C START WITH NO PREVIOUS MESSAGE.
+C
+c+noao
+c Moved save to before data statements.
+ SAVE MESSGP,NERRP
+c-noao
+ DATA MESSGP/'1'/
+ DATA NERRP/0/
+C
+ IF (.NOT.SAVE) GO TO 20
+C
+C SAVE THE MESSAGE.
+C
+ NERRP=NERR
+ MESSGP = MESSG
+C
+ GO TO 30
+C
+ 20 IF (I8SAV(1,0,.FALSE.).EQ.0) GO TO 30
+C
+C PRINT THE MESSAGE.
+C
+c +noao: FTN write rewritten as call to uliber
+c WRITE(IERF,9000) NERRP,MESSGP
+c9000 FORMAT(' ERROR ',I4,' IN ',A113)
+ call uliber (nerrp, messgp, 113)
+C
+ 30 RETURN
+C
+ END
+ INTEGER FUNCTION I8SAV(ISW,IVALUE,SET)
+C
+C IF (ISW = 1) I8SAV RETURNS THE CURRENT ERROR NUMBER AND
+C SETS IT TO IVALUE IF SET = .TRUE. .
+C
+C IF (ISW = 2) I8SAV RETURNS THE CURRENT RECOVERY SWITCH AND
+C SETS IT TO IVALUE IF SET = .TRUE. .
+C
+ LOGICAL SET
+C
+C START EXECUTION ERROR FREE AND WITH RECOVERY TURNED OFF.
+C
+c+noao
+c Moved save to before data statement.
+ SAVE LERROR,LRECOV
+ DATA LERROR/0/ , LRECOV/2/
+c-noao
+ IF (ISW .EQ. 1) THEN
+ I8SAV = LERROR
+ IF (SET) LERROR = IVALUE
+ ELSE IF (ISW .EQ. 2) THEN
+ I8SAV = LRECOV
+ IF (SET) LRECOV = IVALUE
+ ENDIF
+ RETURN
+ END
+ SUBROUTINE FDUM
+C
+C DUMMY ROUTINE TO BE LOCALLY IMPLEMENTED
+C
+ RETURN
+ END
+c +noao: Blockdata uerrbd rewritten as a runtime initialization subroutine
+c BLOCKDATA UERRBD
+ subroutine uerrbd
+c
+ COMMON /UERRF/IERF
+C DEFAULT ERROR UNIT
+c DATA IERF/0/
+ IERF= 0
+ END
+c -noao
diff --git a/sys/gio/nspp/sysint/fencode.x b/sys/gio/nspp/sysint/fencode.x
new file mode 100644
index 00000000..fe3e37ed
--- /dev/null
+++ b/sys/gio/nspp/sysint/fencode.x
@@ -0,0 +1,79 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include <error.h>
+include <ctype.h>
+
+define SZ_FORMAT 11
+
+# FENCD -- Format a real variable and return as a spp character string.
+# A packed format string is passed as an input argument to define how the
+# number is to be encoded. The format of the format string is:
+# format string = "(cW.D)"
+# where c is one of [EFGI], and where W and D are the field width and
+# number of decimal places or precision, respectively.
+
+procedure fencd (nchars, f_format, spp_outstr, rval)
+
+int nchars # desired number of output chars
+char f_format[SZ_FORMAT+1] # SPP string containing format
+char spp_outstr[SZ_FORMAT+1] # SPP string containing encoded number
+real rval # value to be encoded
+
+char fmtchar, outstr[MAX_DIGITS], spp_format[SZ_FORMAT+1]
+int ip, op, stridx()
+real x
+
+begin
+ # Encode format string for SPRINTF, format "%w.d". Start copying
+ # Fortran format at char 3, which should follow the EFGI char.
+
+ spp_format[1] = '%'
+ op = 2
+
+ if (f_format[1] != '(')
+ call fatal (1, "Missing lparen in Ncar ENCODE format")
+ for (ip=3; f_format[ip] != ')' && f_format[ip] != EOS; ip=ip+1) {
+ spp_format[op] = f_format[ip]
+ op = op + 1
+ }
+
+ # Now add the SPP format character. EFG are the same for sprintf as
+ # as for Fortran. The integer format is 'd' for decimal in SPP.
+
+ fmtchar = f_format[2]
+ if (IS_UPPER(fmtchar))
+ fmtchar = TO_LOWER (fmtchar)
+
+ switch (fmtchar) {
+ case 'e', 'f', 'g':
+ spp_format[op] = fmtchar
+ case 'i':
+ spp_format[op] = 'd'
+ default:
+ call fatal (1, "Unknown Ncar ENCODE format code")
+ }
+ op = op + 1
+ spp_format[op] = EOS
+ x = rval
+ if (rval > 0)
+ x = -x
+
+ # Now encode the user supplied variable and return it as a spp
+ # string.
+
+ iferr {
+ call sprintf (outstr, MAX_DIGITS, spp_format)
+ call pargr (x)
+ } then
+ call erract (EA_FATAL)
+
+ # Let's try adding a "+" prefix to positive numbers to set if that
+ # makes nicer plots.
+
+ op = stridx ('-', outstr)
+ if (rval > 0 && op > 0)
+ outstr[op] = '+'
+
+ call strcpy (outstr, spp_outstr, SZ_LINE)
+end
diff --git a/sys/gio/nspp/sysint/fulib.x b/sys/gio/nspp/sysint/fulib.x
new file mode 100644
index 00000000..1951f26c
--- /dev/null
+++ b/sys/gio/nspp/sysint/fulib.x
@@ -0,0 +1,29 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <error.h>
+
+# FULIB -- Print an error message processed by fortran routine uliber.
+
+procedure fulib (errcode, upkmsg, msglen)
+
+int errcode
+char upkmsg[ARB] # unpacked string
+int msglen # number of chars in string
+
+pointer sp, sppmsg
+
+begin
+ call smark (sp)
+ call salloc (sppmsg, SZ_LINE, TY_CHAR)
+
+ # Construct error message string
+ call sprintf (Memc[sppmsg], SZ_LINE, "ERROR %d IN %s\n")
+ call pargi (errcode)
+ call pargstr (upkmsg)
+
+ # Call error with the constructed message
+ iferr (call error (errcode, Memc[sppmsg]))
+ call erract (EA_WARN)
+
+ call sfree (sp)
+end
diff --git a/sys/gio/nspp/sysint/intt.x b/sys/gio/nspp/sysint/intt.x
new file mode 100644
index 00000000..315248fd
--- /dev/null
+++ b/sys/gio/nspp/sysint/intt.x
@@ -0,0 +1,16 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <nspp.h>
+
+# INTT -- Test whether the argument is an integer (return true) or a real
+# (return false). This works, hopefully, because legal NCAR metacode integers
+# are always less than 2 ** 15, while real numbers will always appear to be
+# large positive or negative integers.
+
+bool procedure intt (value)
+
+int value
+
+begin
+ return (value > 0 && value < INTT_TESTVAL)
+end
diff --git a/sys/gio/nspp/sysint/ishift.x b/sys/gio/nspp/sysint/ishift.x
new file mode 100644
index 00000000..580996c0
--- /dev/null
+++ b/sys/gio/nspp/sysint/ishift.x
@@ -0,0 +1,55 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+
+# ISHIFT -- integer shift. To be used for calls to ISHIFT in NCAR routines.
+
+int procedure ishift (in_word, n)
+
+int in_word, n
+int new_word, bit, index, i
+int bitupk()
+
+begin
+ if (n > NBITS_INT)
+ call error (0, "n > NBITS_INT in ishift")
+ if (n < 0)
+ # Right end-off shift
+ new_word = bitupk (in_word, abs(n) + 1, NBITS_INT - abs(n))
+ else {
+ # Left circular shift (rotate)
+ do i = 1, NBITS_INT {
+ index = n + i
+ if (index > NBITS_INT)
+ index = mod ((n + i), NBITS_INT)
+ bit = bitupk (in_word, i, 1)
+ call bitpak (bit, new_word, index, 1)
+ }
+ }
+
+ return (new_word)
+end
+
+
+# IAND -- AND two integers.
+
+int procedure iand (a, b)
+
+int a, b
+int and()
+
+begin
+ return (and (a, b))
+end
+
+
+# IOR -- OR two integers.
+
+int procedure ior (a, b)
+
+int a, b
+int or()
+
+begin
+ return (or (a, b))
+end
diff --git a/sys/gio/nspp/sysint/loc.x b/sys/gio/nspp/sysint/loc.x
new file mode 100644
index 00000000..59e509b5
--- /dev/null
+++ b/sys/gio/nspp/sysint/loc.x
@@ -0,0 +1,23 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+
+# LOCI -- Return the zero-indexed offset of the argument in the user address
+# space, in integer units. In other words, if A is an integer array,
+# { loci(a[2]) - loci(a[1]) } is exactly one.
+#
+# NOTE -- The original NSPP (portlib) code called this function LOC, however,
+# the Sun-4 Fortran compiler has an intrinsic function of the same name which
+# behaves slightly differently, hence the name was changed to LOCI.
+
+int procedure loci (x)
+
+int x
+int xaddr
+
+begin
+ # ZLOCVA returns the address of the variable in units of XCHAR.
+
+ call zlocva (x, xaddr)
+ return (xaddr / SZ_INT)
+end
diff --git a/sys/gio/nspp/sysint/mcswap.x b/sys/gio/nspp/sysint/mcswap.x
new file mode 100644
index 00000000..eb9cee7d
--- /dev/null
+++ b/sys/gio/nspp/sysint/mcswap.x
@@ -0,0 +1,17 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# MCSWAP -- Swap the instructions in a metacode array.
+
+procedure mcswap (a, npix)
+
+int a[npix]
+int npix
+int i, temp
+
+begin
+ do i = 1, npix, 2 {
+ temp = a[i]
+ a[i] = a[i+1]
+ a[i+1] = temp
+ }
+end
diff --git a/sys/gio/nspp/sysint/mkpkg b/sys/gio/nspp/sysint/mkpkg
new file mode 100644
index 00000000..b00eb46e
--- /dev/null
+++ b/sys/gio/nspp/sysint/mkpkg
@@ -0,0 +1,24 @@
+# Make the system interface modules for libnspp.a.
+
+$checkout libnspp.a lib$
+$update libnspp.a
+$checkin libnspp.a lib$
+$exit
+
+libnspp.a:
+ encd.f
+ encode.f
+ erprt77.f
+ fencode.x <ctype.h> <error.h> <mach.h>
+ fulib.x <error.h>
+ intt.x <nspp.h>
+ ishift.x <mach.h>
+ loc.x <mach.h>
+ mcswap.x
+ ncgchr.x
+ ncpchr.x
+ packum.x <mach.h> <nspp.h> nspp.com
+ perror.x
+ q8qst4.f
+ uliber.f
+ ;
diff --git a/sys/gio/nspp/sysint/ncgchr.x b/sys/gio/nspp/sysint/ncgchr.x
new file mode 100644
index 00000000..5cf40b22
--- /dev/null
+++ b/sys/gio/nspp/sysint/ncgchr.x
@@ -0,0 +1,22 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# NCGCHR -- Get a single character (byte) from a packed array. Return
+# a blank if the index is out of bounds.
+
+procedure ncgchr (ichars, len_ichars, index, char_value)
+
+int ichars[ARB] # packed character array
+int len_ichars # length of the array
+int index # index of char to be extracted
+int char_value # return value
+
+char ch
+
+begin
+ if (index < 1 || index > len_ichars)
+ char_value = ' '
+ else {
+ call chrupk (ichars, index, ch, 1, 1)
+ char_value = ch
+ }
+end
diff --git a/sys/gio/nspp/sysint/ncpchr.x b/sys/gio/nspp/sysint/ncpchr.x
new file mode 100644
index 00000000..4312068d
--- /dev/null
+++ b/sys/gio/nspp/sysint/ncpchr.x
@@ -0,0 +1,20 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# NCPCHR -- Put a single character (byte) into a packed array. Do nothing if
+# the index is out of bounds.
+
+procedure ncpchr (ichars, len_ichars, index, char_value)
+
+int ichars[ARB] # packed character array
+int len_ichars # length of the array
+int index # index of char to be set
+int char_value # value to be stored
+
+char ch[1]
+
+begin
+ if (index >= 1 && index <= len_ichars) {
+ ch[1] = char_value
+ call chrpak (ch, 1, ichars, index, 1)
+ }
+end
diff --git a/sys/gio/nspp/sysint/nspp.com b/sys/gio/nspp/sysint/nspp.com
new file mode 100644
index 00000000..e3cac846
--- /dev/null
+++ b/sys/gio/nspp/sysint/nspp.com
@@ -0,0 +1,40 @@
+# NSPP.COM -- The nspp system plot package common block.
+
+int mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab
+int mflg ,mtype ,mxa ,mya ,mxb ,myb
+int mx ,my ,mtypex ,mtypey
+real xxa ,yya , xxb ,yyb ,xxc ,yyc
+real xxd ,yyd , xfactr ,yfactr ,xadd ,yadd
+real xx ,yy
+
+# XX declared integer some places in nspp code !!!
+# on a VAX this works, but what if float not same size as int ???
+
+int mfmtx[3] ,mfmty[3] ,mumx ,mumy
+int msizx ,msizy ,mxdec ,mydec ,mxor ,mop[19]
+int mname[19] ,mxold ,myold ,mxmax ,mymax
+int mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty
+int mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst
+int mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin
+int mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto
+int mxysto ,mprint ,msybuf[360] ,mncpw ,minst
+int mbufa ,mbuflu ,mfwa[12] ,mlwa[12]
+int mipair ,mbprs[16] ,mbufl ,munit ,mbswap
+
+real small
+
+common /sysplt/ mmajx ,mmajy ,mminx ,mminy ,mxlab ,mylab,
+ mflg ,mtype ,mxa ,mya ,mxb ,myb,
+ mx ,my ,mtypex ,mtypey ,xxa ,yya,
+ xxb ,yyb ,xxc ,yyc ,xxd ,yyd,
+ xfactr ,yfactr ,xadd ,yadd ,xx ,yy,
+ mfmtx ,mfmty ,mumx ,mumy,
+ msizx ,msizy ,mxdec ,mydec ,mxor ,mop,
+ mname ,mxold ,myold ,mxmax ,mymax,
+ mxfac ,myfac ,modef ,mf2er ,mshftx ,mshfty,
+ mmgrx ,mmgry ,mmnrx ,mmnry ,mfrend ,mfrlst,
+ mcrout ,mpair1 ,mpair2 ,msblen ,mflcnt ,mjxmin,
+ mjymin ,mjxmax ,mjymax ,mnxsto ,mnysto ,mxxsto,
+ mxysto ,mprint ,msybuf ,mncpw ,minst,
+ mbufa ,mbuflu ,mfwa ,mlwa,
+ mipair ,mbprs ,mbufl ,munit ,mbswap ,small
diff --git a/sys/gio/nspp/sysint/packum.x b/sys/gio/nspp/sysint/packum.x
new file mode 100644
index 00000000..7991658c
--- /dev/null
+++ b/sys/gio/nspp/sysint/packum.x
@@ -0,0 +1,43 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+include <mach.h>
+include <nspp.h>
+
+# PACKUM -- Pack an integer array containing 16 bit quantities into a buffer.
+# Each 16 bit input datum occupies one integer; the input integers may be
+# any size. This implementation will work on most byte oriented machines,
+# but will generate a fatal error on machines with 24, 60, etc. bit words.
+
+procedure packum (a, npix, bp)
+
+int a[ARB] # input array, one 16-bit datum per word
+int npix # number of mc words
+int bp # LOC pointer to output buffer
+
+int offset, dummy[1]
+int loci()
+include "nspp.com"
+
+begin
+ offset = bp - loci (dummy) + 1
+
+ # It is necessary to swap the order of the metacode words on some
+ # machines. Npix is always an even number. The swapping must be
+ # done here because the NSPP and MCTR code assumes that the bytes
+ # are ordered in a certain manner (most significant first). Thus,
+ # when the buffer is flushed FLUSHB will set the magic bits, and
+ # if we wait and swap upon output rather than here, it will set the
+ # bits in the wrong word.
+
+ if (mbswap == YES) # flag set from graphcap in nsppkern
+ call mcswap (a, npix)
+
+ switch (NBITS_MCWORD) {
+ case NBITS_SHORT:
+ call achtis (a, dummy[offset], npix)
+ case NBITS_INT:
+ call amovi (a, dummy[offset], npix)
+ default:
+ call fatal (1, "gio.ncar.packum: cannot pack metacode")
+ }
+end
diff --git a/sys/gio/nspp/sysint/perror.x b/sys/gio/nspp/sysint/perror.x
new file mode 100644
index 00000000..6c1cb85b
--- /dev/null
+++ b/sys/gio/nspp/sysint/perror.x
@@ -0,0 +1,9 @@
+# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.
+
+# PERROR -- Fatal error in NSPP.
+
+procedure perror()
+
+begin
+ call fatal (0, "Fatal error in Ncar system plot package")
+end
diff --git a/sys/gio/nspp/sysint/q8qst4.f b/sys/gio/nspp/sysint/q8qst4.f
new file mode 100644
index 00000000..0b8ca796
--- /dev/null
+++ b/sys/gio/nspp/sysint/q8qst4.f
@@ -0,0 +1,24 @@
+ SUBROUTINE Q8QST4(NAME,LBRARY,ENTRY,VRSION)
+C
+C DIMENSION OF NAME(1),LBRARY(1),ENTRY(1),VRSION(1)
+C ARGUMENTS
+C
+C LATEST REVISION MARCH 1984
+C
+C PURPOSE MONITORS LIBRARY USE BY WRITING A RECORD WITH
+C INFORMATION ABOUT THE CIRCUMSTANCES OF A
+C LIBRARY ROUTINE CALL TO THE SYSTEM ACCOUNTING
+C TAPE FOR LATER PROCESSING.
+C
+C NOTE--- THIS VERSION OF Q8QST4 SIMPLY RETURNS TO THE
+C CALLING ROUTINE. LOCAL IMPLEMENTORS MAY WISH
+C TO IMPLEMENT A VERSION OF THIS ROUTINE THAT
+C MONITORS USE OF NCAR ROUTINES WITH LOCAL
+C MECHANISMS. OTHERWISE IT WILL SAVE A SMALL
+C AMOUNT OF SPACE AND TIME IF CALLS TO Q8QST4 ARE
+C DELETED FROM ALL NSSL ROUTINES.
+C
+ CHARACTER*(*) NAME,LBRARY,ENTRY,VRSION
+C
+ RETURN
+ END
diff --git a/sys/gio/nspp/sysint/uliber.f b/sys/gio/nspp/sysint/uliber.f
new file mode 100644
index 00000000..7dba302e
--- /dev/null
+++ b/sys/gio/nspp/sysint/uliber.f
@@ -0,0 +1,14 @@
+ subroutine uliber (errcode, pkerrmsg, msglen)
+
+ character*80 pkerrmsg
+ integer errcode, msglen
+ integer*2 sppmsg(81)
+ integer SZLINE
+ parameter (SZLINE=80)
+
+c unpack the fortran character string, call fulib to output the string.
+c
+ call f77upk (pkerrmsg, sppmsg, SZLINE)
+ call fulib (errcode, sppmsg, msglen)
+
+ end
generated by cgit (git 2.34.1) at 2025-09-20 09:55:53 -0400