META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      1
SERVER           

    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C FILE NAME SERVER
    	C
0001	      PROGRAM SERVER
    	C
    	C
    	C       FUNKTION:
    	C       DETTA [R RADIOSYSTEMETS N[TVERKSPROGRAM F\R UTK\RNINGSBEVAKNINGEN.
    	C       DESS UPPGIFT [R ATT UPPR[TTH]LLA EN L[NK TILL HK::ACCITY F\R UTV[XLING
    	C       AV DATA OCH ATT FR]GA DUTACC EFTER UPPGIFTER UR RADIODATABASEN SAMT ATT
    	C       GE UPPGIFTER TILL ...QUE OM MEDDELANDEN ATT L[GGA UPP I K\N.
    	C
    	C       TASKET COMMUNICERAR MED "HK"::ACCITY OCH SERVAR DESS REQUEST.
    	C       AVKODAR INFORMATIONEN SAMT S[NDER FR]GOR OCH TAR EMOT SVAR FR]N
    	C       DUTACC SAMT S[NDER ORDER TILL ...QUE (RADIOSYSTEMETS ALLTS])
    	C
    	C       KVITTENSER SAMT SVAR S[NDS TILLBAKA TILL ACCITY.
    	C
    	C       UNDER TIDEN DEN V[NTAR P] ORDER G\R DEN WAITNT
    	C
    	C       HISTORIK:
    	C       DATUM           NAMN                    ORSAK
    	C       860128          B-E TAPPER              URUPPF\RANDE
    	C       860129          B-E TAPPER              MERA JOBB
    	C       860131          B-E TAPPER              MERA JOBB
    	C       860201          B-E TAPPER              F[RDIGT
    	C       860207          B-E TAPPER              FLAGQUE =56 + UTSKRIFTER
    	C       860214          B-E TAPPER              BUGGAR R[TTADE
    	C       860217          B-E TAPPER              NY KOMMUNIKATION MED DUTACC
    	C       860220          B-E TAPPER              DRIFTSS[TTNING
    	C       860502          JBdk & BTA              REQ.TYPE 8 -> 11 TO QUE
    	C       861213          BTA                     TILL UBABJBDK
    	C       870923          BTA                     LARM VID N[TAVBROTT
    	C       870928          BTA                     CIO TRYCKER UT
    	C       871007          BTA                     kan s{tta car active
    	C       871015          BTA                     GENOMG]NGET
    	C       871102          BTA                     SJ[LVUPPL\SANDE OM UR SYNK MED
    	C                                               DUTACC
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      2
SERVER           

    	C       880213          BTA                     T\MNING AV RECEIVE-BUFFER VID
    	C                                               ABORT FEL
    	C       880213          BTA                     B[TTRE MODULARISERING.
    	C       880330          BTA                     CANCEL MARKTIME + H[NGSKYDD
    	C
    	C
    	C       KOM IH]G: COMBUF(2) MODIFIERAS I DOIT (SHIFTLEFT)
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       DEFINITION OF MAPPED COMMON AREA SPECOM
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
0002	      INTEGER SPECOM(3842)            <HELA SPECOM
0003	      COMMON/SPECOM/SPECOM
    	C
0004	      INTEGER SPICOM(170)     <0-523
0005	      EQUIVALENCE(SPECOM(1),SPICOM(1))
    	C       SPECOM 000000-R
    	C
0006	      INTEGER QELMTS          <524-525
0007	      EQUIVALENCE(SPECOM(171),QELMTS)
    	C       QELMTS 000524-R
    	C
0008	      INTEGER QLENGT          <526-527
0009	      EQUIVALENCE(SPECOM(172),QLENGT)
    	C       QLENGT 000526-R
    	C
0010	      INTEGER QHHEAD(3)       <530-535
0011	      EQUIVALENCE(SPECOM(173),QHHEAD(1))
    	C       QHHEAD 000530-R
    	C
0012	      INTEGER QLHEAD(3)       <536-543
0013	      EQUIVALENCE(SPECOM(176),QLHEAD(1))
    	C       QLHEAD 000536-R
    	C
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      3
SERVER           

0014	      INTEGER QUECOM(1764)    <544-7453
0015	      EQUIVALENCE(SPECOM(179),QUECOM(1))
    	C       QUECOM 000544-R
    	C
0016	      INTEGER QPRES(36)       <7454-7563
0017	      EQUIVALENCE(SPECOM(1943),QPRES(1))
    	C       QPRES  007454-R
    	C
0018	      INTEGER UBABCO(76)      <7564-10013
0019	      EQUIVALENCE(SPECOM(1979),UBABCO(1))
    	C       UBABCO 007564-R 
    	C
0020	      INTEGER SCARCO(26)      <10014-10077
0021	      EQUIVALENCE(SPECOM(2055),SCARCO(1))
    	C       SCARCO 010014-R
    	C
0022	      INTEGER LATECO(103)     <10100-10415
0023	      EQUIVALENCE(SPECOM(2081),LATECO(1))
    	C       LATECO 010100-R
    	C
0024	      INTEGER NODUCO(113)     <10416-10757
0025	      EQUIVALENCE(SPECOM(2184),NODUCO(1))
    	C       NODUCO 010416-R
    	C
0026	      INTEGER BUSCO(61)       <10760-11151
0027	      EQUIVALENCE(SPECOM(2297),BUSCO(1))
    	C       BUSCO  010760-R
    	C
0028	      INTEGER XTRCO(151)      <11152-11627
0029	      EQUIVALENCE(SPECOM(2358),XTRCO(1))
    	C       XTRCO  011152-R
    	C
0030	      INTEGER OPRCO(189)      <11630-12421
0031	      EQUIVALENCE(SPECOM(2509),OPRCO(1))
    	C       OPRCO  011630-R
    	C
0032	      INTEGER STACO(9)        <12422-12443
0033	      EQUIVALENCE(SPECOM(2698),STACO(1))
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      4
SERVER           

    	C       STACO  012422-R 
    	C
0034	      INTEGER RADCO(1110)     <12444-16717
0035	      EQUIVALENCE(SPECOM(2707),RADCO(1))
    	C       RADCO  012444-R
    	C
0036	      INTEGER NQDCO(3)        <16720-16725
0037	      EQUIVALENCE(SPECOM(3817),NQDCO(1))
    	C       NQDCO  016720-R
    	C
0038	      INTEGER RESCO(20)       <16726-16775
0039	      EQUIVALENCE(SPECOM(3820),RESCO(1))
    	C       RESCO  016726-R
    	C
0040	      INTEGER PSTCO(3)        <16776-17003
0041	      EQUIVALENCE(SPECOM(3840),PSTCO(1))
    	C       PSTCO  016776-R
    	C
    	C
    	C
    	C       Task  image  size  : 3872. words
    	C       Task address limits: 000000 017003
    	C       R/W mem  limits: 000000 017003 017004 07684.
    	C
    	C SPECOM:(RW,D,GBL,REL,OVR) 000000 017004 07684.
    	C                           000000 017004 07684. SPECOM DATOPROLB.OLB;12
    	C       SPECOM 000000-R
    	C       QELMTS 000524-R
    	C       QLENGT 000526-R
    	C       QHHEAD 000530-R
    	C       QLHEAD 000536-R
    	C       QUECOM 000544-R
    	C       QPRES  007454-R
    	C       UBABCO 007564-R 
    	C       SCARCO 010014-R
    	C       LATECO 010100-R
    	C       NODUCO 010416-R
    	C       BUSCO  010760-R
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      5
SERVER           

    	C       XTRCO  011152-R
    	C       OPRCO  011630-R
    	C       STACO  012422-R 
    	C       RADCO  012444-R
    	C       NQDCO  016720-R
    	C       RESCO  016726-R
    	C       PSTCO  016776-R
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       COPYTEXTER      (SUBCOMMONS)
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C
*	COPY TEXT FILE:    DR0:[361,15]UBABCOM.CPY;4    29-JAN-86 14:39
    	C& SC:[361,15]UBABCOM.CPY
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C*      END OF COPY TEXT FILE
0077	      EQUIVALENCE(UBABPT(1),UBABCO(1))
    	C
*	COPY TEXT FILE:    DR0:[361,15]PSTCOM.CPY;2    29-JAN-86 12:45
    	C& SC:[361,15]PSTCOM.CPY &=X
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C*      END OF COPY TEXT FILE
0085	      EQUIVALENCE(XPSTPT(1),PSTCO(1))
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       INTERNA VARIABLER
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C
0086	      INTEGER         QUEBUF(13)      <BUFFER FOR MESSAGE TO QUE
    	C
    	C                       WORD 1          11      REQUEST TYPE (FORMER 8)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      6
SERVER           

    	C                       WORD 2          BUSS NUMBER
    	C                       WORD 3          0       PORT NUMBER
    	C                       WORD 4          MESSAGE TYPE 95--99
    	C                       WORD 5-7        DUTY
    	C                       WORD 8          PNR
    	C                       WORD 9-11       LINRUN
    	C                       WORD 12         TIME (MINUTER EFTER MIDNATT)
    	C                       WORD 13         SPARE
    	C
0087	      INTEGER         RECBUF(15)      <RECEIVE DATA BUFFER FROM LOCAL
    	C
0088	      INTEGER         COMBUF(13)      <COMMUNICATIONS BUFFER TO LOCAL
    	C
0089	      INTEGER         NETBUF(13)      <COMMUNICATIONS BUFFER FROM NETWORK
    	C
0090	      INTEGER         SNDBUF(13)      <COMMUNICATIONS BUFFER TO NETWORK
    	C
    	C                       WORD 1          REQUEST FOR SERVER
    	C                                       *       1 = PLEASE GIVE DAYTYPE
    	C                                       *       2 = PLEASE GIVE BUSS + PLAC
    	C                                               3 = PLEASE ALERT NO ARRIV
    	C                                               4 = PLEASE ALERT LATE ARRIV
    	C                                               5 = PLEASE ALERT STRNGE ARRIV
    	C                                       *       6 = PLEASE SHOW ACTIVE PSO-CALLS
    	C                                               7 = spare
    	C                                               8 = SYSTEM-UP-MESSAGE
    	C                                               9 = SYSTEM DOWN MESSAGE
    	C                                               0 = PLEASE EXIT SERVER
    	C
    	C                                       * = ANSWER EXPECTED
    	C
    	C               FOR 0-5 WORD 2-4        DUTYID
    	C                       WORD 5          BUSS NUMBER
    	C                       WORD 6          PLAC.
    	C                       WORD 7          DAYTYPE
    	C                       WORD 8          PNR OF OFFENDING PERSON
    	C                       WORD 9-11       LINJE/KURS
    	C                       WORD 12         TIME (INTEGER HHMM)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      7
SERVER           

    	C                       WORD 13         for 2-5: 1=mark as active if possible
    	C                       WORD 13         for 0 and 1: spare
    	C
    	C               FOR 6   WORD 2-4        TIME FOR PSO-OPERATOR 1-3
    	C                       WORD 5-13       spare
    	C
0091	      INTEGER         FAULT           <TRACE-BACK FAULT CODE
    	C
0092	      INTEGER         MLTYP           <MESSAGE TYPE CODE IN GNDNT
    	C
0093	      INTEGER         IDS             <DIRECTIVE STATUS RETURN CODE
    	C
0094	      BYTE            MLBX(98)        <MAILBOX
    	C
0095	      BYTE            ERRMES(2)       <ERRMES CODE
    	C
0096	      INTEGER         IESB(8)         <EXIT STATUS BLOCK
    	C
0097	      INTEGER         INDEX           <MESSAGE TYPE TO INDICATE WHICH ONE
    	C                                       OF WAITNT:s STATUS BLOCKS THAT COMPLETED
    	C
0098	      INTEGER         IOST(2)         <IO-STATUS BLOCK
0099	      INTEGER         IOSTG(2)        <IO-STATUS BLOCK FOR GNDNT
0100	      INTEGER         IOSTR(2)        <IO-STATUS BLOCK FOR RECNT
0101	      INTEGER         IOSTS(2)        <IO-STATUS BLOCK FOR SNDNT
    	C
0102	      INTEGER         MSTAT(3)        <M-STATUS BLOCK
    	C
0103	      INTEGER         COUNT           <R[KNAR FAIL P] DUTACC. MAX 3 ST.
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       KONSTANTER
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      8
SERVER           

0104	      REAL            QUE             <CALLING TASK RADIX-50 NAME
0105	      DATA    QUE/6R...QUE/
    	C
0106	      INTEGER         FLAGQUE         <GLOBAL EVENTFLAG FOR ...QUE SYNC
0107	      DATA    FLAGQUE/56/             <FLAGQUE FROM [361,10]FLAGQUE.PAS
    	C
0108	      INTEGER         FLAGDUT         <GLOBAL EVENTFLAG FOR DUTACC SYNC
0109	      DATA    FLAGDUT/47/             <EX SPEDUMP FROM [361,10]FLAGCON.PAS
    	C
    	C
0110	      REAL            DUTACC          <CALLING TASK RADIX-50 NAME
0111	      DATA    DUTACC/6RDUTACC/
    	C
    	C
0112	      INTEGER         OPNLUN          <OPEN LUN
0113	      DATA    OPNLUN/1/
    	C
0114	      INTEGER         CONLUN          <CONNECT LUN
0115	      DATA    CONLUN/2/
    	C
0116	      INTEGER         LRP             <LINK RECOVERY PERIOD
0117	      DATA    LRP/0/                  <INGEN ALLS
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       FORMATSATSER
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
0118	999   FORMAT(1X,'SERVER: CONNECTED TO HK::ACCITY')
0119	1000  FORMAT('$** SERVER ERROR: ')
0120	1001  FORMAT('+NETWORK CONNECT FAILED. IOST(1)=',I4)
0121	998   FORMAT(1X,'SERVER: CONNECT REQ. RECEIVED.')
0122	1003  FORMAT('+INTERRUPT MES. RECEIVED. MES=',2I5)
0123	1004  FORMAT('+USER DISCONNECT. MES=',2I5)
0124	1005  FORMAT('+USER ABORT. MES=',2I5)
0125	1006  FORMAT('+NETWORK ABORT. MES=',2I5)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE      9
SERVER           

0126	1007  FORMAT('+IN GNDNT. IOSTG=',2I5)
0127	1008  FORMAT('+IN CLSNTW. IOST=',2I5)
0128	1009  FORMAT('+NETWORK DECLARE FAILED. IOST=',2I5)
0129	1010  FORMAT('+FAULT=',I5)
0130	1011  FORMAT('+NO LETTER IN MAILBOX')
0131	1012  FORMAT('+OTHER MESS. MES=',2I5)
0132	1013  FORMAT('+IN SNDNT. IOSTS=',2I5)
0133	1014  FORMAT('+IN RECNT. IOSTR=',2I5)
    	C
0134	1020  FORMAT(1X,'SERVER RETRIES NETWORK CONNECT.')
0135	1021  FORMAT(1X,'SERVER EXITS AS ORDERED.')
    	C
0136	1030  FORMAT('+NETWORK DISCONNECT FAILED.
    	     *IOST=',2I5)
    	C
0137	2000  FORMAT('+MESSAGE TO QUE FAILED. IDS=',I5)
0138	2001  FORMAT('+MESSAGE TO DUTACC FAILED. IDS=',I5)
0139	2002  FORMAT('+UNSTOP AND REQUEST DUTACC FAILED. IDS=',I5)
0140	2003  FORMAT('+WAITFR DUTACC FAILED. IDS=',I5)
0141	2004  FORMAT('+RECEIVE FROM DUTACC FAILED. IDS=',I5)
0142	2005  FORMAT('+RECEIVE FROM DUTACC WRONG. ABORTED.')
0143	2006  FORMAT('+COMM. WITH DUTACC RETRIED. IDS=',I5)
0144	2007  FORMAT('+MARK TIME DUTACC FAILED. IDS=',I5)
    	C
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       STYRSEKTION
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C
0145	      'POSIT'         <EJ SYSTEMFEL ELLER MOTSVARANDE
    	C
0146	      .   IOSTS(1)=1      <DUMMY DECLARE SEND NETWORK OK
    	C
    	C       -- DECLARE AS DECNET TASK
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     10
SERVER           

    	C
0147	      .   FAULT=1
0148	      .   CALL OPNNTW(OPNLUN,IOST,MSTAT,0,LRP)
0149	      .   'IF'(IOST(1).NE.1)
0151	      .   .   WRITE(5,1000)                   <SERVER ERROR
0152	      .   .   WRITE(5,1009)IOST               <OPEN FAILED
0153	      .   .   CALL EXIT
0155	      .   'ELSIF'(MSTAT(1).EQ.0)
0157	      .   .   WRITE(5,1000)                   <SERVER ERROR
0158	      .   .   WRITE(5,1011)           <NO LETTER IN MAILBOX
0159	      .   .   'QUIT'
0161	      .   'ENDIF'
    	C
    	C       - GET DATA FROM NETWORK QUE
    	C
0162	      .   CALL GNDNT(IOSTG,MLTYP,98,MLBX)         <ASYNCHRONUOS
    	C
    	C       - LOOP
    	C
0163	      .   'WHILE'(.TRUE.)
    	C
0165	      .   .   CALL WAITNT(INDEX,IOSTG,IOSTR)
    	C
0166	      .   .   'IF'(IOSTG(1).GT.0)     <GNDNT COMPLETED OK
0168	      .   .   .   FAULT=MLTYP
0169	      .   .   .   'CASE' MLTYP
0170	      .   .   .   'WHEN' 1
0172	      .   .   .   .   CALL ACCNTW(CONLUN,IOST,MLBX)
0173	      .   .   .   .   WRITE(5,998)    <CONNECT REQUEST
0174	      .   .   .   .   'IF'(IOST(1).NE.1)
0176	      .   .   .   .   .   WRITE(5,1000)           <SERVER ERROR
0177	      .   .   .   .   .   WRITE(5,1001)IOST       <CONNECT FAILED
0178	      .   .   .   .   .   'QUIT'
0180	      .   .   .   .   'ELSE'
0181	      .   .   .   .   .   CALL RECNT(CONLUN,IOSTR,26,NETBUF)
0182	      .   .   .   .   .   CALL GNDNT(IOSTG,MLTYP,98,MLBX) <ASYNCHRONUOS
0183	      .   .   .   .   .   CALL CHANGE(,0,COMBUF,26)
0184	      .   .   .   .   .   COMBUF(1)=8     <SYSTEM UP
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     11
SERVER           

0186	      .   .   .   .   .   'PERFORM' DOIT  <MEDDELA TILLSLAG
0188	      .   .   .   .   .   WRITE(5,999)            <CONNECT OK
0190	      .   .   .   .   'ENDIF'
0192	      .   .   .   'WHEN' 2
0194	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0195	      .   .   .   .   WRITE(5,1003)ERRMES <ERROR: INTERRUPT MESSAGE
0196	      .   .   .   .   'QUIT'
0198	      .   .   .   'WHEN' 3
0200	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0201	      .   .   .   .   WRITE(5,1004)ERRMES     <ERROR: USER DISCNCT
0202	      .   .   .   .   'QUIT'
0204	      .   .   .   'WHEN' 4
0206	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0207	      .   .   .   .   WRITE(5,1005)ERRMES     <ERROR: USER ABORT
0208	      .   .   .   .   'QUIT'
0210	      .   .   .   'WHEN' 5
0212	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0213	      .   .   .   .   WRITE(5,1006)ERRMES     <NETWORK ABORT
0214	      .   .   .   .   'QUIT'
0216	      .   .   .   'OTHER'
0217	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0218	      .   .   .   .   WRITE(5,1012)ERRMES     <OTHER ABORT
0219	      .   .   .   .   'QUIT'
0221	      .   .   .   'ENDCASE'
0223	      .   .   'ELSIF'(IOSTG(1).LT.0)  <GNDNT COMPLETED NOT OK
0225	      .   .   .   WRITE(5,1000)           <SERVER ERROR
0226	      .   .   .   WRITE(5,1007)IOSTG      <ERROR IN GNDNT
0227	      .   .   .   FAULT=6
0228	      .   .   .   CALL XMINT(CONLUN,IOST,2,'GD')
0229	      .   .   .   'QUIT'
0231	      .   .   'ELSE'                  <GNDNT STILL PENDING
0232	      .   .   .   CONTINUE
0234	      .   .   'ENDIF'
    	C
    	C
    	C
0235	      .   .   'IF'(IOSTR(1).EQ.1)     <RECNT COMPLETED OK
    	C
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     12
SERVER           

0237	      .   .   .   FAULT=0
0238	      .   .   .   'QUITIF'(NETBUF(1).EQ.0)        <EXIT ORDER
0240	      .   .   .   CALL MOVE01(26,NETBUF,COMBUF)
0241	      .   .   .   CALL RECNT(CONLUN,IOSTR,26,NETBUF)      <RECEIVE NEXT
0243	      .   .   .   'PERFORM' DOIT
0245	      .   .   .   'IF'(COMBUF(1).EQ.1 .OR. COMBUF(1).EQ.2 .OR.
    	     *.   .   .   .   COMBUF(1).EQ.6)          <ANSWER EXPECTED
0247	      .   .   .   .   'IF'(IOSTS(1).NE.1)     <NOT COMPLETED OR NOT SENT
0249	      .   .   .   .   .   WRITE(5,1000)           <SERVER ERROR
0250	      .   .   .   .   .   WRITE(5,1013)IOSTS      <ERROR IN SNDNT
0251	      .   .   .   .   .   CALL XMINT(CONLUN,IOST,2,'SN')
0252	      .   .   .   .   .   'QUIT'
0254	      .   .   .   .   'ENDIF'
0255	      .   .   .   .   CALL MOVE01(26,COMBUF,SNDBUF)
0256	      .   .   .   .   CALL SNDNT(CONLUN,IOSTS,26,SNDBUF)      <ASYNK
0258	      .   .   .   'ENDIF'
    	C
0260	      .   .   'ELSIF'(IOSTR(1).NE.0)          <RECNT COMPLETED NOT OK
    	C
0262	      .   .   .   CALL XMINT(CONLUN,IOST,2,'RD')
0263	      .   .   .   WRITE(5,1000)           <SERVER ERROR
0264	      .   .   .   WRITE(5,1014)IOSTR      <ERROR IN RECNT
0265	      .   .   .   'QUIT'
0267	      .   .   'ELSE'                          <RECNT STILL PENDING
0268	      .   .   .   CONTINUE
0270	      .   .   'ENDIF'
    	C
    	C
0271	      .   'ENDDO'
    	C
0274	      'ADMIT'
    	C
0275	      .   WRITE(5,1000)           <SERVER ERROR
0276	      .   WRITE(5,1010)FAULT      <SERVER FAULT OR OTHER FAULT
    	C
    	C       - DISCONNECT ACTIVITY ON LOGICAL LINK
    	C
0277	      .   CALL DSCNTW(CONLUN,IOST)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     13
SERVER           

0278	      .   'IF'(IOST(1).NE.1)
0280	      .   .   WRITE(5,1000)           <SERVER ERROR
0281	      .   .   WRITE(5,1030)IOST(1)    <DISCONNECT FAILED
0283	      .   'ENDIF'
    	C
    	C       - CLOSE NETWORK CONNECTION
    	C
0284	      .   CALL CLSNTW(IOST)
0285	      .   'IF'(IOST(1).NE.1)
0287	      .   .   WRITE(5,1000)           <SERVER ERROR
0288	      .   .   WRITE(5,1008)IOST(1)    <CLOSE FAILED
0290	      .   'ENDIF'
    	C
    	C
0291	      'ENDPOSIT'
    	C
0292	      CALL CHANGE(,0,COMBUF,26)
0293	      COMBUF(1)=9
0295	      'PERFORM' DOIT          <LARMA OM FELFUNKTION
0297	      WRITE(5,1021)           <SERVER EXITS
    	C
    	C       - EXIT TASK
    	C
0298	      CALL EXIT
    	C
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       #DOIT  - SENDS DATA TO ...QUE OR LOOKS AT SPECOM OR READS DUTYTABLE
    	C                OR SOME COMBINATION
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C
0301	      'SECTION' DOIT
    	C
    	C
0302	      .   'CASE' COMBUF(1)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     14
SERVER           

0303	      .   'WHEN' 1                        < 1 = PLEASE GIVE DAYTYPE
0305	      .   .   COMBUF(7)=UDAG1TYP+1    < WORD 7        DAYTYPE (0-7 -> 1-8)
0307	      .   'WHEN' 2                < 2 = PLEASE GIVE BUSS + PLAC
    	C
    	C
0309	      .   .   CALL SHIFTL(6,COMBUF(2))  <V[NSTERJUSTERA, TY S] I DUTYTABLE
0310	      .   .   'IF'(ICOMPA(6,COMBUF(2),'      ').NE.0 .AND.
    	     *.   .   .   ICOMPA(6,COMBUF(2),'VET EJ').NE.0)       <EJ BLANK ELLER VET EJ
0313	      .   .   .   'PERFORM' ACCESS
0316	      .   .   'ENDIF'
    	C
0318	      .   'WHEN' 6                        < 6 = PLEASE SHOW ACTIVE PSO-CALLS
    	C
0320	      .   .   CALL MOVE01(6,XPSO1,COMBUF(2))  <WORD 2-4 TIME FOR PSO-OP.1-3
    	C
    	C
0322	      .   'OTHER'                 < SEND DATA TO ...QUE
    	C
    	C
    	C               COMBUF
    	C                       WORD 1          REQUEST FOR SERVER
    	C                               3 = PLEASE ALERT NO ARRIV
    	C                               4 = PLEASE ALERT LATE ARRIV
    	C                               5 = PLEASE ALERT STRNGE ARRIV
    	C                               8 = SYSTEM UP
    	C                               9 = SYSTEM DOWN
    	C                       WORD 2-4        DUTYID
    	C                       WORD 5          BUSS NUMBER
    	C                       WORD 6          PLAC.
    	C                       WORD 7          DAYTYPE
    	C                       WORD 8          PNR OF OFFENDING PERSON
    	C                       WORD 9-11       LINJE/KURS
    	C                       WORD 12         TIME (INTEGER HHMM)
    	C
    	C               QUEBUF
    	C                       WORD 1          11
    	C                       WORD 2          BUSS NUMBER
    	C                       WORD 3          0
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     15
SERVER           

    	C                       WORD 4          MESSAGE TYPE 95--99
    	C                       WORD 5-7        DUTY
    	C                       WORD 8          PNR
    	C                       WORD 9-11       LINRUN
    	C                       WORD 12         TIME
    	C                       WORD 13         SPARE
    	C
    	C               -- IF BUSS = 0 TA REDA P] DET (<>0 REDAN GJORT)
    	C
0323	      .   .   'IF'(COMBUF(1).LT.7)    <EJ INTERNT
0325	      .   .   .   CALL SHIFTL(6,COMBUF(2)) <V[NSTERJUSTERA, TY S] I RADIO
0326	      .   .   .   'IF'(COMBUF(5).EQ.0)    <BUSSNUMMER [R NOLL
0328	      .   .   .   .   'IF'(ICOMPA(6,COMBUF(2),'      ').NE.0 .AND.
    	     *.   .   .   .   .   ICOMPA(6,COMBUF(2),'VET EJ').NE.0)       <EJ BLANK ELLER VET EJ
0331	      .   .   .   .   .   'PERFORM' ACCESS
0334	      .   .   .   .   'ENDIF'
0336	      .   .   .   'ENDIF'
0338	      .   .   'ELSE'                  <INTERNT
0339	      .   .   .   CALL MOVE01(6,'*DATA*',COMBUF(2))       <DUTYID
0340	      .   .   .   COMBUF(5)=0                             <PNR
0341	      .   .   .   CALL MOVE01(6,'DATAHK',COMBUF(9))       <LINE/RUN
0342	      .   .   .   COMBUF(12)=0                            <TIME
0344	      .   .   'ENDIF'
    	C
    	C               -- SET UP QUEBUF
    	C
0345	      .   .   CALL CHANGE(,0,QUEBUF,26)
0346	      .   .   QUEBUF(1)=11                    <MESSAGE TYPE
0347	      .   .   QUEBUF(2)=COMBUF(5)             <BUSS NUMMER
    	C
0348	      .   .   'IF'(COMBUF(1).EQ.3)            <NO ARRIVAL
0350	      .   .   .   QUEBUF(4)=95
0352	      .   .   'ELSIF'(COMBUF(1).EQ.4)         <LATE ARRIVAL
0354	      .   .   .   QUEBUF(4)=96
0356	      .   .   'ELSIF'(COMBUF(1).EQ.5)         <STRANGE ARRIVAL
0358	      .   .   .   QUEBUF(4)=97
0360	      .   .   'ELSIF'(COMBUF(1).EQ.8)         <SYSTEM UP
0362	      .   .   .   QUEBUF(4)=98
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     16
SERVER           

0364	      .   .   'ELSE'                          <SYSTEM DOWN
0365	      .   .   .   QUEBUF(4)=99
0367	      .   .   'ENDIF'
    	C
0368	      .   .   CALL MOVE01(6,COMBUF(2),QUEBUF(5))              <DUTYID
0369	      .   .   QUEBUF(8)=COMBUF(8)                     <PNR
0370	      .   .   CALL MOVE01(6,COMBUF(9),QUEBUF(9))      <LINE/RUN
0371	      .   .   QUEBUF(12)=(COMBUF(12)/100*60)+MOD(COMBUF(12),100)   <TIME
    	C
    	C
0372	      .   .   CALL SEND(QUE,QUEBUF,FLAGQUE,IDS)       <SYNC = FLAG 56
0373	      .   .   'IF'(IDS.NE.1)
0375	      .   .   .   WRITE(5,1000)                   <SERVER ERROR
0376	      .   .   .   WRITE(5,2000)IDS                <SEND MES TO QUE FAILED
0377	      .   .   .   CALL XMINT(CONLUN,IOST,2,'SQ')
0379	      .   .   'ENDIF'
    	C
    	C
0381	      .   'ENDCASE'
    	C
    	C
0382	      'ENDSECT'               <doit
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C       #ACCESS - COLLECTS DATA FROM DUTYTABLE
    	C
    	CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
    	C
    	C                       WORD 2-4        DUTYID
    	C                       WORD 5          BUSS NUMBER
    	C                       WORD 6          PLAC.
    	C                       WORD 7          DAYTYPE
    	C                       WORD 8          PNR OF OFFENDING PERSON
    	C                       WORD 9-11       LINJE/KURS
    	C                       WORD 12         TIME (INTEGER HHMM)
    	C                       WORD 13         1: mark as active
    	C                       WORD 13         2: (returned) success
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     17
SERVER           

    	C
    	C
    	C
0385	      'SECTION' ACCESS
    	C
0386	      .   COUNT=0
0387	      .   IDS=9999
0388	      .   'WHILE'(IDS.NE.1 .AND. COUNT.LE.3)
0390	      .   .   'IF'(IDS.NE.9999)
0392	      .   .   .   CALL XMINT(CONLUN,IOST,2,'RT')
0393	      .   .   .   WRITE(5,1000)                   <SERVER ERROR
0394	      .   .   .   WRITE(5,2006)IDS        <DUTACC RESTART
0395	      .   .   .   COUNT=COUNT+1
0397	      .   .   'ENDIF'
    	C
0398	      .   .   CALL MARK( FLAGDUT, 6, 2, IDS )  <MARK TIME 6 SEK
    	C
0399	      .   .   'IF'(IDS.NE.1)
    	C
0401	      .   .   .   WRITE(5,1000)                   <SERVER ERROR
0402	      .   .   .   WRITE(5,2007)IDS        <MARK TIME FOR DUTACC FAILED
0403	      .   .   .   'REDO'
    	C
0405	      .   .   'ENDIF'
    	C
0406	      .   .   CALL SEND(DUTACC,COMBUF,,IDS) <SEND LETTER TO DUTACC
0407	      .   .   'IF'(IDS.NE.1)
0409	      .   .   .   WRITE(5,1000)                   <SERVER ERROR
0410	      .   .   .   WRITE(5,2001)IDS  <SEND MES TO DUTACC FAILED
0411	      .   .   .   CALL XMINT(CONLUN,IOST,2,'SC')
0412	      .   .   .   'REDO'
0414	      .   .   'ENDIF'
    	C
0415	      .   .   CALL USTP(DUTACC,IDS)
0416	      .   .   'IF'(IDS.NE.1)  <NOT ACTIVE
0418	      .   .   .   CALL REQUES(DUTACC,,IDS)        <REQUEST DUTACC
0419	      .   .   .   'IF'(IDS.NE.1)
0421	      .   .   .   .   CALL XMINT(CONLUN,IOST,2,'UP')
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     18
SERVER           

0422	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0423	      .   .   .   .   WRITE(5,2002)IDS <UNSTOP/REQUEST DUTACC FAILED
0424	      .   .   .   .   'REDO'
0426	      .   .   .   'ENDIF'
0428	      .   .   'ENDIF'
    	C
0429	      .   .   CALL WAITFR(FLAGDUT,IDS)        <V[NTA P] SVAR FR]N DUTACC
0430	      .   .   'IF'(IDS.NE.1)
0432	      .   .   .   CALL XMINT(CONLUN,IOST,2,'WF')
0433	      .   .   .   WRITE(5,1000)                   <SERVER ERROR
0434	      .   .   .   WRITE(5,2003)IDS        <WAITFR ERROR
0435	      .   .   .   'REDO'
0437	      .   .   'ENDIF'
    	C
0438	      .   .   CALL CANMT( FLAGDUT)    <CANCEL MARK TIME IF ACTIVE
    	C
0439	      .   .   'WHILE'(COUNT.LE.4)             <LOOPA P] EJ SVAR
0441	      .   .   .   CALL RECEIV(,RECBUF,,IDS)
0442	      .   .   .   'IF'(IDS.EQ.-8 .AND. COUNT.LE.3) <NO MESSAGE IN QUE
0444	      .   .   .   .   COUNT=COUNT+1
0445	      .   .   .   .   CALL WAIT(4,2)  <4 EXTRA SECONDS
0447	      .   .   .   'ELSIF'(IDS.NE.1)
0449	      .   .   .   .   CALL XMINT(CONLUN,IOST,2,'RC')
0450	      .   .   .   .   WRITE(5,1000)                   <SERVER ERROR
0451	      .   .   .   .   WRITE(5,2004)IDS <REC MES FROM DUTACC FAILED
0452	      .   .   .   .   'BREAK'
0454	      .   .   .   'ELSE'
0455	      .   .   .   .   'IF'(ICOMPA(6,COMBUF(2),RECBUF(4)).EQ.0)
0457	      .   .   .   .   .   CALL MOVE01(26,RECBUF(3),COMBUF)
0458	      .   .   .   .   .   'BREAK'
0460	      .   .   .   .   'ELSE'
0461	      .   .   .   .   .   CALL XMINT(CONLUN,IOST,2,'AB')
0462	      .   .   .   .   .   WRITE(5,1000)           <SERVER ERROR
0463	      .   .   .   .   .   WRITE(5,2005)
    	C                       <RECEIVE MESSAGE FROM DUTACC WRONG - ABORT DUTACC
0464	      .   .   .   .   .   CALL ABORT(DUTACC)
0465	      .   .   .   .   .   IDS=1
0466	      .   .   .   .   .   'WHILE'(IDS.EQ.1)
META FORTRAN  X08.09		30-MAR-88	00:27:01	PAGE     19
SERVER           

0468	      .   .   .   .   .   .   CALL RECEIV(,RECBUF,,IDS) <T\M BUFFERTEN
0469	      .   .   .   .   .   'ENDDO'
0471	      .   .   .   .   .   'BREAK'
0473	      .   .   .   .   'ENDIF'
0475	      .   .   .   'ENDIF'
0476	      .   .   'ENDDO'
0478	      .   'ENDDO'
    	C
0480	      .   'IF'(COUNT.GT.3)
0482	      .   .   CALL XMINT(CONLUN,IOST,2,'CO')
0484	      .   'ENDIF'
    	C
    	C
0485	      'ENDSECT'               <access
    	C
    	C
0487	      END



ERRORS DETECTED:      0
SC:SERVER,SC:SERVER.MLS/-SP=SC:SERVER