subroutine mat_print(ID,K)
! ident_17="@(#) M_matrix mat_print(3fp) primary output routine"
integer :: id(GG_MAX_NAME_LENGTH)
integer :: k
character(len=81) :: message
character(len=80) :: form
character(len=1) :: ls_char
doubleprecision :: s
doubleprecision :: tr
doubleprecision :: ti
doubleprecision :: pr(12)
doubleprecision :: pi(12)
integer :: sig(12)
integer :: typ
integer :: f
integer :: location,m,n,mn
integer :: ks
integer :: i
integer :: ios
integer :: istep
integer :: j
integer :: j1
integer :: j2
integer :: j3
integer :: jinc
integer :: jm
integer :: ls
integer,save :: fno(11)= [11,12,21,22,23,24,31,32,33,34,-1]
integer,save :: fnl(11)= [12, 6, 8, 4, 6, 3, 4, 2, 3, 1, 1]
integer :: itype
! FORMAT NUMBERS AND LENGTHS
! G_FMT 1 2 3 4 5
! SHORT LONG SHORT E LONG E Z
! TYP 1 2 3
! INTEGER REAL COMPLEX
!.......................................................................
if (G_LINECOUNT(1) .lt. 0) goto 99
!.......................................................................
location = G_VAR_DATALOC(k)
m = G_VAR_ROWS(k)
n = G_VAR_COLS(k)
mn = m*n
typ = 1
s = 0.0d0
itype=-9999
do i = 1, mn
ls = location+i-1
tr = GM_REALS(ls)
ti = GM_IMAGS(ls)
s = dmax1(s,dabs(tr),dabs(ti))
if (mat_round(tr) .ne. tr) typ = max(2,typ)
if (ti .ne. 0.0d0) typ = 3
enddo
if (s .ne. 0.0d0) s = dlog10(s)
ks = int(s)
if (-2 .le. ks .and. ks .le. 1) ks = 0
if (ks .eq. 2 .and. G_FMT .eq. 1 .and. typ .eq. 2) ks = 0
f=0 ! initialize to bad value
if (typ .eq. 1 )then ! if output type is integer
if( ks .le. 2 )then
f = 1
else
f = 2
endif
endif
if (typ .eq. 1 .and. ks .gt. 9) typ = 2 !change type from integer to real
if (typ .eq. 2) f = G_FMT + 2 ! if type is real
if (typ .eq. 3) f = G_FMT + 6 ! if type is complex
if(f.eq.0)then
call journal('*mat_print* internal error - bad type')
goto 99
endif
if (mn.eq.1 .and. ks.ne.0 .and. G_FMT.lt.3 .and. typ.ne.1) f = f+2
if (G_FMT .eq. 5) f = 11
jinc = fnl(f)
f = fno(f)
s = 1.0d0
if (f.eq.21 .or. f.eq.22 .or. f.eq.31 .or. f.eq.32) s = 10.0D0**ks
ls = ((n-1)/jinc+1)*m + 2
!.......................................................................
IF (G_LINECOUNT(1) + LS .gt. G_LINECOUNT(2)) then
G_LINECOUNT(1) = 0
if(G_PROMPT)then
WRITE(message, "(' AT LEAST ',I5,' MORE LINES.',' ENTER BLANK LINE TO CONTINUE OUTPUT.')") LS
call journal(message)
READ(G_INPUT_LUN,'(a1)',END=19) LS_CHAR ! read response to pause from standard input
IF (LS_CHAR .EQ. ' ') goto 20 ! if blank or a return display the values
G_LINECOUNT(1) = -1
goto 99
else
LS_CHAR = ' '
goto 20
endif
19 continue
call mat_files(-G_INPUT_LUN,G_BUF)
endif
20 continue
!.......................................................................
call journal(' ')
call mat_print_id(ID,-1)
G_LINECOUNT(1) = G_LINECOUNT(1)+2
if (s .ne. 1.0d0)then
write(message,'('' '',1PD9.1," *")') s
call journal(message)
endif
do j1 = 1, n, jinc
j2 = min(n, j1+jinc-1)
if (n .gt. jinc)then
write(message,'('' COLUMNS'',I6,'' THRU'',I6)') j1,j2
call journal(message)
endif
do i = 1, m
jm = j2-j1+1
do j = 1, jm
ls = location+i-1+(j+j1-2)*m
pr(j) = GM_REALS(ls)/s
pi(j) = dabs(GM_IMAGS(ls)/s)
sig(j) = plus
if (GM_IMAGS(ls) .lt. 0.0d0) sig(j) = minus
enddo
select case(F)
case(11)
form='(1X,12F6.0)' ! integer
istep=12
itype= 777
case(12)
form='(1X,6F12.0)' ! integer
istep=6
itype= 777
case(21)
form='(1X,F9.4,7F10.4)' ! 8 numbers
istep=8
itype= 999
case(22)
form='(1X,F19.15,3F20.15)' ! 4 numbers
istep=4
itype= 999
case(23)
form='(1X,1P6D13.4)' ! 6 numbers
istep=6
itype= 999
case(24)
form='(1X,1P3D24.15)' ! 3 numbers
istep=3
itype= 999
case(31)
form='(1X,4(F9.4,1X,A1,F7.4,''i''))' ! 4x3
istep=12
itype= 888
case(32)
form='(1X,F19.15,A1,F18.15,''i'',F20.15,A1,F18.15,''i'')' ! 6
istep=6
itype= 888
case(33)
form='(1X,3(1PD13.4,1X,A1,1PD10.4,''i''))' ! 9
istep=9
itype= 888
case(34)
form='(1X,1PD24.15,1X,A1,1PD21.15,''i'')' ! 3
istep=3
itype= 888
case(-1)
call mat_formz(GM_REALS(ls),GM_IMAGS(ls))
istep=-1
itype=-1
case default
call journal('*internal error*')
goto 99
end select
! print data based on type
if(itype.gt.0)then
do j3=1,jm,istep
select case(itype)
case(777); write(message,form)(pr(j),j=j3,min(j3+istep-1,jm))
case(999); write(message,form)(pr(j),j=j3,min(j3+istep,jm))
case(888); write(message,form)(pr(j),sig(j),pi(j),j=j3,min(j3+istep-1,jm))
end select
call journal(message)
enddo
endif
G_LINECOUNT(1) = G_LINECOUNT(1)+1
enddo
enddo
99 continue
flush(unit=STDOUT,iostat=ios)
end subroutine mat_print