PROGRAM VRTARY C C VRTARY.FOR NAB 02-Jan-85/20-Feb-85. C C Test the routines in VRTARY.MAC. C INTEGER * NCOL, !number of columns * NROW, !number of rows * TSXFLG !=0 -> RT-11, >0 -> TSX-Plus C C 1 FORMAT (/,' VRTARY: 85b20b',/) 2 FORMAT (/,' VRTARY: All done',/,/) 3 FORMAT (' TSXFLG =',I3) 4 FORMAT (' Enter the NROW value: ',$) 5 FORMAT (I4) 6 FORMAT (' Enter the NCOL value: ',$) C C If the operating system is TSX-Plus, lock the job into lowest memory C and put the terminal into high efficency mode. C TYPE 1 TSXFLG = ITSLIN () TYPE 3,TSXFLG IF (TSXFLG .EQ. 0) GO TO 100 CALL LKLOMY CALL HIEFON 100 CONTINUE C C Ask for and accept the NROW and NCOL values. C TYPE 4 ACCEPT 5,NROW TYPE 6 ACCEPT 5,NCOL C C Test an array of bytes. C CALL TSTBYT (NROW,NCOL) C C Test an array of integers. C CALL TSTINT (NROW,NCOL) C C Test an array of reals. C CALL TSTREL (NROW,NCOL) C C Test an array of complexes. C CALL TSTCPX (NROW,NCOL) C C If running under TSX-Plus, unlock the job from memory and return the C terminal to normal efficiency mode. C IF (TSXFLG .EQ. 0) GO TO 110 CALL IUNLKM CALL HIEFOF 110 CONTINUE TYPE 2 CALL EXIT END C C SUBROUTINE TSTBYT (NROW,NCOL) C C Test an array of bytes. C BYTE * BUFA, ! for holding generated data * BUFB, ! for sending and receiving data * ZERO ! for clearing BUFB C DIMENSION * BUFA(1024), * BUFB(1024) C INTEGER * ICOL, ! column index number * IERR, ! error return * IROW, ! row index number * NCOL, ! number of columns * NROW, ! number of rows * NSIZ ! number of bytes per array element C DATA * NSIZ /1/, * ZERO /0/ C 1 FORMAT (/,' TSTBYT: 85b13a') 2 FORMAT (' TSTBYT: All done') 3 FORMAT (' IVINIT: IERR =',I3) 4 FORMAT (' IVINIT: Array initialized') 5 FORMAT (' IVELIM: IERR =',I3) 6 FORMAT (' IVELIM: Array eliminated') 7 FORMAT (' IPTROW: IERR =',I3) 8 FORMAT (' IGTROW: IERR =',I3) 9 FORMAT (' IROW =',/) 10 FORMAT ('+ ',I5) 11 FORMAT (' IPTROW/IGTROW: Error',2I5) 12 FORMAT (' ICOL =',/) 13 FORMAT (' IPTCOL/IGTCOL: Error',2I5) 14 FORMAT (' IPTCOL: IERR =',I3) 15 FORMAT (' IGTCOL: IERR =',I3) C TYPE 1 C C Create and initialize the array. C IERR = IVINIT (NROW,NCOL,NSIZ,BUFB) IF (IERR .EQ. 0) GO TO 200 TYPE 3,IERR GO TO 290 200 CONTINUE TYPE 4 C C Test the transfer of rows of data between the array and BUFB. C TYPE 9 DO 235 IROW = 1,NROW TYPE 10,IROW DO 205 ICOL = 1,NCOL BUFA(ICOL) = INT(128. * RAN(I,J)) BUFB(ICOL) = BUFA(ICOL) 205 CONTINUE IERR = IPTROW (IROW) IF (IERR .EQ. 0) GO TO 210 TYPE 7,IERR GO TO 280 210 CONTINUE DO 215 ICOL = 1,NCOL BUFB(ICOL) = ZERO 215 CONTINUE IERR = IGTROW (IROW) IF (IERR .EQ. 0) GO TO 220 TYPE 8,IERR GO TO 280 220 CONTINUE DO 230 ICOL = 1,NCOL IF (BUFA(ICOL) .EQ. BUFB(ICOL)) GO TO 225 TYPE 11,BUFA(ICOL),BUFB(ICOL) GO TO 280 225 CONTINUE 230 CONTINUE 235 CONTINUE C TYPE 12 DO 270 ICOL = 1,NCOL TYPE 10,ICOL DO 240 IROW = 1,NROW BUFA(IROW) = INT(128. * RAN(I,J)) BUFB(IROW) = BUFA(IROW) 240 CONTINUE IERR = IPTCOL (ICOL) IF (IERR .EQ. 0) GO TO 245 TYPE 14,IERR GO TO 280 245 CONTINUE DO 250 IROW = 1,NROW BUFB(IROW) = ZERO 250 CONTINUE IERR = IGTCOL (ICOL) IF (IERR .EQ. 0) GO TO 255 TYPE 15,IERR GO TO 280 255 CONTINUE DO 265 IROW = 1,NROW IF (BUFA(IROW) .EQ. BUFB(IROW)) GO TO 260 TYPE 13,BUFA(IROW),BUFB(IROW) GO TO 280 260 CONTINUE 265 CONTINUE 270 CONTINUE C C Eliminate the array. C 280 CONTINUE IERR = IVELIM () IF (IERR .EQ. 0) GO TO 285 TYPE 5,IERR GO TO 290 285 CONTINUE TYPE 6 C 290 CONTINUE TYPE 2 RETURN END C C SUBROUTINE TSTINT (NROW,NCOL) C C Test an array of integers. C DIMENSION * BUFA(1024), * BUFB(1024) C INTEGER * BUFA, ! for holding generated data * BUFB, ! for sending and receiving data * ICOL, ! column index number * IERR, ! error return * IROW, ! row index number * NCOL, ! number of columns * NROW, ! number of rows * NSIZ, ! number of bytes per array element * ZERO ! for clearing BUFB C DATA * NSIZ /2/, * ZERO /0/ C 1 FORMAT (/,' TSTINT: 85b13a') 2 FORMAT (' TSTINT: All done') 3 FORMAT (' IVINIT: IERR =',I3) 4 FORMAT (' IVINIT: Array initialized') 5 FORMAT (' IVELIM: IERR =',I3) 6 FORMAT (' IVELIM: Array eliminated') 7 FORMAT (' IPTROW: IERR =',I3) 8 FORMAT (' IGTROW: IERR =',I3) 9 FORMAT (' IROW =',/) 10 FORMAT ('+ ',I5) 11 FORMAT (' IPTROW/IGTROW: Error',2I5) 12 FORMAT (' ICOL =',/) 13 FORMAT (' IPTCOL/IGTCOL: Error',2I5) 14 FORMAT (' IPTCOL: IERR =',I3) 15 FORMAT (' IGTCOL: IERR =',I3) C TYPE 1 C C Create and initialize the array. C IERR = IVINIT (NROW,NCOL,NSIZ,BUFB) IF (IERR .EQ. 0) GO TO 200 TYPE 3,IERR GO TO 290 200 CONTINUE TYPE 4 C C Test the transfer of rows of data between the array and BUFB. C TYPE 9 DO 235 IROW = 1,NROW TYPE 10,IROW DO 205 ICOL = 1,NCOL BUFA(ICOL) = INT(128. * RAN(I,J)) BUFB(ICOL) = BUFA(ICOL) 205 CONTINUE IERR = IPTROW (IROW) IF (IERR .EQ. 0) GO TO 210 TYPE 7,IERR GO TO 280 210 CONTINUE DO 215 ICOL = 1,NCOL BUFB(ICOL) = ZERO 215 CONTINUE IERR = IGTROW (IROW) IF (IERR .EQ. 0) GO TO 220 TYPE 8,IERR GO TO 280 220 CONTINUE DO 230 ICOL = 1,NCOL IF (BUFA(ICOL) .EQ. BUFB(ICOL)) GO TO 225 TYPE 11,BUFA(ICOL),BUFB(ICOL) GO TO 280 225 CONTINUE 230 CONTINUE 235 CONTINUE C TYPE 12 DO 270 ICOL = 1,NCOL TYPE 10,ICOL DO 240 IROW = 1,NROW BUFA(IROW) = INT(128. * RAN(I,J)) BUFB(IROW) = BUFA(IROW) 240 CONTINUE IERR = IPTCOL (ICOL) IF (IERR .EQ. 0) GO TO 245 TYPE 14,IERR GO TO 280 245 CONTINUE DO 250 IROW = 1,NROW BUFB(IROW) = ZERO 250 CONTINUE IERR = IGTCOL (ICOL) IF (IERR .EQ. 0) GO TO 255 TYPE 15,IERR GO TO 280 255 CONTINUE DO 265 IROW = 1,NROW IF (BUFA(IROW) .EQ. BUFB(IROW)) GO TO 260 TYPE 13,BUFA(IROW),BUFB(IROW) GO TO 280 260 CONTINUE 265 CONTINUE 270 CONTINUE C C Eliminate the array. C 280 CONTINUE IERR = IVELIM () IF (IERR .EQ. 0) GO TO 285 TYPE 5,IERR GO TO 290 285 CONTINUE TYPE 6 C 290 CONTINUE TYPE 2 RETURN END C C SUBROUTINE TSTREL (NROW,NCOL) C C Test an array of reals. C DIMENSION * BUFA(1024), * BUFB(1024) C INTEGER * ICOL, ! column index number * IERR, ! error return * IROW, ! row index number * NCOL, ! number of columns * NROW, ! number of rows * NSIZ ! number of bytes per array element C REAL * BUFA, ! for holding generated data * BUFB, ! for sending and receiving data * ZERO ! for clearing BUFB C DATA * NSIZ /4/, * ZERO /0./ C 1 FORMAT (/,' TSTREL: 85b20b') 2 FORMAT (' TSTREL: All done') 3 FORMAT (' IVINIT: IERR =',I3) 4 FORMAT (' IVINIT: Array initialized') 5 FORMAT (' IVELIM: IERR =',I3) 6 FORMAT (' IVELIM: Array eliminated') 7 FORMAT (' IPTROW: IERR =',I3) 8 FORMAT (' IGTROW: IERR =',I3) 9 FORMAT (' IROW =',/) 10 FORMAT ('+ ',I5) 11 FORMAT (' IPTROW/IGTROW: Error',2F9.3) 12 FORMAT (' ICOL =',/) 13 FORMAT (' IPTCOL/IGTCOL: Error',2F9.3) 14 FORMAT (' IPTCOL: IERR =',I3) 15 FORMAT (' IGTCOL: IERR =',I3) C TYPE 1 C C Create and initialize the array. C IERR = IVINIT (NROW,NCOL,NSIZ,BUFB) IF (IERR .EQ. 0) GO TO 200 TYPE 3,IERR GO TO 290 200 CONTINUE TYPE 4 C C Test the transfer of rows of data between the array and BUFB. C TYPE 9 DO 235 IROW = 1,NROW TYPE 10,IROW DO 205 ICOL = 1,NCOL BUFA(ICOL) = 128. * RAN(I,J) BUFB(ICOL) = BUFA(ICOL) 205 CONTINUE IERR = IPTROW (IROW) IF (IERR .EQ. 0) GO TO 210 TYPE 7,IERR GO TO 280 210 CONTINUE DO 215 ICOL = 1,NCOL BUFB(ICOL) = ZERO 215 CONTINUE IERR = IGTROW (IROW) IF (IERR .EQ. 0) GO TO 220 TYPE 8,IERR GO TO 280 220 CONTINUE DO 230 ICOL = 1,NCOL IF (BUFA(ICOL) .EQ. BUFB(ICOL)) GO TO 225 TYPE 11,BUFA(ICOL),BUFB(ICOL) GO TO 280 225 CONTINUE 230 CONTINUE 235 CONTINUE C TYPE 12 DO 270 ICOL = 1,NCOL TYPE 10,ICOL DO 240 IROW = 1,NROW BUFA(IROW) = 128. * RAN(I,J) BUFB(IROW) = BUFA(IROW) 240 CONTINUE IERR = IPTCOL (ICOL) IF (IERR .EQ. 0) GO TO 245 TYPE 14,IERR GO TO 280 245 CONTINUE DO 250 IROW = 1,NROW BUFB(IROW) = ZERO 250 CONTINUE IERR = IGTCOL (ICOL) IF (IERR .EQ. 0) GO TO 255 TYPE 15,IERR GO TO 280 255 CONTINUE DO 265 IROW = 1,NROW IF (BUFA(IROW) .EQ. BUFB(IROW)) GO TO 260 TYPE 13,BUFA(IROW),BUFB(IROW) GO TO 280 260 CONTINUE 265 CONTINUE 270 CONTINUE C C Eliminate the array. C 280 CONTINUE IERR = IVELIM () IF (IERR .EQ. 0) GO TO 285 TYPE 5,IERR GO TO 290 285 CONTINUE TYPE 6 C 290 CONTINUE TYPE 2 RETURN END C C SUBROUTINE TSTCPX (NROW,NCOL) C C Test an array of complexes. C DIMENSION * BUFA(1024), * BUFB(1024) C COMPLEX * BUFA, ! for holding generated data * BUFB, ! for sending and receiving data * ZERO ! for clearing BUFB C INTEGER * ICOL, ! column index number * IERR, ! error return * IROW, ! row index number * NCOL, ! number of columns * NROW, ! number of rows * NSIZ ! number of bytes per array element C DATA * NSIZ /8/, * ZERO /(0.,0.)/ C 1 FORMAT (/,' TSTCPX: 85b20b') 2 FORMAT (' TSTCPX: All done') 3 FORMAT (' IVINIT: IERR =',I3) 4 FORMAT (' IVINIT: Array initialized') 5 FORMAT (' IVELIM: IERR =',I3) 6 FORMAT (' IVELIM: Array eliminated') 7 FORMAT (' IPTROW: IERR =',I3) 8 FORMAT (' IGTROW: IERR =',I3) 9 FORMAT (' IROW =',/) 10 FORMAT ('+ ',I5) 11 FORMAT (' IPTROW/IGTROW: Error',4F9.3) 12 FORMAT (' ICOL =',/) 13 FORMAT (' IPTCOL/IGTCOL: Error',4F9.3) 14 FORMAT (' IPTCOL: IERR =',I3) 15 FORMAT (' IGTCOL: IERR =',I3) C TYPE 1 C C Create and initialize the array. C IERR = IVINIT (NROW,NCOL,NSIZ,BUFB) IF (IERR .EQ. 0) GO TO 200 TYPE 3,IERR GO TO 290 200 CONTINUE TYPE 4 C C Test the transfer of rows of data between the array and BUFB. C TYPE 9 DO 235 IROW = 1,NROW TYPE 10,IROW DO 205 ICOL = 1,NCOL BUFA(ICOL) = CMPLX(128.*RAN(I,J),128.*RAN(I,J)) BUFB(ICOL) = BUFA(ICOL) 205 CONTINUE IERR = IPTROW (IROW) IF (IERR .EQ. 0) GO TO 210 TYPE 7,IERR GO TO 280 210 CONTINUE DO 215 ICOL = 1,NCOL BUFB(ICOL) = ZERO 215 CONTINUE IERR = IGTROW (IROW) IF (IERR .EQ. 0) GO TO 220 TYPE 8,IERR GO TO 280 220 CONTINUE DO 230 ICOL = 1,NCOL IF (BUFA(ICOL) .EQ. BUFB(ICOL)) GO TO 225 TYPE 11,BUFA(ICOL),BUFB(ICOL) GO TO 280 225 CONTINUE 230 CONTINUE 235 CONTINUE C TYPE 12 DO 270 ICOL = 1,NCOL TYPE 10,ICOL DO 240 IROW = 1,NROW BUFA(IROW) = CMPLX(128.*RAN(I,J),128.*RAN(I,J)) BUFB(IROW) = BUFA(IROW) 240 CONTINUE IERR = IPTCOL (ICOL) IF (IERR .EQ. 0) GO TO 245 TYPE 14,IERR GO TO 280 245 CONTINUE DO 250 IROW = 1,NROW BUFB(IROW) = ZERO 250 CONTINUE IERR = IGTCOL (ICOL) IF (IERR .EQ. 0) GO TO 255 TYPE 15,IERR GO TO 280 255 CONTINUE DO 265 IROW = 1,NROW IF (BUFA(IROW) .EQ. BUFB(IROW)) GO TO 260 TYPE 13,BUFA(IROW),BUFB(IROW) GO TO 280 260 CONTINUE 265 CONTINUE 270 CONTINUE C C Eliminate the array. C 280 CONTINUE IERR = IVELIM () IF (IERR .EQ. 0) GO TO 285 TYPE 5,IERR GO TO 290 285 CONTINUE TYPE 6 C 290 CONTINUE TYPE 2 RETURN END