Google
 

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.