home *** CD-ROM | disk | FTP | other *** search
/ Liren Large Software Subsidy 6 / 06.iso / b / b002 / 2.ddi / CTG1.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1992-03-02  |  5.4 KB  |  213 lines
  1. program ctg1(input,output,inf,outf);
  2.  
  3. type
  4.  
  5.     byte = char;
  6.  
  7. var
  8.  
  9.     inf,outf                      : text;
  10.     infile,outfile                : packed array[1..80] of char;
  11.     header_recs                   : integer;
  12.     recs_tally                    : integer;
  13.     col1,col2,row1,row2,cols,rows : integer;
  14.     tx,ty                         : integer;
  15.     min,max                       : integer;
  16.     minval,maxval,adjz            : integer;
  17.     layer,fmt                     : integer;
  18.  
  19. procedure get_parameters;
  20.  
  21. begin
  22.  
  23.     writeln(chr(27),'[2J',chr(27),'[1;1H');        (* clears the screen *)
  24.  
  25.     writeln('         IDRISI USGS Composite Theme Grid Windowing Program');
  26.     writeln('         --------------------------------------------------');
  27.     writeln;
  28.  
  29.     write('Enter the name of the raw CTG tape file   : ');
  30.     readln(infile);
  31.     writeln;
  32.     writeln;
  33.  
  34.     write('Enter a new name for the extracted window : ');
  35.     readln(outfile);
  36.     writeln;
  37.     writeln;
  38.  
  39.     write('Enter the number of header records        : ');
  40.     readln(header_recs);
  41.     writeln;
  42.     writeln;
  43.  
  44.     write('Enter the start easting                   : ');
  45.     readln(col1);
  46.     tx:=col1;
  47.     writeln;
  48.     writeln;
  49.  
  50.     write('Enter the finish easting                  : ');
  51.     readln(col2);
  52.     writeln;
  53.     writeln;
  54.  
  55.     write('Enter the start northing                  : ');
  56.     readln(row1);
  57.     ty:=row1;
  58.     writeln;
  59.     writeln;
  60.  
  61.     write('Enter the finish northing                 : ');
  62.     readln(row2);
  63.     writeln;
  64.     writeln;
  65.  
  66.     write('Enter the data layer number               : ');
  67.     readln(layer);
  68.     writeln;
  69.     writeln;
  70.  
  71.     write('Enter the lower cutoff data layer value   : ');
  72.     readln(minval);
  73.     writeln;
  74.     writeln;
  75.  
  76.     write('Enter the upper cutoff data layer value   : ');
  77.     readln(maxval);
  78.     writeln;
  79.     writeln;
  80.  
  81.     write('Enter the data layer adjustment value     : ');
  82.     readln(adjz);
  83.     adjz:=abs(adjz);
  84.     writeln;
  85.     writeln;
  86.  
  87.     write('Enter the output field width desired      : ');
  88.     readln(fmt);
  89.     fmt:=fmt+1;
  90.  
  91.     rows:=round((row2-row1)/200)+1;
  92.     cols:=round((col2-col1)/200)+1;
  93.  
  94. end;
  95.  
  96. procedure extract;
  97.  
  98. var i,j,k  : integer;
  99.     buffer : packed array[1..80] of char;
  100.     raw    : packed array[1..80] of char;
  101.     cooked : array[1..9] of integer;
  102.     row,col: integer;
  103.     rk,ck  : integer;
  104.  
  105. begin
  106.  
  107.     for i:=1 to header_recs do read(inf,buffer);
  108.  
  109.     max:=-maxint;
  110.     min:= maxint;
  111.  
  112.     rk:=0;
  113.     ck:=0;
  114.  
  115.     recs_tally:=header_recs;
  116.  
  117.     repeat
  118.  
  119.       read(inf,buffer);
  120.       recs_tally:=recs_tally+1;
  121.  
  122.       raw:=substr(buffer,1,3);
  123.       readv(raw,cooked[1],error:=continue);  (* UTM Zone *)
  124.       raw:=substr(buffer,4,8);
  125.       readv(raw,cooked[2],error:=continue);  (* UTM Easting *)
  126.       raw:=substr(buffer,12,8);
  127.       readv(raw,cooked[3],error:=continue);  (* UTM Northing *)
  128.       raw:=substr(buffer,21,10);
  129.       readv(raw,cooked[4],error:=continue);  (* Land Use / Land Cover *)
  130.       raw:=substr(buffer,31,10);
  131.       readv(raw,cooked[5],error:=continue);  (* FIPS Code *)
  132.       raw:=substr(buffer,41,10);
  133.       readv(raw,cooked[6],error:=continue);  (* Hydrologic Unit Code *)
  134.       raw:=substr(buffer,51,10);
  135.       readv(raw,cooked[7],error:=continue);  (* Census Tract or Cnty Subdiv *)
  136.       raw:=substr(buffer,61,10);
  137.       readv(raw,cooked[8],error:=continue);  (* Fed. Land Ownership Code *)
  138.       raw:=substr(buffer,71,10);
  139.       readv(raw,cooked[9],error:=continue);  (* State Land Ownership Code *)
  140.  
  141.       row:=(rows-1)-round((cooked[3]-ty)/200);
  142.       col:=round((cooked[2]-tx)/200);
  143.  
  144.       if (((row>=0) and (row<rows)) and ((col>=0) and (col<cols))) then
  145.          begin
  146.            if ((cooked[layer]>=minval) and (cooked[layer]<=maxval)) then
  147.               begin
  148.                 cooked[layer]:=cooked[layer]-adjz;
  149.                 writeln(outf,row:4,col:4,cooked[layer]:fmt);
  150.                 if cooked[layer]>max then max:=cooked[layer];
  151.                 if cooked[layer]<min then min:=cooked[layer];
  152.               end;
  153.          end;
  154.  
  155.          (* note : it is assumed here that the data file has been downloaded *)
  156.          (* onto disk as an 8000 byte fixed length file. This results in 100 *)
  157.          (* cell records per physical record. If this is not the case change *)
  158.          (* the numeric constant below to reflect the number of cell records *)
  159.          (* which occur within each physical record [ie. change the no. 100] *)
  160.  
  161.          if (recs_tally mod 100)=0 then readln(inf);
  162.  
  163.     until ((row>=rows) and (col>=cols));
  164.  
  165. end;
  166.  
  167. procedure do_it;
  168.  
  169. begin
  170.  
  171.     open(inf,infile,old);
  172.     open(outf,outfile,new);
  173.     reset(inf);
  174.     rewrite(outf);
  175.  
  176.     extract;
  177.  
  178.     close(inf);
  179.     close(outf);
  180.  
  181. end;
  182.  
  183. procedure print_results;
  184.  
  185. begin
  186.  
  187.     writeln(chr(27),'[2J',chr(27),'[1;1H');        (* clears the screen *)
  188.  
  189.     writeln('         IDRISI USGS Composite Theme Grid Windowing Program');
  190.     writeln('         --------------------------------------------------');
  191.     writeln;
  192.  
  193.     writeln;
  194.     writeln;
  195.     writeln('Windowing operation complete :');
  196.     writeln;
  197.     writeln('The number of rows is        : ',rows);
  198.     writeln('The number of cols is        : ',cols);
  199.     writeln;
  200.     writeln('The minimum value  is        : ',min);
  201.     writeln('The maximum value  is        : ',max);
  202.     writeln;
  203.  
  204. end;
  205.  
  206. begin
  207.  
  208.     get_parameters;
  209.     do_it;
  210.     print_results;
  211.  
  212. end.
  213.