1 /* ***********************************************************
  2    *                                                         *
  3    * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  4    *                                                         *
  5    *********************************************************** */
  6 convert_numeric_file: cnf: proc;
  7 
  8 /* This command converts a  single precision random numeric file (basic or fortran)
  9    to a double precision random numeric file or vice versa.
 10    Usage: convert_numeric_file old_path new_path -control arg-
 11    1) old_path      is the pathname of the file to be converted
 12    2) new_path      is the  pathname of the target file;
 13    .                if it is not of 0 length, it  is automatically truncated
 14    3) control arg may be either
 15    .                -double_precision,-dp         convert from single  to double precision;  default
 16    .                -single_precision,-sp         convert from double to single precision
 17 */
 18 /* coded  76.02.17  by M. Weaver */
 19 
 20 dcl  arg char (alng) based (aptr);
 21 dcl  header_numbers (2) char (1) init ("1", "2");
 22 dcl  me char (20) aligned static init ("convert_numeric_file") options (constant);
 23 dcl  path (2) char (168);
 24 
 25 dcl (alng, i, j, name_num, prec (2)) fixed bin;
 26 dcl (num_size (2), n_read) fixed bin (21);
 27 dcl (onum, tnum) float bin (63);
 28 dcl  based_single float bin (27) based (bs_ptr);
 29 dcl  code fixed bin (35);
 30 dcl (error_table_$badopt, error_table_$end_of_info, error_table_$incompatible_attach) fixed bin (35) ext;
 31 dcl  sp_to_dp bit (1) aligned;
 32 
 33 dcl  cleanup condition;
 34 
 35 dcl (aptr, iocb_ptr (2), onum_ptr, tnum_ptr, bs_ptr) ptr;
 36 
 37 dcl (addr, null, round, substr) builtin;
 38 
 39 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin) returns (fixed bin (35));
 40 dcl (com_err_, ioa_) entry options (variable);
 41 dcl  iox_$attach_ioname entry (char (*), ptr, char (*), fixed bin (35));
 42 dcl  iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35));
 43 dcl  iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35));
 44 dcl  iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35));
 45 dcl  iox_$close entry (ptr, fixed bin (35));
 46 dcl  iox_$detach_iocb entry (ptr, fixed bin (35));
 47 dcl  iox_$destroy_iocb entry (ptr, fixed bin (35));
 48 dcl  unique_chars_ entry (bit (*)) returns (char (15));
 49 
 50           ^L
 51 %include iox_modes;
 52 
 53 %include iocb;
 54           ^L
 55           sp_to_dp = "1"b;                                  /* initialize default */
 56           name_num = 0;
 57           i = 1;
 58 
 59           do while (cu_$arg_ptr (i, aptr, alng) = 0);
 60                if substr (arg, 1, 1) = "-" then do;         /* have control arg */
 61                     if arg = "dp" | arg = "-double_precision" then sp_to_dp = "1"b;
 62                     else if arg = "-sp" | arg = "-single_precision" then sp_to_dp = "0"b;
 63                     else do;
 64                          call com_err_ (error_table_$badopt, me, arg);
 65                          return;
 66                     end;
 67                end;
 68 
 69                else do;                                     /* must be pathname */
 70                     name_num = name_num + 1;
 71                     if name_num > 2 then goto name_error;
 72                     path (name_num) = arg;
 73                end;
 74                i = i + 1;
 75           end;
 76 
 77           if name_num ^= 2 then do;
 78 name_error:
 79                call com_err_ (0, me, "Exactly two pathnames must be given.");
 80                return;
 81           end;
 82 
 83           iocb_ptr (1), iocb_ptr (2) = null;
 84 
 85           on cleanup call clean_up;
 86           if sp_to_dp then do;
 87                prec (1) = 1;
 88                prec (2) = 2;
 89                bs_ptr = addr (onum);
 90           end;
 91           else do;
 92                prec (1) = 2;
 93                prec (2) = 1;
 94                bs_ptr = addr (tnum);
 95           end;
 96 
 97 /* open input file */
 98 
 99           j = 1;
100           call iox_$attach_ioname ((unique_chars_ ("0"b)), iocb_ptr (1), "vfile_ " || path (1)
101                || " -ssf -no_trunc -header " || header_numbers (prec (1)), code);
102           if code ^= 0 then goto finish;
103 
104           call iox_$open (iocb_ptr (1), Stream_input, "0"b, code);
105           if code ^= 0 then goto finish;
106 
107 /* open output file */
108 
109           j = 2;
110           call iox_$attach_ioname ((unique_chars_ ("0"b)), iocb_ptr (2), "vfile_ " || path (2)
111                || " -ssf -header " || header_numbers (prec (2)), code);
112           if code ^= 0 then goto finish;
113 
114           call iox_$open (iocb_ptr (2), Stream_output, "0"b, code);
115           if code ^= 0 then goto finish;
116 
117           onum_ptr = addr (onum);
118           tnum_ptr = addr (tnum);
119           do i = 1 to 2;
120                num_size (i) = prec (i) * 4;                 /* get byte count for input, output */
121           end;
122 
123 /* copy numbers one at a time; double precision variables are used for the actual I/O
124    but the appropriate one is referenced as single precision */
125 
126           do while ("1"b);                                  /* loop is terminated by end of info */
127                call iox_$get_chars (iocb_ptr (1), onum_ptr, num_size (1), n_read, code);
128                if code ^= 0 then do;
129                     if code = error_table_$end_of_info then code = 0; /* normal termination */
130                     j = 1;                                  /* print first pathname */
131                     goto finish;
132                end;
133                if sp_to_dp then tnum = based_single;
134                else based_single = round (onum, 27);
135                call iox_$put_chars (iocb_ptr (2), tnum_ptr, num_size (2), code);
136                if code ^= 0 then goto finish;
137           end;
138 
139 finish:   call clean_up;
140           if code ^= 0 then do;
141                if (j = 1) & (code = error_table_$incompatible_attach)
142                then call com_err_ (0, me, "File ^a does not need converting.", path (j));
143                else call com_err_ (code, me, path (j));
144           end;
145           return;
146 
147 
148 clean_up: proc;
149 
150 dcl  ecode fixed bin (35);
151 
152                do i = 1 to 2;                               /* close, etc. all files */
153                     if iocb_ptr (i) ^= null then do;
154                          ecode = -1;
155                          if iocb_ptr (i) -> iocb.open_descrip_ptr ^= null
156                          then call iox_$close (iocb_ptr (i), ecode);
157                          if ecode <= 0
158                          then if iocb_ptr (i) -> iocb.attach_descrip_ptr ^= null
159                               then call iox_$detach_iocb (iocb_ptr (i), ecode);
160                          if ecode = 0 then call iox_$destroy_iocb (iocb_ptr (i), ecode);
161                     end;
162                end;
163 
164                return;
165           end;
166 
167      end;