*
* $Id: sisysf.F,v 1.1.1.1 1995/12/12 14:36:20 mclareni Exp $
*
* $Log: sisysf.F,v $
* Revision 1.1.1.1  1995/12/12 14:36:20  mclareni
* Imported sources
*
*
#include "sigma/pilot.h"
*CMZ :  1.09/02 06/08/93  16.52.58  by  Carlo E. Vandoni
*-- Author :
      SUBROUTINE SISYSF
C    ....................................................
C
C
C         PURPOSE
C            HANDLING OF SYSTEM FUNCTION CODES
C
C         USAGE
C            CALL SYSFUN
C
C         COMM. BLOCKS USED
C            COM1
C            COMVAR USED: DYNA(),IADDR,ISTRI,ITAM,IZADA,IZMODA,
C                         KLASS,LENGTH,MISIDX,MODE,NDIM
C
C         SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C            TRACE
C            SINERR
C            BOO
C            IGETT2
C            SILSTK
C            SISTAK
C            NGET
C            OPER2
C            SIROU
C            SISTR2
C            SIUSTK
C
C...  PAW VERSION  ...  MAY 1988
C    ......................................................
C
C        INTERNAL CODES FOR SYSTEM FUNCTIONS
C        ***********************************
C
C
C    SYSTEM FUNCTIONS WITH ONE ARGUMENT
C   -----------------------------------------------
C
C 001    SIN
C
C 002    COS
C
C 003    SQRT
C
C 004    EXP
C
C 005    LOG
C
C 006    ATAN
C
C 007    ABS                 RESULT ALWAYS REAL
C
C 008    INT
C
C 009    LOG10
C
C 010    TANH
C
C
C 045    NOT       COMPILED DIFFERENTLY  SEE SIFAM0
C
C
C
C ------------------------------------------------
C 101    DBLE
C
C 102    SNGL      RESULT ALWAYS MODE=1 AS DOEBLE PREC. CPLX NOT POSSIBL
C
C 103    CONJ
C
C 104    REAL                RESULT ALWAYS REAL
C
C 105    IMAG                RESULT ALWAYS REAL
C
C 106    STRING              RESULT ALWAYS REAL AND ISTRI=1
C
C 107    NUMBER              RESETS ISTRI, LEAVES MODE UNCHANGED
C
C      SYSTEM FUNCTIONS WITH 2  ARGUMENTS
C   -----------------------------------------------
C
C 201    MOD
C
C 202    ATAN2
C
C 203    SIGN
C
C 204    CPLX
C
C 205    LS
C
C      SYSTEM FUNCTIONS WORKING ON THE ENTIRE VECTOR AT ONCE
C   -----------------------------------------------
C
C 301    MAX
C
C 302    MIN
C
C 303    DIFF
C
C 304    DEL
C
C 305    SUM
C
C 306    PROD
C
C
C ------------------------------------------------
C 401    SMAX
C
C 402    SMIN
C
C 403    ANY
C
C
C -------------------------------------------------
C 501    NCO
C
C
C     FOLLWING CODES ARE CALLED BY SISYSO
C --------------------------------------------------
C
C 608    EIGVAL
C
C 609    EIGVEC
C
C 601    INV
C
C 602    DET
C
C 603    MULT
C
C 604    TP
C
C 605    TRACE
C
C 606    DROP
C
C 607    DIAG
C
C 610    PROJ
C
C 611    ORDER
C
C 612    SUMN
C
C 613    QUAD
C
C 614    EVAL
C
C 615    WHIT
C
C 616    BESCJ
C
C 617    CONT
C
C...PAW VERSION
C
C.................................................
#include "sigma/sicsig.inc"
#include "sigma/sigc.inc"
#include "sigma/pawc.inc"
#include "sigma/siclin.inc"
C
C
      DIMENSION RCA(2),RCB(2),RCX(2)
      EQUIVALENCE(CPLA,RCA(1)),(CPLB,RCB(1)),(CPLX,RCX(1))
      EQUIVALENCE(RA,RCA(1)),(CA,RCA(2)),(RB,RCB(1)),(CB,RCB(2))
     ,,(RX,RCX(1)),(CX,RCX(2))
C
      DIMENSION DIM(10)
C
C
C
C   SELECT TWO OPERAND SYSFUNS  MOD ATAN2 SIGN CPLX LS (DONE VIA OPER2)
      IF(KLASS.LT.201.OR.KLASS.GT.209) GOTO 111
      CALL SIOPR2
      RETURN
C
111   CONTINUE
C     MISSING INDEX IS MEANINGLESS
      CALL SISTAK(0,MP,MN)
      IF(MN.EQ.MISIDX) CALL SINERR(18)
      IF(IERRNO.NE.0)RETURN

C   LOOK UP THE SINGLE ARGUMENT OF THE SYSFUN,ERROR IF NOT NUMERICAL
      DIM(1)=1.0
      CALL SINGET(ISI,0,DIM)
      IF(IERRNO.NE.0)RETURN
      IF(ISI.GE.3)CALL SINERR(45)
      IF(IERRNO.NE.0)RETURN

      LA2=IADDR
      IZMODA=MODE
      IMODEF=MODE
      LA4=LA2+LENGTH-1
C
C   SELECT SYSFUNS WITH SCALAR RESULT  SMAX SMIN ANY
      IF(KLASS.LT.401.OR.KLASS.GT.406) GOTO 22
      X=DYNA(LA2)
      IXM=LA2
      IF(KLASS.EQ.403) X=0.
      IF(KLASS.EQ.406) X=0.
C
      DO 4000 I=LA2,LA4,IZMODA
      IF(KLASS.EQ.406)  X=X+DYNA(I)
      IF(KLASS.EQ.406) GOTO 4000
      IF(KLASS.NE.403)GOTO 401
C   ANY
C   ANY  ALWAYS HAS A REAL RESULT
C   IGNORE IMAGINARY PART
      IF(SIBOOL(DYNA(I)).EQ.1) X=1.
      GOTO 4000
C
401   CONTINUE
C   SMAX
C   SMIN
C   EXTREMA IGNORE IMAGINARY PARTS AND PRODUCE REAL RESULTS
      IF(KLASS.EQ.401.AND.DYNA(I).LE.X) GOTO 4000
      IF(KLASS.EQ.402.AND.DYNA(I).GE.X) GOTO 4000
      IF(KLASS.EQ.404.AND.DYNA(I).LE.X) GOTO 4000
      IF(KLASS.EQ.405.AND.DYNA(I).GE.X) GOTO 4000
      X=DYNA(I)
      IXM=I
C
4000  CONTINUE
      IF(KLASS.EQ.404.OR.KLASS.EQ.405)X=FLOAT((IXM-LA2)+1)
      CALL SIUSTK
      DIM(1)=1.0
      CALL SIGTT2(INDEX,1,1,DIM)
      IF(IERRNO.NE.0)RETURN
      DYNA(INDEX)=X
      RETURN
C
22    CONTINUE
C   IF NOT NCO
      IF(KLASS.NE.501) GOTO 33
C   NCO
      MODE=1
      ISTRI=0
      CALL SIGTT2(LA3,NDIM,1,FLOAT(NDIM))
      IF(IERRNO.NE.0)RETURN
C
      DO 5000 I=1,NDIM
C
C      DYNA(LA3)=DIM(NDIM-I+1)
C
      DYNA(LA3)=DIM(I)
      LA3=LA3+1
5000  CONTINUE
      GOTO 888
C
 33   CONTINUE
C   IF REAL, SKIP LONG TEST
      IF(MODE.EQ.1) GOTO 44
C
C   CHANGE MODE TO REAL FOR  ABS  NOT  SNGL  REAL  IMAG  MAX  MIN  DEL
C   STRING
      IF(KLASS.EQ.7.OR.KLASS.EQ.37.OR.KLASS.EQ.102
     ,      .OR.KLASS.EQ.104.OR.KLASS.EQ.105.OR.KLASS.EQ.301
     ,            .OR.KLASS.EQ.302.OR.KLASS.EQ.304.OR.KLASS.EQ.1
     ,06)MODE=1
      LENGTH=LENGTH/IZMODA*MODE
C
44    CONTINUE
C   GET AN AREA FOR THE RESULT
C   FOR STRING SET ISTRI=1, ELSE RESET IT
      ISTRI=0
      IF(KLASS.EQ.106) ISTRI=1
        CALL SIGTT2(LA3,LENGTH,NDIM,DIM)
      IF(IERRNO.NE.0)RETURN
C
C
C   IF NOT A LOGICAL NOT
      IF(KLASS.NE.37) GOTO 555
C   NOT
C   NOT
C   IGNORE THE IMAGINARY PART
      DO 45 I=LA2,LA4,IZMODA
      DYNA(LA3)=0.
      IF(SIBOOL(DYNA(I)).EQ.0) DYNA(LA3)=1.
      LA3=LA3+1
45    CONTINUE
C
      GOTO 888
C
C
555   CONTINUE
C    THIS MOD TO FIX
C               CPLX ABS
C
      IF(KLASS.NE.7)GO TO 55556
C
C     IF REAL,SKIP   TO REAL ABS
C
      IF(IZMODA.EQ.1) GO TO 55556
      DO 55557 I=LA2,LA4,IZMODA
      DYNA(LA3)=SQRT(DYNA(I)*DYNA(I)+DYNA(I+1)*DYNA(I+1))
      LA3=LA3+1
55557 CONTINUE
      GO TO 888
55556 CONTINUE
C   SELECT OP1 TYPE FNS, SIN COS SQRT EXP LOG ATAN ABS INT LOG10 TANH
      IF(KLASS.LT.1.OR.KLASS.GT.10) GOTO 66666
C
C   OP1
C   OP1COM
C   USE IZMODB AS A SWITCH TO SIGNAL THE NEED FOR CPLX RESULT FROM OP1
      IZMODB=1
      CX=0.
      IADASV=LA2
C
      DO 10 I=1,LENGTH,MODE
*      PRINT*,'BEF CALL',DYNA(LA2),DYNA(LA2+1)
      IF(IMODEF.EQ.2) CALL SIOP1C
      IF(IMODEF.EQ.1) CALL SIGOP1(DYNA(LA2),DYNA(LA3))
C     IF REAL ARG DEMANDS COMPLEX RESULT, SET EFFECTIVE MODE TO 2
C     IZMODB WILL SWITCH ITSELF OFF BY IZMODB=1 ABOVE
      IF(IZMODB.EQ.1) GOTO 9
      IMODEF=2
      GOTO 12
C
 9    CONTINUE
      LA2=LA2+IZMODA
      LA3=LA3+MODE
10    CONTINUE
C
      GOTO 888
C
12    CONTINUE
C   GET A NEW, COMPLEX RESULT AND START AGAIN
      LA2=IADASV
C   IF NOT A ONECOMP-ARRAY, SIUSTK THE REAL RESULT
      IF(LENGTH.NE.MODE) CALL SIUSTK
      MODE=2
      LENGTH=LENGTH*2
      GOTO 44
C
C
66666 CONTINUE
C   SELECT MODE CONVERSION FUNCTIONS DBLE SNGL CONJ REAL IMAG
C   STRING NUMBER
      IF(KLASS.LT.101.OR.KLASS.GT.107) GOTO 77777
      KLASS=KLASS-100
      DO 1000 I=LA2,LA4,IZMODA
      GOTO(101,102,103,104,105,106,107),KLASS
C
101   CONTINUE
C   DBL
      CNAME='DBL     '
      CALL SINERR(7)
      IF(IERRNO.NE.0)RETURN
C
102   CONTINUE
C   SNGL
      CNAME='SNGL    '
      CALL SINERR(7)
      IF(IERRNO.NE.0)RETURN
C
103   CONTINUE
C   CONJ
C   CONJ  IS COMPLEX CONJUGATION
      DYNA(LA3)=DYNA(I)
      IF(IZMODA.EQ.2) DYNA(LA3+1)=-DYNA(I+1)
      GOTO 199
C
104   CONTINUE
C   REAL
C   REAL IS THE REAL PART OF A COMPLEX OR REAL ARG(RESULT ALWAYS REAL)
      DYNA(LA3)=DYNA(I)
      GOTO 199
C
105   CONTINUE
C   IMAG
C   IMAG IS THE IMAG PART OF A COMPLEX OR REAL ARG(RESULT ALWAYS REAL)
      DYNA(LA3)=0.
      IF(IZMODA.EQ.2) DYNA(LA3)=DYNA(I+1)
      GOTO 199
C
106   CONTINUE
C   STRING
C   STRING CONVERTS REAL PT OF ANY NUMBER INTO STRING CHARACTER
      DYNA(LA3)=AMOD(SIROUN(DYNA(I)),64.)
      IF(DYNA(LA3).LT.0.) DYNA(LA3)=DYNA(LA3)+64.
      GOTO 199
C
107   CONTINUE
C   NUMBER SETS ISTRI EQUAL TO ZERO FOR ANY ARRAY
      DYNA(LA3)=DYNA(I)
      IF(IZMODA.EQ.2) DYNA(LA3+1)=DYNA(I+1)
C
199   CONTINUE
C
      LA3=LA3+MODE
1000  CONTINUE
C
      GOTO 888
C
C
77777 CONTINUE
C   SELECT ARRAY FUNCTIONS  MAX MIN DIFF DEL SUM
C                           PROD
C   IF NOT ARRAY SYSFUN, IT MUST BE AN ILLEGAL SYSFUN CODE
      IF(KLASS.LT.301.OR.KLASS.GT.306) CALL SINERR(6)
      IF(IERRNO.NE.0)RETURN

      KLASS=KLASS-300
      LENROW=IFIX(DIM(1))
      NUMROW=LENGTH/LENROW/MODE
C
C
      DO 3000 I=1,NUMROW
      X=DYNA(LA2)
      DYNA(LA3)=X
      IF(MODE.EQ.2)DYNA(LA3+1)=DYNA(LA2+1)
C
      DO 3001 J=1,LENROW
      GOTO(301,302,303,304,305,306),KLASS
C
301   CONTINUE
C   MAX
C   MAX EXTREMA IGNORE IMAGINARY PARTS AND PRODUCE REAL RESULTS
      IF(DYNA(LA2).GT.X) X=DYNA(LA2)
      GOTO 399
C
302   CONTINUE
C   MIN
C   MIN EXTREMA IGNORE IMAGINARY PARTS AND PRODUCE REAL RESULTS
      IF(DYNA(LA2).LT.X) X=DYNA(LA2)
      GOTO 399
C
303   CONTINUE
C   DIFF
C   LEAVE OUT LAST POINT FOR EXTRAPOLATION
      IF(J.EQ.LENROW) GOTO 399
      DYNA(LA3)=DYNA(LA2+IZMODA)-DYNA(LA2)
      IF(MODE.EQ.2) DYNA(LA3+1)=DYNA(LA2+3)-DYNA(LA2+1)
      GOTO 399
C
304   CONTINUE
C   DEL
C   DEL IGNORES THE IMAGINARY PART AND PRODUCES A REAL RESULT
      DYNA(LA3)=0.
      IF(J.EQ.1.OR.J.EQ.LENROW) GOTO 399
      IF(((DYNA(LA2-IZMODA)+DYNA(LA2))*DYNA(LA2).LT.0.0)
     ,.OR.((DYNA(LA2)+DYNA(LA2+IZMODA))*DYNA(LA2).LE.0.))
     ,DYNA(LA3)=1.
      GOTO 399
C
305   CONTINUE
C   SUM
      IF(J.EQ.1) GOTO 399
      DYNA(LA3)=DYNA(LA3-MODE)+DYNA(LA2)
      IF(MODE.EQ.2)DYNA(LA3+1)=DYNA(LA3-1)+DYNA(LA2+1)
      GOTO 399
C
306   CONTINUE
C     PROD
C     PROD CALCULATES RUNNING PRODUCTS OF ROWS
      IF(J.EQ.1) GOTO 399
      IF(MODE.EQ.2) GOTO 3061
C
C     ARGUMENT IS A REAL ARRAY
      DYNA(LA3)=DYNA(LA3-MODE)*DYNA(LA2)
C     CHECK FOR INFINITY IN REAL CASE ONLY
      GOTO 399
C
3061  CONTINUE
C     ARGOMENT IS A COMPLEX ARRAY
      DYNA(LA3)=DYNA(LA3-2)*DYNA(LA2)-DYNA(LA3-1)*DYNA(LA2+1)
      DYNA(LA3+1)=
     ,DYNA(LA3-2)*DYNA(LA2+1)+DYNA(LA3-1)*DYNA(LA2)
C
C
399   CONTINUE
      LA2=LA2+IZMODA
      LA3=LA3+MODE
C
3001  CONTINUE
C
C
      GOTO(3010,3010,3030,3040,3000,3000),KLASS
C
3010  CONTINUE
C   MAX
C   MIN
      DO 3011 J=1,LENROW
      DYNA(LA3-J)=X
3011  CONTINUE
      GOTO 3000
C
3030  CONTINUE
C   DIFF
C   DIFF, EXTRAPOLATE AT THE END OF ROW, SET ZERO FOR ROW LEN. ONE
      IF(LENROW.EQ.1) GOTO 3035
      IF(LENROW.EQ.2) GOTO 3037
      DYNA(LA3-MODE)=2.*DYNA(LA3-2*MODE)-DYNA(LA3-3*MODE)
      IF(MODE.EQ.2)DYNA(LA3-1)=2.*DYNA(LA3-3)-DYNA(LA3-5)
      GOTO 3000
C
3035  CONTINUE
C   DIFF  ONE COMPONENT ROW DEFINED TO GIVE ZERO
      DYNA(LA3-MODE)=0.
      IF(MODE.EQ.2) DYNA(LA3-1)=0.
      GOTO 3000
C
3037  CONTINUE
C   DIFF  TWO COMPONENT ROW HAS ONLY ONE DIFF, HENCE LINEAR EXTRAPOL.
      DYNA(LA3-MODE)=DYNA(LA3-2*MODE)
      IF(MODE.EQ.2)DYNA(LA3-1)=DYNA(LA3-3)
      GOTO 3000
C
3040  CONTINUE
C   DEL
C   DEL EXTRAPOLATES LINEARLY AT BOTH ENDS OF THE ROW
      IF(LENROW.EQ.1) GOTO 3055
      J=LA2-LENROW*IZMODA
      IF((3*DYNA(J)-DYNA(J+IZMODA))*(DYNA(J)+DYNA(J+IZMODA)).LE.0.)
     ,DYNA(LA3-LENROW)=1.
      J=LA2-IZMODA
      IF((3*DYNA(J)-DYNA(J-IZMODA))*(DYNA(J)+DYNA(J-IZMODA)).LE.0.)
     ,DYNA(LA3-1)=1.
      GOTO 3000
C
3055  CONTINUE
C   DEL  ONE COMPONENT ROW GIVES ONE IF EQUAL TO ZERO
      IF(DYNA(LA2-IZMODA).EQ.0)DYNA(LA3-1)=1.
3000  CONTINUE
C
C
888   CONTINUE
C   LA3 HAS TO POINT AT REAL PART OF ONE COMP. ARRAY(SEE STORE&NGET)
      LA3=LA3-MODE
      CALL SISTR2(1)
 999  END