;     Fortran Friends 2018
;                      update log
;
;  removed wimp_spriteop because it does not wory any more            11/07/18
;  spop60_61 flag current state in COMMON SpOp_state                  20/03/96
;
       TTL    sperr
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sperr_;(IERR,ERRTXT) return error info to fortran
       EXPORT SpOp_F
       DCB    "SPERR",0,0,0,8,0,0,255
sperr_ MOV    ip,sp
       STMDB  sp!,{R0-R2,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,errptr
       LDR    R3,[R3]       ;address of error message
       MOVS   ip,R3         ;if error,
       LDRNE  ip,[R3],#4    ;get error number
       STR    ip,[R0]       ;store error number or zero
err1   LDRNEB ip,[R3],#1
       CMPNE  ip,#31
       STRGTB ip,[R1],#1    ;transfer error message
       SUBGTS R2,R2,#1
       BGT    err1
       MOV    ip,#" "
err2   SUBS   R2,R2,#1
       STRGEB ip,[R1],#1    ;pad with blanks
       BGT    err2
       MOV    R0,#1         ;return .TRUE.
       LDMDB  fp,{fp,sp,pc} ;return
;
SpOp_F LDR    R1,errptr
       MOVVC  R0,#0
       STR    R0,[R1]
       MOVVS  R0,#0         ;.FALSE.
       MOVVC  R0,#1         ;.TRUE.
       LDMDB  fp,{R4-R7,fp,sp,pc} ;return
errptr DCD    SpOp_E        ;address of error info
;
       AREA   |C$$data|,DATA
SpOp_E DCD    0
       END
;
       TTL    spop2_3
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
OS_SpriteOp   EQU &2002E
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       IMPORT SpOp_N
       EXPORT spssav_; (NAME,IPAL)  save screen to file NAME
       EXPORT spslod_; (NAME)  load screen  from file NAME
       DCB    "SPSSAV",0,0,8,0,0,255
spssav_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[R1] ;get ipal
       MOV    R1,R2   ;length of name
       MOV    ip,#2   ;Sprite_Op 2
       B      spl1
;
       DCB    "SPSLOD",0,0,8,0,0,255
spslod_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#3   ;Sprite_Op 3
spl1   LDR    R2,namptr
       CMP    R1,#255
       MOVGT  R1,#255       ;limit name length
       MOV    R4,#0
spl2   STRB   R4,[R2,R1]
       SUBS   R1,R1,#1
       LDRGTB lr,[R0,R1]
       RSBGTS lr,lr,#33
       BGT    spl2          ;skip trailing blanks
spl3   LDRB   lr,[R0,R1]
       STRB   lr,[R2,R1]    ;move name
       SUBS   R1,R1,#1
       BGE    spl3
       MOV    R0,ip
       SWI    OS_SpriteOp   ;go do the job
       B      SpOp_F        ;return to fortran
;
namptr DCD    SpOp_N        ;address of file name
       END
;
       TTL    spop08
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R7     RN     7
OS_SpriteOp   EQU &2002E
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       EXPORT spasiz_; (ISR,NSPRITE,ISIZE,JFREE) read area control block
       DCB    "SPASIZ",0,0,8,0,0,255
spasiz_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    R1,R0         ;address of sprite area
       LDR    R2,[R1]       ;get first word of sprite area
       TEQ    R2,#0         ; see whether system or user area
       MOV    R0,#8         ;SpriteOp type 8
       ADDNE  R0,R0,#256    ;add 256 for user area
       SWI    OS_SpriteOp   ;   do the job.....
sz2    LDMIB  sp!,{R4,ip,lr};addresses of NSPRITE,ISIZE,JFREE
       BVS    fail
       SUB    R0,R2,R5      ;free space
empty  STRPL  R2,[ip]       ;store ISIZE
       STR    R3,[R4]       ;store NSPRITE
       STRPL  R0,[lr]       ;store JFREE
       B      SpOp_F        ;return to fortran
fail   SUBEQS R0,R0,R0      ;remove V flag if system area
       MOVEQ  R3,#0
       MOVEQ  R2,#0
       BEQ    empty
       B      SpOp_F
       END
;
       TTL    spop09
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R4     RN     4
R7     RN     7
OS_SpriteOp   EQU &2002E
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       EXPORT spinit_;(LEN,ISR) initialise sprite area
       DCB    "SPINIT",0,0,8,0,0,255
spinit_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUBS   fp,ip,#4      ;clear V
       LDR    R0,[R0]       ;get LEN
       MOVS   R0,R0,LSL#2   ;LEN in bytes
       STRGT  R0,[R1]       ;store as first word
       MOVGT  R0,#16
       STRGT  R0,[R1,#8]    ;offset in 3rd word
       MOV    R0,#9         ;Spriteop #9
       ADDGT  R0,R0,#256    ; add 256 for user area
       SWIGE  OS_SpriteOp   ;   do the job.....
       B      SpOp_F        ;return to fortran
       END
;
       TTL    spop10_12
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
OS_SpriteOp   EQU &2002E
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       IMPORT SpOp_N
       EXPORT spalod_; (ISR,NAME)  load sprite area from file NAME
       EXPORT spamrg_; (ISR,NAME)  merge sprite area from file NAME
       EXPORT spasav_; (ISR,NAME)  save sprite area to file NAME
       DCB    "SPASAV",0,0,8,0,0,255
spasav_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       MOV    R0,#12
       B      spafl
;
       DCB    "SPAMRG",0,0,8,0,0,255
spamrg_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       MOV    R0,#11
       B      spafl
;
       DCB    "SPALOD",0,0,8,0,0,255
spalod_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       MOV    R0,#10        ;Sprite_Op type
spafl  SUB    fp,ip,#4
       LDR    R3,namptr     ;get address of buffer for file name
       CMP    R2,#255       ;check file name length
       MOVGT  R2,#255
       MOV    R4,#0
spl2   STRB   R4,[R3,R2]    ;fill with zeros
       SUBS   R2,R2,#1
       LDRGTB lr,[R1,R2]
       RSBGTS lr,lr,#33
       BGT    spl2          ;skip trailing blanks
spl3   LDRB   lr,[R1,R2]
       STRB   lr,[R3,R2]    ;move name
       SUBS   R2,R2,#1
       BGE    spl3
       LDR    R1,[sp]       ;pointer to sprite area
       LDR    R3,[R1]       ;first word (length) of sprite area
       TEQ    R3,#0
       ADDNE  R0,R0,#256    ;add 256 to Sprite_Op type if user sprite area
       LDR    R2,namptr     ;file name
       SWI    OS_SpriteOp   ;   do the job.....
       B      SpOp_F        ;return to fortran
namptr DCD    SpOp_N        ;address of file name
       END
;
       TTL    spop13
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
OS_SpriteOp   EQU &2002E
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       IMPORT SpOp_N
       EXPORT spname_;(ISR,NUM,NAME) get sprite name
       DCB    "SPNAME",0,0,8,0,0,255
spname_
       MOV    ip,sp
       STMDB  sp!,{R0-R3,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R4,[R1]       ;sprite # to find
       MOV    R1,R0         ;address of sprite area
       LDR    R2,namptr     ;pointer to name
       MOV    R3,#16        ;maximum length
       MOV    R0,#13        ;set Sprite_Op type
       LDR    ip,[R1]       ;get first word of sprite area
       TEQ    ip,#0         ; see whether system or user area
       ADDNE  R0,R0,#256    ;add 256 for user area
       SWI    OS_SpriteOp   ;   do the job.....
sn2    BVS    SpOp_F        ; V is set, so not OK
       LDMIB  sp,{R0,R1,lr}
       CMP    R3,lr
       MOVGT  R3,lr         ;length to store
       MOV    ip,#" "
sp1    CMP    lr,R3
       SUBGT  lr,lr,#1
       STRGTB ip,[R1,lr]    ;pad with blanks
       BGT    sp1
sp2    SUBS   lr,lr,#1
       LDRGEB ip,[R2,lr]
       STRGEB ip,[R1,lr]
       BGT    sp2
       B      SpOp_F        ;return to fortran (V clear)
namptr DCD    SpOp_N        ;address of file name
       END
;
       TTL    spop14
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdefc_;(ISR,NAME,IPAL) define sprite from graphics cursors
       IMPORT SpOp_A
       DCB    "SPDEFC",0,0,8,0,0,255
spdefc_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#14+64     ; SpriteOp 14 = 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop15
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R7     RN     7
OS_Byte  EQU 6
       AREA   |C$$code|,CODE,READONLY
       EXPORT spresv_;(ISR,NAME,IPAL,IWID,IHITE,MODE)
;                  reserve space for sprite
       IMPORT SpOp_A
       DCB    "SPRESV",0,0,8,0,0,255
spresv_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R0,[fp,#8]    ;address of MODE
       LDR    R0,[R0]       ;get MODE
       CMP    R0,#-1
       BNE    sr1
       MOV    R0,#135
       SWI    OS_Byte       ;get current mode
       LDR    R0,ptr        ;place to store it
       STR    R2,[R0]
       STR    R0,[fp,#8]    ;reset pointer (a bit dodgy)
sr1    LDMIA  sp,{R0,R1}    ;restore addresses of ISR and NAME
       LDR    R3,[fp,#12]   ;length of name
       MOV    ip,#15        ; SpriteOp 15
       ADD    ip,ip,#256    ;4 extra arguments
       B      SpOp_A        ;go do the job...
ptr    DCD    mode
       AREA   |C$$data|,DATA
mode   DCD    0
       END
;
       TTL    spop16
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdefr_;(ISR,NAME,IPAL,IX1,IY1,IX2,IY2) define sprite
       IMPORT SpOp_A
       DCB    "SPDEFR",0,0,8,0,0,255
spdefr_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#16]   ;length of name
       MOV    ip,#16+320    ; SpriteOp 16 + 5 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop24
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spaddr_;(ISR,NAME,ISADD) get address of sprite
       IMPORT SpOp_AR
       IMPORT SpOp_F
       DCB    "SPADDR",0,0,8,0,0,255
spaddr_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#24        ; SpriteOp 24
       BL     SpOp_AR       ;go do the job...
       LDRVC  R4,[sp,#8]
       STRVC  R2,[R4]       ;store ISADD
       B      SpOp_F        ;return to fortran
       END
;
       TTL    spop25
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdels_;(ISR,NAME) delete sprite
       IMPORT SpOp_A0
       DCB    "SPDELS",0,0,8,0,0,255
spdels_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#25        ; SpriteOp 25
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop26_27_35
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R6     RN     6
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sprena_;(ISR,NAME,NEWNAM) rename sprite 'NAME' to 'NEWNAME'
       EXPORT spcopy_;(ISR,NAME,NEWNAM) copy sprite 'NAME' to 'NEWNAME'
       EXPORT spadd_;(ISR,NAME,NEWNAM,BELOW) add sprite 'NEWNAME'
       IMPORT SpOp_A
       IMPORT SpOp_N
       DCB    "SPADD",0,0,0,8,0,0,255
spadd_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#35+128    ; SpriteOp 35 + 2 extra arguments
       LDR    R3,[fp,#4]    ;length of NAME
       LDR    R6,[fp,#8]    ;length of NEWNAME
       B      spr2
;
       DCB    "SPCOPY",0,0,8,0,0,255
spcopy_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#27+64     ; SpriteOp 27 + 1 extra argument
       B      spr1
;
       DCB    "SPRENA",0,0,8,0,0,255
sprena_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#26+64     ; SpriteOp 26 + 1 extra argument
spr1   LDR    R6,[fp,#4]    ;length of NEWNAM
spr2   CMP    R6,#12
       MOVGT  R6,#12        ;limit length to 12
       ADR    R4,nam16      ;pointer to address of NEWNAM copy
       STR    R4,[sp,#8]    ;store for first extra argument
       LDR    R4,[R4]       ;address of NEWNAM copy
       MOV    R5,#0
spr3   STRB   R5,[R4,R6]    ;store zeros in end of local name
       SUBS   R6,R6,#1
       LDRB   R7,[R2,R6]
       RSBGTS lr,R7,#33     ;check for blank (or less)
       BGT    spr3
spr4   STRB   R7,[R4,R6]    ;copy name to local store
       SUBS   R6,R6,#1
       LDRGEB R7,[R2,R6]
       BGE    spr4
       B      SpOp_A        ;go do the job...
nam16  DCD    SpOp_N+16
       END
;
       TTL    spop28
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sppl_;(ISR,NAME,IACT) plot sprite at graphics cursor
       IMPORT SpOp_A
       DCB    "SPPL",0,0,0,0,8,0,0,255
sppl_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#28+64     ; SpriteOp 28 + 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop29
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spcmsk_;(ISR,NAME) create mask
       IMPORT SpOp_A0
       DCB    "SPCMSK",0,0,8,0,0,255
spcmsk_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#29        ; SpriteOp 29
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop30
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdelm_;(ISR,NAME) delete mask
       IMPORT SpOp_A0
       DCB    "SPDELM",0,0,8,0,0,255
spdelm_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#30        ; SpriteOp 30
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop31
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spinsr_;(ISR,NAME,IROW) insert blank row in sprite
       IMPORT SpOp_A
       DCB    "SPINSR",0,0,8,0,0,255
spinsr_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#31+64     ; SpriteOp 31 + 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop32
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdelr_;(ISR,NAME,IROW) delete row from sprite
       IMPORT SpOp_A
       DCB    "SPDELR",0,0,8,0,0,255
spdelr_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#32+64     ; SpriteOp 32 + 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop33
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spflpx_;(ISR,NAME) flip sprite about X-axis
       IMPORT SpOp_A0
       DCB    "SPFLPX",0,0,8,0,0,255
spflpx_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#33        ; SpriteOp 33
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop34
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spplxy_;(ISR,NAME,IX,IY,IACT) plot sprite at IX,IY
       IMPORT SpOp_A
       DCB    "SPPLXY",0,0,8,0,0,255
spplxy_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#8]    ;length of name
       MOV    ip,#34+192    ; SpriteOp 34 + 3 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop36
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spsetp_;(ISR,NAME,IBITS,IX,IY,SCALE,IPXTR) set pointer shape
       IMPORT SpOp_A
       IMPORT SpOp_S
       DCB    "SPSETP",0,0,8,0,0,255
spsetp_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    lr,[fp,#12]   ;pointer to IPXTR
       TST    lr,#3
       LDREQ  R3,[lr]       ;IPXTR(1)
       CMPEQ  R3,#0
       LDRNE  ip,nam16
       STRNE  ip,[fp,#12]   ;address of pointer to IPXTR
       STRNE  lr,[ip]
       ADD    R2,fp,#8      ;address of SCALE pointer
       BL     SpOp_S        ;fix up scale
       LDR    R3,[fp,#16]   ;length of name
       MOV    ip,#36+320    ; SpriteOp 36 + 5 extra arguments
       B      SpOp_A        ;go do the job...
;
       IMPORT SpOp_N
nam16  DCD    SpOp_N+16
       END
;
       TTL    spop37
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdelp_;(ISR,NAME) delete palette
       EXPORT spcpal_;(ISR,NAME) create palette
       IMPORT SpOp_A0
       DCB    "SPDELP",0,0,8,0,0,255
spdelp_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       ADR    R4,zero       ;zero reason code to delete palette
       B      sp1
;
       DCB    "SPCPAL",0,0,8,0,0,255
spcpal_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       ADR    R4,one        ;one reason code to create palette
sp1    SUB    fp,ip,#4
       STR    R4,[sp,#8]    ;address of 'R2'
       MOV    ip,#37+64     ;SpriteOp 37 + 1 extra arguments
       B      SpOp_A0       ;go do the job...
zero   DCD    0
one    DCD    1
       END
;
       TTL    spop40
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R6     RN     6
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spinfo_;(ISR,NAME,IWIDTH,IHITE,MASK,MODE,LPAL) get sprite info
       IMPORT SpOp_AR
       IMPORT SpOp_F
       DCB    "SPINFO",0,0,8,0,0,255
spinfo_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#16]   ;length of name
       MOV    ip,#40        ;SpriteOp 40
       BL     SpOp_AR       ;go do the job...
       LDMVCIA sp,{R0,R1,ip,lr} ;restore ISR to IHITE pointers
       STRVC  R3,[ip]       ;store IWIDTH
       STRVC  R4,[lr]       ;store IHITE
       LDMVCIB fp,{R2,R3}    ;addresses of MASK & MODE
       STRVC  R5,[R2]       ;store MASK
       STRVC  R6,[R3]       ;store MODE
       ADRVC  R2,m1         ;-1 to read palette size
       STRVC  R2,[sp,#8]    ;store new argument
       LDRVC  R3,[fp,#16]   ;length of name
       MOVVC  ip,#37+64     ;SpriteOp 37 + 1 extra argument
       BLVC   SpOp_AR       ;go do the job...
       LDRVC  R4,[fp,#12]
       STRVC  R3,[R4]       ;store LPAL
       B      SpOp_F        ;return to fortran
m1     DCD    -1
       END
;
       TTL    spop41
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R5     RN     5
R6     RN     6
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sprpix_;(ISR,NAME,IX,IY,ICOL,ITINT) read pixel colour
       IMPORT SpOp_AR
       IMPORT SpOp_F
       DCB    "SPRPIX",0,0,8,0,0,255
sprpix_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#12]   ;length of name
       MOV    ip,#41+128    ;SpriteOp 41 + 2 extra arguments
       BL     SpOp_AR       ;go do the job...
       LDMVCIB fp,{R2,R3}   ;addresses of ICOL,ITINT
       STRVC  R5,[R2]       ;store ICOL
       STRVC  R6,[R3]       ;store ITINT
       B      SpOp_F        ;return to fortran
       END
;
       TTL    spop42
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spwpix_;(ISR,NAME,IX,IY,ICOL,ITINT) writes pixel to sprite
       IMPORT SpOp_A
       DCB    "SPWPIX",0,0,8,0,0,255
spwpix_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#12]   ;length of name
       MOV    ip,#42        ;SpriteOp 42
       ORR    ip,ip,#256    ;4 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop43
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R5     RN     5
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sprmsk_;(ISR,NAME,IX,IY,MASK) read contents of mask
       IMPORT SpOp_AR
       IMPORT SpOp_F
       DCB    "SPRMSK",0,0,8,0,0,255
sprmsk_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#8]    ;length of name
       MOV    ip,#43+128    ;SpriteOp 43 + 2 extra arguments
       BL     SpOp_AR       ;go do the job...
       LDRVC  ip,[fp,#4]
       STRVC  R5,[ip]       ;store MASK
       B      SpOp_F        ;return to fortran
       END
;
       TTL    spop44
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spwmsk_;(ISR,NAME,IX,IY,IMASK) writes pixel to mask
       IMPORT SpOp_A
       DCB    "SPWMSK",0,0,8,0,0,255
spwmsk_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#8]    ;length of name
       MOV    ip,#44+192    ;SpriteOp 44 + 3 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop45
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spinsc_;(ISR,NAME,ICOL) insert blank column in sprite
       IMPORT SpOp_A
       DCB    "SPINSC",0,0,8,0,0,255
spinsc_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#45+64     ; SpriteOp 45 + 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop46
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spdelc_;(ISR,NAME,ICOL) delete column from sprite
       IMPORT SpOp_A
       DCB    "SPDELC",0,0,8,0,0,255
spdelc_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#46+64     ; SpriteOp 46 + 1 extra argument
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop47
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spflpy_;(ISR,NAME) flip sprite about Y-axis
       IMPORT SpOp_A0
       DCB    "SPFLPY",0,0,8,0,0,255
spflpy_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#47        ; SpriteOp 47
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop48
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sppm_;(ISR,NAME) plots mask at graphics cursor
       IMPORT SpOp_A0
       DCB    "SPPM",0,0,0,0,8,0,0,255
sppm_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#48        ; SpriteOp 48
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop49
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sppmxy_;(ISR,NAME,IX,IY) plot mask at IX,IY
       IMPORT SpOp_A
       DCB    "SPPMXY",0,0,8,0,0,255
sppmxy_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R3,[fp,#4]    ;length of name
       MOV    ip,#49+128    ; SpriteOp 49 + 2 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop50
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sppmsc_;(ISR,NAME,IX,IY,SCALE) plot scaled mask
       IMPORT SpOp_A
       IMPORT SpOp_S
       DCB    "SPPMSC",0,0,8,0,0,255
sppmsc_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       ADD    R2,fp,#4      ;address of pointer to SCALE
       BL     SpOp_S        ;fix up scale
       LDR    R3,[fp,#8]    ;length of name
       MOV    ip,#50+192    ; SpriteOp 50 + 3 extra arguments
       B      SpOp_A        ;go do the job...
       END
;
       TTL    spop51
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R6     RN     6
R7     RN     7
OS_SpriteOp   EQU &2002E ; error return bit set
       AREA   |C$$code|,CODE,READONLY
       EXPORT spchar_;(ICHAR,IX,IY,SCALE) plot scaled ASCII character
       IMPORT SpOp_F
       IMPORT SpOp_S
       DCB    "SPCHAR",0,0,8,0,0,255
spchar_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       ADD    R2,sp,#12 ;address of pointer to SCALE
       BL     SpOp_S    ;fix up scale
       LDMIA  sp!,{R0,R1,ip,lr}
       LDR    R6,[lr]   ;scale
       LDR    R4,[ip]   ;y-coord
       LDR    R3,[R1]   ;x-coord
       LDRB   R1,[R0]   ;character
       MOV    R0,#51
       SWI    OS_SpriteOp
       B      SpOp_F    ;return to fortran
       END
;
       TTL    spop52
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spplsc_;(ISR,NAME,IX,IY,IACT,SCALE,IPXTR) plot scaled sprite
       IMPORT SpOp_A
       IMPORT SpOp_S
       DCB    "SPPLSC",0,0,8,0,0,255
spplsc_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    lr,[fp,#12]   ;pointer to IPXTR
       TST    R3,#3
       LDREQ  R3,[lr]
       CMPEQ  R3,#0
       LDRNE  ip,nam16
       STRNE  ip,[fp,#12]   ;address of pointer to IPXTR
       STRNE  lr,[ip]
       ADD    R2,fp,#8      ;address of pointer to address of SCALE
       BL     SpOp_S        ;fix up scale
       LDR    R3,[fp,#16]   ;length of name
       MOV    ip,#52+320    ; SpriteOp 52 + 5 extra arguments
       B      SpOp_A        ;go do the job...
;
       IMPORT SpOp_N
nam16  DCD    SpOp_N+16
       END
;
       TTL    spop53
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spplaa_;(ISR,NAME,IX,IY,SCALE,IPXTR) plot anti-aliased sprite
       IMPORT SpOp_A
       IMPORT SpOp_S
       IMPORT SpOp_N
       DCB    "SPPLAA",0,0,8,0,0,255
spplaa_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       ADD    R2,fp,#4      ;address of pointer to address of SCALE
       BL     SpOp_S        ;fix up scale
       LDR    R3,[fp,#12]   ;length of name
       LDR    lr,[fp,#8]    ;pointer to IPXTR
       TST    lr,#3
       LDREQ  R2,[lr]
       CMPEQ  R2,#0
       STREQ  lr,[fp,#12]   ;address of pointer to 0
       LDRNE  ip,nam16
       STRNE  ip,[fp,#12]   ;address of pointer to IPXTR
       STRNE  lr,[ip]
       LDR    lr,[fp,#4]    ;address of SCALE
       STR    lr,[fp,#8]    ;shifted address of SCALE
       ADR    R2,zero
       STR    R2,[fp,#4]    ;R5 (3rd extra argument is zero)
       MOV    ip,#53        ; SpriteOp 53
       ORR    ip,ip,#320    ;5 extra arguments
       B      SpOp_A        ;go do the job...
zero   DCD    0
nam16  DCD    SpOp_N+16
       END
;
       TTL    spop54
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT spleft_;(ISR,NAME) remove left hand wastage
       IMPORT SpOp_A0
       DCB    "SPLEFT",0,0,8,0,0,255
spleft_
       MOV    ip,sp
       STMDB  sp!,{R0-R1,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#54        ; SpriteOp 54
       B      SpOp_A0       ;go do the job...
       END
;
       TTL    spop56
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R6     RN     6
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT sppltr_;(ISR,NAME,IFLG,ISRC,IACT,TR,IPX) plot sprite transformed
       IMPORT SpOp_A
       IMPORT SpOp_N
       DCB    "SPPLTR",0,0,8,0,0,255
sppltr_
       MOV    ip,sp
       STMDB  sp!,{R0-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    ip,nam16
       STR    ip,[sp,#12]   ;address of pointer to ISRC
       STR    R3,[ip],#4    ;pointer to ISRC
       LDR    lr,[fp,#12]   ;pointer to IPXTR
       TST    lr,#3
       LDREQ  R3,[lr]
       CMPEQ  R3,#0
       STRNE  ip,[fp,#12]   ;address of pointer to IPXTR
       STRNE  lr,[ip],#4
       LDR    R7,[R2]       ;IFLG
       LDR    R2,[fp,#8]    ;pointer to TR
       STR    ip,[fp,#8]    ;address of pointer to TR
       ADD    R3,ip,#4      ;pointer to new ITR
       STR    R3,[ip]       ;store pointer
       TST    R7,#1         ;test for Draw trans or parallelogram
       MOVEQ  ip,#6         ;6 words in transform
       MOVEQ  R4,#134       ;16-bit shift for transform
       MOVNE  ip,#8         ;8 coordinates
       MOVNE  R4,#142       ;8-bit shift for coords
sp1    CMP    ip,#2
       MOVEQ  R4,#142       ;8-bit shift for coeffs 5&6
;  transform the REAL*4 word at R2 to a binary.R4 integer at R3
       LDR    R5,[R2],#4     ;get word
       MOV    R6,R5,ASR#23   ;get exponent and sign
       BIC    R5,R5,R6,LSL#23;remove exponent and sign
       ORR    R5,R5,#&800000 ;restore m.s. digit
       AND    R7,R6,#&FF     ;get exponent
       RSBS   R7,R7,R4       ;remove bias
       MOVGT  R5,R5,LSR R7   ;shift right if +ve
       RSBLT  R7,R7,#0
       MOVLT  R5,R5,LSL R7   ;shift left if -ve
       CMP    R6,#0
       RSBLT  R5,R5,#0       ;change sign if word was negative
       STR    R5,[R3],#4     ;store answer
       SUBS   ip,ip,#1
       BGT    sp1
       LDR    R3,[fp,#16]   ;length of name
       MOV    ip,#56+320    ; SpriteOp 56 + 5 extra arguments
       B      SpOp_A        ;go do the job...
nam16  DCD    SpOp_N+16
       END
;
       TTL    spop60_61
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R7     RN     7
;  spop60_61 flag current state in COMMON SpOp_state                  20/03/96
       AREA   |SpOp_state|,COMMON
       %      4  ;flag: 0 normally, <>0 if pointing to sprite or mask
OS_SpriteOp   EQU &2002E ; error return bit set
       AREA   |C$$code|,CODE,READONLY
       EXPORT sp2spr_;(ISR,NAME) vdu output to sprite
       EXPORT sp2msk_;(ISR,NAME) vdu output to mask
       EXPORT sp2scr_;           vdu output to screen
       IMPORT SpOp_A0
       IMPORT SpOp_F
       DCB    "SP2SCR",0,0,8,0,0,255
sp2scr_
       MOV    ip,sp
       STMDB  sp!,{R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    R0,#60
       MOV    R2,#0         ;switch O/P to VDU
       MOV    R3,#1
       LDR    R7,ptr
       STR    R2,[R7]       ;set flag to 0 (screen)
       SWI    OS_SpriteOp
       B      SpOp_F        ;return to fortran
;
       DCB    "SP2SPR",0,0,8,0,0,255
sp2spr_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#60+64     ; SpriteOp 60 + 1 extra argument
       B      sp2
;
       DCB    "SP2MSK",0,0,8,0,0,255
sp2msk_
       MOV    ip,sp
       STMDB  sp!,{R0-R2,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       MOV    ip,#61+64     ; SpriteOp 61 + 1 extra argument
sp2    ADR    R4,zero       ;no save area
       STR    R4,[sp,#8]
       LDR    R7,ptr
       STR    ip,[R7]       ;set flag to 124 (sprite) or 125 (mask)
       B      SpOp_A0
zero   DCD    0
ptr    DCD    |SpOp_state|
       END
;
       TTL    SpOp_A
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R6     RN     6
R7     RN     7
OS_SpriteOp   EQU &2002E ; error return bit set
;
;   standard Sprite_Op call
;      R0, R1 pointers to store and name, R3 is length of name
;      ip contains the SpriteOp number +
;      + 2**24 * # extra arguments  to be stored in R3, R4, etc
;      addresses of extra arguments are on the stack
;        sp->(R1),R3,R4  fp->,R5,R6,R7
;   returns V set if failure
;
       AREA   |C$$code|,CODE,READONLY
       EXPORT SpOp_A
       EXPORT SpOp_A0
       EXPORT SpOp_AR
       IMPORT SpOp_F
SpOp_A0
       MOV    R3,R2         ;entry for no extra args
SpOp_A LDR    lr,retn
SpOp_AR
       MOV    R7,R0
       AND    R0,ip,#63     ;bare spriteop #
       LDR    R4,[R7]       ;get first word of sprite area
       CMP    R4,#0         ;see whether system or user area (clears V)
       ADDNE  R0,R0,#256    ;add 256 for user area
       BLE    strng         ;must be string if system area
       TST    R1,#3
       LDREQ  R2,[R1]       ;get first word (possible address)
       TSTEQ  R2,#3
       CMPEQ  R7,R2         ;check it is higher than start of area
       ADDLT  R4,R4,R7      ;end of area
       CMPLT  R2,R4         ;if sprite address is inside sprite area...
       ADDLT  R0,R0,#256    ;add another 256
       BLT    xargs         ;and don't try to get name
strng  CMP    R3,#12        ;check name length is not greater than 12
       MOVGT  R3,#12        ;set it to 12 if it is too big
       LDR    R2,namptr     ;get address of local store for name
       MOV    R6,#0
lp1    STRB   R6,[R2,R3]    ;store zeros in end of local name
       SUBS   R3,R3,#1
       LDRB   R5,[R1,R3]
       RSBGTS R5,R5,#33     ;check for blank (or less)
       BGT    lp1
lp2    LDRB   R5,[R1,R3]
       STRB   R5,[R2,R3]    ;copy name to local store
       SUBS   R3,R3,#1
       BGE    lp2
xargs  MOV    R1,R7         ;pointer to sprite area
       SUBS   ip,ip,#64
       LDRGE  R3,[sp,#8]    ;address of arg 1
       LDRGE  R3,[R3]       ;1st arg if there is one
       SUBGES ip,ip,#64
       LDRGE  R4,[sp,#12]   ;address of arg 1
       LDRGE  R4,[R4]       ;2nd arg if there is one
       SUBGES ip,ip,#64
       LDMGEIB fp,{R5-R7}   ;get addresses of 3rd to 5th extra arguments
       LDRGE  R5,[R5]       ;3rd arg if there is one
       SUBGES ip,ip,#64
       LDRGE  R6,[R6]       ;4th arg if there is one
       SUBGES ip,ip,#64
       LDRGE  R7,[R7]       ;5th arg if there is one
       AND    ip,R0,#63     ;Base SpriteOp number
       TEQ    ip,#28
       MOVEQ  R5,R3         ;SpriteOp 28 requires its argument in R5
       TEQ    ip,#50
       MOVEQ  R6,R5         ;SpriteOp 50 requires its argument in R6
       SWI    OS_SpriteOp   ;  at last go and do the job.....
       MOV    pc,lr
retn   DCD    SpOp_F
;
       IMPORT SpOp_N
namptr DCD    SpOp_N
       END
;
       TTL    SpOp_S
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R2     RN     2
R3     RN     3
R4     RN     4
R5     RN     5
R6     RN     6
R7     RN     7
       AREA   |C$$code|,CODE,READONLY
       EXPORT SpOp_S; fix up scale factors pointed at by R2
;                     uses R2-R7
SpOp_S LDR    R3,[R2]        ;address of SCALE
       LDR    R4,[R3]        ;SCALE(1)
       CMP    R4,#0
       MOVEQ  pc,lr          ;nothing to fix if SCALE(1) is zero
       ADR    R4,nam32
       STR    R4,[R2]        ;new pointer to address of new scales
       LDR    R4,[R4]        ;address of new scales
       MOV    R2,#2          ;count of x,y
sp1    LDR    R5,[R3],#4     ;get word (SCALE(1) or SCALE(2))
       MOV    R6,R5,ASR#23   ;get exponent and sign
       BIC    R5,R5,R6,LSL#23;remove exponent and sign
       ORR    R5,R5,#&800000 ;restore m.s. digit
       AND    R7,R6,#&FF     ;get exponent
       RSBS   R7,R7,#134     ;shift for binary.16
       MOVGT  R5,R5,LSR R7   ;shift right if +ve
       RSBLT  R7,R7,#0
       MOVLT  R5,R5,LSL R7   ;shift left if -ve
       CMP    R6,#0
       RSBLT  R5,R5,#0       ;change sign if word was negative
       MOV    R7,#&10000     ;initial divisor
       TST    R5,#&FF
       MOVEQ  R5,R5,ASR #8
       MOVEQ  R7,R7,LSR #8
       TST    R5,#&FF
       MOVEQ  R5,R5,ASR #8
       MOVEQ  R7,R7,LSR #8
sp2    TST    R7,#1
       TSTEQ  R5,#1
       MOVEQ  R5,R5,ASR #1
       MOVEQ  R7,R7,LSR #1
       BEQ    sp2
       STR    R7,[R4,#8]     ;store divisor
       STR    R5,[R4],#4     ;store multiplier
       SUBS   R2,R2,#1
       BGT    sp1            ;loop over x,y
       MOV    pc,lr
       IMPORT SpOp_N
nam32  DCD    SpOp_N+32
       END
;
       TTL    spop_temp
       AREA   |C$$data|,DATA
       EXPORT SpOp_N
SpOp_N %      16            ;reserve 16 bytes for sprite name
       %      240           ;and up to 256 for pathname
       END
;
       TTL    spasys
pc     RN     15
lr     RN     14
sp     RN     13
ip     RN     12
fp     RN     11
R0     RN     0
R1     RN     1
R4     RN     4
R7     RN     7
OS_ChangeDynamicArea   EQU &2002A ; error return bit set
       AREA   |C$$code|,CODE,READONLY
       IMPORT SpOp_F
       EXPORT spasys_;(NK) kilobytes to increase system sprite area
       DCB    "SPASYS",0,0,8,0,0,255
spasys_
       MOV    ip,sp
       STMDB  sp!,{R0,R4-R7,fp,ip,lr,pc}
       SUB    fp,ip,#4
       LDR    R1,[R0]       ;NK
       MOV    R1,R1,LSL #10 ; * 1024
       MOV    R0,#3         ;sprite area
       SWI    OS_ChangeDynamicArea
       B      SpOp_F        ;return to fortran
       END
