*
* $Id: siprit.F,v 1.1.1.1 1995/12/12 14:36:20 mclareni Exp $
*
* $Log: siprit.F,v $
* Revision 1.1.1.1  1995/12/12 14:36:20  mclareni
* Imported sources
*
*
#include "sigma/pilot.h"
*CMZ :  1.09/00 22/07/93  11.45.55  by  Carlo E. Vandoni
*-- Author :
      SUBROUTINE SIPRIT (KIK,KISTRI)
C
C
C    ..................................................
C
C
C         PURPOSE
C            TO PRINT OUT ANY NUMERICAL QUANTITY OR PROGRAM
C
C         USAGE
C            CALL PRIT(KIT)
C
C         DESCRIPTION OF PARAMETERS
C            KIK= STACK POSITION OF ITEM,STACKTOP AT 0 THEN 1,2...
C
C         COMM. BLOCKS USED
C            COM1
C
C         SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C            TRACE
C            SILSKK
C            SISTAK
C            NGET
C            PRA10
C
C         METHOD
C
C         AUTHOR.   JURIS REINFELDS      DATE 15/06/74
C
C
C    ..................................................
C
C
C
C
#include "sigma/sicsig.inc"
#include "sigma/sigc.inc"
#include "sigma/pawc.inc"
C
C
C
C   PRIT WILL WRITE OUT
C        THE SOURCE CODE OF PROGRAMS
C        THE VALUE OF NUMERICAL ITEMS
C
C   !LENGTH   CONTROLS THE LINE LENGTH OF STRING OR NUMBER ARRAY
C   !DIGITS   CONTROLS THE NUMBER OF SIGNIFICANT DIGITS PRINTED
C
      CHARACTER CDOLLA*1,CL*8,CSTRI1*22,CSTRI2*12
      CHARACTER CSTRI3*41,CS1*8,CS2*8,CS3*25
      EQUIVALENCE(CDOLLA,CL)
      DIMENSION DIM(10),IDIME(10)
C
      CALL SITRAC (' SIPRIT')
C
      NPRINT = 6
C     IF MISSING INDEX, PRINT BLANK LINE
      CALL SILSKK(KIK,INAME,CNAME)
      CL=CNAME
      CALL SISTAK(KIK,NIDX,NDIM)
      IF(SITRAK(40).EQ.1)PRINT 298,NIDX,MISIDX
  298  FORMAT(' SIPRIT NIDX, MISIDX  ',2I3)
      IF(NIDX.NE.MISIDX) GOTO 17
      WRITE(NPRINT,1029)
      GOTO 5000
C
   17 CONTINUE
C
C   IF SUBROUTINE,FUNCTION OR MACRO
      CALL SINGET(INGE,KIK,DIM)
      IF(IERRNO.NE.0)RETURN
      IF(INGE.EQ.3)GOTO 300
      IF(INGE.EQ.0)GOTO 4000
      IF(SITRAK(40).EQ.1)PRINT 299,ITYPE,DIM(1),DIM(2)
  299     FORMAT(' SIPRIT ITYPE DIM(1+2)',I4,2F4.0)
      IF(ITYPE.EQ.4.OR.ITYPE.EQ.7) GOTO 300
C   IF LIBRARY FUNCTION
      IF(ITYPE.EQ.5) CALL SINERR(44)
      IF(ITYPE.EQ.5) RETURN
C   IF NUMERICAL QUANTITY
      IF(ITYPE.EQ.2) GOTO 15
C   IF UNDEFINED NAME
      IF(ITYPE.EQ.17) GOTO 4000
C   NON-EXISTENT TYPE
      CALL SINERR(6)
      RETURN
C
C
   15 CONTINUE
C
C   PROCESS ARRAY PARAMETERS
C
      L=IADDR-1
      IDIM1=DIM(1)
      IDIM2=DIM(2)
      IF (NDIM.EQ.1) IDIM2=1
      IF(SITRAK(40).EQ.1)PRINT *,LENGTH,IDIM1,MODE
      NROWS=LENGTH/IDIM1/MODE
C        TOTAL NUMBER OF ROWS, CONPLEX ELEMENTS IN TWO WORDS
C   !DIGITS  IN I8DGT
C   !LENGTH  IN I8LEN
      ILINE=I8LEN
      ICPLX=I8DGT+7
      IFIELD=ICPLX*MODE
C   WRITE AT LEAST ONE ITEM PER LINE
      IF(ILINE.LT.IFIELD) ILINE=IFIELD
C   NUMBER OF ITEMS PER FULL LINE
      ITEM=ILINE/IFIELD
C
C
      IF(CDOLLA.EQ.'$'.OR.KISTRI.NE.0)GO TO 250
C IF WRITE FLAG ON OR STRING ARRAY OR
C        IF $ NAME THEN DO NOT WRITE NAME NOR NCO
C
C        FORMAT TO WRITE NCO(NAME)= WITHOUT GAPS E.G. (NAME   )
C
C
      CSTRI1='(5H NCO(,A8,2H)=,10I5)'
C
C      K=NDIM
C      DO 240 I=1,NDIM
C         IDIME(K)=DIM(I)
C         K=K-1
C  240 CONTINUE
      DO 240 I=1,NDIM
         IDIME(I)=DIM(I)
  240 CONTINUE


C
C        WRITE NCO OF ARRAY IN ONE LINE
      WRITE(NPRINT,CSTRI1)CNAME,(IDIME(I),I=1,NDIM)
C
C      WRITE(NPRINT,CSTRI1)CNAME,(IDIME(I),I=1,3)
C
  230 CONTINUE
C   WRITE LOCAL NAME OF ARRAY
C   IF ONE LINE ONLY AND IF NOT A STRING,SKIP THIS TO WRITE NAME LATER
C   AND IF ARRAY IS ONE-DIMENSIONAL
      IF(LENGTH.LT.ITEM*MODE.AND.KISTRI.NE.1.AND.NDIM.EQ.1) GOTO 250
      CSTRI2='(1H ,A8,1H=)'
      WRITE(NPRINT,CSTRI2)CNAME
C
  250 CONTINUE
C
C        LOOP TO WRITE ARRAY COMPONENTS ROW BY ROW,MATRIX BY MATRIX
      CS1='((1X'
      CS2='    '
C
      IF(KISTRI.EQ.1)GOTO 255
C        IF STRING ARRAY SKIP DIGITS PART
C
      IF(MODE.EQ.2)GOTO 252
C        IF COMPLEX ARRAY
C
C        VARIABLE FORMAT FOR REAL ARRAY
C
      WRITE(CS3,1025)ITEM,IFIELD,I8DGT
 1025 FORMAT(',',I3,'G',I2,'.',I2,'))')
      GOTO 270
C
  252 CONTINUE
C
C        VARIABLE FORMAT FOR COMPLEX ARRAY
C
      WRITE(CS3,1023)ITEM,ICPLX,I8DGT,ICPLX,I8DGT
 1023 FORMAT(',',I3,'(G',I2,'.',I2,',1HI,G',I2,'.',I2,')))')
      GOTO 270
C
  255 CONTINUE
C
c20 august
C        VARIABLE FORMAT FOR COMPLEX ARRAY
C
      WRITE(CS3,1024)ILINE
1024  FORMAT(',',I3,'A1))')
C
  270 CONTINUE
C
C
C   IF OUTPUT TAKES MORE THAN ONE LINE OR IS A DOLLAR NAME OR STRING
C   OR IF OUTPUT IS MORE THAN ONE-DIMENSIONAL
C   OR IF WRITE FLAG ON
      IF(LENGTH.GE.ITEM*MODE.OR.CDOLLA.EQ.'$'.OR.KISTRI.EQ.1.OR.
     + NDIM.GE.2)GO TO 271
      CS1='((1X,A8'
CCC      CS2='=   '
      CS2='    '
      L=L+LENGTH
      CSTRI3=CS1//CS2//CS3
      WRITE(NPRINT,CSTRI3)CNAME,(DYNA(J),J=IADDR,L)
      GOTO 5000
C
  271 CONTINUE
C
C        LOOP FOR ALL ROWS
C
      DO 275 I=1,IDIM2
C        LOOP FOR EACH MATRIX
         K=L+1
C        ADDRESS OF FIRST ELEMENT OF EACH ROW
         L=K+IDIM1*MODE-1
CDCC        ADDRESS OF LAST ELEMENT OF EACH ROW
C
C        WRITE ROW OF NUMERICAL ARRAY IN ONE OR MORE LINES
C
         CSTRI3=CS1//CS2//CS3
         WRITE(NPRINT,CSTRI3)(DYNA(J),J=K,L)
         IF(IDIM1.GT.ITEM)WRITE(NPRINT,1029)
C        WRITE A BLANK LINE AFTER EACH ROW WHICH FILLS
C        MORE THAN ONE LINE
 1029 FORMAT(1X)
  274    CONTINUE
  275 CONTINUE
C
C
      NROWS=NROWS-IDIM2
      IF(NDIM.NE.1)WRITE(NPRINT,1028)
C        WRITE TWO BLANK LINES AFTER EACH MATRIX BUT NOT AFTER VECTORS
 1028 FORMAT(//)
      IF(NROWS.GT.0) GOTO 271
C
      GOTO 5000
C
C        WRITE SOURCE CODE OF PROGRAM
C
  300 CONTINUE
 4000 CONTINUE
C      PRINT 1100,CNAME
C 1100 FORMAT(' *---------> ',A8,'  UNDEFINED')
C
 5000 CONTINUE
 999  END