
C     PROGRAM SURVEY
C
C     DESCRIPTION
C	THIS PROGRAM READS CODED RESPONSES TO A QUESTIONNAIRE AND WRITES
C	THEM INTO AN ASCII DATA FILE.
C
C     SOURCE
C	NORMAN W. JOHNSON, DEPARTMENT OF MATHEMATICS, WHEATON COLLEGE,
C	NORTON, MASS.
C
C     INSTRUCTIONS
C	THERE SHOULD BE NO MORE THAN 128 QUESTIONS.  RESPONSES MAY BE
C	CODED BY ANY DIGIT FROM 0 TO 9.  ADDITIONAL SYMBOLS THAT MAY BE
C	USED ARE THE MINUS SIGN (-), THE AMPERSAND (&), AND THE BLANK,
C	INTERPRETED RESPECTIVELY AS THE NUMBERS 11, 12, AND 13.  THESE
C	SHOULD BE RESERVED FOR SUCH CATEGORIES AS "NOT APPLICABLE",
C	"DON'T KNOW", AND "NO RESPONSE".
C
C	THE FIRST 5 COLUMNS OF EACH DATA CARD ARE FOR IDENTIFICATION,
C	WITH THE FIRST 4 COLUMNS BEING UNIQUE TO THE RESPONDENT.  THE
C	NEXT 67 COLUMNS OF THE CARD ARE FOR THE CODED RESPONSES, ONE
C	COLUMN PER QUESTION.  THE LAST 8 COLUMNS ARE NOT USED.  IF THERE
C	ARE MORE THAN 67 QUESTIONS, A SECOND CARD FOR EACH RESPONDENT
C	MAY BE PREPARED IN THE SAME MANNER.
C
C	THE SET OF DATA CARDS MUST BE PRECEDED BY FIVE OR SEVEN PROGRAM
C	CARDS.  THE FIRST OF THESE HAS PUNCHED IN ITS FIRST 5 COLUMNS
C	THE NAME THAT THE DATA FILE IS TO HAVE.  THE SECOND MAY BE USED
C	FOR A DESCRIPTION OF THE SURVEY (NOT MORE THAN 48 CHARACTERS).
C	THE THIRD CARD SPECIFIES THE NUMBER OF QUESTIONS (ANY FORMAT
C	IS ACCEPTABLE).  THE LAST TWO CARDS OR PAIRS OF CARDS, PUNCHED
C	IN THE SAME FORMAT AS THE DATA CARDS, INDICATE RESPECTIVELY THE
C	LOWEST NUMBER AND THE HIGHEST NUMBER TO BE COUNTED AS A RESPONSE
C	TO EACH QUESTION.  NUMBERS OUTSIDE THIS RANGE ARE TREATED AS "NO
C	RESPONSE" AND EXCLUDED FROM THE TOTAL.  ON THESE CARDS BLANKS
C	AND MINUS SIGNS ARE EQUIVALENT TO ZEROS, AND AMPERSANDS MAY NOT
C	BE USED.
C
C	THE LAST DATA CARD MUST BE FOLLOWED BY A SINGLE BLANK CARD OR A
C	PAIR OF BLANK CARDS, ACCORDING AS ONE OR TWO CARDS ARE USED FOR
C	EACH RESPONDENT.
C
C	THIS PROGRAM ASSUMES THAT INPUT IS FROM THE USER TERMINAL AND
C	OUTPUT IS TO THE DISK.  IF A DIFFERENT INPUT DEVICE, SUCH AS THE
C	SYSTEM CARD READER, IS TO BE USED, IT SHOULD BE ASSIGNED LOGICAL
C	UNIT 5 PRIOR TO RUNTIME.  ALSO, FOR INPUT FROM THE CARD READER,
C	THE USER SHOULD RESPOND TO THE PROGRAM'S REQUEST FOR DATA BY
C	TYPING "@CDR:".  FOR INPUT FROM A FILE ON THE DISK, THE USER
C	SHOULD TYPE "@DSK:FILNAM.EXT", WHERE 'FILNAM.EXT' IS THE NAME
C	OF A CARD-IMAGE SOURCE FILE.
C
C     SPECIAL INSTRUCTIONS FOR NONSTANDARD SOURCE DECKS
C	DATA CARDS DO NOT NEED TO BE PREPARED IN EXACT ACCORDANCE WITH
C	THE ABOVE INSTRUCTIONS TO BE ACCEPTABLE, PROVIDED THAT (1) THERE
C	ARE NO MORE THAN TWO CARDS PER RESPONDENT, (2) EACH CARD CON-
C	TAINS AN IDENTIFICATION LABEL, AND (3) THE ONLY RESPONSE CODES
C	USED ARE DIGITS, MINUS SIGNS, AMPERSANDS, AND BLANKS.  WHEN A
C	NONSTANDARD SOURCE DECK IS INPUT, THE PROGRAM CARD SPECIFYING
C	THE NUMBER OF QUESTIONS MUST BE REPLACED BY A FORMAT CARD GIVING
C	THE BLOCKS OF COLUMNS IN WHICH IDENTIFICATION AND RESPONSES ARE
C	PUNCHED ON EACH DATA CARD.
C
C	FOR EXAMPLE, IF THE SOURCE DECK CONTAINS ONE CARD PER RESPONDENT
C	WITH RESPONSES PUNCHED IN COLUMNS 1 THROUGH 72 AND IDENTIFICA-
C	TION IN COLUMNS 74 THROUGH 80, THE FORMAT CARD SHOULD READ:
C		74-80,1-72
C	FOR A SOURCE DECK CONTAINING TWO CARDS PER RESPONDENT, HAVING
C	IDENTIFICATION IN THE FIRST 4 COLUMNS OF EACH CARD AND RESPONSES
C	IN COLUMNS 5 THROUGH 80 OF THE FIRST CARD AND 5 THROUGH 64 OF
C	THE SECOND CARD, BUT WITH THE LAST 8 RESPONSES TO BE IGNORED,
C	THE FORMAT CARD SHOULD READ:
C		1-4,5-80/1-4,5-56
C
C     RELATED PROGRAMS
C	THE PROGRAM SORTER TABULATES THE RESPONSES TO EACH QUESTION OF
C	THE QUESTIONNAIRE BY FREQUENCIES AND PERCENTAGES.  THE PROGRAM
C	CROSS CORRELATES RESPONSES TO SELECTED QUESTIONS TO GIVE MAR-
C	GINAL FREQUENCIES, CROSS-TABULATIONS, AND OTHER STATISTICS AND
C	PERMITS THE COLLAPSING OF TABLES AND THE COMBINING OF VARIABLES.
C	THE PROGRAM MERGE COMBINES UP TO 64 FILES OF RESPONSES TO THE
C	SAME SET OF QUESTIONS.  THE PROGRAM UNITE COMBINES TWO FILES OF
C	RESPONSES TO DIFFERENT QUESTIONS BY THE SAME RESPONDENTS.
C
C     ..................................................................
C
      INTEGER A(48),TODAY(2),IFMT(13),AFMT(13),NEW(7),END(4)
      INTEGER XOFF,BLANK,TWELVE,ELEVEN,ZERO,NINE
      INTEGER R(128),IR(2)
      LOGICAL SKIP
      COMMON IFMT,AFMT,NEW,END
      DATA IFMT /'    (         A  4  ,     1 X,     ',
     1  ' 67  I1 /  5 X,      61  I1 ) '/
      DATA AFMT /'    (         A  4  ,     1 X,     ',
     1  ' 67  A1 /  5 X,      61  A1 ) '/
      IR(1) = 'LOW'
      IR(2) = 'HIGH'
      XOFF   = 17260188454
      BLANK  = 17315143744
      TWELVE = 20536369216
      ELEVEN = 24294465600
      ZERO   = 25905078336
      NINE   = 30736916544
      CALL TIME(NOW)
      CALL DATE(TODAY)
      TYPE 1, NOW,TODAY
    1 FORMAT (' SURVEY',8X,A5,9X,2A5//)
   20 TYPE 2
    2 FORMAT (/' ENTER DATA.'//)
C     ENTER FILE NAME.
   30 ACCEPT 3, DATA,FILNAM,EXT
    3 FORMAT (3A5)
      IF (DATA.EQ.' ') GO TO 20
      SKIP = DATA.LT.'A'
      IF (DATA.EQ.'@DSK:') CALL IFIL(5,FILNAM,EXT)
      IF (SKIP) READ (5,3) DATA
      FILE = RENAME(DATA,'.TMP',DATA,'.BAK')
      CALL OFIL(1,DATA,'.TMP')
      WRITE (1,17)
C     ENTER DESCRIPTION OF SURVEY.
   50 READ (5,5) (A(I),I=1,48)
    5 FORMAT (48A1)
      DO 60  I=48,1,-1
      IF (A(I).NE.BLANK) GO TO 70
   60 A(I) = 0
   70 WRITE (1,5) (A(I),I=1,48)
C     ENTER NUMBER OF QUESTIONS OR FORMAT INFORMATION.
  100 READ (5,10) (NEW(2*I-1),END(I),I=1,4)
   10 FORMAT (8I)
      M = NEW(1)
      IF (END(1).NE.0) CALL FORMAT(M)
      IF (M.GE.2 .AND. M.LE.128) GO TO 110
      IF (SKIP) STOP 100
      TYPE 3, XOFF
      PAUSE 'MISSING OR IMPROPER SPECIFICATION'
      GO TO 100
  110 WRITE (1,11) M
   11 FORMAT (2X,I3,' VARIABLES')
      IF (END(1).EQ.0 .AND. M.GT.67) GO TO 120
      IF (END(1).NE.0 .AND. NEW(5).NE.0) GO TO 120
      DO 115  I=9,12
      IFMT(I) = BLANK
  115 AFMT(I) = BLANK
  120 DO 140  K=1,2
      GO TO 130
  125 TYPE 3, XOFF,ID
      IERR = IERR+1
      IF (SKIP) GO TO 140
      PAUSE 'ILLEGAL CHARACTER IN INPUT STRING'
C     ENTER LOWEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
C     ENTER HIGHEST NUMBER USED AS CODED RESPONSE TO EACH QUESTION.
  130 READ (5,IFMT,ERR=125) ID,(R(I),I=1,M)
  140 WRITE (1,14) IR(K),(R(I),I=1,M)
   14 FORMAT (A4,1X,128I1)
      WRITE (1,17)
      LAST = 0
C     ENTER RESPONSES TO QUESTIONS BY EACH RESPONDENT.
  150 READ (5,AFMT,END=170) ID,(R(I),I=1,M)
      IF (ID.EQ.BLANK) GO TO 170
      DO 155  I=1,M
      IF (R(I).GE.ZERO .AND. R(I).LE.NINE) GO TO 155
      IF (R(I).EQ.BLANK)  GO TO 155
      IF (R(I).EQ.TWELVE) GO TO 155
      IF (R(I).EQ.ELEVEN) GO TO 155
      TYPE 3, XOFF,ID,R(I)
      IERR = IERR+1
      IF (SKIP) GO TO 155
      PAUSE 'ILLEGAL CHARACTER IN INPUT STRING'
      GO TO 150
  155 CONTINUE
  160 WRITE (1,16) ID,(R(I),I=1,M)
   16 FORMAT (A4,1X,128A1)
      LAST = LAST+1
      GO TO 150
  170 WRITE (1,17)
   17 FORMAT ()
  180 WRITE (1,18) LAST
   18 FORMAT (1X,I4,' RESPONDENTS')
      END FILE 1
      FILE = RENAME(DATA,'.BAK',DATA,'.DAT')
      FILE = RENAME(DATA,'.DAT',DATA,'.TMP')
      IF (IERR.NE.0 .AND. SKIP) TYPE 19
   19 FORMAT (/' ILLEGAL CHARACTERS IN ABOVE LINES'/)
      TYPE 18, LAST
      STOP
      END
C
      SUBROUTINE FORMAT(M)
      INTEGER IFMT(13),AFMT(13),NEW(7),END(4),NEWFMT(7)
      COMMON IFMT,AFMT,NEW,END
      M = 0
      NEW(5) = NEW(7)
      IF (NEW(1).LT.1 .OR. -END(1).GT.80 .OR. NEW(1).GT.-END(1)) RETURN
      IF (NEW(3).LT.1 .OR. -END(2).GT.80 .OR. NEW(3).GT.-END(2)) RETURN
      IF (NEW(5).LT.0 .OR. -END(4).GT.80 .OR. NEW(5).GT.-END(4)) RETURN
      M = 2-END(2)-NEW(3)-END(4)-NEW(5)+(NEW(5).EQ.0)
      IF (M.LT.2 .OR. M.GT.128) RETURN
      NEW(2) = MIN0(1-END(1)-NEW(1),4)
      NEW(4) = 1-END(2)-NEW(3)
      NEW(6) = 1-END(4)-NEW(5)
      ENCODE (35,103,NEWFMT) NEW
  103 FORMAT (3(' T',I2,',',I3,2X),I5)
      IF (NEW(1).EQ.1) NEWFMT(1) = ' '
      IF (NEW(3).EQ.NEW(1)+NEW(2)) NEWFMT(3) = ' '
      IF (NEW(5).EQ.1) NEWFMT(5) = ' '
      DO 105  I=1,6
      IFMT(2*I) = NEWFMT(I)
  105 AFMT(2*I) = NEWFMT(I)
      RETURN
      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.
