Trailing-Edge
-
PDP-10 Archives
-
decus_20tap2_198111
-
decus/20-0047/unite.for
There is 1 other file named unite.for in the archive. Click here to see a list.
C PROGRAM UNITE
C
C DESCRIPTION
C THIS PROGRAM COMBINES TWO FILES OF RESPONSES TO DIFFERENT QUES-
C TIONS BY THE SAME RESPONDENTS.
C
C SOURCE
C NORMAN W. JOHNSON, DEPARTMENT OF MATHEMATICS, WHEATON COLLEGE,
C NORTON, MASS.
C
C INSTRUCTIONS
C CODED RESPONSES TO THE TWO SETS OF QUESTIONS SHOULD BE WRITTEN
C INTO ASCII DATA FILES BY THE PROGRAM SURVEY. THE ORDER OF THE
C RESPONDENTS AND THE FIRST 4 CHARACTERS OF THE 5-CHARACTER IDEN-
C TIFICATION OF EACH RESPONDENT SHOULD BE THE SAME IN BOTH FILES.
C
C THE PROGRAM WILL REQUEST THE NAMES OF THE TWO FILES TO BE UNITED
C AND, FOR EACH, THE RANGE OF QUESTIONS TO BE INCLUDED. THE USER
C SHOULD ENTER EITHER THE WORD "ALL", TWO NUMBERS JOINED BY A HY-
C PHEN TO INDICATE A BLOCK OF CONSECUTIVE QUESTIONS, OR ONE NUMBER
C FOR A SINGLE QUESTION. THE TOTAL NUMBER OF QUESTIONS INCLUDED
C FROM BOTH FILES MUST NOT EXCEED 128. THE TWO FILES WILL BE
C CHECKED TO SEE THAT THE NUMBER OF RESPONDENTS AND THEIR IDENTI-
C FICATIONS AGREE. THE PROGRAM WILL ALSO ASK FOR THE NAME (NOT
C MORE THAN 5 CHARACTERS) THAT THE NEW DATA FILE IS TO HAVE AND
C FOR A DESCRIPTION OF THE SURVEY (NOT MORE THAN 48 CHARACTERS).
C
C MORE THAN TWO FILES CAN BE COMBINED BY REPEATED EXECUTIONS OF
C THIS PROGRAM.
C
C ..................................................................
C
INTEGER A(48),TODAY(2),BLANK,UNIT
INTEGER R(128)
INTEGER DATA(2),MAP(2)
LOGICAL GROUP(2),JUMP
BLANK = 17315143744
CALL TIME(NOW)
CALL DATE(TODAY)
TYPE 1, NOW,TODAY
1 FORMAT (' UNITE ',8X,A5,9X,2A5//)
20 TYPE 2
2 FORMAT (/' FILES TO BE UNITED?'/)
DO 130 J=1,2
TYPE 21, J
21 FORMAT (' FILE ',I1,': ',$)
C ENTER FILE NAME.
30 ACCEPT 3, MAP(J)
3 FORMAT (A5)
31 FORMAT (/A5)
IF (MAP(J).EQ.' ') GO TO 20
GROUP(J) = RENAME(MAP(J),'.MAP',MAP(J),'.MAP')
UNIT = 20+J
IF (GROUP(J)) CALL IFIL(UNIT,MAP(J),'.MAP')
IF (GROUP(J)) READ (UNIT,31) DATA(J)
IF (.NOT.GROUP(J)) DATA(J) = MAP(J)
5 FORMAT (48A1)
CALL IFILE(UNIT,DATA(J))
C INPUT NUMBER OF QUESTIONS.
70 READ (UNIT,7) M
7 FORMAT (//I)
READ (UNIT,7) ID
GO TO 90
80 TYPE 8, M
8 FORMAT ('+INVALID ENTRY--NUMBERS RUN FROM 1 TO ',I3/)
90 TYPE 9
9 FORMAT ('+WHICH QUESTIONS? ',$)
C ENTER RANGE OF QUESTIONS TO BE INCLUDED.
100 ACCEPT 10, IA,IB
10 FORMAT (2I)
IB = IABS(IB)
IF (IA.LT.0 .OR. IA.GT.M .OR. IB.GT.M) GO TO 80
IF (IB.EQ.0) IB = IA
IF (IA.EQ.0 .AND. IB.NE.0 .OR. IA.GT.IB) GO TO 80
IA = MAX0(IA,1)
IF (IB.EQ.0) IB = M
IF (J.EQ.2) GO TO 120
110 I1A = IA
I1B = IB
GO TO 130
120 I2A = IA
I2B = IB
130 CONTINUE
M = I1B-I1A+I2B-I2A+2
IF (M.LE.128) GO TO 165
140 TYPE 14
14 FORMAT (' TOO MANY QUESTIONS--START OVER')
GO TO 20
150 TYPE 15
15 FORMAT (' FILES OF DIFFERENT LENGTH--CAN''T UNITE')
STOP
160 TYPE 16, ID1,ID2
16 FORMAT (' IDENTIFICATION MISMATCH: ',A4,' = ',A4,'?')
PAUSE
165 READ (21,24) ID1
READ (22,24) ID2
IF (ID1.EQ.BLANK .AND. ID2.NE.BLANK) GO TO 150
IF (ID1.NE.BLANK .AND. ID2.EQ.BLANK) GO TO 150
IF (ID1.NE.ID2) GO TO 160
IF (ID1.NE.BLANK) GO TO 165
C INPUT NUMBER OF RESPONDENTS.
READ (21,10) LAST
170 TYPE 17
17 FORMAT (' NEW FILE NAME? ',$)
C ENTER FILE NAME.
ACCEPT 3, UNION
FILE = RENAME(UNION,'.TMP',UNION,'.BAK')
180 TYPE 18
18 FORMAT (' DESCRIPTION: ',$)
C ENTER DESCRIPTION OF SURVEY.
ACCEPT 5, (A(I),I=1,48)
DO 190 I=48,1,-1
IF (A(I).NE.BLANK) GO TO 200
190 A(I) = 0
200 CALL OFIL(1,UNION,'.TMP')
WRITE (1,27)
WRITE (1,5) (A(I),I=1,48)
210 CALL IFILE(21,DATA(1))
READ (21,7) ID
220 CALL IFILE(22,DATA(2))
READ (22,7) ID
230 WRITE (1,23) M
23 FORMAT (2X,I3,' VARIABLES')
DO 240 K=1,2
READ (21,24) ID,(I1R,I=0,I1A-1),(R(I+1-I1A),I=I1A,I1B)
READ (22,24) ID,(I2R,I=0,I2A-1),(R(I+M-I2B),I=I2A,I2B)
240 WRITE (1,24) ID,BLANK,(R(I),I=1,M)
24 FORMAT (A4,A1,128I1)
IF (JUMP) GO TO 250
READ (21,26) ID
READ (22,26) ID
WRITE (1,27)
250 DO 260 K=JUMP+1,LAST
READ (21,26) ID,(I1R,I=0,I1A-1),(R(I+1-I1A),I=I1A,I1B)
READ (22,26) ID,(I2R,I=0,I2A-1),(R(I+M-I2B),I=I2A,I2B)
260 WRITE (1,26) ID,BLANK,(R(I),I=1,M)
26 FORMAT (A4,A1,128A1)
IF (JUMP) GO TO 390
WRITE (1,27)
27 FORMAT ()
280 WRITE (1,28) LAST
28 FORMAT (1X,I4,' RESPONDENTS')
290 END FILE 1
FILE = RENAME(UNION,'.BAK',UNION,'.DAT')
FILE = RENAME(UNION,'.DAT',UNION,'.TMP')
IF (.NOT.GROUP(1) .OR. .NOT.GROUP(2)) GO TO 400
FILE = RENAME(UNION,'.TMP',UNION,'.OLD')
300 CALL OFIL(1,UNION,'.TMP')
WRITE (1,31) UNION
310 CALL IFIL(21,MAP(1),'.MAP')
READ (21,7) ID
320 CALL IFIL(22,MAP(2),'.MAP')
READ (22,7) ID
LAST = 14
JUMP = .TRUE.
GO TO 230
390 END FILE 1
FILE = RENAME(UNION,'.OLD',UNION,'.MAP')
FILE = RENAME(UNION,'.MAP',UNION,'.TMP')
400 TYPE 40
40 FORMAT ('1CORRESPONDING VARIABLE NUMBERS:'/)
401 FORMAT (1X,A5,3X,16I4)
410 DO 415 K=0,7
M1 = MIN0(16*(K+1),I1B-I1A+1)
TYPE 27
IF (JUMP) DATA(1) = MAP(1)
TYPE 401, DATA(1),(I,I=16*K+I1A,M1+I1A-1)
TYPE 401, UNION,(I,I=16*K+1,M1)
415 IF (M1.GE.I1B-I1A+1) GO TO 420
420 DO 425 K=0,7
M2 = MIN0(M1+16*(K+1),M)
TYPE 27
IF (JUMP) DATA(2) = MAP(2)
TYPE 401, DATA(2),(I,I=16*K+I2A,M2+I2B-M)
TYPE 401, UNION,(I,I=M1+16*K+1,M2)
425 IF (M2.GE.M) GO TO 430
430 TYPE 43
43 FORMAT ('1')
STOP
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.