DataMuseum.dk

top - download

    Length: 11232 (0x2be0)
    Types: TextFile
    Notes: Mikados_K
    Names: »LISTKOMP.K«

└─⟦eb89399bc⟧ Bits:30008990 SOM ISFORIG, MEN KUN K-FILER
    └─⟦this⟧ »LISTKOMP.K« 

Mikados K File

PROGRAM LISTKOMP;
(*$IISFHEAD*)
VPOST=RECORD
       A:AR;
       VARENR1,LVRNDØR,OPRLAND,PAKENHED,
       FORVLEVU,DATSBES1,DATSBES2,DATSORD1,DATSORD2,
       DÆKGRASÅ,ANAFTILG:INTEGER;
       NAVN:ARRAY(1..2) OF PACKED ARRAY (1..30) OF CHAR;
       PRIS,KOSTPRIS,TOLDPNR,FYSLAGER,PRIMOLAG,MINLAGER,RESAFLAG,IORDRE,
       RAIORDRE,STASBEST,ASOLGTIÅ,ASOLGTSÅ,OMSIÅR,OMSSÅR,DÆKBIDTD:REAL
END;
ZONE= RECORD
       H:ISFHEAD;
       T:ARRAY(1..451) OF INTEGER
END;
PROCSTAT=RECORD
       NP,NROSTART:INTEGER
END;
NPFILE=FILE OF PROCSTAT;
VAR    F:ISF;
       NRPF,CF:NPFILE;
       VZ:ZONE;
         FILNAVN2:STRING(20);
      KRIT,IER,LINIE,I,J,K  :INTEGER;
      CH:CHAR;
      PICTURE: ARRAY (1..20,1..6) OF INTEGER;
      SUMS:ARRAY (1..4) OF REAL;
      SUMKRIT:ARRAY (1..4) OF INTEGER;
      QUQ:^INTEGER;
       VARE:VPOST;
       R,FRA,TIL :REAL;
(*$L-*)
(*$R-,IEXCOMCOP*)
(*$IIOPEN*)
(*$IREADPROC*)
(*$IFINDPOST*)
(*$IICLOSE*)
(*$INEXTREC*)
(*$R+*)
(*$L+*)
PROCEDURE PRVAROPL;
PROCEDURE PR1;
BEGIN
WITH VARE DO
BEGIN
GOTOXY(1,1);WRITE('1 VARENR');GOTOXY(30,1);WRITELN(VARENR1:10);
GOTOXY(1,2);WRITE('2 VARENAVN');GOTOXY(30,2);WRITELN(NAVN(1));
GOTOXY(1,3);WRITE('3 NAVN HOS LEVERANDØR');GOTOXY(30,3);WRITELN(NAVN(2));
GOTOXY(1,4);WRITE('4 PRIS');GOTOXY(30,4);WRITELN(PRIS/100:10:2);
GOTOXY(1,5);WRITE('5 KOSTPRIS');GOTOXY(30,5);WRITELN(KOSTPRIS/100:10:2);
GOTOXY(1,6);WRITE('6 LEVERANDØRNR');GOTOXY(30,6);WRITELN(LVRNDØR:10);
GOTOXY(1,7);WRITE('7 OPRINDELSESLAND');GOTOXY(30,7);WRITELN(OPRLAND:10);
GOTOXY(1,8);WRITE('8 TOLDPOSITIONSNR');GOTOXY(30,8);
WRITELN(TOLDPNR/1000:10:3);
GOTOXY(1,9);WRITE('9 PAKNINGSENHED');GOTOXY(30,9);WRITELN(PAKENHED:10);
GOTOXY(1,10);WRITE('10 FYSISK LAGER');GOTOXY(30,10);
WRITE(FYSLAGER:10:-2);
GOTOXY(50,10);WRITE('27 PRIMOLAGER');GOTOXY(67,10);
WRITELN(PRIMOLAG:10:-2);
GOTOXY(1,11);WRITE('11 RESERVERET, FYSISK LAGER');GOTOXY(30,11);WRITELN(
                                                      RESAFLAG:10:-2);
END;
END;
PROCEDURE PR2;
BEGIN
WITH VARE DO
BEGIN
GOTOXY(1,12);WRITE('12 MINIMUMSLAGER');GOTOXY(30,12);
WRITELN(MINLAGER:10:-2);
GOTOXY(1,13);WRITE('13 I ORDRE');GOTOXY(30,13);WRITELN(IORDRE:10:-2);
GOTOXY(1,14);WRITE('14 HERAF RESERVERET');GOTOXY(30,14);
WRITELN(RAIORDRE:10:-2);
GOTOXY(50,14);WRITE('15 FORV. LEV. UGE');GOTOXY(67,14);WRITELN(FORVLEVU:10);
GOTOXY(1,15);WRITE('16 STØRRELSE AF SIDSTE BEST.');GOTOXY(30,15);WRITELN(
STASBEST:10:-2);
GOTOXY(50,15);WRITE('17 SIDST BEST');GOTOXY(67,15);
WRITELN(DATSBES1*10000.0+DATSBES2:10:-2);
GOTOXY(1,16);WRITE('18 SIDST SOLGT');GOTOXY(30,16);WRITELN(
DATSORD1*10000.0+DATSORD2:10:-2);
GOTOXY(1,17);WRITE('19 SOLGT I ÅR');GOTOXY(30,17);
WRITELN(ASOLGTIÅ:10:-2);
GOTOXY(50,17);WRITE('20 SOLGT S. ÅR');GOTOXY(67,17);
WRITELN(ASOLGTSÅ:10:-2);
GOTOXY(1,18);WRITE('21 OMS. I ÅR');GOTOXY(30,18);
WRITELN(OMSIÅR/100:10:2);
GOTOXY(50,1);
WRITELN('26 GODT TAL ',0.0:12:-2);
GOTOXY(50,18);WRITE('22 OMS. S. ÅR');GOTOXY(67,18);WRITELN(OMSSÅR/100:10:2);
GOTOXY(1,19);WRITE('23 DÆKNINGSBIDRAG TIL DATO');GOTOXY(30,19);WRITELN(
DÆKBIDTD/100:10:2);
GOTOXY(50,19);WRITE('24 DÆK.GRAD S. ÅR');GOTOXY(67,19);WRITELN(DÆKGRASÅ:10);
GOTOXY(1,20);WRITE('25 ANDRE AFGANGE-TILGANGE');GOTOXY(30,20);WRITELN(
ANAFTILG:10);
GOTOXY(1,21);WRITELN('28 LAGERVÆRDI',0.0:27:2);
END;
END;
BEGIN
  PR1;
  PR2;
END;
PROCEDURE STOP;
VAR I:INTEGER;
BEGIN I:=I DIV 0 END;
PROCEDURE ERROR;
BEGIN
  WRITELN('FEJL I VAREREG ',IER);
  ICLOSE(VZ.H,F);
  WRITELN('ICLOSE ',IER);
  STOP
END;
PROCEDURE PRINT(O:INTEGER);
BEGIN
CASE O OF
0: WRITE(' ':19);
1: WRITE('VARENR':19);
2: WRITE('VARENAVN':38);
3: WRITE('NAVN H. LEVERANDØR':38);
4: WRITE('PRIS':19);
5: WRITE('KOSTPRIS':19);
6: WRITE('LEVERANDØRNR':19);
7: WRITE('OPRINDELSESLAND':19);
8: WRITE('TOLDPOSITIONSNR':19);
9: WRITE('PAKNINGSENHED':19);
10:WRITE('FYSISK LAGER':19);
27:WRITE('PRIMOLAGER':19);
11:WRITE('RESERV. FYS. LAGER':19);
12:WRITE('MIN. LAGER':19);
13:WRITE('I ORDRE':19);
14:WRITE('RESERV. IORDRE':19);
15:WRITE('LEV. UGE':19);
16:WRITE('STØRR. S. BEST':19);
17:WRITE('DAT. S. BEST':19);
18:WRITE('SIDST SOLGT':19);
19:WRITE('SOLGT I ÅR':19);
20:WRITE('SOLGT S ÅR':19);
21:WRITE('OMS. I ÅR':19);
22:WRITE('OMS. S ÅR':19);
23:WRITE('DÆKNINGSBIDRAG':19);
24:WRITE('DÆK.GRAD S ÅR':19);
25:WRITE('ANDRE AFG/TILG':19);
26:WRITE('GODT TAL':19);
28:WRITE('LAGERVÆRDI':19);
END
END;
PROCEDURE PRINT1(O:INTEGER);
BEGIN
CASE O OF
0: WRITE(LIST,' ':19);
1: WRITE(LIST,'VARENR':19);
2: WRITE(LIST,'VARENAVN':38);
3: WRITE(LIST,'NAVN H. LEVERANDØR':38);
4: WRITE(LIST,'PRIS':19);
5: WRITE(LIST,'KOSTPRIS':19);
6: WRITE(LIST,'LEVERANDØRNR':19);
7: WRITE(LIST,'OPRINDELSESLAND':19);
8: WRITE(LIST,'TOLDPOSITIONSNR':19);
9: WRITE(LIST,'PAKNINGSENHED':19);
10:WRITE(LIST,'FYSISK LAGER':19);
27:WRITE(LIST,'PRIMOLAGER':19);
11:WRITE(LIST,'RESERV. FYS. LAGER':19);
12:WRITE(LIST,'MIN. LAGER':19);
13:WRITE(LIST,'I ORDRE':19);
14:WRITE(LIST,'RESERV. IORDRE':19);
15:WRITE(LIST,'LEV. UGE':19);
16:WRITE(LIST,'STØRR. S. BEST':19);
17:WRITE(LIST,'DAT. S. BEST':19);
18:WRITE(LIST,'SIDST SOLGT':19);
19:WRITE(LIST,'SOLGT I ÅR':19);
20:WRITE(LIST,'SOLGT S ÅR':19);
21:WRITE(LIST,'OMS. I ÅR':19);
22:WRITE(LIST,'OMS. S ÅR':19);
23:WRITE(LIST,'DÆKNINGSBIDRAG':19);
24:WRITE(LIST,'DÆK.GRAD S ÅR':19);
25:WRITE(LIST,'ANDRE AFG/TILG':19);
26:WRITE(LIST,'GODT TAL':19);
28:WRITE(LIST,'LAGERVÆRDI':19);
END
END;
PROCEDURE SKRIG(O:INTEGER);
BEGIN
WITH VARE DO
CASE O OF
0: WRITE(LIST,' ':19);
1: WRITE(LIST,VARENR1:19);
2: WRITE(LIST,NAVN(1):38);
3: WRITE(LIST,NAVN(2):38);
4: WRITE(LIST,PRIS/100:19:2);
5: WRITE(LIST,KOSTPRIS/100:19:2);
6: WRITE(LIST,LVRNDØR:19);
7: WRITE(LIST,OPRLAND:19);
8: WRITE(LIST,TOLDPNR/1000:19:3);
9: WRITE(LIST,PAKENHED:19);
10:WRITE(LIST,FYSLAGER:19:-2);
27:WRITE(LIST,PRIMOLAG:19:-2);
11:WRITE(LIST,RESAFLAG:19:-2);
12:WRITE(LIST,MINLAGER:19:-2);
13:WRITE(LIST,IORDRE:19:-2);
14:WRITE(LIST,RAIORDRE:19:-2);
15:WRITE(LIST,FORVLEVU:19);
16:WRITE(LIST,STASBEST:19:-2);
17:WRITE(LIST,DATSBES1*10000.0+DATSBES2:19:-2);
18:WRITE(LIST,DATSORD1*10000.0+DATSORD2:19:-2);
19:WRITE(LIST,ASOLGTIÅ:19:-2);
20:WRITE(LIST,ASOLGTSÅ:19:-2);
21:WRITE(LIST,OMSIÅR/100:19:2);
22:WRITE(LIST,OMSSÅR/100:19:2);
23:WRITE(LIST,DÆKBIDTD/100:19:2);
24:WRITE(LIST,DÆKGRASÅ:19);
25:WRITE(LIST,ANAFTILG:19);
26:IF (PRIMOLAG+FYSLAGER<>0) AND (OMSIÅR<>0) THEN
      WRITE(LIST,ASOLGTIÅ*200*DÆKBIDTD/((PRIMOLAG+FYSLAGER)*OMSIÅR):19:-2)
   ELSE
      WRITE(LIST,0.0:19:3);
28:WRITE(LIST,FYSLAGER*KOSTPRIS/100:19:2);
END
END;
FUNCTION CHECK(KRIT:INTEGER):BOOLEAN;
BEGIN
  WITH VARE DO
  CASE KRIT OF
1:R:=VARENR1;
4:R:=PRIS/100;
5:R:=KOSTPRIS/100;
6:R:=LVRNDØR;
7:R:=OPRLAND;
8:R:=TOLDPNR/1000;
9:R:=PAKENHED;
10:R:=FYSLAGER;
11:R:=RESAFLAG;
12:R:=MINLAGER;
13:R:=IORDRE;
14:R:=RAIORDRE;
15:R:=FORVLEVU;
16:R:=STASBEST;
17:R:=DATSBES1*10000.0+DATSBES2;
18:R:=DATSORD1*10000.0+DATSORD2;
19:R:=ASOLGTIÅ;
20:R:=ASOLGTSÅ;
21:R:=OMSIÅR/100;
22:R:=OMSSÅR/100;
23:R:=DÆKBIDTD/100;
24:R:=DÆKGRASÅ;
25:R:=ANAFTILG;
26:IF (PRIMOLAG+FYSLAGER<>0) AND (OMSIÅR<>0) THEN
     R:=ASOLGTIÅ*200*DÆKBIDTD/((PRIMOLAG+FYSLAGER)*OMSIÅR)
   ELSE
     R:=0.0;
27:R:=PRIMOLAG;
28:R:=FYSLAGER*KOSTPRIS/100;
END;
IF (R>=FRA) AND (R<=TIL) THEN CHECK:=TRUE ELSE CHECK:=FALSE
END;
PROCEDURE INDKRIT;
BEGIN
  REPEAT
    CLEARSCREEN;
    PRVAROPL;
  FOR I:=1 TO 20 DO FOR J:=1 TO 6 DO PICTURE(I,J):=0;
  I:=1;J:=1;
  REPEAT
    GOTOXY(1,23);
    WRITELN('FELTER I LINIE ',I:2);
    GOTOXY(20,23);READLN;
    WHILE (NOT EOLN) AND (J<7) DO
    BEGIN
      READ(PICTURE(I,J));
      IF (IORESULT<>0) OR (PICTURE(I,J)<0) OR (PICTURE(I,J)>40) THEN J:=9;
      J:=J+1
    END;
    IF PICTURE(I,1)<0 THEN I:=21;
    IF J<8 THEN I:=I+1;
    J:=1;
  UNTIL I>20;
  CLEARSCREEN;
  FOR I:=1 TO 20 DO
  BEGIN
    FOR J:=1 TO 6 DO PRINT(PICTURE(I,J));
    WRITELN
  END;
  GOTOXY(1,23);WRITELN('O.K. (J/N) ');
  REPEAT
    GOTOXY(15,23);
    READLN;READ(CH)
  UNTIL (IORESULT=0) AND ((CH='J') OR (CH='N') OR (CH='n') OR (CH='j'))
  UNTIL (CH='J') OR (CH='j');
  CLEARSCREEN;
  PRVAROPL;
  GOTOXY(1,23);WRITELN('UDVALGSKRITERIE 1, 4-40 ');
  REPEAT
    GOTOXY(25,23);READLN;READ(KRIT)
  UNTIL (IORESULT=0) AND ((KRIT=1) OR ((KRIT>3) AND (KRIT<41)));
  GOTOXY(1,23);WRITELN('FRA              TIL                      ');
  REPEAT
    GOTOXY(5,23);READLN;READ(FRA);
    IF IORESULT=0 THEN
    BEGIN
      GOTOXY(22,23);READLN;READ(TIL)
    END;
  UNTIL (IORESULT=0) AND (FRA<=TIL);
  I:=1;
  REPEAT
  GOTOXY(1,23);WRITELN('Summeringsfelter 1, 4-40       ');
    REPEAT
       GOTOXY(26,23);READLN;READ(J)
    UNTIL (IORESULT=0) AND ((J=0) OR (J=1) OR ((J>3) AND (J<41)));
    SUMKRIT(I):=J;
    IF J=0 THEN I:=5 ELSE I:=I+1;
  UNTIL I=5;
  FOR I:=1 TO 4 DO SUMS(I):=0.0;
END;
BEGIN
  FILNAVN2:='PROCSTAT:P2:0:I';
(*$C-*)
  REPEAT
    REWRITE(NRPF,FILNAVN2);
    SEEK(NRPF,1)
  UNTIL IORESULT=0;
(*$C+*)
  GET(NRPF);
  NRPF^.NP:=1;
  SEEK(NRPF,1);
  PUT(NRPF);
  REPEAT
    GOTOXY(1,20);
    WRITELN('Sæt plade 1 i drev 1 og tryk RETURN');
    READLN;
(*$C-*)
    REWRITE(CF,'C1:P1:0:J');
    SEEK(CF,1)
(*$C+*)
  UNTIL IORESULT=0;
  CLOSE(CF);
  CLOSE(NRPF);
  FILNAVN2:='REGVARE:P1:1137:I';
  RESET(F,FILNAVN2);
  IOPEN(VZ.H,F,LÆS);
  VARE.VARENR1:=0;
  NEXTREC(VZ.H,F,VARE.A);
  INDKRIT;
  IER:=0;
  LINIE:=0;
  FOR I:=1 TO 20 DO
  BEGIN
    FOR J:=1 TO 6 DO PRINT1(PICTURE(I,J));
    WRITELN(LIST);
    LINIE:=LINIE+1;
    IF I<20 THEN
    IF PICTURE(I+1,1)<0 THEN I:=20
  END;
  REPEAT
  WRITELN(LIST);
  LINIE:=LINIE+1
  UNTIL LINIE=72;
  LINIE:=0;
  REPEAT
    WHILE (NOT CHECK(KRIT)) AND (IER=0) DO NEXTREC(VZ.H,F,VARE.A);
    IF IER=0 THEN
    BEGIN
      FOR I:=1 TO 20 DO
      BEGIN
        FOR J:=1 TO 6 DO SKRIG(PICTURE(I,J));
        WRITELN(LIST);
        LINIE:=LINIE+1;
        IF LINIE=60 THEN
        BEGIN
          REPEAT
            WRITELN(LIST);LINIE:=LINIE+1
          UNTIL LINIE=72;
          LINIE:=0
        END;
        IF I<20 THEN
        IF PICTURE(I+1,1)<0 THEN I:=20
      END;
      FOR I:=1 TO 4 DO IF SUMKRIT(I)=0 THEN I:=4 ELSE
          BEGIN
            IF CHECK(SUMKRIT(I)) THEN;
            SUMS(I):=SUMS(I)+R
          END;
      NEXTREC(VZ.H,F,VARE.A);
    END
  UNTIL IER<>0;
  REPEAT
    WRITELN(LIST);LINIE:=LINIE+1
  UNTIL LINIE=72;
  WRITELN(LIST,'Summer af');
  FOR I:=1 TO 4 DO PRINT1(SUMKRIT(I));
  WRITELN(LIST);
  FOR I:=1 TO 4 DO IF SUMKRIT(I)<>0 THEN WRITE(LIST,SUMS(I):19:3);
  WRITELN(LIST);
  IF IER<>-2 THEN ERROR;
  ICLOSE(VZ.H,F);
  CHAIN('INTRE   *1','HOVSA:P1',QUQ)
END.