subroutine mat_stack_get(id)
! ident_29="@(#) M_matrix mat_stack_get(3fp) get variables from storage"
integer,intent(in) :: id(GG_MAX_NAME_LENGTH)
integer :: i
integer :: j
integer :: k
integer :: location
integer :: l2
integer :: l3
integer :: li
integer :: lj
integer :: current_location
integer :: ll
integer :: ls
integer :: m
integer :: mk
integer :: mn
integer :: mnk
integer :: n
call mat_copyid(G_VAR_IDS(1,G_TOP_OF_SAVED-1), ID) ! copy ID to next blank entry in G_VAR_IDS in case it is not there(?)
do k=GG_MAX_NUMBER_OF_NAMES,1,-1 ! start at bottom and search up through names till find the name
if (mat_eqid(G_VAR_IDS(1:,k), id))exit ! if found name exit loop
enddo
! if (?)
! or if matched the name inserted above did not find it.
if ( (k .ge. GG_MAX_NUMBER_OF_NAMES-1 .and. G_RHS .gt. 0) .or. (k .eq. G_TOP_OF_SAVED-1) ) then
G_FIN = 0
return
endif
current_location = G_VAR_DATALOC(K) ! found it, so this is the location where the data begins
IF (G_RHS .EQ. 1) then ! VECT(ARG)
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .EQ. 0) goto 99
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
MN = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
MNK = G_VAR_ROWS(K)*G_VAR_COLS(K) ! number of values in this variable
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .LT. 0) MN = MNK
DO I = 1, MN
LL = location+I-1
LS = current_location+I-1
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .GT. 0) LS = current_location + int(GM_REALS(LL)) - 1
IF (LS .LT. current_location .OR. LS .GE. current_location+MNK) then
call mat_err(21) ! Subscript out of range
return
endif
GM_REALS(LL) = GM_REALS(LS)
GM_IMAGS(LL) = GM_IMAGS(LS)
enddo
G_VAR_ROWS(G_ARGUMENT_POINTER) = 1
G_VAR_COLS(G_ARGUMENT_POINTER) = 1
IF (G_VAR_ROWS(K) .GT. 1) G_VAR_ROWS(G_ARGUMENT_POINTER) = MN
IF (G_VAR_ROWS(K) .EQ. 1) G_VAR_COLS(G_ARGUMENT_POINTER) = MN
goto 99
elseif (G_RHS .EQ. 2) then ! MATRIX(ARG,ARG)
G_ARGUMENT_POINTER = G_ARGUMENT_POINTER-1
location = G_VAR_DATALOC(G_ARGUMENT_POINTER)
IF (G_VAR_ROWS(G_ARGUMENT_POINTER+1) .EQ. 0) G_VAR_ROWS(G_ARGUMENT_POINTER) = 0
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .EQ. 0) goto 99
L2 = G_VAR_DATALOC(G_ARGUMENT_POINTER+1)
M = G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .LT. 0) M = G_VAR_ROWS(K)
N = G_VAR_ROWS(G_ARGUMENT_POINTER+1)*G_VAR_COLS(G_ARGUMENT_POINTER+1)
IF (G_VAR_ROWS(G_ARGUMENT_POINTER+1) .LT. 0) N = G_VAR_COLS(K)
L3 = L2 + N
MK = G_VAR_ROWS(K)
MNK = G_VAR_ROWS(K)*G_VAR_COLS(K)
DO J = 1, N
DO I = 1, M
LI = location+I-1
IF (G_VAR_ROWS(G_ARGUMENT_POINTER) .GT. 0) LI = location + int(GM_REALS(LI)) - 1
LJ = L2+J-1
IF (G_VAR_ROWS(G_ARGUMENT_POINTER+1) .GT. 0) LJ = L2 + int(GM_REALS(LJ)) - 1
LS = current_location + LI-location + (LJ-L2)*MK
IF (LS.LT.current_location .OR. LS.GE.current_location+MNK) then
call mat_err(21)
return
endif
LL = L3 + I-1 + (J-1)*M
GM_REALS(LL) = GM_REALS(LS)
GM_IMAGS(LL) = GM_IMAGS(LS)
enddo
enddo
MN = M*N
call mat_wcopy(MN,GM_REALS(L3),GM_IMAGS(L3),1,GM_REALS(location),GM_IMAGS(location),1)
G_VAR_ROWS(G_ARGUMENT_POINTER) = M
G_VAR_COLS(G_ARGUMENT_POINTER) = N
goto 99
elseif (G_RHS .GT. 2) then
call mat_err(21) ! Subscript out of range
return
else ! SCALAR
location = 1
IF (G_ARGUMENT_POINTER .GT. 0) &
& location = G_VAR_DATALOC(G_ARGUMENT_POINTER) + &
& G_VAR_ROWS(G_ARGUMENT_POINTER)*G_VAR_COLS(G_ARGUMENT_POINTER)
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
! LOAD VARIABLE TO TOP OF STACK
G_VAR_DATALOC(G_ARGUMENT_POINTER) = location
G_VAR_ROWS(G_ARGUMENT_POINTER) = G_VAR_ROWS(K)
G_VAR_COLS(G_ARGUMENT_POINTER) = G_VAR_COLS(K)
MN = G_VAR_ROWS(K)*G_VAR_COLS(K)
if(too_much_memory( location+MN - G_VAR_DATALOC(G_TOP_OF_SAVED) ) )return
! IF RAND, MATFN6 GENERATES RANDOM NUMBER
IF (K .EQ. GG_MAX_NUMBER_OF_NAMES) then
G_FIN = 7
G_FUN = 6
return
endif
call mat_wcopy(MN,GM_REALS(current_location), &
& GM_IMAGS(current_location), &
& 1, &
& GM_REALS(location), &
& GM_IMAGS(location), &
& 1)
endif
99 continue
G_FIN = -1
G_FUN = 0
END SUBROUTINE MAT_STACK_GET