C*********************************************************************** C THIS SUBROUTINE IS DESIGNED TO CALL ROUTINES TO READ IN THE DATA C AND GIVE DESCRIPTIVE OUTPUT - LISTING OF THE CUT POINTS AND C FREQUENCIES AND A HISTOGRAM. THIS ROUTINE IS USED FOR GROUPED C DATA ANALYSIS. C C SUBROUTINES CALLED: FREE,HEADER,SORT,SKIP,HISTGM C*********************************************************************** SUBROUTINE GRPD C*********************************************************************** C DECLARATIONS C*********************************************************************** INCLUDE 'PARMTR.INC' INTEGER CNT, STATUS, SYSIN, FILPOS CHARACTER*1 LABEL, HEAD, DUM(80), KEY(4), UL LOGICAL GRP, POOL, PEST, SEST, DESC, DEF, CUTP, TRUNC, OK, EF, 1 WARN, SK, HELP C*********************************************************************** C COMMON STATEMENTS C*********************************************************************** COMMON /ALPHA/ LABEL(80), HEAD(30), UL(3,25) COMMON /PAGE/ IPAGE COMMON /FILE/ SYSIN, SK, FILPOS COMMON /NUM/ XL(MAXLIN), WIDTH, N, CNT, CONV(3), VARN, IDF, WARN COMMON /IND/ IC, II, IREP, STATUS COMMON /OPTION/ GRP, POOL, PEST, SEST, DESC, DEF, CUTP, TRUNC, 1 HELP COMMON /INTER/ KCUT, CUT(MAXCEL), FREQ(MAXCEL), NCUT, NKC(5), 1 NK(5), RFREQ(5,MAXCEL), CCUT(5,MAXCEL) C*********************************************************************** C DATA STATEMENTS C*********************************************************************** DATA ZERO /0.0/ DATA KEY /'E','N','D','.'/ C*********************************************************************** C FIRST READ IN THE HEADER STATEMENT FOR THIS PARTICULAR DATA SET. C IF THE FIRST FOUR CHARACTERS OF THE HEADER ARE END. THIS SIGNIFIES C THE END OF THE DATA FOR THE PARTICULAR SET OF CONTROL CARDS. C*********************************************************************** READ(SYSIN,180,END=170)(HEAD(I),I=1,30) DO 10 I=1,4 IF (KEY(I).NE.HEAD(I)) GO TO 20 10 CONTINUE C*********************************************************************** C THE END. CARD HAS BEEN ENCOUNTERED SO SET THE FLAG IC=-2 C*********************************************************************** IC=-2 RETURN 20 CALL HEADER (1) WRITE (6,240) C*********************************************************************** C NEXT READ IN THE CUT POINTS FOR THE INTERVALS. IF THERE ARE KCUT C INTERVALS THEN THERE SHOULD BE KCUT CUT POINTS,I.E.,0.,C(1),C(2),. C ,C(KCUT-1),C(KCUT) COMPLETELY DELINEATE THE INTERVALS BUT ZERO IS C ASSUMED.C(KCUT) IS EITHER INFINITY FOR UNTRUNCATED DATA OR POSSIBLY C W(WIDTH) IF TRUNCATED. W CAN BE SET TO SOMETHING LESS THAN C(KCUT) C IF FURTHER TRUNCATION IS DESIRED.EVEN THOUGH C(KCUT) IS INFINITY FOR C UNTRUNCATED DATA A VALUE SHOULD BE GIVEN FOR ILLUSTRATIVE PURPOSES C AND FOR ESTIMATION BY THE FOURIER SERIES AND EXPONENTIAL POWER C SERIES. C*********************************************************************** CALL FREE (MAXCEL,DUM,CUT,SYSIN,KCUT,NALPHA,OK,EF) IF (.NOT.OK) WRITE (6,190) 'Cut point input card.' IF (.NOT.EF) GO TO 30 WRITE (6,200) STOP 'TRANSECT Aborted.' C*********************************************************************** C IF THE CUT POINTS ARE OUT OF ORDER THEN SORT THEM. C*********************************************************************** 30 HOLD=0.0 DO 40 J=1,KCUT IF (CUT(J).LE.HOLD) GO TO 50 HOLD=CUT(J) 40 CONTINUE GO TO 60 50 CALL SORT (CUT,KCUT) WRITE (6,340) C*********************************************************************** C READ IN THE NUMBER OF OBSERVATIONS FOR EACH OF THE INTERVALS. C*********************************************************************** 60 CALL FREE (MAXCEL,DUM,FREQ,SYSIN,MCUT,NALPHA,OK,EF) IF (.NOT.OK) WRITE (6,190) 'Frequency input card.' IF (.NOT.EF) GO TO 70 WRITE (6,200) STOP 'TRANSECT Aborted.' 70 IF (KCUT.EQ.MCUT) GO TO 80 WRITE (6,220) CALL SKIP RETURN C*********************************************************************** C CONVERT THE CUT POINTS AND CALCULATE THE TOTAL SAMPLE SIZE. C*********************************************************************** 80 N=0 DO 90 I=1,KCUT CUT(I)=CUT(I)*CONV(1) RFREQ(1,I)=FREQ(I) 90 N=N+IFIX(FREQ(I)) CNT=N C*********************************************************************** C IF THE DATA IS TRUNCATED AND THE SPECIFIED WIDTH IS LESS THAN THE C LAST CUT POINT THEN DETERMINE HOW MANY OF THE INTERVALS WILL BE C USED AND CALCULATE THE NEW SAMPLE SIZE(CNT). C*********************************************************************** IF (TRUNC) GO TO 100 WIDTH=CUT(KCUT) GO TO 140 100 IF (WIDTH.LE.CUT(KCUT)) GO TO 110 WRITE (6,300) WIDTH=CUT(KCUT) GO TO 140 110 IF (WIDTH.EQ.CUT(KCUT)) GO TO 140 CNT=0 OK=.TRUE. KCUTM1=KCUT-1 DO 130 I=1,KCUTM1 IF (CUT(I).LE.WIDTH) GO TO 120 WIDTH=CUT(I-1) KCUT=I-1 OK=.FALSE. GO TO 140 120 CNT=CNT+IFIX(FREQ(I)) IF (CUT(I).LT.WIDTH) GO TO 130 KCUT=I GO TO 140 130 CONTINUE C*********************************************************************** C WRITE OUT THE DESCRIPTIVE OUTPUT - LISTING AND HISTOGRAM C*********************************************************************** 140 CALL HEADER (2) WRITE (6,280) CALL HEADER (1) WRITE (6,330) (UL(1,J),J=1,25) WRITE (6,250) ZERO,CUT(1),FREQ(1) IF (KCUT.EQ.1) GO TO 150 KCUTM2=KCUT-2 WRITE (6,260) (CUT(I),CUT(I+1),FREQ(I+1),I=1,KCUTM2) IF (.NOT.TRUNC) WRITE (6,270) CUT(KCUT-1),FREQ(KCUT) IF (TRUNC) WRITE (6,260) CUT(KCUT-1),CUT(KCUT),FREQ(KCUT) WRITE (6,320) IF (.NOT.OK) WRITE (6,230) WIDTH,KCUT 150 IF (CNT.LT.N) WRITE (6,350) CNT IF (KCUT.LE.10) GO TO 160 CALL HEADER (1) WRITE (6,310) 160 WRITE (6,290) (UL(1,J),J=1,25) NCUT=1 CALL HISTGM (FREQ,KCUT,38,CUT) RETURN C*********************************************************************** C END OF THE DATA FILE. ALL DATA AND CONTROL CARDS HAVE BEEN C PROCESSED SET THE FLAG IC=-1 C*********************************************************************** 170 IC=-1 RETURN C*********************************************************************** C FORMAT STATEMENTS C*********************************************************************** C 180 FORMAT (30A1) 190 FORMAT ('0*** ERROR - ',A/13X,'Will attempt processing.') 200 FORMAT ('0*** TERMINAL ERROR - End of file encountered while', 1' processing control cards.') 220 FORMAT ('0*** TERMINAL ERROR - An improper number of cut points', 1' or frequencies was given.') 230 FORMAT ('0*** WARNING - Specified width fell in between cut', 1' points.'/ 2' The width was changed to the greatest cut point less than the', 3' specified width.'/' The new width is',G13.6,' and', 4 I2,' intervals were used.') 240 FORMAT (//10X,60('*')/10X,'*',58X,'*'/10X,'*', 1 21X,'Data Description',21X,'*'/10X,'*',58X,'*'/10X,60('*')) 250 FORMAT (//18X,'Cut Points',12X,'Number Observed'/7X,50('-')/ 1 10X,F7.5,4X,' - ',G14.6,5X,F6.0) 260 FORMAT (7X,G14.6,' - ',G14.6,5X,F6.0) 270 FORMAT (7X,G14.6,' - INFINITY',8X,F6.0) 280 FORMAT (//'0The descriptive output for grouped data is quite', 1' simple. The output'/ 2' includes a listing of the cut points for perpendicular', 3' distances and the'/ 4' number of observations between the cut points, and a', 5' histogram of the data.'/ 6' Caution must be exercised in interpreting histograms', 7' with unequal intervals.') 290 FORMAT ('0Histogram of perpendicular distances in ',25A1/) 300 FORMAT ('0***WARNING - The specified width given is greater', 1' than the last'/ 2' cut point. It has been set equal to the last cut point.') 310 FORMAT (//) 320 FORMAT (7X,50('-')) 330 FORMAT (/'0Data listing of cut points for perpendicular'/ 1' distances in ',25A1/ 2' and numbers of observations (frequencies).') 340 FORMAT ('0*** WARNING - Cut points were out of order. They', 1' have been rearranged.') 350 FORMAT (' *** NOTE - The data have been truncated at a width', 1' such that some of the'/' data have not been used. Only ', 3I4,' data points have been used.') END