PRO Wrtfits, image, header=header, filename=file, swap=swap, overwrit=ow, $ exab=exab, remote=rem, bs=bs, nodel=nd, append=ap, $ scale=scl, sub_mean=sub_mean, nofilemarks=nfm ;+ ; NAME: ; WRTFITS ; PURPOSE: ; save a 1 to 3 dimensional integer or byte array to a diskfile or ; an exabyte using the FITS standard format ; CATEGORY: ; Data storage ; CALLING SEQUENCE: ; WRTFITS,IMAGE[,KEYWORDS] ; INPUTS: ; IMAGE : 1 to 3 dimensional array, either byte or (short) integer ; KEYWORDS: ; HEADER : (input) string array with the FITS header ; information. See eg. D.C.Wells et al., A&A ; Suppl. 44, 363 If omitted, a minimum standard header ; is created ; ; FILENAME: (input) string with the name of the diskfile to ; write the data to. If omitted, first the header is ; searched for an FILENAME-card, and that value is ; taken. If that card does not exist, the user is ; prompted to type the name in ; ; OVERWRIT: (Flag) If this keyword has a value <> 0, existing ; files are overwritten without further request. ; Default is to ask. ; ; SWAP : (Flag) Byteswap the image data before writing to disk ; ; EXAB : (input) Write the data (also) to exabyte device No ; exab. A 'dd' command is spawned to UNIX. allowed ; values for exab depend on the Host. ; ; REMOTE : (input) string with the name of the host where the ; exabyte device is located, if not on the local ; machine. possible choices are VENUS, MARS, GOOFY ; and DAISY. ; ; BS : (input) blocking size for the tape write. Default is ; 4096. See Unix command dd for allowed syntax. ; ; APPEND : (Flag) Append the data at the end of the last data ; on the tape. A mt-command is spawned before writing ; to tape. ; ; NODEL : (Flag) Don't delete the diskfile after writing to ; tape. If NODEL is not set, the keyword FILENAME will ; be ignored and tmp.at1 will be used. this file will ; be deleted after writing to tape. However, if set, ; you have to specify a filename, and the file won't ; be deleted. ; ; SCALE : (input) if image is float array, it is multiplied ; with SCALE and converted to integer. A BSCALE header ; card is appended to the FITS-Header. ; ; SUB_MEAN: (Flag/input) Subtract an offset from the dataset before ; saving/scaling. Nice for saving arrays that have ; small variations around a large mean (so scaling ; would get them out of the possible range). An ; Keyword BSCALE is added to the header to shift the ; data back to orig value at loadtime. ; Either the average of the data (when called as /SUB) ; or an explicit given value (SUB=value) is used. ; OUTPUTS: ; none ; COMMON BLOCKS: ; none ; SIDE EFFECTS: ; ?? ; RESTRICTIONS: ; ?? ; MODIFICATION HISTORY: ; 15-10-92 PS ; 21-10-92 PS Add the possibility of scaling the data ; 14-04-95 PS Subtraction of mean value ;- on_error,2 bitpix = '16' ;;Default is INTEGER cd, '.', current = work_dir & work_dir = work_dir+'/' ;;Get working dir s = size(image) IF s(0) EQ 0 OR s(0) GT 3 THEN $ message, 'Only for writing 1 to 3-dim integer arrays, aborting' p = image IF keyword_set(sub_mean) THEN BEGIN IF sub_mean EQ 1 THEN sub_mean = avg(p) p = p-sub_mean ENDIF IF keyword_set(scl) THEN BEGIN p = fix((image*scl) < 32767) s = size(p) ENDIF CASE s(s(0)+1) OF 1: bitpix = '8' 2: 3: bitpix = '32' ELSE: message, 'Only for writing integer/byte arrays, aborting' ENDCASE ;IF s(s(0)+1) NE 2 THEN BEGIN ; IF s(s(0)+1) EQ 1 THEN BEGIN ; bitpix = '8' ; GOTO, ok ; ENDIF ; message, 'Only for writing integer/byte arrays, aborting', /cont ; GOTO, aus ;ENDIF Ok: ecard = 'END / end of fits header data' simcard = fitscard('SIMPLE', 'T', '(logical) file is basic FITS format') bcard = fitscard('BITPIX', bitpix, '(integer) number of bits per pixel') ncard = fitscard('NAXIS', strtrim(s(0), 2), '(integer) number of axes') n1card = fitscard('NAXIS1', strtrim(s(1), 2), $ '(integer) pixels on fastest varying axis') n2card = fitscard('NAXIS2', strtrim(s(2), 2), '(integer) pixels on 2nd ' + $ 'axis') n3card = fitscard('NAXIS3', strtrim(s(3), 2), '(integer) pixels on 3rd ' + $ 'axis') IF NOT keyword_set(header) THEN BEGIN header = simcard header = [header, bcard] header = [header, ncard] header = [header, n1card] IF s(0) GE 2 THEN header = [header, n2card] IF s(0) EQ 3 THEN header = [header, n3card] IF keyword_set(scl) THEN $ header = [header, fitscard('BSCALE', 1./scl, '(float) scaling ' + $ 'factor for data')] IF keyword_set(sub_mean) THEN $ header = [header, fitscard('BZERO', sub_mean, '(float) Data offset')] header = [header, ecard] ENDIF ELSE BEGIN pos = (where(strpos(header, 'BITPIX') EQ 0))(0) IF pos LT 0 THEN add, header, bcard, 1 ELSE add, header, bcard, pos, /ov pos = (where(strpos(header, 'NAXIS') EQ 0))(0) IF pos LT 0 THEN add, header, ncard, 2 ELSE add, header, ncard, $ pos, /ov pos = (where(strpos(header, 'NAXIS1') EQ 0))(0) IF pos LT 0 THEN add, header, n1card, 3 ELSE add, header, n1card, pos, /ov IF s(0) GE 2 THEN BEGIN pos = (where(strpos(header, 'NAXIS2') EQ 0))(0) IF pos LT 0 THEN add, header, n2card, 4 ELSE add, header, $ n2card, pos, /ov ENDIF IF s(0) EQ 3 THEN BEGIN pos = (where(strpos(header, 'NAXIS3') EQ 0))(0) IF pos LT 0 THEN add, header, n3card, 5 ELSE add, header, $ n3card, pos, /ov ENDIF IF keyword_set(scl) THEN BEGIN scard = fitscard('BSCALE', 1./scl, '(float) scaling factor for data') pos = (where(strpos(header, 'BSCALE') EQ 0))(0) IF pos LT 0 THEN add, header, scard, 3+s(0) ELSE add, header, $ scard, pos, /ov ENDIF IF keyword_set(sub_mean) THEN BEGIN zcard = fitscard('BZERO', sub_mean, '(float) data offset') pos = (where(strpos(header, 'BZERO') EQ 0))(0) IF pos LT 0 THEN add, header, zcard, 3+s(0) ELSE add, header, $ zcard, pos, /ov ENDIF pos = (where(strpos(header, 'END ') EQ 0))(0) IF pos LT 0 THEN header = [header, ecard] FOR i = 0, n_elements(header)-1 DO $ IF strlen(header(i)) NE 80 THEN BEGIN tmp = string(replicate(32b, 80)) strput, tmp, strmid(header(i), 0, 80) header(i) = tmp ENDIF ENDELSE IF keyword_set(exab) AND NOT keyword_set(nd) THEN BEGIN file = 'tmp.fits' ow = 1 ENDIF IF NOT keyword_set(file) THEN BEGIN fpos = (where(strpos(header, 'FILENAME') EQ 0))(0) IF fpos GE 0 THEN BEGIN file = dos_name(strmid(header(fpos), 9, 21)) file = work_dir+file ENDIF ELSE REPEAT BEGIN file = '' print, 'Please enter name for disk file' read, file ENDREP UNTIL file NE '' ENDIF f0 = strmid(file, 0, 1) IF (f0 NE '~') AND (f0 NE '/') THEN file = work_dir+file IF exists(file) THEN BEGIN IF NOT keyword_set(ow) THEN BEGIN message, 'File '+file+' allready exists !', /cont writeu, -1, 'Overwrite ? (Y/N) ' choice = '' & read, choice IF strupcase(choice) NE 'Y' THEN GOTO, aus ENDIF message, 'Overwritten: '+file, /cont ENDIF IF keyword_set(swap) THEN byteorder, p, /sswap n = fix(80*n_elements(header)/2880)+1 head = replicate(32b, n*2880) head(0) = reform(byte(header), 80*n_elements(header)) openw, unit, file, /get_lun writeu, unit, head, p free_lun, unit s_exab = size(exab) & s_exab=s_exab(s_exab(0)+1) IF s_exab EQ 0 THEN GOTO, aus IF keyword_set(rem) THEN BEGIN CASE strupcase(rem) OF 'MARS' : cmd0 = 'rsh mars ' 'VENUS': cmd0 = 'rsh venus ' 'DAISY': cmd0 = 'rsh daisy ' 'GOOFY': cmd0 = 'rsh goofy ' ELSE : BEGIN message, 'unknown host : '+rem+' trying local machine', $ /continue cmd0 = '' END ENDCASE ENDIF ELSE cmd0 = '' IF NOT keyword_set(bs) THEN bs = 4096 IF exab GT 2 THEN message, 'Only Exabyte devices 1 and 2 possible' dev = '/dev/nrst'+strtrim(fix(exab), 2) IF cmd0 EQ '' THEN BEGIN ON_IOERROR, fehler openr, 1, dev close, 1 ON_IOERROR, null GOTO, ok1 Fehler: ON_IOERROR, null message, 'No such tape device on this host !!' ENDIF Ok1: IF keyword_set(ap) THEN BEGIN writeu, -1, 'Looking for last filemark...' spawn, cmd0+'mt -f '+dev+' eom' print, ' ok' ENDIF cmd = cmd0+'dd of='+dev+' if='+file+' bs='+strtrim(bs, 2) spawn, cmd ;;;;;; ;;; Horrible to do like that, but dd insists on writing filemarks :-( ;;;;;; IF keyword_set(nfm) THEN spawn, 'mt -f '+dev+' bsf 1' IF NOT keyword_set(nd) THEN spawn, 'rm '+file Aus: END