      PROGRAM MAKELB
C           To make library from assembler or Fortran source
C           Version 3.01
C           Copyright D.J. Crennell
C     Needs Wimp Graphics and Utilities libraries
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      CALL WPINIT('MakeLib')
      CALL INIT
      CALL WPLOOP(MASK)
      END
C
C                                                     Inactive flag
C     scratch directory: DIR (name length LDIR=16)        LDIR = 0
C     Files in DIR     use                   handle
C     'symt'       symbol table block        KSYM         KSYM = 0
C     'diry'       directory block           KDIRY       KDIRY = 0
C     'aof'        procedure object code     KAOF         KAOF = 0
C     'f.temp'     procedure source code    (Fortran 10) LTEMP = 0
C       ( TEMP = DIR//'f.temp' : LTEMP = 22 )
C     'message'    assembler/compiler O/P   (Fortran 11)
C
C Input source file:
C     IN  ( LIN = LNBLNK(IN) )              (Fortran 9)    LIN = 0
C Output library file
C     OUT                                    KOUT         KOUT = 0
C
      BLOCK DATA
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      DATA KOUT,KSYM,KDIRY,KAOF,MRAM/5*0/
      DATA LTEMP,LDIR,LIN,LIND/4*0/
      DATA MASK,NPROC/1,0/
      END
C
      SUBROUTINE ADDAOF
C           append aof to KOUT
      PARAMETER(MAXCH=10)
      DIMENSION IWHD(4,MAXCH),IPTOLD(MAXCH),NWDNEW(MAXCH)
C      CHARACTER*16 NAMHD(MAXCH)
C      EQUIVALENCE (IWHD,NAMHD)
      DIMENSION IOBJ(2)
      DATA IOBJ(1)/4HOBJ_/,IOBJ(2)/4HIDFN/
C
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
C          append all of file K to file KOUT
      CALL PTRSET(KAOF,0)
      CALL READWD(J,KAOF)
      CALL READWD(NCHNK,KAOF)
      CALL READWD(NCHNK,KAOF)
      IF(NCHNK.GT.MAXCH) STOP' Aof file has too many blocks'
C          length required for headers
      L = 4*(4*NCHNK + 3)
      DO 20 I=1,NCHNK
        DO 10 K=1,4
          CALL READWD(IWHD(K,I),KAOF)
   10   CONTINUE
        IPTOLD(I) = IWHD(3,I)
        IWHD(3,I) = L
C        IF(NAMHD(I)(1:8).EQ.'OBJ_IDFN') THEN
        IF(IWHD(1,I).EQ.IOBJ(1) .AND. IWHD(2,I).EQ.IOBJ(2)) THEN
          NWDNEW(I) = 2
          IWHD(4,I) = 8
        ELSE
          NWDNEW(I) = (IWHD(4,I)+3)/4
        ENDIF
        L = L + 4*NWDNEW(I)
   20 CONTINUE
C          add directory entry to ALF
      CALL HD(L,'LIB_DATA')
C          write the aof record header (3 words)
      CALL SENDWD(J,KOUT)
      CALL SENDWD(NCHNK,KOUT)
      CALL SENDWD(NCHNK,KOUT)
C          now write out the block headers (4*NCHNK words)
      DO 30 I=1,NCHNK*4
        CALL SENDWD(IWHD(I,1),KOUT)
   30 CONTINUE
C          and now the blocks
      DO 50 I=1,NCHNK
C        IF(NAMHD(I)(1:8).EQ.'OBJ_IDFN') THEN
        IF(IWHD(1,I).EQ.IOBJ(1) .AND. IWHD(2,I).EQ.IOBJ(2)) THEN
          CALL SENDWD('Make',KOUT)
          CALL SENDWD('Lib'//CHAR(0),KOUT)
        ELSE
          CALL PTRSET(KAOF,IPTOLD(I))
          DO 40 K=1,NWDNEW(I)
            CALL READWD(J,KAOF)
            CALL SENDWD(J,KOUT)
   40     CONTINUE
        ENDIF
   50 CONTINUE
      RETURN
      END
C
      SUBROUTINE APPEND(K,A)
C           append block name A from file K
      CHARACTER A*(*)
      DIMENSION IREGS(0:9)
      EQUIVALENCE (L,IREGS(2))
C
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
C        get size of file
      IREGS(0) = 2
      IREGS(1) = K
C          SWI OS_Args,2,handle TO ,,extent
      CALL ARCSWI('OS_Args',IREGS,IDUM,'N')
C          add directory entry to ALF
      CALL HD(L,A)
C          append all of file K to file KOUT
      CALL PTRSET(K,0)
      DO 10 I = 1, L, 4
        CALL READWD(J,K)
   10   CALL SENDWD(J,KOUT)
      RETURN
      END
C
      LOGICAL FUNCTION CHKEND(LINE)
C           check line for END statement
      CHARACTER LINE*(*), TEST*4
      SAVE TEST
      DATA TEST/'END '/
      CHKEND = .FALSE.
C           END must not have label
      J = 0
      DO 10 I = 1, LNBLNK(LINE)
        K = ICHAR(LINE(I:I))
        IF(K.NE.32) THEN
          IF(K.GT.96) K = K - 32
          J = J + 1
          IF(K.NE.ICHAR(TEST(J:J))) RETURN
        ENDIF
   10 CONTINUE
      IF(J.EQ.3) CHKEND = .TRUE.
      RETURN
      END
C
      LOGICAL FUNCTION CHKINC(LINE)
C           check line for INCLUDE' statement
      CHARACTER LINE*(*), TEST*8
      SAVE TEST
      DATA TEST/'INCLUDE'''/
      CHKINC = .FALSE.
C           INCLUDE must not have label
      J = 0
      DO 10 I = 1, LNBLNK(LINE)
        K = ICHAR(LINE(I:I))
        IF(K.NE.32) THEN
          IF(K.GT.96) K = K - 32
          J = J + 1
          IF(K.NE.ICHAR(TEST(J:J))) RETURN
          IF(J.EQ.8) THEN
            CHKINC = .TRUE.
            RETURN
          ENDIF
        ENDIF
   10 CONTINUE
      RETURN
      END
C
      SUBROUTINE CLOSEF
C              to close all open files
C
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
C
      IF(LIN.GT.0) THEN
        CLOSE(9)
        LIN = 0
      ENDIF
      CALL KLOSE(KOUT)
      IF(LDIR.EQ.0) RETURN
      CALL KLOSE(KSYM)
      CALL REMOVD('symt')
      CALL KLOSE(KDIRY)
      CALL REMOVD('diry')
      CALL KLOSE(KAOF)
      CALL REMOVD('aof')
      CALL REMOVD('message')
      IF(LTEMP.GT.0) CALL REMOVE(TEMP)
      LTEMP = 0
      CALL REMOVD('f')
      IF(ASM(1:3).EQ.'RAM') THEN
C             remove the compiler from RAMFS, but first ensure it is not locked
        CALL OSCLI('ACCESS '//ASM//'WR')
        CALL REMOVE(ASM)
        ASM = ' '
      ENDIF
      IF(MRAM.GT.0) CALL RAMSET(-MRAM)
      MRAM = 0
      LDIR = 0
      END
C
      SUBROUTINE CMPILE
C           compile or assemble from temp to aof
      DIMENSION IREGS(0:9)
      CHARACTER LINE*80, JOB*256
      EQUIVALENCE (LINE, JOB)
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      COMMON /MENUS/ MTOP(43),MFOP(61)
      NERR = 1
C           set current directory for INCLUDE
      JOB = 'DIR '//IN(1:LIND)
      CALL OSCLI(JOB(1:LIND+4))
C           get next slot and free space
      CALL WPGTSS(K,I,J)
C           fill machine with next task
      CALL WPSTNS(J)
C           make up command line
      LO = LNBLNK(OPT)
      JOB = ASM//OPT(1:LO)//' { > '//DIR//'message }'
C           compile/assemble
      CALL WPTASK(JOB)
C           reset next slot size
      CALL WPSTNS(I)
C           delete temporary source file
      CALL REMOVE(TEMP)
C           check for compilation errors
      LINE(11:) = 'Sys$ReturnCode'//CHAR(0)
      IREGS(0) = LOCC(LINE(11:11))
      IREGS(1) = LOCC(LINE)
      IREGS(2) = 10
      IREGS(3) = 0
      IREGS(4) = 0
C           SWI OS_ReadVarVal,'Sys$ReturnCode',<result>,LEN(result),0,0
      CALL ARCSWI('OS_ReadVarVal',IREGS,IDUM,'N')
C            check the return code for error
      IF(LINE(1:1).GT.'0') THEN
C            copy error message to status window
        OPEN(11,FILE=DIR//'message',STATUS='OLD')
   10   READ(11,101,IOSTAT=IOS)LINE
        IF(IOS.EQ.0) THEN
  101     FORMAT(A)
          IF(LINE.NE.' ') THEN
            STATUS(NERR) = LINE
            NERR = NERR + 1
          ENDIF
          IF(NERR.LT.6) GO TO 10
        ENDIF
        CLOSE(11)
        L = LNBLNK(PROGNM)
        STATUS(NERR) = PROGNM(1:L)//' Failed,    No library created'
        CALL DISP(NERR)
        MASK = 1
        CALL BEEP
      ELSE
C             no error, open the aof file giving handle KAOF
        KAOF = KOPID('aof')
C             move aof file to new library
        CALL ADDAOF
C        CALL APPEND(KAOF,'LIB_DATA')
C             make up symbol table and directory
        CALL SYMT
C             close and delete the object file
        CALL KLOSE(KAOF)
        CALL REMOVD('aof')
        IF(IPROC.EQ.NPROC) THEN
C             finished, copy in the symbol table and directory blocks
          CALL APPEND(KSYM,'OFL_SYMT')
          CALL APPEND(KDIRY,'LIB_DIRY')
          CALL CLOSEF
          MASK = 1
          STATUS(1) = 'Library complete; no errors'
          CALL DISP(1)
        ELSE
C             get new source file for next compilation
          CALL CPYSRC
        ENDIF
      ENDIF
      IF(MASK.EQ.1) THEN
C          done, restore greying to top menu items
        CALL WPSTMF(2,MTOP,5,.FALSE.)
        CALL WPSTMF(2,MTOP,4,.TRUE.)
        CALL WPSTMF(2,MTOP,3,.FALSE.)
        CALL WPSTMF(2,MTOP,2,.FALSE.)
C          close files
        CALL CLOSEF
        IF(NERR.GT.1) CALL REMOVE(OUT)
      ENDIF
      RETURN
      END
C
      SUBROUTINE CPYSRC
C           copy source of a routine to temp for compilation
      CHARACTER*80 LINE,EXTEND*320
      LOGICAL FOUND,CHKEND,GETNAM
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      CHARACTER*8 SCHINC
      DATA SCHINC/'INCLUDE'''/
      SAVE SCHINC
C
C                make score icon black
      CALL WPSTIF(JWSCOR,IPROC,22,.FALSE.)
C                increment count of procedures
      IPROC = IPROC + 1
C          scroll score window if necessary
      CALL WPGTWS(JWSCOR,IBLOCK)
      IF(IPROC*40.GT.IBLOCK(5)-IBLOCK(3)-IBLOCK(7)) THEN
        IBLOCK(7) = IBLOCK(7) - 40
        CALL WPSTWS(IBLOCK)
      ENDIF
      OPEN(10,FILE=TEMP,STATUS='NEW')
      FOUND = .FALSE.
   10 READ(9,101)LINE
  101 FORMAT(A)
      IF(.NOT.FOUND) FOUND = GETNAM(LINE)
      IF(.NOT.FOUND) GO TO 10
C               check for "INCLUDE'"
      L = LNBLNK(LINE)
      IF(L.EQ.0) GO TO 10
      IF(.NOT.ASSEMB) THEN
        J = 0
        M = 0
        DO 20 I = 1, L
          K = ICHAR(LINE(I:I))
C             convert to upper case
          IF(K.GT.96) K = K - 32
          IF(K.NE.32) THEN
            J = J + 1
            IF(J.LT.9) THEN
              IF(K.NE.ICHAR(SCHINC(J:J))) GO TO 50
            ELSE
              GO TO 30
            ENDIF
          ENDIF
   20   CONTINUE
C           here we have INCLUDE, insert whole file name
   30   EXTEND = LINE(1:I-1)//IN(1:LIND)//'.'//LINE(I:L)
        L = LNBLNK(EXTEND)
        I = 1
   40   LINE = EXTEND(I:)
        IF(L-I.GT.71) THEN
          WRITE(10,101)LINE(1:72)
          I = I + 66
          EXTEND(I:I+5) = '     +'
          GO TO 40
        ELSE
          L = LNBLNK(LINE)
        ENDIF
      ENDIF
   50 WRITE(10,101)LINE(1:L)
      IF(.NOT.CHKEND(LINE)) GO TO 10
      CLOSE(10)
      RETURN
      END
C
      SUBROUTINE DISP(N)
C         force display of N lines of status
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      CALL WPGTWS(JWSTAT,IBLOCK)
      IF(IBITS(IBLOCK(9),16,2).NE.3) THEN
C           re-open status window on top if not completely visible
        IBLOCK(8) = -1
        CALL WPSTWS(IBLOCK)
      ENDIF
      CALL WPPLOT(JWSTAT,-1)
      NDISP = N
      END
C
      LOGICAL FUNCTION GETNAM(LINE)
C         search for appropriate name in LINE
      LOGICAL FLAG
      CHARACTER LINE*(*),BUF*72,MESSG*60
C
      COMMON /MENUS/ MTOP(43),MFOP(61)
C
      GETNAM = .FALSE.
C          line with procedure name must have blank first character
      IF(LINE(1:1).NE.' ') RETURN
      L = MIN(72,LNBLNK(LINE))
      J = 0
C             squeeze out blanks and make upper case
      DO 10 I = 1, L
        K = ICHAR(LINE(I:I))
        IF(K.NE.32) THEN
C             make upper case
          IF(K.GT.96 .AND. K.LT.123) K = K - 32
C             stop on non-alphanumeric, or (*)
          IF(K.LT.40 .OR. K.GT.95) GO TO 20
          IF(K.GT.57 .AND. K.LT.65) GO TO 20
          IF(K.GT.42 .AND. K.LT.48) GO TO 20
          J = J + 1
          BUF(J:J) = CHAR(K)
        ENDIF
   10 CONTINUE
   20 IF(J.LT.4) RETURN
C            check if we are doing assemblies or compilations
      CALL WPGTMF(0,MTOP,2,FLAG)
      I = 0
      IF(FLAG) THEN
C            assembler header is 'TTL'
        IF(BUF(1:3).EQ.'TTL') I = 4
      ELSE
C           check for FORTRAN procedure header
        IF(BUF(1:7).EQ.'PROGRAM') I = 8
        IF(BUF(1:10).EQ.'SUBROUTINE') I = 11
        IF(BUF(1:9).EQ.'BLOCKDATA') I = 1
        IF(I.EQ.0) THEN
          I = INDEX(BUF(1:J),'FUNCTION')
          IF(I.GT.0) I = I + 8
        ENDIF
      ENDIF
      IF(I.GT.0) THEN
        K=INDEX(BUF(I:J),'(')
        IF(K.GT.0) J = I + K - 2
        CALL INS(BUF(I:J))
        GETNAM = .TRUE.
      ENDIF
      RETURN
      END
C
      SUBROUTINE HD(LENG,BLOC)
C          insert header for block 'BLOC' length LENG
C       BLOC is really an 8-byte character string but it is easier as 2 words
      DIMENSION BLOC(2)
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C          save output pointer
      CALL PTRGET(KOUT,IPOUT)
C          point to next header position
      CALL PTRSET(KOUT,LHPTR)
C          2 words of header
      CALL SENDWD(BLOC(1),KOUT)
      CALL SENDWD(BLOC(2),KOUT)
C          pointer and length
      CALL SENDWD(IPOUT,KOUT)
      CALL SENDWD(LENG,KOUT)
C          allow 16 bytes for header
      LHPTR = LHPTR + 16
C          restore output pointer
      CALL PTRSET(KOUT,IPOUT)
      RETURN
      END
C
      INTEGER FUNCTION IGETWD(I)
C        get word at I from file KAOF
C
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
      CALL PTRSET(KAOF,I)
      CALL READWD(IGETWD,KAOF)
      RETURN
      END
C
      SUBROUTINE INIT
C           initialise wimp blocks and icon bar
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /MENUS/ MTOP(43),MFOP(61)
C
C           create menus
      CALL WPMKMB('MakeLib,info,help,assembler,Fortran,cancel,quit',
     +             MTOP)
      CALL WPMKMB('F77Options,Real*8,Integer*2,Inline Bool,F66,'//
     +'!comment,Conversions,Static mem,132ch lines,C ''\'' codes',MFOP)
      CALL WPAM2M(MFOP,MTOP,3)
C           set in-line bool
      CALL WPSTMF(0,MFOP,2,.TRUE.)
C           load windows from template file
      CALL WPOPNT('<MakeLib$Dir>.Templates')
      CALL WPLDTW('info',IBLOCK,SINFO,JW)
      CALL WPAW2M(JW,MTOP,0)
      CALL WPLDTW('scoreboard',IBLOCK,TITL,JWSCOR)
      CALL WPLDTW('status',IBLOCK,IN,JWSTAT)
      CALL WPCLST
C           make save window
      CALL WPSAVE('FFD',999,OUT,JWDRAG)
C           set up flags for icons: noborder, left-justify,
C           no-background, grey, no click
      CALL WPCHTF(2,.FALSE.)
      CALL WPCHTF(3,.FALSE.)
      CALL WPCHTC(1,0)
C      CALL WPCHTF(5,.FALSE.)
      CALL WPCHTF(22,.TRUE.)
      CALL WPCHTF(100,.TRUE.)
C           grey 'stop'
      CALL WPSTMF(2,MTOP,4,.TRUE.)
C           now install icon at right of Icon Bar
      CALL WPBARI('!MakeLib',-1,MTOP,ICBARI)
      RETURN
      END
C
      SUBROUTINE INS(NAME)
C          insert icon on scoreboard
      CHARACTER NAME*(*)
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
      IF(KOUT.EQ.0) THEN
        L = MIN(12,LEN(NAME))
        CALL WPADTI(JWSCOR,0,-40-40*NPROC,216,40,NAME(1:L),0,I)
      ELSE
        PROGNM = NAME
      ENDIF
      RETURN
      END
C
      INTEGER FUNCTION JINDX(NAME)
C          find chunk 'name' in aof file and return address of pointer
C          to block. NAME is 8 bytes long.
      DIMENSION NAME(2)
C        get number of entries
      N = IGETWD(4)
      K = 12
C        search entries
      DO 10 I = 1, N
        IF(IGETWD(K).EQ.NAME(1)) THEN
          IF(IGETWD(K+4).EQ.NAME(2)) THEN
            JINDX = K + 8
            RETURN
          ENDIF
        ENDIF
   10 K = K + 16
      JINDX = 0
      RETURN
      END
C
      SUBROUTINE KLOSE(K)
C             close direct access file handle K
      DIMENSION IREGS(0:9)
      IF(K.EQ.0) RETURN
      IREGS(0) = 0
      IREGS(1) = K
C             SWI OS_Find,0,handle
      CALL ARCSWI('OS_Find',IREGS,IDUM,'N')
      K = 0
      RETURN
      END
C
      INTEGER FUNCTION KOPID(NAME)
C             open input direct access file with DIR prefix
      CHARACTER NAME*(*),DNAME*80
      DIMENSION IREGS(0:9)
C
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
C
      DNAME = DIR//NAME//CHAR(0)
      IREGS(0) = 78
      IREGS(1) = LOC(DNAME)
C             SWI OS_Find,&4E,name TO handle
      CALL ARCSWI('OS_Find',IREGS,IDUM,'N')
      KOPID = IREGS(0)
      RETURN
      END
C
      INTEGER FUNCTION KOPOUT(NAME)
C           open direct access output stream
      CHARACTER NAME*(*), DNAME*256
      DIMENSION IREGS(0:9)
      L = LNBLNK(NAME)
      DNAME = NAME(1:L)//CHAR(0)
      IREGS(0) = 131
      IREGS(1) = LOC(DNAME)
C             SWI OS_Find,&83,name TO handle
      CALL ARCSWI('OS_Find',IREGS,IDUM,'N')
      KOPOUT = IREGS(0)
      RETURN
      END
C
      SUBROUTINE RAMSET(L)
C         change the size of RAMFS by L
      DIMENSION IREGS(0:9)
      IREGS(0) = 5
      IREGS(1) = L
C      CALL ARCSWI('OS_ChangeDynamicArea',IREGS,IDUM,'N')
      RETURN
      END
C
      SUBROUTINE PTRGET(K,L)
C           get file K pointer into L
      DIMENSION IREGS(0:9)
      IREGS(0) = 0
      IREGS(1) = K
C             SWI OS_Args,0,handle TO ,,pointer
      CALL ARCSWI('OS_Args',IREGS,IDUM,'N')
      L = IREGS(2)
      RETURN
      END
C
      SUBROUTINE PTRSET(K,L)
C           set file K pointer to L
      DIMENSION IREGS(0:9)
      IREGS(0) = 1
      IREGS(1) = K
      IREGS(2) = L
C             SWI OS_Args,1,handle,pointer
      CALL ARCSWI('OS_Args',IREGS,IDUM,'N')
      RETURN
      END
C
      SUBROUTINE READWD(I,K)
C          read 4-byte word from file handle K
      DIMENSION IREGS(0:9)
      IREGS(0) = 4
      GO TO 10
      ENTRY SENDWD(I,K)
C          write 4-byte word to file handle K
      IREGS(0) = 2
C
   10 IREGS(1) = K
      IREGS(2) = LOC(I)
      IREGS(3) = 4
C          OS_GBPB,?,handle,buf,nbytes
      CALL ARCSWI('OS_GBPB',IREGS,IDUM,'N')
      RETURN
      END
C
      SUBROUTINE REMOVD(NAME)
C            remove file NAME in directory DIR
      CHARACTER NAME*(*),DNAM*256
C
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
C
      DNAM = 'REMOVE '//DIR//NAME
      GO TO 10
      ENTRY REMOVE(NAME)
      DNAM ='REMOVE '//NAME
   10 L = LNBLNK(DNAM)
      CALL OSCLI(DNAM(1:L))
      RETURN
      END
C
      SUBROUTINE SYMT
C           write out symbol table
      CHARACTER*4 CI,IHBLK(10),CNAM*12
      EQUIVALENCE (CNAM,IHBLK(8))
      LOGICAL FLAG
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
      J  = JINDX('OBJ_SYMT')
      IS = IGETWD(J)
      NS = IGETWD(J+4)
      J  = JINDX('OBJ_STRT')
      IT = IGETWD(J)
C           make list of external symbols in KSYM file
C this is probably not OK since we have truncated the output file
      DO 20 J = 1, NS, 16
        IF(IAND(IGETWD(IS+4),3).EQ.3) THEN
          CALL PTRGET(KSYM,LSYM)
          CALL SENDWD(IPROC+2,KSYM)
          CALL PTRSET(KSYM,LSYM+12)
          IA = IT + IGETWD(IS)
          CALL PTRSET(KAOF,IA)
C             copy 4-byte words of name until one with a null byte
   10       CALL READWD(CI,KAOF)
            CALL SENDWD(CI,KSYM)
            I = INDEX(CI,CHAR(0))
            IF(I.EQ.0) GO TO 10
          CALL PTRGET(KSYM,IR)
          IB = IR + I - 4
          CALL PTRSET(KSYM,LSYM+4)
          CALL SENDWD(IR-LSYM,KSYM)
          CALL SENDWD(IB-LSYM-12,KSYM)
          CALL PTRSET(KSYM,IR)
        ENDIF
   20   IS = IS + 16
C        make up directory entry in KDIRY file
C          this is OK I think!
      CALL PTRGET(KDIRY,LDIRY)
C        data chunk index (word 1)
      CALL SENDWD(IPROC+2,KDIRY)
C        then, starting at word 4...
      CALL PTRSET(KDIRY,LDIRY+12)
C        copy name from icon
      CALL WPGTIS(JWSCOR,IPROC-1,IHBLK)
      N = INDEX(CNAM,CHAR(0))
      IF(N.EQ.0) N = 12
      DO 30 I=N,12
        CNAM(I:I)=CHAR(0)
   30 CONTINUE
      N=7 + (N+3)/4
      DO 40 I=8,N
        CALL SENDWD(IHBLK(I),KDIRY)
   40 CONTINUE
C        time of entry
      CALL TIMSET(KDIRY)
C        find end of entry
      CALL PTRGET(KDIRY,IR)
      CALL PTRSET(KDIRY,LDIRY+4)
C        entry length (word 2)
      CALL SENDWD(IR-LDIRY,KDIRY)
C        directory entry data length (word 3) (is 3 words less than total)
      CALL SENDWD(IR-LDIRY-12,KDIRY)
      CALL PTRSET(KDIRY,IR)
      RETURN
      END
C
      SUBROUTINE TIMSET(K)
C           set time to stream K
      DIMENSION ITIM(2)
      ITIM(1) = 3
      CALL OSWORD(14,ITIM)
      CALL SENDWD(
     +   IAND(ISHFT(ITIM(1),-16),65535)+ISHFT(IAND(ITIM(2),255),16),K)
      CALL SENDWD(ISHFT(ITIM(1),16),K)
      RETURN
      END
C
      SUBROUTINE WQCLSW(IWHAN)
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
C               close all windows if any one is closed
      IF(IWHAN.NE.JWDRAG) THEN
        CALL WPCLSW(JWSTAT)
        CALL WPCLSW(JWSCOR)
      ENDIF
      CALL WPCLSW(JWDRAG)
      RETURN
      END
C
      SUBROUTINE WQPLOT(IWH,IX1,IY1,IX2,IY2)
C         draw status info
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      DO 10 I=1,NDISP
        IF(I.EQ.NDISP .AND. I.GT.1) CALL WPSETC(0,11)
   10   CALL WPTEXT(8,36-40*I,STATUS(I)(1:LNBLNK(STATUS(I))))
      RETURN
      END
C
      SUBROUTINE WQMENU(MBLOC,ITEMS,NMENU)
C              click over menu
      DIMENSION ITEMS(*)
      LOGICAL FLAG
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /MENUS/ MTOP(43),MFOP(61)
C
      IF(NMENU.EQ.1)  THEN
        IF(ITEMS(1).EQ.1) THEN
C               help
          CALL WPEDIT('<MakeLib$Dir>.!Help')
        ELSE IF(ITEMS(1).EQ.2) THEN
C               assembler
           CALL WPSTMF(0,MTOP,2,.TRUE.)
           CALL WPSTMF(0,MTOP,3,.FALSE.)
           TITL = 'Assembling'//CHAR(0)
        ELSE IF(ITEMS(1).EQ.3) THEN
C               Fortran
           CALL WPSTMF(0,MTOP,3,.TRUE.)
           CALL WPSTMF(0,MTOP,2,.FALSE.)
           TITL = 'Compiling'//CHAR(0)
        ELSE IF(ITEMS(1).EQ.4) THEN
C               Stop
          CALL WPERR(3,'Cancel library? "OK" to continue',IRES)
          IF(IRES.EQ.2) THEN
            CALL CLOSEF
            MASK =  1
            CALL WPSTMF(2,MTOP,5,.FALSE.)
            CALL WPSTMF(2,MTOP,4,.TRUE.)
            CALL WPSTMF(2,MTOP,3,.FALSE.)
            CALL WPSTMF(2,MTOP,2,.FALSE.)
            CALL REMOVE(OUT)
            STATUS(2) = '    Cancelled...  Library deleted'
            CALL DISP(2)
          ENDIF
        ELSE IF(ITEMS(1).EQ.5) THEN
C             Quit
          CALL CLOSEF
          CALL WPQUIT
        ENDIF
      ELSE
C              toggle compiler options
        CALL WPGTMF(0,MFOP,ITEMS(2),FLAG)
        CALL WPSTMF(0,MFOP,ITEMS(2),.NOT.FLAG)
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQNULL
C           called to do processing
      CHARACTER*80 LINE
      LOGICAL FOUND,GETNAM,CHKEND,CHKINC
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      SAVE L
C
      IF(KOUT.NE.0) THEN
C           compile routines with egg-timer
        CALL GRHOUR(-1)
        CALL CMPILE
        CALL GRHOUR(0)
      ELSE
C           check input file
        FOUND = .FALSE.
   10   READ(9,101,IOSTAT=IOS)LINE
        IF(IOS.EQ.0) THEN
  101     FORMAT(A80)
          IF(.NOT.FOUND) THEN
            FOUND = GETNAM(LINE)
            L = LNBLNK(LINE) + 1
          ELSE
            L = L + LNBLNK(LINE) + 1
            IF(CHKEND(LINE)) THEN
C               found end of procedure
              MSIZE = MAX(MSIZE, L)
              NPROC = NPROC + 1
              FOUND = .FALSE.
              RETURN
            ENDIF
          ENDIF
          GO TO 10
        ENDIF
C               end of source file found; initiate library assembly
        CLOSE(9)
        LIN = 0
        IF(FOUND) THEN
          CALL WPERR(2,'no END statement at end of source file',IDUM)
          CALL WPCLSW(JWSTAT)
        ELSE
          CALL WPOPNW(JWDRAG)
          STATUS(1) =
     +      'Please drag the "save as:" icon to your library directory'
          CALL DISP(1)
        ENDIF
        MASK = 1
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQQUIT
C           forced shutdown; tidy up files
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
C
      IF(KOUT.NE.0) THEN
C         in process of making library; kill it all off and remove output
        CALL CLOSEF
        CALL REMOVE(OUT)
        MASK = 1
      ENDIF
      RETURN
      END
C
      SUBROUTINE WQRFIL(IWHAN,ICONH,ISIZE,ITYP,SFILE)
C             source file dropped on application
      CHARACTER*(*) SFILE
      CHARACTER FD*3
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      COMMON /MENUS/ MTOP(43),MFOP(61)
      SAVE I1
C
C              check for text file
      IF(ITYP.EQ.4095) THEN
        IN = SFILE
        LLIN = LNBLNK(IN)
        IP = 2
C              find directory name
        DO 10 I = LLIN-1, 1, -1
          IF(IN(I:I).EQ.'.') THEN
            IP = IP - 1
            IF(IP.EQ.1) THEN
              FNAME = IN(I+1:LLIN)
              OUT = IN(I+1:LLIN)//CHAR(0)
              I1 = I
            ENDIF
            IF(IP.EQ.0) GO TO 20
          ENDIF
   10   CONTINUE
        RETURN
   20   IDT = ICHAR(IN(I+1:I+1))
C             length of source path name
        LIND = I - 1
        IF(IDT.GT.96) IDT = IDT - 32
C            check for f. or s. directory
        IF((IDT.EQ.70.OR.IDT.EQ.83) .AND. I1-I.EQ.2) THEN
C               source file is OK; prepare to count routines
C               fix up menu ticks
          ASSEMB = IDT.EQ.83
          IF(ASSEMB) THEN
            CALL WQMENU(MTOP,2,1)
          ELSE
            CALL WQMENU(MTOP,3,1)
          ENDIF
C               erase any old procedure icons
          DO 30 IPROC = NPROC-1, 0, -1
   30       CALL WPDELI(JWSCOR,IPROC)
C               open source file
          LIN = LLIN
          OPEN(9,FILE=IN(1:LIN),STATUS='OLD')
C               initialise maximum source length & # procedures
          MSIZE = 0
          NPROC = 0
          STATUS(1) = 'Counting routines, please wait...'
          CALL DISP(1)
          MASK = 0
        ELSE
          OUT = 'Unknown source directory type '//IN(I:I1)
          CALL WPERR(1,OUT(1:31+I1-I),IDUM)
        ENDIF
      ELSE
        WRITE(FD,101)ITYP
  101   FORMAT(Z3)
        CALL WPERR(1,'Unknown file type &'//FD,IDUM)
      ENDIF
      CALL WPCLSW(JWSCOR)
      RETURN
      END
C
      SUBROUTINE WQWFIL(IWHAN,FILNAM)
C         assemble the library
      CHARACTER FILNAM*(*)
      DIMENSION IREGS(0:9),JFOPTS(0:8)
      LOGICAL FLAG1,FLAG2
C         assembler and compiler sizes and run space
      PARAMETER (LASSM = 80*1024, LARUN = 320*1024)
      PARAMETER (LCMP = 288*1024, LCRUN = 1024*1024)
C
      COMMON /ADMIN/ MASK,NPROC,IPROC,LHPTR,MSIZE,NDISP,
     +      JWSCOR,JWSTAT,JWDRAG,ICBARI,ASSEMB,
     +      IBLOCK(256)
      LOGICAL ASSEMB
      COMMON /FILES/ KOUT,KSYM,KDIRY,KAOF,MRAM
      COMMON /STRING/ ASM,FNAME,DIR,TEMP,TITL,IN,OUT,SINFO,OPT,PROGNM,
     +                STATUS(6)
      CHARACTER ASM*12,FNAME*12,DIR*16,TITL*12,TEMP*22,IN*256,OUT*256,
     +          SINFO*172,OPT*96,PROGNM*12,STATUS*80
      COMMON /LSTRNG/ LTEMP,LDIR,LIN,LIND
      COMMON /MENUS/ MTOP(43),MFOP(61)
      DATA JFOPTS/?I400000,?I200000,?I40,?I800,?I2000,?I4000,
     +            ?I100000,?I4000000,?I8000000/
C
C              check file does not already exist
      CALL FLTYPE(.FALSE.,FILNAM,KTYPE,IERR)
C      INQUIRE(FILE=FILNAM,EXIST=FLAG2)
      IF(IERR.NE.-1) THEN
        CALL WPERR
     +    (3,'library file already exists; overwrite?',IDUM)
        IF(IDUM.EQ.1) THEN
          CALL REMOVE(FILNAM)
        ELSE
          CALL WPCLSW(JWDRAG)
          RETURN
        ENDIF
      ENDIF
C                close dragbox window
      CALL WPCLSW(JWDRAG)
C                get memory needed for assembly/compilation
      IF(ASSEMB) THEN
        LCOMP = LASSM
        LRUN = LARUN
        ASM = 'objasm'
        LRNEED = ((MSIZE+2047)/2048)*4096+LCOMP
        STATUS(1) = 'Assembling'
      ELSE
C                values for f77
        LCOMP = LCMP
        LRUN = LCRUN
        ASM = 'f77'
        LRNEED = (16+(MSIZE+2047)/2048)*4096+LCOMP
        STATUS(1) = 'Compiling'
      ENDIF
C          get size of free memory in 32K chunks
      CALL WPGTSS(I,J,LFREE)
      LFREE = IAND(LFREE,-32768)
C          get current RAMFS size
      IREGS(0) = 5
C          SWI OS_ReadDynamicArea,RAMFS TO ,size
      CALL ARCSWI('OS_ReadDynamicArea',IREGS,IDUM,'N')
      LCRRAM = IREGS(1)
      IF(LCRRAM.GT.0) THEN
C         RAMFS is already in use, find if there are any files
        DIR = 'RAM:$'//CHAR(0)
        IREGS(0) = 9
        IREGS(1) = LOC(DIR)
        IREGS(2) = LOC(TEMP)
        IREGS(3) = 1
        IREGS(4) = 0
        IREGS(5) = 20
        IREGS(6) = 0
        CALL ARCSWI('OS_GBPB',IREGS,IDUM,'N')
        IF(IREGS(3).EQ.0) THEN
C            RAMFS is empty, remove it
          CALL RAMSET(-LCRRAM)
          LCRRAM = 0
        ELSE
C             find free space
          DIR = 'RamDisc0'//CHAR(0)
          IREGS(0) = LOC(DIR)
C            SWI RamFS_FreeSpace,'RamDisc0' TO free
          CALL ARCSWI('RamFS_FreeSpace',IREGS,IDUM,'N')
C            set free space in RAMFS
          LCRRAM = IREGS(0)
          IF(LCRRAM.EQ.0) LCRRAM = -1
        ENDIF
      ENDIF
C            set default scratch directory to RAM
      DIR = 'RAM::RamDisc0.$.'
      IF(LCRRAM.EQ.0) THEN
C            no RAMFS yet
        IF(LRNEED+LRUN.GT.LFREE) THEN
C            not enough room for compiler and data in available memory
          TEMP = '%.'//ASM
          LRNEED = LRNEED - LCOMP
          IF(LRNEED+LRUN.GT.LFREE) THEN
C             not even enough room for data in available memory, use Scrap
            DIR = '<Wimp$ScrapDir>.'
C                 'RAM::RamDisc0.$.'
          ELSE
C               set up RAMFS for data only
            MRAM = IAND(LRNEED+32767,-32768)
            CALL RAMSET(MRAM)
          ENDIF
        ELSE
C            enough room for compiler and data in available memory
C               set up RAMFS for whole space
          MRAM = IAND(LRNEED+32767,-32768)
          CALL RAMSET(MRAM)
C               copy the compiler into RAM
          CALL OSCLI('COPY %.'//ASM//'RAM:'//ASM//' ~C~V')
C               and point to compiler/assembler
          TEMP = 'RAM:'//ASM
        ENDIF
      ELSE
C            RAMFS in use (LCRRAM free)
        IF(LRNEED.GT.LCRRAM) THEN
C            not enough room for compiler and data in available memory
          TEMP = '%.'//ASM
          LRNEED = LRNEED - LCOMP
          IF(LRNEED.GT.LCRRAM) THEN
C             not even enough room for data in available memory, use Scrap
            DIR = '<Wimp$ScrapDir>.'
          ENDIF
        ELSE
C            enough room for compiler and data in available memory
C               copy the compiler into RAM
          CALL OSCLI('COPY %.'//ASM//'RAM:'//ASM//' ~C~V')
C               and point to compiler/assembler
          TEMP = 'RAM:'//ASM
        ENDIF
      ENDIF
C               pointer to assembler/compiler
      ASM = TEMP
C              activate scratch directory DIR
      LDIR = 16
C              set up output file
      OUT = FILNAM
C              make up name of temporary source file
      TEMP =  DIR//'f.temp'
      LTEMP = 22
C              make 'f' directory for temporary source of each procedure
      CALL OSCLI('CDIR '//DIR//'f')
C              all OK, so proceed with making library
C
      IF(ASSEMB) THEN
C             make up command script for assembler
        OPT = ' -from '//TEMP//' -to '//DIR//'aof -stamp -quit'
      ELSE
C             make up command script for compiler (all warnings suppressed)
        OPT(1:17) = ' -c -w       -zpx'
C             make up options word
        IOPT = 12
        DO 10 I=0,8
          CALL WPGTMF(0,MFOP,I,FLAG2)
          IF(FLAG2) IOPT = IOPT + JFOPTS(I)
   10   CONTINUE
C             store after '-zpx'
        WRITE(OPT(18:),*)IOPT
        LOPT = LNBLNK(OPT)
        OPT(LOPT+2:) = TEMP//' -o '//DIR//'aof'
      ENDIF
      LOPT = LNBLNK(OPT)
C          grey out top menu items not allowed during processing
      CALL WPSTMF(2,MTOP,5,.TRUE.)
      CALL WPSTMF(2,MTOP,4,.FALSE.)
      CALL WPSTMF(2,MTOP,3,.TRUE.)
      CALL WPSTMF(2,MTOP,2,.TRUE.)
C               set up title of scoring window
      L = LNBLNK(STATUS(1))
      TITL = STATUS(1)(1:L)//CHAR(0)
C               send status message
      STATUS(1)(L+2:) = FNAME
      CALL DISP(1)
C            open scoring window at right size
      CALL WPSTWA(JWSCOR,224,NPROC*40)
      CALL WPGTWS(JWSCOR,IBLOCK)
      IBLOCK(7) = 0
      IBLOCK(3) = IBLOCK(5) - NPROC*40
      CALL WPSTWS(IBLOCK)
C            open input file
      LIN = LNBLNK(IN)
      OPEN(9,FILE=IN(1:LIN),STATUS='OLD')
C            open direct access output
      KOUT = KOPOUT(OUT)
C            open direct access file for symbol table
      KSYM = KOPOUT(DIR//'symt')
C            open direct access file for directory
      KDIRY = KOPOUT(DIR//'diry')
C            initialise library output file:
C            identifier
      CALL SENDWD(?IC3CBC6C5,KOUT)
C            # blocks (twice)
      CALL SENDWD(NPROC+5,KOUT)
      CALL SENDWD(NPROC+5,KOUT)
C         pointer to next header block
      LHPTR = 12
C         skip header blocks
      CALL PTRSET(KOUT,LHPTR+16*(NPROC+5))
C         set up library time block
      CALL HD(8,'LIB_TIME')
      CALL TIMSET(KOUT)
C         set up library version block
      CALL HD(4,'LIB_VRSN')
      CALL SENDWD(1,KOUT)
      CALL HD(8,'OFL_TIME')
      CALL TIMSET(KOUT)
C          set processing flags
      IPROC = 0
      MASK = 0
C          read in first procedure
      CALL CPYSRC
      RETURN
      END
C
c      SUBROUTINE DEBUG(TEXT)
c      CHARACTER*(*) TEXT
c      SAVE LINE
c      DATA LINE/0/
c      CALL GRVDU(4)
c      CALL GRTAB(0,LINE)
c      PRINT *,TEXT,'         '
c      LINE = LINE + 1
c      CALL GRVDU(5)
c      RETURN
c      END
