1 files changed, 95 insertions, 0 deletions
diff --git a/pkg/tbtables/tbfptf.x b/pkg/tbtables/tbfptf.x
new file mode 100644
index 00000000..b4be451d
--- /dev/null
+++ b/pkg/tbtables/tbfptf.x
@@ -0,0 +1,95 @@
+# tbfptf -- change format from SPP to Fortran
+# This is similar to tbbptf except that the output should be legal Fortran.
+# The input and output may be the same string.
+#
+# Phil Hodge,  6-Jul-1995  Subroutine created
+
+procedure tbfptf (sppfmt, ftnfmt, maxch)
+
+char	sppfmt[ARB]	# i: print format in SPP style
+char	ftnfmt[ARB]	# o: print format in Fortran style
+int	maxch		# i: max size of ftnfmt
+#--
+pointer sp
+pointer fmt		# scratch for Fortran format
+pointer numpart		# copy of numerical portion of print format
+char	sppcode		# SPP format code
+char	fcode		# Fortran format code
+int	fmtlen		# length of string sppfmt
+int	index		# position of character in format string
+int	w, d		# as in w.d
+int	ip, ctoi()
+
+string	sppchr	"fgdeHhMmbsxo"
+string	ftnchr	"FGIEFFFFLAZO"
+
+int	strlen(), stridx()
+
+begin
+	call smark (sp)
+	call salloc (fmt, SZ_FNAME, TY_CHAR)
+	call salloc (numpart, SZ_FNAME, TY_CHAR)
+
+	fmtlen = strlen (sppfmt)
+
+	# Copy numerical portion to numpart.  Ignore any minus sign (which
+	# means left justify the value).
+	if (sppfmt[2] == '-')
+	    call strcpy (sppfmt[3], Memc[numpart], fmtlen-3)
+	else
+	    call strcpy (sppfmt[2], Memc[numpart], fmtlen-2)
+
+	# Get fortran format code corresponding to spp format code.
+	sppcode = sppfmt[fmtlen]
+	index = stridx (sppcode, sppchr)
+	if (index == 0) {
+	    call sprintf (Memc[fmt], SZ_FNAME, "bad print format `%s'")
+		call pargstr (sppfmt)
+	    call error (1, Memc[fmt])
+	} else {
+	    fcode = ftnchr[index]
+	}
+
+	# Extract numerical parts (w.d).
+	ip = 1
+	if (ctoi (Memc[numpart], ip, w) < 0)
+	    w = 0
+	if (Memc[numpart+ip-1] == '.') {
+	    ip = ip + 1
+	    if (ctoi (Memc[numpart], ip, d) < 0)
+		d = 0
+	}
+
+	# Construct Fortran format.
+	if (sppfmt[fmtlen] == 'H' || sppfmt[fmtlen] == 'h') {
+	    # Use F format instead of H.MSd, so increase w and d.
+	    w = w + 4
+	    d = d + 4
+	    call sprintf (Memc[fmt], SZ_FNAME, "%c%d.%d")	# e.g. F12.5
+		call pargc (fcode)
+		call pargi (w)
+		call pargi (d)
+	} else if (sppfmt[fmtlen] == 'M' || sppfmt[fmtlen] == 'm') {
+	    w = w + 2
+	    d = d + 2
+	    call sprintf (Memc[fmt], SZ_FNAME, "%c%d.%d")
+		call pargc (fcode)
+		call pargi (w)
+		call pargi (d)
+	} else if (Memc[numpart] == '0' &&
+		(sppcode == 'd' || sppcode == 'o' || sppcode == 'x')) {
+	    call sprintf (Memc[fmt], SZ_FNAME, "%c%d.%d")	# e.g. I4.4
+		call pargc (fcode)
+		call pargi (w)
+		call pargi (w)
+	} else {
+	    # Append numerical portion from SPP format without modification.
+	    Memc[fmt] = fcode
+	    Memc[fmt+1] = EOS
+	    call strcat (Memc[numpart], Memc[fmt], SZ_FNAME)
+	}
+
+	call strcpy (Memc[fmt], ftnfmt, maxch)
+
+	call sfree (sp)
+end