C MOVES.FTN, SEGSRC, CEH-KJC, 08/25/78
C Routine for the MOVE processor in SEG
C Copyright (c) 1981, Prime Computer, Inc., Natick, MA 01760
C
C      MOVES - ROUTINE TO SET UP MOVE FOR SEG
C
C      CALLING SEQUENCE: CALL MOVES(IBUF)
C
       SUBROUTINE MOVES(IBUF)
C
       INTEGER*2 I,INFO(8),IBUF(18),CODE,FLAG,IK,IL,IP(5),SETSEG
C
$INSERT SYSCOM>KEYS.INS.FTN
$INSERT SYSCOM>ERRD.INS.FTN
$INSERT LODCOM.INS.FTN
C
       FLAG=IBUF(1)-'  '
       IF(FLAG.NE.0) GO TO 20
10     CALL TNOUA('START: ',7)
       CALL COMANL
       CALL RDTK$$(1,INFO,IBUF,3,CODE)
       IF(AND(INFO(3),:40000).NE.0) GO TO 100 /*IS ANSW NUMERIC?
20     IF(MOVE1(IBUF).EQ. 0) GO TO 10  /*NO, SET UP NAME
       IP(3)=MAP1(P1SUBS+A$SEGM)       /*SET UP STARTING ADDRESS
       IP(4)=MAP1(P1SUBS+A$RANG)
       GO TO 200
C
100    IP(3)=INFO(5)                   /*USER SUPPLIED A NUMERIC ANSWER
       CALL RDTK$$(1,INFO,IBUF,3,CODE) /*GET WORD ADDRESS
       IF(AND(INFO(3),:40000).EQ.0) GO TO 10
       IP(4)=INFO(5)
C
C      SET UP RANGE
C
200    IF(FLAG.NE.0) GO TO 310         /*DID USER PASS VALUES?
210    CALL TNOUA('END: ',5)           /*NO, GET VALUE
       CALL COMANL
       CALL RDTK$$(1,INFO,IBUF,3,CODE)
       IF(AND(INFO(3),:40000).NE.0) GO TO 300 /*IS VALUE NUMERIC?
       IF(INFO(1).EQ.6) GO TO 310      /*NO, IS IT NULL?
       IF(MOVE1(IBUF).EQ.0) GO TO 210  /*NO, SET UP NAME
       IF(IP(3).NE.MAP1(P1SUBS+A$SEGM)) GO TO 210
       IP(5)=MAP1(P1SUBS+2)-IP(4)
       GO TO 400
C
300    IF(INFO(5).EQ.0) GO TO 310
       IP(5)=INFO(5)-IP(4)             /*USE NUMERIC TOKEN FOR RANGE
       GO TO 400
C
C      TO TOP OF SEGMENT
C
310    CALL INITNE(POINT1,:21,0)
320    IF(NEXT(POINT1).EQ.0) GO TO 210
       IF(MAP1(P1SUBS+A$SEGM).NE.IP(3)) GO TO 320
       IF(IUCAS(MAP1(P1SUBS+A$RANG),IP(4)).LE.0) GO TO 320
       IP(5)=1+MAP1(P1SUBS+A$HIGH)-IP(4)  /*MOVE TO HERE
C
C      SET UP DESTINATION SEGMENT
C
       IF(FLAG.EQ.0) GO TO 400         /*DID USER SUPPLY VALUES?
       INFO(5)=IBUF(7)                 /*YES, USE IT
       GO TO 410
C
400    CALL TNOUA('DEST. SEGMENT: ',15)
       CALL COMANL
       CALL RDTK$$(1,INFO,IBUF,3,CODE)
       IF(AND(INFO(3),:40000).EQ.0) GO TO 400 /*MUST BE NUMERIC
410    CALL ASSSEG(:13000,INFO(5),IP(5),IP(1),
     +   IP(2),$9000)                  /*GET SPACE IN SEGMENT
C
C      CHECK IF USER WANTS MOVE VECTOR
C
       IF(FLAG.NE.0) GO TO 510
500    CALL TNOUA('IP VECTOR: ',11)
       CALL COMANL
       CALL RDTK$$(1,INFO,IBUF(4),3,CODE)
       IF(INFO(1).EQ.5) GO TO 600 /*NO
510    IF(IBUF(4).EQ.'  ') GO TO 600 /*NO
       IF(MOVE1(IBUF(4)).EQ.0) GO TO 500
C
C      MOVE IP VECTOR TO USER SPACE
C
       CODE=SETSEG(MAP1(P1SUBS+A$SEGM))
       IF(CODE.EQ.0) GO TO 9000
       LOADPT=MAP1(P1SUBS+2)           /*ADDRESS FOR PLACE
       DO 550 I=1,5
       CALL CHEKSG(SEGPNT)            /* CHECK FOR USAGE OF SEG'S
                                      /* SYMBOL TABLE SEGMENT
       CALL PLACE(IP(I))
550    CONTINUE
C
C      NOW MOVE STUFF TO BE MOVED
C
600    LOADPT=IP(2)                    /*START OF DESTINATION
       IK=IP(4)                        /*START OF SOURCE
       IL=IP(4)+IP(5)-1                /*END OF DO RANGE
700    CODE=SETSEG(IP(3))
       IF(CODE.EQ.0) GO TO 9000
       I=LOOK(IK)
       CODE=SETSEG(IP(1))
       IF(CODE.EQ.0) GO TO 9000
       CALL CHEKSG(SEGPNT)            /* SAME CHECK AS ABOVE
       CALL PLACE(I)
       IK=IK+1
       IF(IK.NE.IL+1) GO TO 700
800    CONTINUE
       CODE=SETSEG(IP(1))
       IF(CODE.EQ.0) GO TO 9000
       RETURN
C
9000   CALL ERRPR$(K$NRTN,E$NULL,0,0,'MOVES',5)
       END
C      MOVE1 - ROUTINE TO HELP MOVES
C
       INTEGER FUNCTION MOVE1(IBUF)
C
       INTEGER*2 IBUF(3),JBUF(4)
C
       NOLIST
$INSERT LODCOM.INS.FTN
       LIST
       DATA JBUF/0,0,0,:20040/
C
       MOVE1=1
       JBUF(1)=AND(IBUF(1),:77577)
       JBUF(2)=AND(IBUF(2),:77577)
       JBUF(3)=AND(IBUF(3),:77577)
       CALL INITNE(POINT1,1,JBUF)
       IF(NAMESE(JBUF,POINT1).EQ.0) GO TO 600
       IF(AND(MAP1(P1SUBS),:100).EQ.0) GO TO 600
       RETURN
C
600    MOVE1=0
       RETURN
       END