# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include "rfits.h" define NEPSILON 10.0d0 # number of machine epsilon # RFT_READ_HEADER -- Read a FITS header. # If BSCALE and BZERO are different from 1.0 and 0.0 scale is set to true # otherwise scale is false. # EOT is detected by an EOF on the first read and EOF is returned to the calling # routine. Any error is passed to the calling routine. int procedure rft_read_header (fits_fd, fits, im, gim) int fits_fd # FITS file descriptor pointer fits # FITS data structure pointer im # IRAF image descriptor pointer gim # IRAF global header image descriptor int i, stat, nread, max_lenuser, fd_usr, ndiscard char card[LEN_CARD+1], type_str[LEN_TYPESTR] int rft_decode_card(), rft_init_read_pixels(), rft_read_pixels(), strmatch() int stropen() errchk rft_decode_card, rft_init_read_pixels, rft_read_pixels errchk stropen, close include "rfits.com" begin # Initialization. XTENSION(fits) = EXT_PRIMARY BITPIX(fits) = INDEFI NAXIS(im) = 0 do i = 1, IM_MAXDIM IM_LEN(im,i) = 0 PCOUNT(fits) = 0 GCOUNT(fits) = 1 SCALE(fits) = NO FITS_BSCALE(fits) = 1.0d0 FITS_BZERO(fits) = 0.0d0 BLANKS(fits) = NO BLANK_VALUE(fits) = INDEFL NRECORDS(fits) = 0 IRAFNAME(fits) = EOS INHERIT(fits) = NO ndiscard = 0 OBJECT(im) = EOS UNKNOWN(im) = EOS max_lenuser = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 # The FITS header is character data in FITS_BYTE form. Open the # header for reading. Open the user area which is a character # string as a file. i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) fd_usr = stropen (UNKNOWN(im), max_lenuser, NEW_FILE) # Loop until the END card is encountered. nread = 0 repeat { # Read the card. i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) card[LEN_CARD + 1] = '\n' card[LEN_CARD + 2] = EOS # Decode the card images. if ((i == EOF) && (nread == 0)) { call close (fd_usr) return (EOF) } else if ((nread == 0) && SIMPLE(fits) == NO && strmatch (card, "^SIMPLE ") == 0) { call flush (STDOUT) call close (fd_usr) call error (30, "RFT_READ_HEADER: Not a FITS file (no SIMPLE keyword)") } else if ((nread == 0) && EXTEND(fits) == YES && strmatch (card, "^XTENSION") == 0) { XTENSION(fits) = EXT_SPECIAL call flush (STDOUT) call close (fd_usr) call error (30, "RFT_READ_HEADER: Not a FITS extension (no XTENSION keyword)") } else if (i != LEN_CARD) { call close (fd_usr) call error (2, "RFT_READ_HEADER: Error reading FITS header") } else nread = nread + 1 # Remove contaminating control characters and replace with blanks. call rft_control_to_blank (card, card, LEN_CARD) # Print FITS card images if long_header option specified. if (long_header == YES) { call printf ("%-80.80s\n") call pargstr (card) } # Stat = YES if FITS END card is encountered. stat = rft_decode_card (fits, im, fd_usr, card, ndiscard) } until (stat == YES) # Check for the possibility of a global header. if (NAXIS(im) == 0 && XTENSION(fits) == EXT_PRIMARY) GLOBALHDR(fits) = YES # Set the output image pixel type. call rft_set_image_pixtype (fits, im, FITS_BSCALE(fits), FITS_BZERO(fits)) # Copy the global header title and user area into the output image. if (GLOBALHDR(fits) == YES) { if (XTENSION(fits) == EXT_IMAGE && INHERIT(fits) == YES && gim != NULL) { if (OBJECT(im) == EOS) call strcpy (OBJECT(gim), OBJECT(im), SZ_OBJECT) call close (fd_usr) fd_usr = stropen (UNKNOWN(im), max_lenuser, APPEND) call rft_gheader (im, gim, fd_usr, card, LEN_CARD, ndiscard, long_header) } } # Print optional short header. if (short_header == YES && long_header == NO) { call printf ("%s ") switch (XTENSION(fits)) { case EXT_PRIMARY: call pargstr ("") case EXT_IMAGE: call pargstr ("IMAGE") case EXT_TABLE: call pargstr ("TABLE") case EXT_BINTABLE: call pargstr ("BINTABLE") case EXT_UNKNOWN: call pargstr ("UNKNOWN") default: call pargstr ("UNDEFINED") } if (make_image == NO) { if (old_name == YES) { call printf ("-> %s ") call pargstr (IRAFNAME(fits)) } } else { call printf ("-> %s ") call pargstr (IM_HDRFILE(im)) } call printf ("%-20.20s ") call pargstr (OBJECT(im)) call printf ("size=") if (NAXIS(im) == 0) call printf ("0") else { do i = 1, NAXIS(im) { if (i == 1) { call printf ("%d") call pargl (NAXISN(im,i)) } else { call printf ("x%d") call pargl (NAXISN(im,i)) } } } call printf ("\n") if (XTENSION(fits) == EXT_PRIMARY || XTENSION(fits) == EXT_IMAGE) { call printf (" bitpix=%d") call pargi (BITPIX(fits)) if (SCALE(fits) == NO) { call printf (" scaling=none") } else { call printf (" bscale=%.7g bzero=%.7g") call pargd (FITS_BSCALE(fits)) call pargd (FITS_BZERO(fits)) } call rft_typestring (PIXTYPE(im), type_str, LEN_TYPESTR) call strlwr (type_str) call printf (" pixtype=%s") call pargstr (type_str) call printf ("\n") } } # Let the user know if there is not enough space in the user area. if (ndiscard > 0) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ( "Warning: User area too small %d card images discarded\n") call pargi (ndiscard) } call rft_last_user (UNKNOWN(im), max_lenuser) } call close (fd_usr) return (OK) end # RFT_CONTROL_TO_BLANK -- Replace an ACSII control characters in the # FITS card image with blanks. procedure rft_control_to_blank (incard, outcard, len_card) char incard[ARB] # the input FITS card image char outcard[ARB] # the output FITS card image int len_card # the length of the FITS card image int i begin for (i = 1; i <= len_card; i = i + 1) { if (IS_PRINT(incard[i])) outcard[i] = incard[i] else outcard[i] = ' ' } end # RFT_DECODE_CARD -- Decode a FITS card and return YES when the END # card is encountered. The keywords understood are given in rfits.h. int procedure rft_decode_card (fits, im, fd_usr, card, ndiscard) pointer fits # FITS data structure pointer im # IRAF image descriptor int fd_usr # file descriptor of user area char card[ARB] # FITS card int ndiscard # Number of cards for which no space available char cval double dval int nchar, i, j, k, len pointer sp, str, comment bool rft_equald() int strmatch(), ctoi(), ctol(), ctod(), cctoc(), rft_hms() errchk putline include "rfits.com" begin call smark (sp) call salloc (str, LEN_CARD, TY_CHAR) call salloc (comment, SZ_LINE, TY_CHAR) i = COL_VALUE if (strmatch (card, "^END ") != 0) { call sfree (sp) return(YES) } else if (strmatch (card, "^SIMPLE ") != 0) { if (SIMPLE(fits) == YES) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate SIMPLE keyword ignored\n") } } else { nchar = cctoc (card, i, cval) if (cval != 'T') call error (13, "RFT_DECODE_CARD: Non-standard FITS format") else SIMPLE(fits) = YES } } else if (strmatch (card, "^XTENSION") != 0) { call rft_get_fits_string (card, Memc[str], LEN_CARD) if (strmatch (Memc[str], "^IMAGE") != 0) XTENSION(fits) = EXT_IMAGE else if (strmatch (Memc[str], "^TABLE") != 0) XTENSION(fits) = EXT_TABLE else if (strmatch (Memc[str], "^BINTABLE") != 0) XTENSION(fits) = EXT_BINTABLE else XTENSION(fits) = EXT_UNKNOWN } else if (strmatch (card, "^BITPIX ") != 0) { if (! IS_INDEFI(BITPIX(fits))) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate BITPIX keyword ignored\n") } } else nchar = ctoi (card, i, BITPIX(fits)) } else if (strmatch (card, "^NAXIS ") != 0) { if (NAXIS(im) != 0) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate NAXIS keyword ignored\n") } } else nchar = ctoi (card, i, NAXIS(im)) if (NAXIS(im) > IM_MAXDIM) call error (5, "RFT_DECODE_CARD: FITS NAXIS too large") } else if (strmatch (card, "^NAXIS") != 0) { k = strmatch (card, "^NAXIS") nchar = ctoi (card, k, j) if (NAXISN(im,j) != 0) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate NAXIS%d keyword ignored\n") call pargi (j) } } else nchar = ctol (card, i, NAXISN(im, j)) } else if (strmatch (card, "^GROUPS ") != 0) { nchar = cctoc (card, i, cval) if (cval == 'T') { NAXIS(im) = 0 call error (6, "RFT_DECODE_CARD: Group data not implemented") } } else if (strmatch (card, "^EXTEND ") != 0) { if (EXTEND(fits) == YES) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate EXTEND keyword ignored\n") } } else { nchar = cctoc (card, i, cval) if (cval == 'T') EXTEND(fits) = YES } } else if (strmatch (card, "^INHERIT ") != 0) { if (INHERIT(fits) == YES) { if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Duplicate INHERIT keyword ignored\n") } } else { nchar = cctoc (card, i, cval) if (cval == 'T') INHERIT(fits) = YES } } else if (strmatch (card, "^PCOUNT ") != 0) { nchar = ctoi (card, i, PCOUNT(fits)) if (nchar <= 0) PCOUNT(fits) = 0 } else if (strmatch (card, "^GCOUNT ") != 0) { nchar = ctoi (card, i, GCOUNT(fits)) if (nchar <= 0) GCOUNT(fits) = 1 #} else if (strmatch (card, "^TABLES ") != 0) { #nchar = ctoi (card, i, ival) #if (ival > 0) #call printf ("Warning: FITS special records not decoded\n") } else if (strmatch (card, "^BSCALE ") != 0) { nchar = ctod (card, i, dval) if (nchar > 0) FITS_BSCALE(fits) = dval else if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Error decoding BSCALE, BSCALE=1.0\n") } if (! rft_equald (dval, 1.0d0) && (scale == YES)) SCALE(fits) = YES } else if (strmatch (card, "^BZERO ") != 0) { nchar = ctod (card, i, dval) if (nchar > 0) FITS_BZERO(fits) = dval else if (short_header == YES || long_header == YES) { if (long_header == NO) call printf (" ") call printf ("Warning: Error decoding BZERO, BZERO=0.0\n") } if (! rft_equald (dval, 0.0d0) && (scale == YES)) SCALE(fits) = YES } else if (strmatch (card, "^BLANK ") != 0) { BLANKS(fits) = YES nchar = ctol (card, i, BLANK_VALUE(fits)) } else if (strmatch (card, "^OBJECT ") != 0) { call rft_get_fits_string (card, OBJECT(im), SZ_OBJECT) } else if (strmatch (card, "^IRAFNAME") != 0) { call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) } else if (strmatch (card, "^FILENAME") != 0) { if (IRAFNAME(fits) == EOS) call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) } else if (strmatch (card, "^EXTNAME ") != 0) { if (XTENSION(fits) != EXT_PRIMARY && XTENSION(fits) != EXT_IMAGE) call rft_get_fits_string (card, IRAFNAME(fits), SZ_FNAME) } else if (strmatch (card, "^EXTVER ") != 0) { # Filter this quantitity out and ignore it for now. ; } else if (strmatch (card, "^ORIGIN ") != 0) { call rft_trim_card (card, card, LEN_CARD) call strcat (card[i], HISTORY(im), SZ_HISTORY) } else if (strmatch (card, "^DATE ") != 0) { call rft_trim_card (card, card, LEN_CARD) call strcat (card[i], HISTORY(im), SZ_HISTORY) } else if (strmatch (card, "^IRAF-TLM") != 0) { call rft_trim_card (card, card, LEN_CARD) call strcat (card[i], HISTORY(im), SZ_HISTORY) #} else if (strmatch (card, "^HISTORY ") != 0) { #call rft_trim_card (card, card, LEN_CARD) #call strcat (card[i - 2], HISTORY(im), SZ_HISTORY) } else if (strmatch (card, "^UT ") != 0) { len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) if (len > 0) { call wft_encodec ("UT", Memc[str], len, card, Memc[comment]) card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ZD ") != 0) { len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) if (len > 0) { call wft_encodec ("ZD", Memc[str], len, card, Memc[comment]) card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ST ") != 0) { len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) if (len > 0) { call wft_encodec ("ST", Memc[str], len, card, Memc[comment]) card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^RA ") != 0) { len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) if (len > 0) { call wft_encodec ("RA", Memc[str], len, card, Memc[comment]) card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^DEC ") != 0) { len = rft_hms (card, Memc[str], Memc[comment], LEN_CARD) if (len > 0) { call wft_encodec ("DEC", Memc[str], len, card, Memc[comment]) card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else { if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } call sfree (sp) return (NO) end # RFT_HMS -- Procedure to decode a FITS HMS card from the mountain. int procedure rft_hms (card, str, comment, maxch) char card[ARB] # FITS card char str[ARB] # string char comment[ARB] # comment string int maxch # maximum number of characters char colon, minus int ip, nchar, fst, lst, deg, min real sec int stridx(), strldx(), strlen(), ctoi(), ctor() begin # Return if not a FITS string parameter. if (card[COL_VALUE] != '\'') return (0) # Set up key characters. colon = ':' minus = '-' # Get the FITS string. call rft_get_fits_string (card, str, maxch) # Get the comment string. call rft_get_comment (card, comment, maxch) # Test for blank string and for 2 colon delimiters. if (str[1] == EOS) return (0) fst = stridx (colon, str) if (fst == 0) return (0) lst = strldx (colon, str) if (lst == 0) return (0) if (fst == lst) return (0) # Decode the degrees field. ip = 1 while (IS_WHITE(str[ip])) ip = ip + 1 if (str[ip] == '+' || str[ip] == '-') ip = ip + 1 nchar = ctoi (str, ip, deg) if (nchar == 0) deg = 0 # Decode the minutes field. ip = fst + 1 while (IS_WHITE(str[ip])) ip = ip + 1 if (str[ip] == '+' || str[ip] == '-') ip = ip + 1 nchar = ctoi (str, ip, min) if (nchar == 0) min = 0 # Decode the seconds field. ip = lst + 1 while (IS_WHITE(str[ip])) ip = ip + 1 if (str[ip] == '+' || str[ip] == '-') ip = ip + 1 nchar = ctor (str, ip, sec) if (nchar == 0) sec = 0.0 # Reformat the HMS card. if (stridx (minus, str) > 0 || deg < 0 || min < 0 || sec < 0.0) { call sprintf (str, maxch, "%c%d:%02d:%05.2f") call pargc (minus) call pargi (abs (deg)) call pargi (abs (min)) call pargr (abs (sec)) } else { call sprintf (str, maxch, "%2d:%02d:%05.2f") call pargi (deg) call pargi (abs (min)) call pargr (abs (sec)) } return (strlen (str)) end # RFT_GET_COMMENT -- Extract the comment field from a FITS card. procedure rft_get_comment (card, comment, maxch) char card[ARB] # FITS card char comment[ARB] # comment string int maxch # maximum number of characters int istart, j begin istart = 0 for (j = LEN_CARD; (j >= 1) && (card[j] != '\''); j = j - 1) { if (card[j] == '/') { for (istart = j + 1; IS_WHITE(card[istart]) && istart <= LEN_CARD; istart = istart + 1) ; break } } if (istart == 0) comment[1] = EOS else call strcpy (card[istart], comment, LEN_CARD - istart + 1 ) end # RFT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing # blanks. The EOS is marked by either ', /, or the end of the card. # There may be an optional opening ' (FITS standard). procedure rft_get_fits_string (card, str, maxchar) char card[ARB] # FITS card char str[ARB] # FITS string int maxchar # maximum number of characters int j, istart, nchar begin # Check for opening quote for (istart = COL_VALUE; istart <= LEN_CARD && card[istart] != '\''; istart = istart + 1) ; istart = istart + 1 # Check for closing quote. for (j = istart; (j= istart) && (card[j] == ' '); j = j - 1) ; nchar = min (maxchar, j - istart + 1) # Copy the string. if (nchar <= 0) str[1] = EOS else call strcpy (card[istart], str, nchar) end # RFT_EQUALD -- Procedure to compare two double precision numbers for equality # to within the machine precision for doubles. bool procedure rft_equald (x, y) double x, y # the two numbers to be compared for equality int ex, ey double x1, x2, normed_x, normed_y begin if (x == y) return (true) call rft_normd (x, normed_x, ex) call rft_normd (y, normed_y, ey) if (ex != ey) return (false) else { x1 = 1.0d0 + abs (normed_x - normed_y) x2 = 1.0d0 + NEPSILON * EPSILOND return (x1 <= x2) } end # RFT_NORMED -- Normalize a double precision number x to the value normed_x, # in the range [1-10]. Expon is returned such that x = normed_x * # (10.0d0 ** expon). procedure rft_normd (x, normed_x, expon) double x # number to be normailized double normed_x # normalized number int expon # exponent double ax begin ax = abs (x) expon = 0 if (ax > 0) { while (ax < (1.0d0 - NEPSILON * EPSILOND)) { ax = ax * 10.0d0 expon = expon - 1 } while (ax >= (10.0d0 - NEPSILON * EPSILOND)) { ax = ax / 10.0d0 expon = expon + 1 } } if (x < 0) normed_x = -ax else normed_x = ax end # RFT_TRIM_CARD -- Procedure to trim trailing whitespace from the card procedure rft_trim_card (incard, outcard, maxch) char incard[ARB] # input FITS card image char outcard[ARB] # output FITS card int maxch # maximum size of card int ip begin ip = maxch while (incard[ip] == ' ' || incard[ip] == '\t' || incard[ip] == '\0') ip = ip - 1 call amovc (incard, outcard, ip) outcard[ip+1] = '\n' outcard[ip+2] = EOS end # RFT_LAST_CARD -- Remove a partially written card from the data base procedure rft_last_user (user, maxch) char user[ARB] # user area int maxch # maximum number of characters int ip begin ip = maxch while (user[ip] != '\n') ip = ip - 1 user[ip+1] = EOS end # RFT_SET_IMAGE_PIXTYPE -- Set remaining header fields not set in # rft_read_header. procedure rft_set_image_pixtype (fits, im, bscale, bzero) pointer fits # FITS data structure pointer im # IRAF image pointer double bscale # FITS scaling parameter double bzero # FITS offset parameter bool rft_equald() include "rfits.com" begin # Determine data type from BITPIX if user data type not specified. if (data_type == ERR) { if (BITPIX(fits) < 0) { if (abs (BITPIX(fits)) <= (SZ_REAL * SZB_CHAR * NBITS_BYTE)) PIXTYPE(im) = TY_REAL else PIXTYPE(im) = TY_DOUBLE } else if (SCALE(fits) == YES) { if (rft_equald (bscale, 1.0d0)) { if (rft_equald (bzero / 32768.0d0, 1.0d0)) PIXTYPE(im) = TY_USHORT else PIXTYPE(im) = TY_REAL } else PIXTYPE(im) = TY_REAL } else { if (BITPIX(fits) <= (SZ_SHORT * SZB_CHAR * NBITS_BYTE)) PIXTYPE(im) = TY_SHORT else PIXTYPE(im) = TY_LONG } } else PIXTYPE(im) = data_type end # Copy the global header into the output image header. procedure rft_gheader (im, gim, fd_usr, card, len_card, ndiscard, long_header) pointer im # IRAF image header descriptor pointer gim # IRAF global image header descriptor int fd_usr # IRAF image header user area char card[ARB] # FITS card int len_card # length of FITS card int ndiscard # number of cards discarded int long_header # print the long header int ngcards, gim_lenuser, ninherit, count pointer sp, indices, idb_gim, grp, irp bool streq() int strlen(), idb_nextcard(), idb_find() pointer idb_open() errchk putline() begin # Initialize. call smark (sp) ngcards = strlen (UNKNOWN(gim)) / (len_card + 1) call salloc (indices, ngcards, TY_INT) # Mark the global header cards which are to be inherited. These # include all COMMENT, HISTORY, and BLANK cards, plus all those # cards which do not already have values in the extension header. count = 0 idb_gim = idb_open (gim, gim_lenuser) while (idb_nextcard (idb_gim, grp) != EOF) { if (count >= ngcards) break call strcpy (Memc[grp], card, 8) if (streq (card, "COMMENT ")) Memi[indices+count] = YES else if (streq (card, "HISTORY ")) Memi[indices+count] = YES else if (streq (card, " ")) Memi[indices+count] = YES else if (idb_find (im, card, irp) > 0) Memi[indices+count] = NO else Memi[indices+count] = YES count = count + 1 } call idb_close (idb_gim) # Open the global header image user area and loop through the cards. ninherit = 0 count = 0 idb_gim = idb_open (gim, gim_lenuser) while (idb_nextcard (idb_gim, grp) != EOF) { if (Memi[indices+count] == YES) { call strcpy (Memc[grp], card, len_card) card[len_card+1] = '\n' card[len_card+2] = EOS if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 else ninherit = ninherit + 1 } } count = count + 1 } call idb_close (idb_gim) if (long_header == YES) { call printf ("%d global header keywords were inherited\n") call pargi (ninherit) } call sfree (sp) end # RFT_TYPESTRING -- Procedure to set the iraf datatype keyword. procedure rft_typestring (data_type, type_str, maxch) int data_type # the IRAF data type char type_str[ARB] # the output IRAF type string int maxch # maximum size of the type string begin switch (data_type) { case TY_SHORT: call strcpy ("SHORT", type_str, maxch) case TY_USHORT: call strcpy ("USHORT", type_str, maxch) case TY_INT: call strcpy ("INTEGER", type_str, maxch) case TY_LONG: call strcpy ("LONG", type_str, maxch) case TY_REAL: call strcpy ("REAL", type_str, maxch) case TY_DOUBLE: call strcpy ("DOUBLE", type_str, maxch) case TY_COMPLEX: call strcpy ("COMPLEX", type_str, maxch) default: call strcpy ("UNKNOWN", type_str, maxch) } end