File KUWA3B.FT (FORTRAN source file)

Directory of image this file is from
This file as a plain text file


C						SEITE 1
C	KUWA3B
C
C       AUSDRUCK DER FACHBELEGUNGSLISTEN
C
        COMMON IFORM,IHALB,ISTA,ISTB,ISTD,ISTE,ISTF,ISTG,ISTL,ISTM
        COMMON LANF,IANF,I,I2,IZFA,IZFE,N
        DIMENSION I(11,148),I2(148),FACH(2,42),N(67),IKN(148),IFE(227)
	ISTFN=1+ISTA
	CALL RTAPE(1,ISTFN,252,FACH)
        WRITE (1,570)
100     FORMAT (A2)
C	SCHAFFUNG EINES VARIABLEN EINSTIEGS
C	UM BEI JEDER BELIEBIGEN KURSART ODER FACH ZU BEGINNEN
C	( Z.B. NACH EINEM FEHLER )
	READ (1,900) KUART,LFANF
900	FORMAT ('KURSART       'I1/'ANFANGSFACH  'I2)
	GOTO (10,60,80,50,70),KUART
C       LEISTUNGSKURSE
10      IWEI1=1
        ICA=2
        ICE=3
        GOTO 99
40      IF (IFORM+911)50,80,50
C       GRUNDKURSE KLASSE 11/1
60      IWEI1=2
        ICA=2
        ICE=11
        GOTO 99
C       3. ABITURFACH
50      IWEI1=4
        ICA=4
        ICE=4
        GOTO 99
C       4. ABITURFACH
70      IWEI1=5
        ICA=5
        ICE=5
        GOTO 99
C       GRUNDKURSE AB KLASSE 11.2
80      IWEI1=3
        ICA=4
        ICE=11
C       BEGINN SCHLEIFE: DRUCK DER LISTEN
99	DO 300 IFA=LFANF,67
        IF (N(IFA)+2016)120,300,120
120     IFA1=(IFA/10-1)*7+(IFA-10*(IFA/10))
C
C						SEITE 2
C
C       SUCHEN DER SCHUELER FUER EIN FACH
        DO 130 K1=1,148
	IKN(K1)=0
130     I2(K1)=0
        K0=1
        DO 180 K1=1,148
        DO 180 K2=ICA,ICE
        IF (I(1,K1))180,180,140
140     IF (I(K2,K1)-IFA)180,150,180
150     I2(K1)=I(1,K1)
	IKN(K1)=K2
        K0=K0+1
180     CONTINUE
        IF (K0-1)300,300,205
C	EINLESEN DER KURSUNTERNUMMERN
205	CALL RTAPE(1,-ISTE,1628,I)
	DO 220 K1=1,148
	IF (I2(K1)) 220,220,230
230	DO 240 K3=1,148
	IF (I2(K1)-I(1,K3)) 240,250,240
250	IKN(K1)=I(IKN(K1),K3)
	GOTO 220
240	CONTINUE
220	CONTINUE
	K0=K0-1
C       EINLESEN SCHUELERNAMEN
	CALL RTAPE(1,ISTM,1628,I)
C       AUSDRUCK KOPFTEXT
        WRITE (1,450)IFORM,IHALB
450     FORMAT(///' KLASSENSTUFE: ',A2,'  HALBJAHR: ',A1)
	DO 350 M=1,4
	IZA1=0
	DO 470 K1=1,148
	IF(IKN(K1)-M) 470,480,470
480	IZA1=IZA1+1
470	CONTINUE
	IF(IZA1) 350,350,370
370	WRITE (1,420)(FACH(K1,IFA1),K1=1,2),
420     FORMAT (//'FACH:  ',2A6)
        GOTO (421,422,422,424,425),IWEI1
421     WRITE (1,431)N(1),M,
431     FORMAT (2X,'LEISTUNGSKURS',A1,I1,2X)
        GOTO 429
422     WRITE (1,432)N(1),M,
432     FORMAT (2X,'GRUNDKURS',A1,I1,2X)
        GOTO 429
424     WRITE (1,434)N(1),M,
434     FORMAT (2X,'3.ABITURFACH',A1,I1,2X)
        GOTO 429
C
C						SEITE 3
C
425     WRITE (1,435)N(1),M,
435     FORMAT (2X,'4.ABITURFACH',A1,I1,2X)
429	WRITE (1,433)IZA1
433     FORMAT (3X,'('I4' SCHUELER)',///)
C       DRUCK DER NAMEN
	IZA2=0
501	DO 500 K1=1,148
        IF (I2(K1))505,500,505
505     DO 515 K2=LANF,148
        IF (I(1,K2)-I2(K1))515,520,515
515     CONTINUE
520	IF (IKN(K1)-M)500,526,500
526     WRITE (1,525)(I(K3,K2),K3=1,11)
525     FORMAT (I3,2X,10A2)
	IZA2=IZA2+1
	IF(IZA2-IZA1) 500,500,510
500     CONTINUE
510	WRITE (1,570)
570     FORMAT (/////80('-')/////)
350	CONTINUE
C       SCHUELERDATEN EINLESEN
820     CALL RTAPE(1,-ISTD,1628,I)
	ISTE=101+ISTA
	ISTE=-IABS(ISTE)
300     CONTINUE
	LFANF=3
	ISTE=-ISTE
        GOTO (40,860,860,70,80),IWEI1
C       ENDE SCHLEIFE: DRUCK DER LISTEN
C       RESTAURIEREN DES "COMMON"-BEREICHS
860     ITEM=IANF-1
        DO 870 K1=1,ITEM
        DO 870 K2=1,11
870     I(K2,K1)=0
	CALL RTAPE(1,-ISTC,227,IFE)
	DO 880 K1=1,148
880	I2(K1)=IFE(K1+12)
        CALL CHAIN ('KUWA3S')
        END



Feel free to contact me, David Gesswein djg@pdp8online.com with any questions, comments on the web site, or if you have related equipment, documentation, software etc. you are willing to part with.  I am interested in anything PDP-8 related, computers, peripherals used with them, DEC or third party, or documentation. 

PDP-8 Home Page   PDP-8 Site Map   PDP-8 Site Search