subroutine mat_factor()
integer :: r
integer :: id(gg_max_name_length)
integer :: excnt
integer :: i, j, k
integer :: location
integer :: ln
integer :: ls
integer :: n
r = G_RSTK(G_PT)
! 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19
goto (99,99,99,99,99,99,99,01,01,25,45,65,99,99,99,55,75,32,37),r
01 continue
if (.not.(G_SYM.eq.isnum .or. G_SYM.eq.quote .or. (G_SYM.EQ.less.or.G_SYM.eq.lbracket))) then
if (G_SYM .eq. great.or.G_SYM.eq.rbracket)then
! MACROS STRING
call mat_getsym()
if ((G_SYM .eq. less.or.G_SYM.eq.lbracket) .and. G_CHRA.EQ.GG_EOL) then
call mat_err(28) ! Empty macro
return
endif
G_PT = G_PT+1
G_RSTK(G_PT) = 18
! *call* EXPR
return
endif
excnt = 0
if (G_SYM .eq. isname)then
! FUNCTION OR MATRIX ELEMENT
call mat_copyid(id,G_SYN)
call mat_getsym()
if (G_SYM .eq. lparen .or. G_SYM.eq. lbrace) goto 42
G_RHS = 0
call mat_funs(ID)
if (G_FIN .ne. 0) then
call mat_err(25) ! Can not use function name as variable
return
endif
call mat_stack_get(id)
if (G_ERR .gt. 0) return
if (G_FIN .eq. 7) goto 50
if (G_FIN .eq. 0) call mat_copyid(G_IDS(1,G_PT+1),id)
if (G_FIN .eq. 0) then
call mat_err(4) ! undefined variable
return
endif
goto 60
endif
id(1) = BLANK
if (G_SYM .eq. lparen .or. G_SYM.eq. lbrace) goto 42
call mat_err(2)
return
endif
!======================================================================
! put something on the stack
location = 1
if (G_ARGUMENT_POINTER .gt. 0) then
location = G_VAR_DATALOC(G_ARGUMENT_POINTER) &
& + G_VAR_ROWS(G_ARGUMENT_POINTER) &
& * G_VAR_COLS(G_ARGUMENT_POINTER)
endif
if (G_ARGUMENT_POINTER+1 .ge. G_TOP_OF_SAVED) then
call mat_err(18)
return
endif
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER+1
G_VAR_DATALOC(G_ARGUMENT_POINTER) = location
if (G_SYM .ne. quote) then
if (G_SYM .eq. less.or.G_SYM.eq.lbracket) goto 20
! single number, getsym stored it in GM_IMAGS
G_VAR_ROWS(G_ARGUMENT_POINTER) = 1
G_VAR_COLS(G_ARGUMENT_POINTER) = 1
GM_REALS(location) = GM_IMAGS(GM_BIGMEM)
GM_IMAGS(location) = 0.0D0
call mat_getsym()
goto 60
! string
endif
n = 0
G_LINE_POINTER(4) = G_LINE_POINTER(3)
call mat_getch() ! get next character
!==================================
16 continue
if (G_CHRA .eq. QUOTE) goto 18
17 continue
ln = location+n
if (G_CHRA .eq. GG_EOL) then
call mat_err(31) ! Improper string
return
endif
GM_REALS(LN) = dble(G_CHRA)
GM_IMAGS(LN) = 0.0d0
n = n+1
call mat_getch() ! get next character
goto 16
18 continue
call mat_getch() ! get next character
if (G_CHRA .eq. QUOTE) goto 17
!==================================
if (n .le. 0) then
call mat_err(31) ! Improper string
return
endif
G_VAR_ROWS(G_ARGUMENT_POINTER) = 1
G_VAR_COLS(G_ARGUMENT_POINTER) = n
call mat_getsym()
goto 60
!==================================================================================================================================!
! explicit matrix
20 continue
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
G_VAR_COLS(G_ARGUMENT_POINTER) = 0
21 continue
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER + 1
G_VAR_DATALOC(G_ARGUMENT_POINTER) = &
& G_VAR_DATALOC(G_ARGUMENT_POINTER-1) &
& + G_VAR_ROWS(G_ARGUMENT_POINTER-1)&
& * G_VAR_COLS(G_ARGUMENT_POINTER-1)
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
G_VAR_COLS(G_ARGUMENT_POINTER) = 0
call mat_getsym()
22 continue
if (G_SYM.eq.semi .or. (G_SYM.eq.great.or.G_SYM.eq.rbracket) .or. G_SYM.eq.GG_EOL) then
if (G_SYM.eq.semi .and. G_CHRA.eq.GG_EOL) call mat_getsym()
call mat_stack1(quote)
if (G_ERR .gt. 0) return
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 1
if (G_VAR_ROWS(G_ARGUMENT_POINTER) .eq. 0) &
& G_VAR_ROWS(G_ARGUMENT_POINTER) = G_VAR_ROWS(G_ARGUMENT_POINTER+1)
if (G_VAR_ROWS(G_ARGUMENT_POINTER) .ne. G_VAR_ROWS(G_ARGUMENT_POINTER+1) &
& .and. G_VAR_ROWS(G_ARGUMENT_POINTER+1) .gt. 0) then
call mat_err(6)
return
endif
G_VAR_COLS(G_ARGUMENT_POINTER) = G_VAR_COLS(G_ARGUMENT_POINTER) &
& + G_VAR_COLS(G_ARGUMENT_POINTER+1)
if (G_SYM .eq. GG_EOL) call mat_getlin()
if (G_SYM .ne. great.and. G_SYM.ne.rbracket) goto 21
call mat_stack1(quote)
if (G_ERR .gt. 0) return
call mat_getsym()
goto 60
endif
if (G_SYM .eq. comma) call mat_getsym()
G_PT = G_PT+1
G_RSTK(G_PT) = 10
! *call* EXPR
return
!==================================================================================================================================!
25 continue
G_PT = G_PT-1
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 1
if (G_VAR_ROWS(G_ARGUMENT_POINTER) .eq. 0) then
G_VAR_ROWS(G_ARGUMENT_POINTER) = G_VAR_ROWS(G_ARGUMENT_POINTER+1)
endif
if (G_VAR_ROWS(G_ARGUMENT_POINTER) .ne. G_VAR_ROWS(G_ARGUMENT_POINTER+1))then
call mat_err(5)
return
endif
G_VAR_COLS(G_ARGUMENT_POINTER) = &
& G_VAR_COLS(G_ARGUMENT_POINTER) + G_VAR_COLS(G_ARGUMENT_POINTER+1)
goto 22
!==================================================================================================================================!
32 continue
G_PT = G_PT-1
if ((G_SYM.ne.less.or.G_SYM.eq.lbracket) .and. G_SYM.NE.GG_EOL) then
call mat_err(37) ! Improper MACROS
return
endif
if (G_SYM .EQ. LESS.or.G_SYM.eq.lbracket) call mat_getsym()
k = G_LINE_POINTER(6)
G_LIN(k+1) = G_LINE_POINTER(1)
G_LIN(k+2) = G_LINE_POINTER(2)
G_LIN(k+3) = G_LINE_POINTER(6)
G_LINE_POINTER(1) = k + 4
! transfer stack to input line
k = G_LINE_POINTER(1)
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
n = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
do j = 1, n
ls = location + j-1
G_LIN(k) = int(GM_REALS(ls))
if (G_LIN(k).lt.0 .or. G_LIN(k).ge.G_CHARSET_SIZE) then
call mat_err(37) ! Improper MACROS
return
endif
if (k.lt.1024) k = k+1
if (k.eq.1024)call journal('sc','Input buffer char limit exceeded=',K)
enddo
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
G_LIN(k) = GG_EOL;G_LIN(k+1:)=blank
G_LINE_POINTER(6) = k
G_LINE_POINTER(4) = G_LINE_POINTER(1)
G_LINE_POINTER(3) = 0
G_LINE_POINTER(2) = 0
G_LINECOUNT(1) = 0
G_CHRA = blank
call mat_getsym()
G_PT = G_PT+1
G_RSTK(G_PT) = 19
! *call* EXPR
return
!==================================================================================================================================!
37 continue
G_PT = G_PT-1
k = G_LINE_POINTER(1) - 4
G_LINE_POINTER(1) = G_LIN(K+1)
G_LINE_POINTER(4) = G_LIN(K+2)
G_LINE_POINTER(6) = G_LIN(K+3)
G_CHRA = BLANK
call mat_getsym()
goto 60
!==================================================================================================================================!
42 continue
call mat_getsym()
excnt = excnt+1
G_PT = G_PT+1
G_PSTK(G_PT) = excnt
call mat_copyid(G_IDS(1,G_PT),id)
G_RSTK(G_PT) = 11
! *call* expr
return
!==================================================================================================================================!
45 continue
call mat_copyid(id,G_IDS(1,G_PT))
excnt = G_PSTK(G_PT)
G_PT = G_PT-1
if (G_SYM .eq. comma) goto 42
if ((G_SYM .ne. rparen) .and. (G_SYM.ne.rbrace)) then
call mat_err(3)
return
endif
if ((G_SYM .eq. rparen) .or. (G_SYM .eq. rbrace)) call mat_getsym()
if (id(1) .eq. blank) goto 60
G_RHS = excnt
call MAT_STACK_GET(id)
if (G_ERR .gt. 0) return
if (G_FIN .eq. 0) call mat_funs(ID)
if (G_FIN .eq. 0) then
call mat_err(4) ! undefined variable
return
endif
! evaluate matrix function
50 continue
G_PT = G_PT+1
G_RSTK(G_PT) = 16
! *call* matfn
return
!==================================================================================================================================!
55 continue
G_PT = G_PT-1
goto 60
!==================================================================================================================================!
! check for quote (transpose) and ** (power)
60 continue
if (G_SYM .eq. quote) then
i = G_LINE_POINTER(3) - 2
if (G_LIN(i) .eq. blank) goto 90
call mat_stack1(quote)
if (G_ERR .gt. 0) return
call mat_getsym()
endif
if (G_SYM.ne.star .or. G_CHRA.ne.star) goto 90
call mat_getsym()
call mat_getsym()
G_PT = G_PT+1
G_RSTK(G_PT) = 12
! *call* factor
goto 01
!==================================================================================================================================!
65 continue
G_PT = G_PT-1
call mat_stack2(DSTAR)
if (G_ERR .gt. 0) return
if (G_FUN .ne. 2) goto 90
! matrix power, use eigenvectors
G_PT = G_PT+1
G_RSTK(G_PT) = 17
! *call* matfn
return
!==================================================================================================================================!
75 continue
G_PT = G_PT-1
90 continue
return
!==================================================================================================================================!
99 continue
call mat_err(22) ! recursion difficulties
return
end subroutine mat_factor