FTN,L 
      PROGRAM LSPNS(3,40),09570-16657 REV. 1826 780628
C 
C-------------------------------------------------------- 
C 
C     RELOC.       09570-16657
C     SOURCE       09570-18657
C 
C     D. L. BASKINS      13 OCT 76 REV. A 
C 
C-------------------------------------------------------- 
C 
C 
C  PROGRAM SCHEDULED BY LOGON TO SET UP THE SESSION MONITOR 
C 
      DIMENSION IP(16),NAME(68),LOGMS(28) 
      DIMENSION IPROG(10),LOGON(3),IDRTR(3),NUNAM(3)
C 
C  6000 WORD ARRAY = ABOUT A 48 BLOCK MAX /IDNAM FILE SIZE 
C 
      DIMENSION NAMBF(6000),IDCB(528),IDNAM(3)
      DIMENSION MES0(26),MES1(22),MES2(25),MES3(22),MES4(23),MES5(7)
C 
C  /IDNAM  IS THE FILE NAME ON DISC LU=2 FOR LOGON ID.
C 
      DATA IDNAM/2H/I,2HDN,2HAM/,IDRTR/2HD.,2HRT,2HR /
      DATA IRLN/67/,IPR/74000B/,MISSFL/1/,LOGON/2HLO,2HGO,2HN / 
      DATA ICLADR/0/
      DATA LOGMS/2HLO,2HGO,2HN ,2HT=,2H01,2H  / 
      DATA MES0/2HUN,2HAB,2HLE,2H T,2HO ,2HOP,2HEN,2H /,2HID, 
     12HNA,2HM ,2HFI,2HLE,2H >,2H> ,2HTR,2HY ,2HYO,2HUR,2H L, 
     12HOG,2HON,2H S,2HTR,2HIN,2HG /
      DATA MES1/2HRE,2HAD,2HF ,2HER,2HRO,2HR ,2HIN,2H /,2HID, 
     12HNA,2HM ,2H>>,2H I,2HGN,2HOR,2HE ,2HRE,2HST,2H O,2HF , 
     12HFI,2HLE/
      DATA MES2/2HFM,2HGR,2H E,2HRR,2H: ,2H- ,2H15,2H >,2H> , 
     12HUN,2HAB,2HLE,2H T,2HO ,2HCR,2HEA,2HTE,2H P,2HRO,2HGR, 
     12HAM,2H  ,2HXX,2HXX,2HXX/ 
      DATA MES3/2HTO,2HO ,2HMA,2HNY,2H N,2HAM,2HES,2H I,2HN , 
     12H/I,2HDN,2HAM,2H F,2HIL,2HE ,2H>>,2H I,2HGN,2HOR,2HE , 
     12HRE,2HST/
      DATA MES4/2HSE,2HSS,2HIO,2HN ,2HIN,2HCO,2HRE,2H T,2HAB, 
     12HLE,2H F,2HUL,2HL ,2H>>,2H R,2HE-,2HBO,2HOT,2H O,2HR , 
     12HRE,2H-G,2HEN/ 
      DATA MES5/2HIL,2HLE,2HGA,2HL ,2HAC,2HCE,2HSS/ 
C 
      IKVT(IDMY) = 2H00+(IDMY/10*256)+IDMY-(IDMY/10*10) 
C 
C  GET THE TERMINAL LOGICAL UNIT AND CLASS NUMBER ADDRESS FROM LOGON
C 
      IF(IGTSM(5HCLAS%,ICLADR).EQ.0) GO TO 1000 
      ICLASS = IAND(KGET(ICLADR),17777B)
C 
C  IGNORE IF CLASS NUMBER HAS NOT BEEN ALLOCATED
C 
      IF (ICLASS.EQ.0) GO TO 1000 
C 
C  JUST SWAP ME >> NOT THE WHOLE PARTITION
C 
      CALL EXEC (22,2)
C 
C 
C  IF SECURITY IS NEEDED, THE /IDNAM FILE MUST HAVE -(MSC) OF SYSTEM
C 
      ITRK = KGET(1756B) - 1
      CALL EXEC (1,2+IPR,IDCB,128,ITRK,0) 
      MSC = -IDCB(127)
C 
C  CHECK IF LOGON OR LOGOF OR DONE
C 
    1 IWAIT = 120000B 
    2 IFLAG = -1
      CALL EXEC (21,ICLASS+IWAIT,NAME,IRLN,IFLAG,LU,IRCOD)
      CALL ABREG(IA,IB) 
      IF (IA.EQ.-1) GO TO 1000
C 
C  IF LOGOF AND CLASS IS MATURE (ALWAYS?), DO IT. 
C 
      IF (IA.GE.0.AND.IFLAG.GT.0.AND.IRCOD.EQ.1) GO TO 3000 
C 
C  PENDING CLASSES, SO SET FLAG TO WAIT FOR THEM TO MATURE. 
C 
      IWAIT = 20000B
C 
C  CHECK IF ALREADY HAVE FILES
C 
      IF (MISSFL.EQ.0) GO TO 3
C 
C THE /IDNAM FILE MUST BE ON THE SYSTEM DISC OR SECURITY IS NOT POSSIBLE
C 
      CALL LOPEN(IDCB,IERR,IDNAM,1,MSC,-2,528)
      IF (IERR.LT.0) GO TO 300
C 
C  READ ALL ID'S OUT OF THE /IDNAM FILE INTO CORE 
C 
      IWRDNM = 1
  100 NAMBF(IWRDNM) = 0 
      IF (IWRDNM+IRLN+1.GT.6000) GO TO 160
      CALL READF(IDCB,IERR,NAMBF(IWRDNM+1),IRLN,LEN)
      IF (IERR.GE.0) GO TO 125
      CALL REIO(2,LU,MES1,22) 
      LEN = -1
  125 IF (LEN) 250,100,150
C 
C  IF RECORD STARTS WITH '*' THEN IGNORE THE RECORD 
C 
  150 IF (IAND(NAMBF(IWRDNM+1),177400B).EQ.25000B) GO TO 100
      NAMBF(IWRDNM) = LEN 
      IWRDNM = IWRDNM + LEN + 1 
      GO TO 100 
  160 CALL REIO(2,LU,MES3,22) 
  250 MISSFL = 0
      GO TO 350 
  300 MISSFL = 1
  350 CALL LCLOS (IDCB) 
C 
C  CHECK IF THE CLASS IS MATURE YET.
C 
    3 IF (IA.LT.0) GO TO 2
      IF (IRCOD.NE.1) GO TO 1 
C 
C  YES, CHECK THE LENGTH OF CALLERS BUFFER
C 
      IF (IB.EQ.0) GO TO 800
      IF (IB.GT.IRLN) IB = IRLN 
      DO 400 I = IB+1,IRLN
  400 NAME(I) = 2H
      IF (MISSFL.EQ.0) GO TO 485
C 
C  /IDNAM FILE MISSING, OUTPUT ERROR AND USE INPUT STRING AS LOGON STRING 
C 
      CALL REIO(2,LU,MES0,26) 
      DO 475 I = 1,IB 
      NAMBF(I+1) = NAME(I)
  475 NAMBF(I+IB+2) = NAME(I) 
      NAMBF = IB
      NAMBF(IB+2) = IB
      NAMBF(IB+IB+3) = 0
C 
C  NOW LOOK FOR A MATCHING STRING WITH /IDNAM FILE AND USER LOGON STRING
C 
  485 IWRDNM = 1
  490 LEN = NAMBF(IWRDNM) 
      IF (LEN.LE.0) GO TO 850 
      DO 500 I = 1,LEN
      IF (NAME(I).NE.NAMBF(IWRDNM+I)) GO TO 530 
  500 CONTINUE
      DO 510 I = LEN+1,IRLN 
      IF (NAME(I).NE.2H  ) GO TO 530
  510 CONTINUE
      GO TO 520 
C 
C  TRY NEXT ENTRY IN THE /IDNAM FILE
C 
  530 INXRLN = NAMBF(IWRDNM+LEN+1)
C 
C  CHECK IF POSSIBLE AN ODD NUMBER OF RECORDS IN FILE?
C 
      IF (INXRLN.LE.0) GO TO 850
C 
C  BUMP PAST THE PROGENITORS NAME TO THE NEXT IDNAM RECORD
C 
      IWRDNM = IWRDNM + LEN + INXRLN + 2
      GO TO 490 
C 
C  MATCH FOUND, NOW PARSE THE NEXT RECORD TO SETUP CORE TABLE OF SESSION
C 
  520 ISTRC = 1 
      INDEX = IWRDNM + LEN + 2
      LENTH = NAMBF(INDEX-1) * 2
      CALL NAMR(IPROG,NAMBF(INDEX),LENTH,ISTRC) 
      DO 550 I = 1,6
      IFRST = ISTRC 
      CALL NAMR(IP(I),NAMBF(INDEX),LENTH,ISTRC) 
C 
C  REPLACE ANY '0G' SUBPARAMETERS BY THE LOGICAL UNIT OF TERMINAL 
C 
      IPTYPE = IP(I+3)
      IF (IPTYPE.EQ.3.AND.IP(I).EQ.2H0G) IP(I) = LU 
      IF (I.EQ.1.AND.IPTYPE.EQ.0) IP(I) = LU
  550 CONTINUE
C 
C  GET OPTIONAL STRING BUFFER TO PASS PROGENITOR PROGRAM 1ST TIME 
C 
      IF (IPTYPE.EQ.0) GO TO 700
C 
C  LEFT JUSTIFY THE OPTIONAL STRING BUFFER INTO "NAME"
C 
      IPTYPE = 0
      ICNT = LENTH - IFRST + 1
      IF (ICNT.LE.0) GO TO 700
      IPTYPE = (ICNT+1)/2 
      DO 600 K = 1,ICNT 
      KK = (K-1)/2 + 1
      IOFF = (IFRST+K)/2
      KKK = INDEX + IOFF - 1
      ICHAR = IAND(NAMBF(KKK),377B) 
      IF (IOFF+IOFF.EQ.IFRST+K) ICHAR = IXOR(NAMBF(KKK),ICHAR)/256
      IF (KK+KK-K) 610,620,610
  610 NAME(KK) = ICHAR*256 + 40B
      GO TO 600 
  620 NAME(KK) = IAND(NAME(KK),77400B) + ICHAR
  600 CONTINUE
C 
C  NOW FORM THE ALTERNATE NAME FOR THE SESSION I.E.  FMGR = FMG07 (LU=7)
C 
  700 NUNAM = IPROG 
      NUNAM(2) = IPROG(2) 
      IF (IAND(NUNAM,377B).EQ.40B) NUNAM = IAND(NUNAM,177400B)+56B
      IF (IAND(NUNAM(2),177400B).EQ.20000B) NUNAM(2) = 2H.
      NUNAM(2) = IAND(NUNAM(2),177400B) + (LU/10+60B) 
      NUNAM(3) = (MOD(LU,10) + 60B) * 256 + 40B 
C 
C  NOW TRY FOR THE GENERIC NAME ALREADY IN CORE 
C 
      CALL IDDUP(IPROG,NUNAM,IERR)
C 
C  SKIP THE :RP,PROG IF NAME ALREADY EXISTS IN CORE.
C 
      IF (IERR.EQ.23.OR.IERR.EQ.0) GO TO 750
      CALL LOPEN(IDCB,IERR,IPROG,1,0,-2)
      IF (IERR.EQ.-6.AND.KGET(1760B).EQ.0) GO TO 760
      IF (IERR.GE.0) GO TO 725
      CALL LOPEN(IDCB,IERR,IPROG,1,0,-3)
      IF (IERR.LT.0) GO TO 760
  725 CALL IDRPL(IDCB,IERR,NUNAM) 
      CALL LCLOS(IDCB)
      IF (IERR.EQ.0.OR.IERR.EQ.23) GO TO 750
C 
C  UNABLE TO CREATE SESSION PROGRAM ID >> WRITE ERROR MESSAGE 
C 
  760 IERRR = IABS(IERR)
      MES2(7) = IKVT(IERRR) 
      MES2(6) = 2H+ 
      IF (IERR.LT.0) MES2(6) = 2H-
      MES2(23) = NUNAM
      MES2(24) = NUNAM(2) 
      MES2(25) = NUNAM(3) 
      CALL REIO(2,LU,MES2,25) 
      GO TO 800 
C 
C  NOW SET THE SESSION PROGRAM NAME AND 5 P PARAMETERS IN CORE TABLE
C 
  750 CALL ISESN(NUNAM,LU,IP,IP(5),IERR)
      IF (IERR.EQ.0) GO TO 775
      CALL REIO(2,LU,MES4,23) 
C 
C  FORM THE LOGON MESSAGE 
C 
  775 IASLU = IKVT(LU)
      CALL TODAY (LOGMS(7)) 
      LOGMS(5) = IASLU
      LOGMS(3) = 2HN
C 
C  DO A BUFFER UNFLUSH SO THAT THE DRIVER CANNOT EAT LOGON MESSAGE
C 
      CALL ICLRW(3,ICLADR,LU+2400B) 
C 
C  WRITE OUT THE LOGON MESSAGE
C 
      CALL ICLRW(2,ICLADR,LU,0,LOGMS,-37) 
C 
C  SCHEDULE THE PROGENITOR WITH THE OPTIONAL STRING BUFFER
C 
      CALL EXEC(10,NUNAM,IP,IP(2),IP(3),IP(4),IP(5),NAME,IPTYPE)
C 
C  NOW PUT IN THE SESSION STUFF INTO THE IDSEGMENT
C 
      CALL MKIDS(NUNAM,LU)
C 
C  CHECK IF TERMINAL ENABLE IS REQUESTED FROM THE /IDNAM FILE 
C 
      IF (IP(5)) 780,790
C 
C  NOW DO A TERMINAL DISABLE
C 
  780 CALL ICLRW(3,ICLADR,LU+2100B) 
      GO TO 1 
C 
C  SET UP A NULL SESSION AND ENABLE TERMINAL FOR ATTENTION INTO LOGON 
C 
  800 CALL ISESN(0D0,LU,IP,0,IERR)
C 
C  DO A TERMINAL ENABLE REQUEST 
C 
  790 CALL ICLRW(3,ICLADR,LU+2000B) 
      GO TO 1 
C 
C  WRITE OUT THE "ILLEGAL ACCESS" MESSAGE AND START ALL OVER AGAIN
C 
  850 CALL ICLRW(2,ICLADR,LU,0,MES5,7)
      GO TO 800 
C 
C  NOW DO THE LOGOF THING (MORE WORK HERE IS DESERVED)
C  NOTE:  THE SESSION TABLE SHOULD HAVE AN ILLEGAL NAME 
C   IN IT FROM R$PN$, AND THE DISABLE TERMINAL BIT SHOULD 
C   BE SET SO THAT "LOGON" WILL SCHEDULE "LSPNS" TO 
C   RE-ENABLE THE TERMINAL WHEN LOGON IS ACCOMPLISHED.
C 
 3000 CALL TODAY(LOGMS(7))
      IASLU = IKVT(LU)
      LOGMS(5) = IASLU
      LOGMS(3) = 2HF
C 
C  DO A BUFFER UNFLUSH COMMAND TO THE DRIVER
C 
      CALL ICLRW(3,ICLADR,LU+2400B) 
C 
C  NOW WRITE A CR/LF TO GET THE CURSER TO LEFT SIDE 
C 
      CALL ICLRW(2,ICLADR,LU) 
C 
C  NOW WRITE THE LOGOF MESSAGE TO THE TERMINAL
C 
      CALL ICLRW(2,ICLADR,LU,0,LOGMS,-37) 
C 
C  NOW DO A BUFFER FLUSH TO CLEAN OUT ANY RESIDUAL MESSAGES 
C 
      CALL ICLRW(3,ICLADR,LU+2300B) 
      IP(5) = 0 
C 
C  NOW DISMOUNT ALL SESSION CARTRIDGES
C 
      ISES = LU * 4000B 
      MYID = KGET (1717B) 
C 
C  CALL D.RTR TO DISMOUNT ALL SESSION CARTRIDGES TO THIS TERMINAL 
C 
      CALL EXEC (23,IDRTR,MYID,0,ISES,0,10) 
C 
C  NOW CLEAN UP ALL FILES LEFT OPEN ON GLOBAL CRN'S 
C     BY DOING AN UNQUALIFIED SEARCH ON ALL GLOBAL CRN'S
C 
      CALL LOPEN(IDCB,IERR,6H!)"(#')
C 
C  NOW OUTPUT THE LOGON MESSAGE 
C 
      CALL EXEC (23,LOGON,LU) 
      GO TO 1 
 1000 END 
      END$