*
* $Id: simult.F,v 1.1.1.1 1995/12/12 14:36:18 mclareni Exp $
*
* $Log: simult.F,v $
* Revision 1.1.1.1  1995/12/12 14:36:18  mclareni
* Imported sources
*
*
#include "sigma/pilot.h"
*CMZ :  1.10/03 10/02/94  17.17.05  by  Carlo E. Vandoni
*-- Author :
      SUBROUTINE SIMULT
C
C
C
C   ....................................................................
C
C     PURPOSE
C        TO MULTIPLY REAL AND COMPLEX ARRAYS ACCORDING TO THEIR MODE
C
C     USAGE
C        CALL MULT
C
C         COMM. BLOCKS USED
C            COM1
C            COMVAR USED: IADDR,DYNA,ISTRI,NDIM,MODE,
C                          IMODA,IZMODA,IZMODB,IZMODC
C
C     REMARKS
C        Z=MULT(Y,X)
C        C=MULT(A,B)
C
C        THE MULTIPLICATION OF TWO THREE-DIMENSIONAL ARRAYS (OR MORE)
C        IS DONE MATRIX BY MATRIX
C
C        OTHERWISE THE PRINCIPE OF THE OPERATION IS UNCHANGED
C         SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C            TRACE
C            IGETT2
C            SISTR2
C
C
C     METHOD
C        MULTIPLY ROW BY ROW BOTH ARRAYS ACCORDING TO THEIR MODE
C
C        THEN PUT THE RESULT IN THE CORRESPONDING WORD OF ANSWER ARRAY
C
C        DO NOT CHANGE IAD(2) UNLESS WE ARE AT THE END OF A MATRIX
C        OF THE SECOND ARGUMENT
C
C
C     AUTHOR.  W. MAJOR                      DATE 08/08/1974
C
C
C...  PAW VERSION  ...  MAY 1988
C
C
C   ....................................................................
C
C
C
#include "sigma/sicsig.inc"
#include "sigma/sigc.inc"
#include "sigma/pawc.inc"
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))
      DIMENSION FNCO(10,3),IDOPE(11,3)
C
      DIMENSION IAD(3),JMIP(3)
      EQUIVALENCE(IAD,IZAD,IADA),(IADB,IZADB),(JMIP,IMODA,IZMOD
     ,),(IMODB,IZMODB)
C
C
      CALL SITRAC(' SIMULT    ')
C
C
C   IN C=MULT(A,B),A IS K=1,B IS K=2,C IS K=3
C
C   ICONCT DECIDES WHICH IS THE FIRST DIMENSION CONSIDERED
C   1 FOR ALL DIMENSIONS
C   2 FOR WHOLE ROWS ONLY
C   3 FOR WHOLE MATRICES ONLY AND SO ON
C
C
C   IF ITEM ON STACK IS NOT AN ARRAY
      CALL SINGET(ISI,0,FNCO(1,2))
      IF(IERRNO. NE.0)GO TO 999
      IF(ISI.GE.3) GOTO 9108
      IDIMB=NDIM
      IMODB=MODE
      IADB=IADDR-IMODB
      LA1=IADB
C   IF ITEM ON STACK IS NOT AN ARRAY
      FNCO(1,1)=1.0
      CALL SINGET(ISI,1,FNCO(1,1))
      IF(IERRNO.NE.0)GO TO 999
      IF(ISI.GE.3) GOTO 9108
      IDIMA=NDIM
      IMODA=MODE
      IADA=IADDR-IMODA
      LA2=IADA
C
C
C   MAKE NCO OF RESULT IN FNCO( ,3)
C
C   IF NO MATCH IN DIMENSIONS
      IF(FNCO(1,1).NE.FNCO(2,2)) GOTO 968
C   ELSE
      FNCO(1,3)=FNCO(1,2)
      FNCO(2,3)=FNCO(2,1)
      ICONCT=3
      NDIM=MAX0(IDIMA,IDIMB)
      DO 20 I=ICONCT,NDIM
C  INCOMPATIBLE NCO'S IN BINARY OPERATION
      IF((FNCO(I,2).EQ.FNCO(I,1)).OR.(FNCO(I,1).EQ.1.).OR.(FNCO(I,2).EQ.
     11.)) GOTO 25
      GOTO 968
C
25    CONTINUE
      FNCO(I,3)=AMAX1(FNCO(I,2),FNCO(I,1))
20    CONTINUE
C
      DO 24 I=NDIM,9
      FNCO(I+1,3)=1.
24    CONTINUE
C
C   MAKE ALL THREE DOPE VECTORS
C
C   MODE IS EQUIVALENCED TO JMIP(3)
      MODE=1
C   IF FIRST OR SECOND ARG IS COMPLEX,ANSWER IS COMPLEX
      IF((IZMODA.EQ.2).OR.(IZMODB.EQ.2)) MODE=2
      DO 30 K=1,3
      IDOPE(1,K)=JMIP(K)
C
      DO 130 J=1,10
      IDOPE(J+1,K)=IDOPE(J,K)*IFIX(FNCO(J,K))
130   CONTINUE
C
30    CONTINUE
C
      LENGTH=IDOPE(NDIM+1,3)
C
      ISTRI=0
C
       CALL SIGTT2(IADDR,LENGTH+NDIM,NDIM,FNCO(1,3))
       IADDR=IADDR-MODE
       IADA=LA2
       IADB=LA1
C
      ICONCT=3
      M3=IDOPE(3,3)
      II=MOD(IZMODA+1,2)
C
C   CALCULATE THE LENGTH OF ROWS IN EACH ARRAY
C
      IZMODC=MODE
      IROWA=IFIX(FNCO(1,1))*IZMODA
      IROWB=IFIX(FNCO(1,2))*IZMODB
      IROWC=IFIX(FNCO(1,3))*IZMODC
C
C   MAIN LOOP FOR GENERALIZED ARRAY ARITHMETIC
C
      DO 50 IPC=M3,LENGTH,M3
      I=ICONCT
C
      DO 55 IJ=IROWC,M3,IROWC
C
C   MULTIPLY ROW BY ROW ACCORDING TO THE MODE OF EACH ARRAY
C
      DO 150 KK=IZMODC,IROWC,IZMODC
      RMULT=0.
      RAUX=0.
      JJ=(KK/IZMODC)*IZMODB
C
      DO 250 J=IZMODA,IROWA,IZMODA
      RMULT1=DYNA(IAD(1)+J)*DYNA(IAD(2)+JJ)
C
C   IF BOTH ARGUMENTS IN MULT ARE REAL ARRAYS
C
      IF((IZMODA.EQ.1).AND.(IZMODB.EQ.1)) GOTO 2501
C
C   IF ONE OF THEM IS COMPLEX, MULTIPLY THE IMAGINARY PART
C
      RMULT2=DYNA(IAD(1)+J+II)*DYNA(IAD(2)+JJ+MOD(II+1,2))
      IF((IZMODA+IZMODB).EQ.3) GOTO 2502
C
C   IF BOTH ARGUMENTS ARE COMPLEX ARRAYS
C
      RMULT2=RMULT2+DYNA(IAD(1)+J+MOD(II+1,2))*DYNA(IAD(2)+JJ+II)
      RMULT1=RMULT1-DYNA(IAD(1)+J+1)*DYNA(IAD(2)+JJ+1)
2502  RAUX=RAUX+RMULT2
2501  RMULT=RMULT+RMULT1
      JJ=JJ+IROWB
250   CONTINUE
C
C   NOW GENERATE ROW OF ANSWER
C
      IF((IZMODA.EQ.1).AND.(IZMODB.EQ.1)) GOTO 1501
      DYNA(IAD(3)+KK+1)=RAUX
1501  DYNA(IAD(3)+KK)=RMULT
150   CONTINUE
C
C   NOW CALCULATE THE ADDRESS OF THE FIRST ELEMENT OF THE NEXT ROW
C   EXCEPTED FOR IAD(2) WHICH STAYS UNCHANGED
C
      IAD(1)=IAD(1)+IROWA
      IAD(3)=IAD(3)+IROWC
55    CONTINUE
C
      IAD(2)=IAD(2)+IDOPE(3,2)
C
56    CONTINUE
C   CHECK WHICH SUBSTRUCTURE IS COMPLETED
      IF(MOD(IPC,IDOPE(I+1,3)).NE.0) GOTO 57
      I=I+1
      IF(IPC.LT.LENGTH) GOTO 56
57    CONTINUE
C
      DO 157 K=1,3
C   REPEAT A SUBSTRUCTURE IF NECESSARY
      IF(FNCO(I,K).EQ.1.) IAD(K)=IAD(K)-IDOPE(I,K)
157   CONTINUE
C
50    CONTINUE
C
      IADDR=IADDR+MODE
C
      CALL SISTR2(2)
      GO TO 999
C
 968  CONTINUE
      CNAME='MULT    '
      CALL SINERR(68)
      GO TO 999
C
C   ONE ARGUMENT IN THE FUNCTION MULT IS A PROGRAM NAME
9108    CALL SINERR(58)
C
 999  END