subroutine mat_clause()
doubleprecision :: e1,e2
integer :: op
integer :: r
integer,parameter :: for(GG_MAX_NAME_LENGTH) = [iachar(['f','o','r',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter :: while(GG_MAX_NAME_LENGTH) = [iachar(['w','h','i','l','e',' ',' ']),GG_PAD(8:)]
integer,parameter :: iff(GG_MAX_NAME_LENGTH) = [iachar(['i','f',' ',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter :: else(GG_MAX_NAME_LENGTH) = [iachar(['e','l','s','e',' ',' ',' ']),GG_PAD(8:)]
integer,parameter :: ennd(GG_MAX_NAME_LENGTH) = [iachar(['e','n','d',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter :: do(GG_MAX_NAME_LENGTH) = [iachar(['d','o',' ',' ',' ',' ',' ']),GG_PAD(8:)]
integer,parameter :: thenn(GG_MAX_NAME_LENGTH) = [iachar(['t','h','e','n',' ',' ',' ']),GG_PAD(8:)]
integer :: j
integer :: kount
integer :: location
integer :: l2
integer :: lj
integer :: m
integer :: n
r = -G_FIN-10
G_FIN = 0
if (r.lt.1 .or. r.gt.6) goto 01
goto (02,30,30,80,99,90),R
01 continue
r = G_RSTK(G_PT)
goto (99,99,05,40,45,99,99,99,99,99,99,99,15,55,99,99,99),R
call journal('*mat_clause* -- internal error')
goto 99
!.......................................................................
! FOR
02 continue
call mat_getsym()
if (G_SYM .ne. isname) then
call mat_err(34) ! improper for clause
return
endif
G_PT = G_PT+2
call mat_copyid(G_IDS(1,G_PT),G_SYN)
call mat_getsym()
if (G_SYM .ne. equal) then
call mat_err(34) ! improper for clause
return
endif
call mat_getsym()
G_RSTK(G_PT) = 3
! *call* expr
return
05 continue
G_PSTK(G_PT-1) = 0
G_PSTK(G_PT) = G_LINE_POINTER(4) - 1
if (mat_eqid(G_SYN,DO)) G_SYM = semi
if (G_SYM .eq. comma) G_SYM = semi
if (G_SYM .ne. semi) then
call mat_err(34) ! improper for clause
return
endif
10 continue
j = G_PSTK(G_PT-1)
G_LINE_POINTER(4) = G_PSTK(G_PT)
G_SYM = semi
G_CHRA = blank
j = j+1
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
m = G_VAR_ROWS(G_ARGUMENT_POINTER)
n = G_VAR_COLS(G_ARGUMENT_POINTER)
lj = location+(j-1)*m
l2 = location + m*n
if (m .ne. -3) goto 12
lj = location+3
l2 = lj
GM_REALS(lj) = GM_REALS(location) + dble(j-1)*GM_REALS(location+1)
GM_IMAGS(lj) = 0.0d0
if (GM_REALS(location+1).gt.0.0d0 .and. GM_REALS(lj).gt.GM_REALS(location+2)) goto 20
if (GM_REALS(location+1).lt.0.0d0 .and. GM_REALS(lj).lt.GM_REALS(location+2)) goto 20
m = 1
n = j
12 continue
if (j .gt. n) goto 20
if (G_ARGUMENT_POINTER+1 .ge. G_TOP_OF_SAVED) then
call mat_err(18) ! too many names
return
endif
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER+1
G_VAR_DATALOC(G_ARGUMENT_POINTER) = l2
G_VAR_ROWS(G_ARGUMENT_POINTER) = m
G_VAR_COLS(G_ARGUMENT_POINTER) = 1
if(too_much_memory( l2+m - G_VAR_DATALOC(G_TOP_OF_SAVED) ) )return
call mat_wcopy(m,GM_REALS(lj),GM_IMAGS(lj),1,GM_REALS(l2),GM_IMAGS(l2),1)
G_RHS = 0
call mat_stack_put(G_IDS(1,G_PT))
if (G_ERR .gt. 0) return
G_PSTK(G_PT-1) = j
G_PSTK(G_PT) = G_LINE_POINTER(4)
G_RSTK(G_PT) = 13
! *call* PARSE
return
15 continue
goto 10
20 continue
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
G_VAR_COLS(G_ARGUMENT_POINTER) = 0
G_RHS = 0
call mat_stack_put(G_IDS(1,G_PT))
if (G_ERR .gt. 0) return
G_PT = G_PT-2
goto 80
!.......................................................................
!
! WHILE OR IF
!
30 continue
G_PT = G_PT+1
call mat_copyid(G_IDS(1,G_PT),G_SYN)
G_PSTK(G_PT) = G_LINE_POINTER(4)-1
35 continue
G_LINE_POINTER(4) = G_PSTK(G_PT)
G_CHRA = blank
call mat_getsym()
G_RSTK(G_PT) = 4
! *call* EXPR
return
40 continue
if (G_SYM.ne.equal .and. (G_SYM.NE.LESS.and.G_SYM.ne.lbracket) .and. (G_SYM.NE.GREAT.and.G_SYM.ne.rbracket))then
call mat_err(35) ! improper WHILE or IF clause
return
endif
op = G_SYM
call mat_getsym()
if (G_SYM.EQ.equal .or. (G_SYM.EQ.great)) op = op + G_SYM
if (op .gt. great) call mat_getsym()
G_PSTK(G_PT) = 256*G_PSTK(G_PT) + op
G_RSTK(G_PT) = 5
! *call* EXPR
return
45 continue
op = mod(G_PSTK(G_PT),256)
G_PSTK(G_PT) = G_PSTK(G_PT)/256
location = G_VAR_DATALOC(G_ARGUMENT_POINTER-1)
e1 = GM_REALS(location)
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
e2 = GM_REALS(location)
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 2
if (mat_eqid(G_SYN,do) .or. mat_eqid(G_SYN,thenn)) G_SYM = semi
if (G_SYM .EQ. COMMA) G_SYM = SEMI
if (G_SYM .NE. SEMI) then
call mat_err(35) ! improper WHILE or IF clause
return
endif
if (op.eq.equal .and. e1.eq.e2) goto 50
if ((op.eq.less) .and. e1.lt.e2) goto 50
if (op.eq.great .and. e1.gt.e2) goto 50
if (op.eq.(less+equal) .and. e1.le.e2) goto 50
if (op.eq.(great+equal) .and. e1.ge.e2) goto 50
if (op.eq.(less+great) .and. e1.ne.e2) goto 50
G_PT = G_PT-1
goto 80
50 continue
G_RSTK(G_PT) = 14
! *call* PARSE
return
55 continue
IF (mat_eqid(G_IDS(1:,G_PT),while)) goto 35
G_PT = G_PT-1
if (mat_eqid(G_SYN,else)) goto 80
return
!.......................................................................
! SEARCH FOR MATCHING END OR ELSE
80 continue
kount = 0
call mat_getsym()
82 continue
if (G_SYM .eq. GG_EOL) return
if (G_SYM .ne. isname) goto 83
if (mat_eqid(G_SYN,ennd) .and. kount.eq.0) return
if (mat_eqid(G_SYN,else) .and. kount.eq.0) return
if (mat_eqid(G_SYN,ennd) .or. mat_eqid(G_SYN,else))kount = kount-1
if (mat_eqid(G_SYN,for) .or. mat_eqid(G_SYN,while).or.mat_eqid(G_SYN,iff)) kount = kount+1
83 continue
call mat_getsym()
goto 82
!.......................................................................
! EXIT FROM LOOP
90 continue
if (G_RSTK(G_PT) .eq. 14) G_PT = G_PT-1
if (G_PT .le. G_PTZ) return
if (G_RSTK(G_PT) .eq. 14) G_PT = G_PT-1
if (G_PT-1 .le. G_PTZ) return
if (G_RSTK(G_PT) .eq. 13) G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
if (G_RSTK(G_PT) .eq. 13) G_PT = G_PT-2
goto 80
!.......................................................................
!
99 continue
call mat_err(22) ! recursion difficulties
end subroutine mat_clause