PROGRAM REDUCE C C Author: N. A. Bourgeois, Jr. C Sandia National Laboratories C Systems Engineering Division 5238 C PO Box 5800 C Albuquerque, NM 87185 C (505) 844-8088 C C Edit Record: C C 14-Feb-85: Original creation started. C 13-Mar-85: Original creation completed. C C Description: C C This program reduces the resolution of an image of byte sized C pixels by averaging rectangular blocks of pixels. The input C image contains 640 columns and 480 rows. It is stored in a C file where each column is stored in a 512-byte block. The C first 480 bytes contains the data, and the last 32 bytes are C undefined. Thus, the file is 640 blocks long. The output C file follows the same structure. C DIMENSION * BUFFER(640), !local buffer for row or column storage * IFLSPC(20), !input device:filename.type * OFLSPC(20), !output device:filename.type * STRING(5) !temporary input string C BYTE * BUFFER, * IAVG !average value for a group of pixels C INTEGER * ICOL, !column index number * IEND, !end index for group of pixels * IERR, !error return, 0 = normal return * IHRES, !reduced horizontal resolution * ILUN, !input logical unit * INPTR, !input column pointer * IROW, !row index number * ISTRT, !start index for group of pixels * ISUM, !sum of the values of a group of pixels * IVRES, !reduced vertical resolution * NCOL, !number of columns * NROW, !number of rows * NSIZ, !number of bytes per pixel * OLUN, !output logical unit * OUTPTR, !output column pointer * TSXFLG !=0 for RT-11, >0 for TSX-Plus C LOGICAL*1 * IFLSPC, * OFLSPC, * STRING C REAL * CELLS !number of cells in a group of pixels C DATA * ILUN /10/, * NCOL /640/, * NROW /480/, * NSIZ /1/, * OLUN /20/ C 1 FORMAT (/,' REDUCE: 85c13a',/,/) 2 FORMAT (/,' REDUCE: All done',/) 3 FORMAT (I3) 4 FORMAT (' IVINIT: IERR =',I3) 5 FORMAT (' IVELIM: IERR =',I3) 6 FORMAT (' IPTCOL: IERR =',I3) 7 FORMAT (' IGTCOL: IERR =',I3) 8 FORMAT ('+ ICOL =',I4) 9 FORMAT ('+ IROW =',I4) 10 FORMAT (' IGTROW: IERR =',I3) 11 FORMAT (' IPTROW: IERR =',I3) C TYPE 1 C C Enter the input and output file specifications. C CALL GTLIN (IFLSPC,'Enter the input image dev:filnam.typ:') CALL GTLIN (OFLSPC,'Enter the output image dev:filnam.typ:') C C Enter the vertical and horizontal resolution values. C CALL GTLIN (STRING,'Reduce vertical resolution to (1 to 480):') I = LEN (STRING) DECODE (I,3,STRING) IVRES CALL GTLIN (STRING,'Reduce horizontal resolution to (1 to 640):') I = LEN (STRING) DECODE (I,3,STRING) IHRES C C If running under TSX-Plus, lock the job into lowest memory and turn C on high efficiency terminal mode. C TSXFLG = ITSLIN () IF (TSXFLG .EQ. 0) GO TO 100 CALL LKLOMY CALL HIEFON 100 CONTINUE C C Create and initialize the virtual array. C IERR = IVINIT (NROW,NCOL,NSIZ,BUFFER) IF (IERR .EQ. 0) GO TO 110 TYPE 4,IERR GO TO 900 110 CONTINUE C C Open and read the input file a column at a time into the virtual C array. Perform the vertical averaging on the fly between the C column read and the column deposit into the virtual array. Close C the input file when done reading. C OPEN ( * ACCESS = 'DIRECT', * FORM = 'UNFORMATTED', * NAME = IFLSPC, * READONLY, * RECORDSIZE = 512/4, * TYPE = 'OLD', * UNIT = ILUN * ) CELLS = FLOAT (NROW) / FLOAT (IVRES) DO 300 ICOL = 1,NCOL TYPE 8,ICOL READ (ILUN'ICOL) (BUFFER(I),I=1,NROW) IEND = 0 DO 240 I = 1,IVRES ISUM = 0 ISTRT = IEND + 1 IEND = INT (FLOAT (I) * CELLS + .5) DO 210 IROW = ISTRT,IEND ISUM = ISUM + (BUFFER(IROW) .AND. "377) 210 CONTINUE IAVG = ISUM / (IEND - ISTRT + 1) DO 220 IROW = ISTRT,IEND BUFFER(IROW) = IAVG 220 CONTINUE 240 CONTINUE IERR = IPTCOL (ICOL) IF (IERR .EQ. 0) GO TO 290 TYPE 6,IERR GO TO 800 290 CONTINUE 300 CONTINUE TYPE * CLOSE (UNIT = ILUN) C C Perform the horizontal averaging. C CELLS = FLOAT (NCOL) / FLOAT (IHRES) DO 500 IROW = 1,NROW TYPE 9,IROW IERR = IGTROW (IROW) IF (IERR .EQ. 0) GO TO 410 TYPE 10,IERR GO TO 800 410 CONTINUE IEND = 0 DO 440 I = 1,IHRES ISUM = 0 ISTRT = IEND +1 IEND = INT (FLOAT (I) * CELLS + .5) DO 420 ICOL = ISTRT,IEND ISUM = ISUM + (BUFFER(ICOL) .AND. "377) 420 CONTINUE IAVG = ISUM / (IEND - ISTRT + 1) DO 430 ICOL = ISTRT,IEND BUFFER(ICOL) = IAVG 430 CONTINUE 440 CONTINUE IERR = IPTROW (IROW) IF (IERR .EQ. 0) GO TO 490 TYPE 11,IERR GO TO 800 490 CONTINUE 500 CONTINUE TYPE * C C Open and write the array a column at a time into the output file. C Close the file when done writing. C OPEN ( * ACCESS = 'DIRECT', * ASSOCIATEVARIABLE = OUTPTR, * FORM = 'UNFORMATTED', * MAXREC = 640, * NAME = OFLSPC, * RECORDSIZE = 512/4, * TYPE = 'NEW', * UNIT = OLUN * ) DO 700 ICOL = 1,NCOL TYPE 8,ICOL IERR = IGTCOL (ICOL) IF (IERR .EQ. 0) GO TO 690 TYPE 7,IERR GO TO 800 690 CONTINUE OUTPTR = ICOL WRITE (OLUN'OUTPTR) (BUFFER(I),I=1,512) 700 CONTINUE CLOSE (UNIT = OLUN) C C Eliminate the virtual array. C 800 CONTINUE IERR = IVELIM () IF (IERR .EQ. 0) GO TO 900 TYPE 5,IERR 900 CONTINUE C C If running under TSX-Plus, unlock the job from memory and turn off C high efficiency terminal mode. C IF (TSXFLG .EQ. 0) GO TO 910 CALL IUNLKM CALL HIEFOF 910 CONTINUE C C End it all. C TYPE 2 CALL EXIT END