Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0047/merge.for
There are 3 other files named merge.for in the archive. Click here to see a list.
C PROGRAM MERGE
C
C DESCRIPTION
C THIS PROGRAM COMBINES UP TO 64 FILES OF RESPONSES TO THE SAME
C QUESTIONS BY DIFFERENT RESPONDENTS.
C
C SOURCE
C NORMAN W. JOHNSON, DEPARTMENT OF MATHEMATICS, WHEATON COLLEGE,
C NORTON, MASS.
C
C INSTRUCTIONS
C EACH SET OF CODED RESPONSES TO THE QUESTIONS SHOULD BE WRITTEN
C INTO AN ASCII DATA FILE BY THE PROGRAM SURVEY. THE ORDER OF THE
C QUESTIONS SHOULD BE THE SAME IN EACH FILE, THOUGH IT IS PERMIS-
C SIBLE FOR SOME FILES TO HAVE EXTRA QUESTIONS AT THE END.
C
C THE PROGRAM WILL REQUEST THE NUMBER OF FILES TO BE MERGED AND
C THEIR NAMES. THE NAME OF EACH FILE MAY BE ENTERED INDIVIDUALLY.
C ALTERNATIVELY, INSTEAD OF ENTERING A FILE NAME, THE USER MAY
C SIMPLY PRESS <RETURN>, IN WHICH CASE THE PROGRAM WILL ASSUME
C THAT SUCCEEDING FILES ARE NAMED "SET1", "SET2", ETC. THE PRO-
C GRAM WILL ALSO ASK FOR THE NAME (NOT MORE THAN 5 CHARACTERS)
C THAT THE NEW DATA FILE IS TO HAVE AND FOR A DESCRIPTION OF THE
C SURVEY (NOT MORE THAN 48 CHARACTERS).
C
C ..................................................................
C
INTEGER A(48),TODAY(2),BLANK
INTEGER L(128),H(128),R(128)
INTEGER DATA(64)
DATA L,H /128*9,128*0/
BLANK = 17315143744
CALL TIME(NOW)
CALL DATE(TODAY)
TYPE 1, NOW,TODAY
1 FORMAT (' MERGE ',8X,A5,9X,2A5//)
20 TYPE 2
2 FORMAT (/' NUMBER OF FILES TO BE MERGED? ',$)
ACCEPT 10, N
IF (N.LT.2 .OR. N.GT.64) GO TO 20
TYPE 19
DO 35 J=1,N
IF (J.GE.10) R(J) = BLANK
TYPE 21, R(J),J
21 FORMAT ('+FILE',A1,I2,': ',$)
C ENTER FILE NAME.
30 ACCEPT 3, DATA(J)
3 FORMAT (A5)
IF (DATA(J).EQ.BLANK) GO TO 300
35 CONTINUE
40 TYPE 4
4 FORMAT (' NEW FILE NAME? ',$)
C ENTER FILE NAME.
ACCEPT 3, WHOLE
TYPE 41
41 FORMAT (' DESCRIPTION: ',$)
C ENTER DESCRIPTION OF SURVEY.
50 ACCEPT 5, (A(I),I=1,48)
5 FORMAT (48A1)
DO 60 I=48,1,-1
IF (A(I).NE.BLANK) GO TO 80
60 A(I) = 0
M = 0
80 DO 180 J=1,N
CALL IFILE(21,DATA(J))
READ (21,9)
9 FORMAT (//I)
C INPUT NUMBER OF QUESTIONS.
100 READ (21,10) MJ
10 FORMAT (I)
M = MAX0(M,MJ)
C INPUT LOWEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
120 READ (21,14) IL,(R(I),I=1,MJ)
DO 130 I=1,MJ
130 L(I) = MIN0(L(I),R(I))
C INPUT HIGHEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
140 READ (21,14) IH,(R(I),I=1,MJ)
14 FORMAT (A5,128I1)
DO 150 I=1,MJ
150 H(I) = MAX0(H(I),R(I))
C INPUT MAPPING INDICATOR FOR EACH QUESTION.
160 READ (21,16) ID,(R(I),I=1,MJ)
16 FORMAT (A5,128A1)
DO 180 I=1,MJ
IF (R(I).EQ.BLANK) GO TO 180
170 TYPE 17, DATA(J)
17 FORMAT (' MAPPED VARIABLE FOUND IN FILE ',A5)
PAUSE
180 CONTINUE
FILE = RENAME(WHOLE,'.TMP',WHOLE,'.BAK')
CALL OFIL(1,WHOLE,'.TMP')
WRITE (1,19)
19 FORMAT ()
WRITE (1,5) (A(I),I=1,48)
200 WRITE (1,201) M
201 FORMAT (2X,I3,' VARIABLES')
220 WRITE (1,14) IL,(L(I),I=1,M)
240 WRITE (1,14) IH,(H(I),I=1,M)
WRITE (1,19)
LAST = 0
DO 280 J=1,N
CALL IFILE(21,DATA(J))
READ (21,9) ID
READ (21,9) ID
C INPUT RESPONSES TO QUESTIONS BY EACH RESPONDENT.
250 READ (21,16) ID,(R(I),I=1,M)
IF (ID.EQ.BLANK) GO TO 280
260 WRITE (1,16) ID,(R(I),I=1,M)
LAST = LAST+1
GO TO 250
280 CONTINUE
WRITE (1,19)
290 WRITE (1,29) LAST
29 FORMAT (1X,I4,' RESPONDENTS')
END FILE 1
FILE = RENAME(WHOLE,'.BAK',WHOLE,'.DAT')
FILE = RENAME(WHOLE,'.DAT',WHOLE,'.TMP')
TYPE 29, LAST
STOP
300 K = J-1
N1 = MIN0(9,N-K)
DO 310 J=1,N1
310 DATA(J+K) = 'SET0'+256*J
IF (N-K.LT.10) GO TO 40
DO 320 J=10,N-K
320 DATA(J+K) = 'SET00'+236*(J/10)+2*J
GO TO 40
END
C
C LOGICAL FUNCTION RENAME(NEWNAM,NEWEXT,OLDNAM,OLDEXT)
C RETURNS VALUE .FALSE. IF FILE OLDNAM.EXT DOES NOT EXIST.
C OTHERWISE, RENAME IS .TRUE. AND FILE IS RENAMED NEWNAM.EXT
C WITH PROTECTION <155>. THIS SUBPROGRAM IS WRITTEN IN THE
C MACRO-10 ASSEMBLER LANGUAGE.