FTN4,L
C 
C  ***************************************************************
C  * (C) COPYRIGHT HEWLETT-PACKARD COMPANY 1979.  ALL RIGHTS     *
C  * RESERVED.  NO PART OF THIS PROGRAM MAY BE PHOTOCOPIED,      *
C  * REPRODUCED OR TRANSLATED TO ANOTHER PROGRAM LANGUAGE WITHOUT*
C  * THE PRIOR WRITTEN CONSENT OF HEWLETT-PACKARD COMPANY.       *
C  ***************************************************************
C 
C     SOURCE PART NUMBER :92067-18399 
C 
C     RELOCATABLE PART NUMBER : 92067-16363 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C 
C     OPEN OR CREAT A LIST FILE 
C     OR LOCK AN LU 
C 
C 
      SUBROUTINE ACOPL(IERR,ITYPE,JSIZE),92067-16363 REV.2001 791016
      LOGICAL IFBRK,IFBNR 
      DIMENSION ISIZE(2)
      COMMON /ACOM2/ LRTRN,LRTR2,LGOTO,ITY,ITTYT,LTOSEG,NAMSG(3)
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOMC/ IECHO,LU,IDUM(11),LLST(4)
      EQUIVALENCE (LIST,LI1),(LIST(2),LI2),(LIST(3),LI3)
      DATA ISIZE / 0,128 /
      IERR=0
      IF(ITYPE.GE.0) GO TO 5
      LIST(4)=-LIST(4)
      CALL ACOPN(IERR,IDSES)
      GO TO 300 
    5 LIST4=IABS(LIST(4)) 
      IF(ITYPE.EQ.3.OR.LIST4.NE.0) GO TO 7
      LIST4=1 
      LIST(1)=8 
    7 LIST(4)=LIST4 
      IF(LIST4.EQ.0) RETURN 
C 
C     IF LIST SAME AS LLIST USE LLIST 
C 
      DO 20 I=1,3 
      IF(LIST(I).NE.LLST(I)) GO TO 30 
   20 CONTINUE
C 
C     IF CRN'S DIFFERENT AND NOT ZERO OPEN NEW FILE 
C 
      LLDIF=IXOR(LIST(6),LLST(4)) 
      IF(LLDIF.NE.0.AND.LIST(6).NE.0.AND.LLST(4).NE.0) GO TO 30 
      IF(LIST4.EQ.3) LIST(1)=-LIST(1) 
      RETURN
C 
C     LIST IS UNIQUE
C 
   30 IF(LIST4.EQ.3) GO TO 100
      LIST(1)=LUTRU(LIST) 
      IF(LIST(1).LT.0) GO TO 75 
C 
C     LOCK LU 
C 
   60 LU2=IOR(LIST,100000B) 
      CALL ACLCK(LU2,IERR)
      IF(IERR.EQ.10) GO TO 80 
      IF(IERR.EQ.0)GO TO 90 
C 
C     ILLEGAL LU
C 
   75 IERR=12 
   76 LIST(1)=-1
      RETURN
C 
C     CALL ACERR TO TRANSFER CONTROL TO LOGLU 
C 
   80 CALL ACERR(0) 
      GO TO LRTRN 
C 
C     IF NOT BINARY REQUEST RETURN
C 
   90 IF(ITYPE.EQ.3) RETURN 
      LIST(2)=100B
      IF(IFBNR(ITYPE,LIST)) RETURN
      IERR=4
      CALL LURQ(70000B,LU2,1) 
      GO TO 76
   95 GO TO 76
C 
C     TRY TO OPEN 
C 
  100 CALL ACTIN(LIST,IERR) 
      IF(IERR.EQ.0) GO TO 200 
      CALL ACERR(IERR)
      RETURN
  200 IOPTN=0 
      IF(LI1.EQ.2H+@.AND.LI2.EQ.2HCC.AND.LI3.EQ.2HT!) IOPTN=1 
      IF(LIST(7).EQ.0) LIST(7)=3
      IF(LIST(8).EQ.0) LIST(8)=24 
      IF(ITYPE.GE.3) GO TO 250
      LIST(7)=1 
      LIST(8)=JSIZE 
  250 CALL ACROP(LDCB,IERR,LIST,IOPTN,LIST(5),LIST(6) 
     1 ,LIST(8),LIST(7))
  300 IF(IERR.GT.0) IERR=0
      RETURN
      END 
      SUBROUTINE ACLCK(LU,IERR) 
     1 ,92067-16363 REV.1940 790721 
C 
C     LOCK LU IF NOT INTERACTIVE
C 
C                   ERRORS:  10   BREAK 
C                            12   LU NOT IN SWITCH TABLE
C 
C 
      LOGICAL IFBRK,XFTTY,IPFLG 
      DIMENSION LU2(2)
      DATA LU2 /0,0 / 
C 
      IPFLG=.FALSE. 
      IERR=0
      LU2=IOR(LU,100000B) 
      IF(XFTTY(LU2)) RETURN 
   10 CALL LURQ(170001B,LU2,1)
      GO TO 75
   11 CALL ABREG(LOCK,IDUM) 
      IF(LOCK.EQ.0) RETURN
      IF(IPFLG) GO TO 50
      IF(LOCK.LT.0) GO TO 25
      CALL ACWRI(14HWAITING FOR LU,7) 
      GO TO 50
   25 CALL ACWRI(14HWAITING FOR RN,7) 
   50 IF(IFBRK(IDUM)) GO TO 60
      IPFLG=.TRUE.
      CALL EXEC(12,0,2,0,-5)
      GO TO 10
C 
C     CALL ACERR TO TRANSFER CONTROL TO LOGLU 
C 
   60 IERR=10 
      RETURN
C 
C     ILLEGAL LU
C 
   75 IERR=12 
      RETURN
      END 
C 
C 
C     THIS ROUTINE OPENS A LIST FILE
C     AND POSITSIONS IT AT EOF FOR UPDATE 
C 
C     IF FILE DOES NOT EXIST THE FILE IS CREATED. 
C 
      SUBROUTINE ACROP(IDCB,IERR,NAME,IOPT,ISC,ICRN,ISIZE,ITYPE)
     1,92067-16363 REV.1940 790721
      DIMENSION NAME(3),IDCB(144) 
C 
C     TRY TO OPEN 
C 
      CALL OPEN(IDCB,IERR,NAME,IPOTN,ISC,ICRN)
      IF(IERR.EQ.-6) GO TO 200
C 
C     IT EXISTED SO UPDATE
C 
      IF(ITYPE.LT.3) RETURN 
  100 CALL POSNT(IDCB,IERR,10000) 
      IF(IERR.GE.0) GO TO 100 
C 
C     BACK UP TO WRITE OVER EOF 
C 
      CALL POSNT(IDCB,IERR,-1)
      IERR=0
      RETURN
C 
C     WE MUST CREATE IT 
C 
  200 CALL CREAT(IDCB,IERR,NAME,ISIZE,ITYPE,ISC,ICRN) 
      RETURN
      END 
                                                                                                                                                                          