! BROKEN BY GOING TO ASCII. ELIMINATE OR CORRECT
| Type | Visibility | Attributes | Name | Initial | |||
|---|---|---|---|---|---|---|---|
| doubleprecision, | public | :: | b | ||||
| integer, | public | :: | ch | ||||
| doubleprecision, | public | :: | eps | ||||
| character(len=256), | public | :: | errmsg | ||||
| integer, | public, | save | :: | flag | = | 0 | |
| integer, | public | :: | i | ||||
| integer, | public | :: | id(GG_MAX_NAME_LENGTH) | ||||
| integer, | public | :: | img | ||||
| integer, | public | :: | j | ||||
| integer, | public | :: | k | ||||
| integer, | public | :: | l2 | ||||
| integer, | public | :: | ll | ||||
| integer, | public | :: | location | ||||
| integer, | public, | save | :: | lrat | = | 5 | |
| integer, | public | :: | ls | ||||
| integer, | public | :: | lun | ||||
| integer, | public | :: | lunit | ||||
| integer, | public | :: | lw | ||||
| integer, | public | :: | lx | ||||
| integer, | public | :: | ly | ||||
| integer, | public | :: | m | ||||
| character(len=GG_LINELEN), | public | :: | mline | ||||
| integer, | public | :: | mn | ||||
| integer, | public, | save | :: | mrat | = | 100 | |
| integer, | public | :: | n | ||||
| doubleprecision, | public | :: | s | ||||
| integer, | public | :: | space_left | ||||
| doubleprecision, | public | :: | t | ||||
| doubleprecision, | public | :: | tdum(2) | ||||
| logical, | public | :: | text | ||||
| integer, | public | :: | top2 |
subroutine mat_matfn5()
! ident_28="@(#) M_matrix mat_matfn5(3fp) file handling and other I/O"
character(len=GG_LINELEN) :: mline
character(len=256) :: errmsg
integer,save :: flag=0 ! should be saved or set at each call?
integer,save :: lrat=5
integer,save :: mrat=100
integer :: ch,top2
integer :: id(GG_MAX_NAME_LENGTH)
doubleprecision :: eps,b,s,t,tdum(2)
logical :: text
integer :: i, j, k, location, m, n
integer :: img
integer :: space_left
integer :: l2
integer :: ll
integer :: ls
integer :: lun
integer :: lunit
integer :: lw
integer :: lx
integer :: ly
integer :: mn
!
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
m = G_VAR_ROWS(G_ARGUMENT_POINTER)
n = G_VAR_COLS(G_ARGUMENT_POINTER)
! functions/G_FIN
! exec save load prin diar disp base line char plot rat debu doc delete
! 1 2 3 4 5 6 7 8 9 10 11 12 13 14
select case(G_FIN)
case(:5,13,14) ! setup for filename parameter
mn = m*n
if (G_SYM .eq. semi)then
flag = 0
else
flag = 3
endif
if (G_RHS .ge. 2) then ! if more than one parameter on exec('filename',flag) get value of FLAG
flag = int(GM_REALS(location))
top2 = G_ARGUMENT_POINTER
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
mn = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
endif
! if a single character and a digit set LUN to that so exec(0) works
if (mn.eq.1 .and. GM_REALS(location).LT.10.0d0)then
lun = int(GM_REALS(location))
else
lun = -1
do j = 1, GG_LINELEN
ls = location+j-1
if (j .le. mn) ch = int(GM_REALS(ls))
if (j .gt. mn) ch = blank
if (ch.lt.0 .or. ch.ge.g_charset_size) then
call mat_err(38)
return
endif
G_BUF(j) = ch
enddo
endif
end select
!===================================================================================================================================
FUN5 : select case(G_FIN)
!===================================================================================================================================
case(1) ! command::exec
EXEC_CMD : block
character(len=:),allocatable :: filename
if (lun .eq. 0) then ! exec(0)
G_RIO = G_INPUT_LUN
G_ERR = 99
else
k = G_LINE_POINTER(6)
G_LIN(k+1) = G_LINE_POINTER(1)
G_LIN(k+2) = G_LINE_POINTER(3)
G_LIN(k+3) = G_LINE_POINTER(6)
G_LIN(k+4) = G_PTZ
G_LIN(k+5) = G_RIO
G_LIN(k+6) = G_LINECOUNT(4)
G_LINE_POINTER(1) = k + 7
G_LINECOUNT(4) = flag
G_PTZ = G_PT - 4
if (G_RIO .eq. G_INPUT_LUN)then
G_RIO = 12
endif
G_RIO = G_RIO + 1
filename=find_exec_file(ade2str(G_BUF))
call mat_str2buf(filename,G_BUF,GG_LINELEN) ! convert input line to ADE buffer
call mat_files(G_RIO,G_BUF,status='old')
if(G_FILE_OPEN_ERROR)then
G_RIO = G_INPUT_LUN
G_ERR = 99
endif
if (flag .ge. 4)then
call journal(' PAUSE MODE. Enter blank lines.')
endif
G_SYM = GG_EOL
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
endif
endblock EXEC_CMD
!===================================================================================================================================
case(2) ! COMMAND::SAVE
lunit = 1
call mat_files(lunit,G_BUF)
k = GG_MAX_NUMBER_OF_NAMES-4
if (k .lt. G_TOP_OF_SAVED) k = GG_MAX_NUMBER_OF_NAMES
if (G_RHS .eq. 2) k = top2
if (G_RHS .eq. 2) call mat_copyid(G_VAR_IDS(1,k),G_SYN)
do
location = G_VAR_DATALOC(k)
m = G_VAR_ROWS(k)
n = G_VAR_COLS(k)
do i = 1, GG_MAX_NAME_LENGTH
j = G_VAR_IDS(i,k)
G_BUF(i) = j
enddo
img = 0
if (mat_wasum(m*n,GM_IMAGS(location),GM_IMAGS(location),1) .ne. 0.0d0) img = 1
if(.not.G_FILE_OPEN_ERROR)call mat_savlod(lunit,G_BUF,m,n,img,0,GM_REALS(location),GM_IMAGS(location))
k = k-1
if (k .lt. G_TOP_OF_SAVED) exit
enddo
call mat_files(-lunit,G_BUF) ! close unit
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0 ! do not set "ans" to filename
!===================================================================================================================================
case(14) ! COMMAND::DELETE
DELETE_IT: block
integer :: templun
integer :: ios
call mat_buf2str(mline,G_BUF,GG_LINELEN)
open(file=mline,newunit=templun,iostat=ios,iomsg=errmsg,status='old')
if(ios.ne.0)then
call journal('sc','ERROR:',errmsg)
G_ERR=999
exit FUN5
endif
close(unit=templun,iostat=ios,iomsg=errmsg,status='delete')
if(ios.ne.0)then
call journal('sc','ERROR:',errmsg)
G_ERR=999
exit FUN5
endif
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0 ! do not set "ans" to filename
endblock DELETE_IT
!===================================================================================================================================
case(3) ! command::load
call mat_buf2str(mline,G_BUF,GG_LINELEN)
lunit = 2
call mat_files(LUNIT,G_BUF) ! open the unit
call mat_buf2str(mline,G_BUF,GG_LINELEN)
do
space_left = G_VAR_DATALOC(G_TOP_OF_SAVED) - location
IF(.not.G_FILE_OPEN_ERROR)then
call mat_savlod(lunit, &
& id, &
& G_VAR_ROWS(G_ARGUMENT_POINTER), &
& G_VAR_COLS(G_ARGUMENT_POINTER), &
& img, &
& space_left, &
& GM_REALS(location), &
& GM_IMAGS(location))
endif
mn = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
if (mn .ne. 0)then
if (img .eq. 0) call mat_rset(mn,0.0d0,GM_IMAGS(location),1)
!do i = 1, GG_MAX_NAME_LENGTH
! do j=1,G_CHARSET_SIZE
! if(id(i).eq.blank)then
! id(i) = blank
! exit
! elseif (id(i).ne.J)then
! cycle
! else
! id(i) = j-1 ! ????
! exit
! endif
! enddo
!enddo
G_SYM = semi
G_RHS = 0
call MAT_STACK_PUT(ID)
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER + 1
else
exit
endif
enddo
call mat_files(-lunit,G_BUF) ! close unit
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(4) ! command::print
call mat_files(7,G_BUF)
location = G_LINECOUNT(2) ! hold
G_LINECOUNT(2) = 999999 ! turn off paging of output
if (G_RHS .gt. 1) call mat_print(G_SYN,top2)
G_LINECOUNT(2) = location ! restore
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(5) ! command::diary
call mat_files(8,G_BUF)
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(6,7) ! COMMAND::DISPLAY
60 continue
if (G_FIN.eq.7)goto 65
if (G_RHS .ge. 2)then
if (G_RHS .ne. 2) call mat_err(39) ! Incorrect number of arguments
if (GM_REALS(location) .lt. 1.0d0)then ! test if base is 0
call mat_err(36) ! Argument out of range
exit FUN5
endif
b = GM_REALS(location)
if(b.gt.1)then
goto 65
endif
else
b=10
endif
mn = m*n
text = .true.
do i = 1, mn
ls = location+i-1
ch = int(GM_REALS(LS))
text = text .and. (ch.ge.0) .and. (ch.lt.G_CHARSET_SIZE)
text = text .and. (dble(ch).eq.GM_REALS(ls) )
enddo
if(b.le.1)text=.false. ! for forcing non-text display when values are in range of text
do i = 1, m
do j = 1, n
ls = location+i-1+(j-1)*m
if (GM_REALS(ls) .eq. 0.0d0) ch = blank
if (GM_REALS(ls) .gt. 0.0d0) ch = plus
if (GM_REALS(ls) .lt. 0.0d0) ch = minus
if (text) ch = int(GM_REALS(ls))
G_BUF(j) = ch
enddo
call mat_buf2str(mline,G_BUF,n)
call journal(mline)
enddo
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
exit FUN5
!. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
! command::base
65 CONTINUE
if (G_RHS .ne. 2) then
call mat_err(39) ! Incorrect number of arguments
exit FUN5
endif
if (GM_REALS(location) .le. 1.0d0) then ! test if base is <= 0
call mat_err(36) ! Argument out of range
exit FUN5
endif
b = GM_REALS(location)
l2 = location
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
G_RHS = 1
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
m = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
eps = GM_REALS(GM_BIGMEM-4)
do i = 1, m
ls = l2+(i-1)*n
ll = location+i-1
call mat_base(GM_REALS(ll),b,eps,GM_REALS(ls),n)
enddo
call mat_rset(m*n,0.0d0,GM_IMAGS(l2),1)
call mat_wcopy(m*n,GM_REALS(l2),GM_IMAGS(l2),1,GM_REALS(location),GM_IMAGS(location),1)
G_VAR_ROWS(G_ARGUMENT_POINTER) = n
G_VAR_COLS(G_ARGUMENT_POINTER) = m
call mat_stack1(quote)
if (G_FIN .eq. 6) goto 60
!===================================================================================================================================
case(8)
! command::lines
G_LINECOUNT(2) = int(GM_REALS(location))
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
!!! BROKEN BY GOING TO ASCII. ELIMINATE OR CORRECT
case(9) ! COMMAND::CHAR ! does currently not do anything
K = IABS(int(GM_REALS(location)))
IF (M*N.NE.1 .OR. K.GT.G_CHARSET_SIZE-1) then
call mat_err(36) ! Argument out of range
exit FUN5
endif
CH = K
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(10) ! COMMAND::PLOT
IF (G_RHS .GE. 2) goto 82
N = M*N
DO I = 1, N
LL = location+I-1
GM_IMAGS(LL) = dble(I)
enddo
call mat_plot(STDOUT,GM_IMAGS(location),GM_REALS(location),N,TDUM,0)
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
exit FUN5
!. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
82 continue
IF (G_RHS .EQ. 2) K = 0
IF (G_RHS .EQ. 3) K = M*N
IF (G_RHS .GT. 3) K = G_RHS - 2
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - (G_RHS - 1)
N = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
IF (G_VAR_ROWS(G_ARGUMENT_POINTER+1)*G_VAR_COLS(G_ARGUMENT_POINTER+1) .NE. N) then
call mat_err(5)
exit FUN5
endif
LX = G_VAR_DATALOC(G_ARGUMENT_POINTER)
LY = G_VAR_DATALOC(G_ARGUMENT_POINTER+1)
IF (G_RHS .GT. 3) location = G_VAR_DATALOC(G_ARGUMENT_POINTER+2)
call mat_plot(STDOUT,GM_REALS(LX),GM_REALS(LY),N,GM_REALS(location),K)
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(11) ! COMMAND::RAT
if (G_RHS .ne. 2) then
mn = m*n
l2 = location
if (G_lhs .eq. 2) l2 = location + mn
lw = l2 + mn
if(too_much_memory( lw + lrat - G_VAR_DATALOC(G_TOP_OF_SAVED) ) )return
if (G_lhs .eq. 2) 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) = n
call mat_rset(G_lhs*mn,0.0d0,GM_IMAGS(location),1)
do i = 1, mn
call mat_rat(GM_REALS(location),lrat,mrat,s,t,GM_REALS(lw))
GM_REALS(location) = s
GM_REALS(l2) = t
if (G_lhs .eq. 1) GM_REALS(location) = mat_flop(s/t)
location = location + 1
l2 = l2 + 1
enddo
else
mrat = int(GM_REALS(location))
lrat = int(GM_REALS(location-1))
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 1
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
endif
!===================================================================================================================================
case(12) ! COMMAND::DEBUG
G_DEBUG_LEVEL = int(GM_REALS(location))
call journal('sc',' DEBUG ',G_DEBUG_LEVEL)
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
case(13) ! COMMAND::SHOW
call printit()
G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
!===================================================================================================================================
end select FUN5
!===================================================================================================================================
end subroutine mat_matfn5