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-18416 
C 
C     RELOCATABLE PART NUMBER : 92067-16361 
C 
C     PROGRAMER(S)   : J.M.N. 
C 
C 
C 
C 
      SUBROUTINE ACXFR(ICMND,ISTRC,IERR),92067-16361 REV.1940 790722  
      LOGICAL IFBRK,XFTTY 
      DIMENSION LU2(2),ISIZE(2) 
      COMMON /ACOMB /ISTK(90),IPT 
      COMMON /ACOM3/LIST(10),LDCB(144),LLIST,LLDCB(144),ITTY,ITDCB(144) 
      COMMON /ACOMC/IECHO,LULOG,IDUM(11),LLST1,LLST2,LLST3,LLST4
      DIMENSION ICMND(40),IPBUF(11) 
      DATA LU2 / 0,0 /
      DATA ISIZE / 24,0 / 
      IMODE=IERR
C 
C     IF CURRENT INPUT IS A FILE THEN CLOSE 
C 
      IPTT=IPT
      IF(ITTY.LE.255) GO TO 200 
C     SAVE RECORD NUMBER
      CALL LOCF(ITDCB,IERR,ISTK(IPT+4),ISTK(IPT+7),ISTK(IPT+8)) 
      CALL CLOSE(ITDCB) 
      GO TO 210 
  200 LU2(1)=IOR(ITTY,100000B)
C 
C     PARSE TO GET NEXT INPUT LU OR FILE
C 
  210 IF(IPT.LT.80) IPT=IPT+8 
      IF(IMODE.GE.0) GO TO 150
      IF(ITTY.NE.LULOG) GO TO 125 
  110 IPT=IPTT
      RETURN
  125 ITTY=LULOG
      GO TO 300 
  150 CALL NAMR(ISTK(IPT+1),ICMND,80,ISTRC) 
      ISTK4=IAND(ISTK(IPT+4),3) 
  175 IF(ISTK4.NE.1.OR.ISTK(IPT+1).LT.0) GO TO 180
      ISTK(IPT+1)=LUTRU(ISTK(IPT+1))
      IF(ISTK(IPT+1).LT.0) GO TO 975
  180 IF(ITTY.EQ.ISTK(IPT+1).AND.ITTY.LE.255) GO TO 400 
      ITTY=ISTK(IPT+1)
C 
      IF(ITTY.EQ.0.AND.ISTK4.EQ.1) GO TO 975
C     IF ZERO OR NEGATIVE THEN BACK UP STACK
C 
      IF(ITTY.LE.0) GO TO 600 
C 
C     IS THERE ROOM ON STACK
C 
      IF(IPT.GE.80) GO TO 950 
C 
C     IF LU IS IT LEGAL 
C 
      IF(ITTY.GT.255.AND.ISTK4.NE.3) GO TO 900
      ISTK(IPT+4)=1 
  300 IF(ITTY.LE.255) GO TO 350 
      IF(ISTK(IPT+5).EQ.0) ISTK(IPT+5)=-31178 
      CALL OPEN(ITDCB,IERR,ISTK(IPT+1),0,ISTK(IPT+5),ISTK(IPT+6)) 
      IF(IERR.LT.0) GO TO 999 
      IF(ISTK(IPT+4).EQ.1) GO TO 400
      CALL APOSN(ITDCB,IERR,ISTK(IPT+4),ISTK(IPT+7),ISTK(IPT+8))
      IF(IERR.LT.0) GO TO 999 
      GO TO 400 
C 
C     UNLOCK LU 
C 
  350 CALL LURQ(70000B,LU2,1) 
      GO TO 360 
  355 CONTINUE
C 
C     LOCK LU 
C 
  360 CALL ACLCK(ITTY,IERR) 
      IF(IERR.NE.0) GO TO 999 
C 
C     PARSE FOR LIST FILE OR LU 
C 
  400 IF(ITTY.LT.0) GO TO 975 
  410 CALL NAMR(IPBUF,ICMND,80,ISTRC) 
C 
C     IF NULL NO CHANGE 
C 
      ITY=IAND(IPBUF(4),3)
      IF(ITY.EQ.0) GO TO 500
      IF(LLIST.GT.255) GO TO 440
      LU2(1)=IOR(LLIST,100000B) 
      CALL LURQ(70000B,LU2,1) 
      GO TO 445 
  430 CONTINUE
      GO TO 445 
C 
C     CLOSE UNCONDITIONALLY 
C 
  440 CALL ACCLS(LLDCB,3) 
  445 LLIST=IPBUF(1)
      IF(IPBUF(1).EQ.0) GO TO 500 
      IF(ITY.NE.3) GO TO 450
C 
C     SAVE LOGICAL LIST FILE NAME 
C 
      LLST1=IPBUF(1)
      LLST2=IPBUF(2)
      LLST3=IPBUF(3)
      LLST4=IPBUF(6)
C 
C     SET TYPE AND SIZE 
C 
      IF(IPBUF(7).LT.3) IPBUF(7)=3
      IF(IPBUF(8).EQ.0) IPBUF(8)=24 
C 
C     IF FILE OPEN IT 
C 
C          TEST AGAINST CURRENT INPUTS
C 
      CALL ACTIN(IPBUF,IERR)
      IF(IERR.NE.0) GO TO 500 
      CALL ACROP(LLDCB,IERR,IPBUF,0,IPBUF(5),IPBUF(6) 
     1 ,IPBUF(8),IPBUF(7))
      IF(IERR.LT.0) GO TO 998 
      GO TO 500 
  450 IF(IPBUF(1).LE.0.OR.IPBUF(1).GT.255) GO TO 980
C 
C     LOCK LU 
C 
      LLST=LUTRU(LLIST) 
      LLIST=0 
      IECH=IECHO
      IECHO=1 
      IF(LLST.LT.0) GO TO 975 
      CALL ACLCK(LLST,IERR) 
      IECHO=IECH
      IF(IERR.NE.0) GO TO 998 
      LLIST=LLST
C 
C     PARSE FOR ECHO
C 
  500 CALL NAMR(IPBUF,ICMND,80,ISTRC) 
      IF(IPBUF(1).EQ.2HEC) IECHO=1
      IF(IPBUF(1).EQ.2HNO) IECHO=0
      IF(IERR.GT.0) IERR=0
      RETURN
C 
C     BACK UP STACK 
C 
  600 IF(ITTY.EQ.0) ITTY=-1 
      IPT=IPT-8+ITTY*8
      IF(IPT.LT.0) IPT=0
      IPTT=IPT
      ITTY=ISTK(IPT+1)
      GO TO 300 
C 
C     ACERRS
  900 IERR=-222 
      GO TO 999 
  950 IERR=13 
      GO TO 999 
  975 IERR=12 
      GO TO 999 
  980 IERR=-222 
  998 LLIST=0 
  999 IPT=IPTT
      RETURN
      END 
                                                                                                                                                                        