PROGRAM GATSCAT C C Driver for testing GATHER/SCATTER. C Martin J. McBride. 10/25/85. C General Electric CRD, Information System Operation. C C FORTRAN logical unit numbers used: C Input: 3 One line containing CRAY information C Input: 17 Input data for GATHER/SCATTER C Output: 18 Output data for GATHER/SCATTER C PARAMETER(NROUTS = 2) CHARACTER ROUTNME*31,SUBNAME*31,IDENT*5,DATEIN*8 CHARACTER DATERUN*8,COMMENTS*23,HRDWRE*30 CHARACTER DUMMY*30,PERSON*5 INTEGER NTESTS,NFAILS,TTESTS,TFAILS,TEMP DOUBLE PRECISION TOL,PFAILS DIMENSION NTESTS(NROUTS),NFAILS(NROUTS),SUBNAME(NROUTS) DATA NTESTS,NFAILS /NROUTS*0,NROUTS*0/ C An array is set up to hold the names of the 2 subprograms of GATHER/SCATTER. SUBNAME(1) = 'GATHER' SUBNAME(2) = 'SCATTER' C Initialization of tolerance value and CRAY information. TOL = 0.0000000001 READ(3,505) HRDWRE CLOSE(3) C Initialization of data heading. READ(17,500,END=99) ROUTNME,IDENT,DATEIN,PERSON,DATERUN,COMMENTS 15 IF (ROUTNME .NE. ' ') GO TO 20 READ(17,500,END=99) ROUTNME,IDENT,DATEIN,PERSON,DATERUN,COMMENTS GO TO 15 C Loop to run through all sets of input data, which ends with XXX. 20 IF (ROUTNME .EQ. 'XXX') GO TO 99 READ(17,505,END=99) DUMMY CALL FDATE(DATERUN) WRITE(18,590) WRITE(18,590) WRITE(18,600) ROUTNME,IDENT,DATEIN,PERSON,DATERUN,COMMENTS WRITE(18,605) HRDWRE 500 FORMAT(A31,A5,A8,A5,A8,A23) 505 FORMAT(A30) 590 FORMAT(1X) 600 FORMAT(A31,A5,A8,A5,A8,A23) 605 FORMAT(A30) C Determine which of the subprograms is currently being tested. IF (ROUTNME .EQ. 'GATHER') THEN TEMP = NFAILS(1) CALL DRGATHER(NTESTS(1),NFAILS(1),TOL) IF (NFAILS(1) .GT. TEMP) WRITE(6,900) IDENT ELSE IF (ROUTNME .EQ. 'SCATTER') THEN TEMP = NFAILS(2) CALL DRSCATTR(NTESTS(2),NFAILS(2),TOL) IF (NFAILS(2) .GT. TEMP) WRITE(6,900) IDENT ELSE PRINT*,'ERROR IN ROUTINE NAME --- ',ROUTNME PRINT*,' IDENTIFICATION # ',IDENT STOP ENDIF 900 FORMAT(1X,'ERROR IN SCIPORT RESULT - DATA ID# ',A5) C Read next data input heading. READ(17,500,END=99) ROUTNME,IDENT,DATEIN,PERSON,DATERUN,COMMENTS 30 IF (ROUTNME .NE. ' ') GO TO 20 READ(17,500,END=99) ROUTNME,IDENT,DATEIN,PERSON,DATERUN, & COMMENTS GO TO 30 C Print XXX at bottom of output file and proceed to printing of results. 99 CONTINUE WRITE(18,590) WRITE(18,590) WRITE(18,600) ROUTNME C Output of results of all test data. DO 55 I = 1,NROUTS WRITE(6,700) WRITE(6,705) SUBNAME(I) IF (NTESTS(I) .EQ. 0) THEN WRITE(6,708) WRITE(6,707) WRITE(6,708) ELSE IF (NFAILS(I) .GT. 0) THEN PFAILS = DBLE(NFAILS(I))/DBLE(NTESTS(I)) * 100.0 WRITE(6,708) WRITE(6,710) NTESTS(I) WRITE(6,715) NFAILS(I) WRITE(6,720) PFAILS WRITE(6,708) ELSE WRITE(6,710) NTESTS(I) WRITE(6,730) ENDIF 55 CONTINUE C Compute and print totals. TTESTS = 0 TFAILS = 0 DO 65 I = 1,NROUTS TTESTS = TTESTS + NTESTS(I) TFAILS = TFAILS + NFAILS(I) 65 CONTINUE WRITE(6,700) WRITE(6,700) WRITE(6,701) WRITE(6,700) WRITE(6,702) PFAILS = DBLE(TFAILS)/DBLE(TTESTS) * 100.0 WRITE(6,710) TTESTS WRITE(6,715) TFAILS WRITE(6,720) PFAILS WRITE(6,700) 700 FORMAT(1X) 701 FORMAT(1X,50('-')) 702 FORMAT(1X,'TOTALS') 705 FORMAT(1X,A31) 707 FORMAT(5X,'There were no tests performed on this unit.') 708 FORMAT(45X,'******') 710 FORMAT(5X,'Number of tests performed: ',I4) 715 FORMAT(5X,'Number of tests that failed: ',I4) 720 FORMAT(5X,'Percentage of failures: ',F6.2) 730 FORMAT(5X,'All tests on this unit were successful.') CLOSE(17) CLOSE(18) END C------------------------------------------------------------- ************ C DRGATHER C ************ SUBROUTINE DRGATHER(NTESTS,NFAILS,TOL) C C Test driver for GATHER. C Martin J. McBride. 10/30/85. C General Electric CRD, Information System Operation C PARAMETER(MAXDIM = 50) CHARACTER*10 STR1,STR2,STR3,STR4,MESS*8 LOGICAL FAILED INTEGER NTESTS,NFAILS,I,NA,NB,INDEX DOUBLE PRECISION TOL,A,B,CRA DIMENSION A(MAXDIM),B(MAXDIM),CRA(MAXDIM),INDEX(MAXDIM) C Read and write input data and read previous results. READ(17,*) STR1,NA,NB MESS = 'DRGATHER' CALL DIMCHECK(NA,MAXDIM,MESS) CALL DIMCHECK(NB,MAXDIM,MESS) READ(17,*) STR2,(B(I), I=1,NB) READ(17,*) STR3,(INDEX(I), I=1,NA) READ(17,*) STR4,(CRA(I), I=1,NA) WRITE(18,600) STR1,NA,NB WRITE(18,605) STR2,(B(I), I=1,NB) WRITE(18,610) STR3,(INDEX(I), I=1,NA) CALL GATHER(NA,A,B,INDEX) C Check difference between new and previous results. FAILED = .FALSE. DO 10 I = 1,NA DIFF = CRA(I) - A(I) IF (ABS(DIFF) .GE. TOL) FAILED = .TRUE. 10 CONTINUE C Output new results and increment counters. WRITE(18,605) STR4,(A(I), I=1,NA) IF (FAILED) NFAILS = NFAILS + 1 NTESTS = NTESTS + 1 600 FORMAT('''',A10,'''',1X,2I4) 605 FORMAT('''',A10,'''',1X,2(G21.14,','),G21.14,:/(13X,G21.14, & ',',G21.14,',',G21.14)) 610 FORMAT('''',A10,'''',1X,9(I5,','),I5,:/(13X,I5,',',I5,',', & I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5)) RETURN END C------------------------------------------------------------- ************ C DRSCATTR C ************ SUBROUTINE DRSCATTR(NTESTS,NFAILS,TOL) C C Test driver for SCATTER. C Martin J. McBride. 10/30/85. C General Electric CRD, Information System Operation C PARAMETER(MAXDIM = 50) CHARACTER*10 STR1,STR2,STR3,STR4,MESS*8 LOGICAL FAILED INTEGER NTESTS,NFAILS,I,NA,NB,INDEX DOUBLE PRECISION TOL,A,B,CRA DIMENSION A(MAXDIM),B(MAXDIM),CRA(MAXDIM),INDEX(MAXDIM) C Read and write input data and read previous results. READ(17,*) STR1,NA,NB MESS = 'DRSCATTR' CALL DIMCHECK(NA,MAXDIM,MESS) CALL DIMCHECK(NB,MAXDIM,MESS) READ(17,*) STR2,(B(I), I=1,NB) READ(17,*) STR3,(INDEX(I), I=1,NB) READ(17,*) STR4,(CRA(I), I=1,NA) WRITE(18,600) STR1,NA,NB WRITE(18,605) STR2,(B(I), I=1,NB) WRITE(18,610) STR3,(INDEX(I), I=1,NB) CALL SCATTER(NB,A,INDEX,B) C Check difference between new and previous results. FAILED = .FALSE. DO 10 I = 1,NA DIFF = CRA(I) - A(I) IF (ABS(DIFF) .GE. TOL) FAILED = .TRUE. 10 CONTINUE C Output new results and increment counters. WRITE(18,605) STR4,(A(I), I=1,NA) IF (FAILED) NFAILS = NFAILS + 1 NTESTS = NTESTS + 1 600 FORMAT('''',A10,'''',1X,2I4) 605 FORMAT('''',A10,'''',1X,2(G21.14,','),G21.14,:/(13X,G21.14, & ',',G21.14,',',G21.14)) 610 FORMAT('''',A10,'''',1X,9(I5,','),I5,:/(13X,I5,',',I5,',', & I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5,',',I5)) RETURN END C------------------------------------------------------------- ************ C DIMCHECK C ************ SUBROUTINE DIMCHECK(NUSED,NALLCTD,MESS) C C Checks the bounds on an array. C CHARACTER*(*) MESS IF(NUSED.LE.NALLCTD)RETURN PRINT *,' DIMENSION FOR ',MESS,' = ',NALLCTD,' EXCEEDED BY ', 1 NUSED - NALLCTD STOP ' SORRY ' END