subroutine mat_stack_put(id)
! ident_22="@(#) M_matrix mat_stack_put(3fp) put variables into storage"
integer :: id(GG_MAX_NAME_LENGTH)
integer :: i, j, k
integer :: ib
integer :: km1
integer :: location
integer :: l1,l2, li,lj,lk, ll,ls,lt
integer :: m, m1,m2, mk
integer :: mn, mn1, mn2, mnk
integer :: mt
integer :: n, nk, nt
if (G_ARGUMENT_POINTER .le. 0) then
call mat_err(1) ! Improper multiple assignment
return
endif
call mat_funs(id)
if (G_FIN .ne. 0) then
call mat_err(25) ! Can not use function name as variable
return
endif
m = G_VAR_ROWS(G_ARGUMENT_POINTER)
n = G_VAR_COLS(G_ARGUMENT_POINTER)
if (m .gt. 0) then
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
elseif(m.lt.0) then
call mat_err(14) ! EYE-dentity undefined by CONTEXT
return
elseif (m .eq. 0 .and. n .ne. 0) then
goto 99
else ! what about m zero and n not zero???
endif
mn = m*n
lk = 0
mk = 1
nk = 0
lt = 0
mt = 0
nt = 0
! unconditionally add name to end of list
call mat_copyid(G_VAR_IDS(1,G_TOP_OF_SAVED-1),id)
! did variable already exist (knowing name is there at least once)
do k=GG_MAX_NUMBER_OF_NAMES,1,-1
if (mat_eqid(G_VAR_IDS(1:,k),id)) exit
enddo
if (k .ne. G_TOP_OF_SAVED-1) then ! variable exists
lk = G_VAR_DATALOC(k)
mk = G_VAR_ROWS(k)
nk = G_VAR_COLS(k)
mnk = mk*nk
if (G_RHS .gt. 2) then
call mat_err(15) ! Improper assignment to submatrix
return
elseif (G_RHS .ne. 0) then
mt = mk
nt = nk
lt = location + mn
if(too_much_memory( lt + mnk - G_VAR_DATALOC(G_TOP_OF_SAVED) ) )then
return
endif
call mat_wcopy(mnk,GM_REALS(lk),GM_IMAGS(lk),1,GM_REALS(lt),GM_IMAGS(lt),1)
endif
! does it fit
if (G_RHS.eq.0 .and. mn.eq.mnk) then ! size of existing array did not change
goto 40
endif
if (k .ge. GG_MAX_NUMBER_OF_NAMES-3) then
call mat_err(13) ! Improper assignment to PERMANENT VARIABLE
return
endif
if (k .ne. G_TOP_OF_SAVED) then
! shift storage
ls = G_VAR_DATALOC(G_TOP_OF_SAVED)
ll = ls + mnk
call mat_wcopy(lk-ls,GM_REALS(ls),GM_IMAGS(ls),-1,GM_REALS(ll),GM_IMAGS(ll),-1)
km1 = k-1
do ib = G_TOP_OF_SAVED, km1
i = G_TOP_OF_SAVED+km1-ib
call mat_copyid(G_VAR_IDS(1,i+1),G_VAR_IDS(1,i))
G_VAR_ROWS(i+1) = G_VAR_ROWS(i)
G_VAR_COLS(i+1) = G_VAR_COLS(i)
G_VAR_DATALOC(i+1) = G_VAR_DATALOC(i)+mnk
enddo
endif
! destroy old variable
G_TOP_OF_SAVED = G_TOP_OF_SAVED+1
endif
!
! create new variable
if (mn .eq. 0) then
goto 99
endif
if (G_TOP_OF_SAVED-2 .le. G_ARGUMENT_POINTER) then
call mat_err(18) ! Too many names
return
endif
k = G_TOP_OF_SAVED-1
call mat_copyid(G_VAR_IDS(1,k), id)
if (G_RHS .eq. 1) then
! vect(arg)
if (G_VAR_ROWS(G_ARGUMENT_POINTER-1) .lt. 0) then
goto 59
endif
mn1 = 1
mn2 = 1
l1 = 0
l2 = 0
if (n.ne.1 .or. nk.ne.1) then
if (m.ne.1 .or. mk.ne.1) then
call mat_err(15) ! Improper assignment to submatrix
return
endif
l2 = G_VAR_DATALOC(G_ARGUMENT_POINTER-1)
m2 = G_VAR_ROWS(G_ARGUMENT_POINTER-1)
mn2 = m2*G_VAR_COLS(G_ARGUMENT_POINTER-1)
m1 = -1
goto 60
endif
l1 = G_VAR_DATALOC(G_ARGUMENT_POINTER-1)
m1 = G_VAR_ROWS(G_ARGUMENT_POINTER-1)
mn1 = m1*G_VAR_COLS(G_ARGUMENT_POINTER-1)
m2 = -1
goto 60
elseif (G_RHS .eq. 2)then
! matrix(arg,arg)
if (G_VAR_ROWS(G_ARGUMENT_POINTER-1).lt.0 .and. G_VAR_ROWS(G_ARGUMENT_POINTER-2).lt.0) then
goto 59
endif
l2 = G_VAR_DATALOC(G_ARGUMENT_POINTER-1)
m2 = G_VAR_ROWS(G_ARGUMENT_POINTER-1)
mn2 = m2*G_VAR_COLS(G_ARGUMENT_POINTER-1)
if (m2 .lt. 0) mn2 = n
l1 = G_VAR_DATALOC(G_ARGUMENT_POINTER-2)
m1 = G_VAR_ROWS(G_ARGUMENT_POINTER-2)
mn1 = m1*G_VAR_COLS(G_ARGUMENT_POINTER-2)
if (m1 .lt. 0) mn1 = m
goto 60
endif
!
! STORE
40 continue
if (k .lt. GG_MAX_NUMBER_OF_NAMES) G_VAR_DATALOC(k) = G_VAR_DATALOC(k+1) - mn
G_VAR_ROWS(k) = m
G_VAR_COLS(k) = n
lk = G_VAR_DATALOC(k)
call mat_wcopy(mn,GM_REALS(location),GM_IMAGS(location),-1,GM_REALS(lk),GM_IMAGS(lk),-1)
goto 90
!===================================================================================================================================
59 continue
if (mn .ne. mnk) then
call mat_err(15) ! Improper assignment to submatrix
return
endif
lk = G_VAR_DATALOC(k)
call mat_wcopy(mn,GM_REALS(location),GM_IMAGS(location),-1,GM_REALS(lk),GM_IMAGS(lk),-1)
goto 90
!===================================================================================================================================
60 continue
if (mn1.ne.m .or. mn2.ne.n) then
call mat_err(15) ! Improper assignment to submatrix
return
endif
ll = 1
if (m1 .ge. 0) then
do i = 1, mn1
ls = l1+i-1
mk = max(mk,int(GM_REALS(ls)))
ll = min(ll,int(GM_REALS(ls)))
enddo
endif
mk = max(mk,m)
if (m2 .ge. 0) then
do i = 1, mn2
ls = l2+i-1
nk = max(nk,int(GM_REALS(ls)))
ll = min(ll,int(GM_REALS(ls)))
enddo
endif
nk = max(nk,n)
if (ll .lt. 1) then
call mat_err(21) ! Subscript out of range
return
endif
mnk = mk*nk
lk = G_VAR_DATALOC(k+1) - mnk
if(too_much_memory( lt + mt*nt - lk) )return
G_VAR_DATALOC(k) = lk
G_VAR_ROWS(k) = mk
G_VAR_COLS(k) = nk
call mat_wset(mnk,0.0d0,0.0d0,GM_REALS(lk),GM_IMAGS(lk),1)
if (nt .ge. 1) then
do j = 1, nt
ls = lt+(j-1)*mt
ll = lk+(j-1)*mk
call mat_wcopy(mt,GM_REALS(ls),GM_IMAGS(ls),-1,GM_REALS(ll),GM_IMAGS(ll),-1)
enddo
endif
do j = 1, n
do i = 1, m
li = l1+i-1
if (m1 .gt. 0) li = l1 + int(GM_REALS(li)) - 1
lj = l2+j-1
if (m2 .gt. 0) lj = l2 + int(GM_REALS(lj)) - 1
ll = lk+li-l1+(lj-l2)*mk
ls = location+i-1+(j-1)*m
GM_REALS(ll) = GM_REALS(ls)
GM_IMAGS(ll) = GM_IMAGS(ls)
enddo
enddo
goto 90
!===================================================================================================================================
! print if desired and pop stack
90 continue
if (G_SYM.ne.semi .and. G_LINECOUNT(3).eq.0) call mat_print(id,k) ! if not a semi-colon and "semi" mode print
if (G_SYM.eq.semi .and. G_LINECOUNT(3).eq.1) call mat_print(id,k) ! if a semi-colon and "semi" mode off print
if (k .eq. G_TOP_OF_SAVED-1) G_TOP_OF_SAVED = G_TOP_OF_SAVED-1
99 continue
if (m .eq. 0) then
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 1
else
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER - 1 - G_RHS
endif
end subroutine MAT_STACK_PUT