* * $Id: siopr2.F,v 1.1.1.1 1995/12/12 14:36:19 mclareni Exp $ * * $Log: siopr2.F,v $ * Revision 1.1.1.1 1995/12/12 14:36:19 mclareni * Imported sources * * #include "sigma/pilot.h" *CMZ : 1.10/03 10/02/94 17.17.05 by Carlo E. Vandoni *-- Author : SUBROUTINE SIOPR2 C C C C .................................................... C C C PURPOSE C STEERING OF OP2, TO PROCESS OPERATIONSOF TWO ARGUMENTS C C USAGE C CALL OPER2 C C COMM. BLOCKS USED C COM1 C COMVAR USED: DYNA(),IADDR,KLASS,LENGTH,MODE,NDIM C C REMARKS C KLASS CODES USED: 13, 19, 21, 204, 205 C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SINERR C IGETT2 C SISTAK C NGET AND ENTRY NGET2 C OP2 C OP2COM C SISTR2 C TRACE C SIUSTK C C... PAW VERSION ... MAY 1988 C C ...................................................... C #include "sigma/sigc.inc" #include "sigma/pawc.inc" #include "sigma/siclin.inc" C 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)) DIMENSION FNCO(10,3),IDOPE(11,3) C DIMENSION IAD(3),JMIP(3) EQUIVALENCE(IAD(1),IZAD(1),IADA),(IADB,IZADB),(JMIP(1),IMODA,IZMOD ,(1)),(IMODB,IZMODB) C C C C C IN C=A&B, A IS K=1, B IS K=2, C IS K=3 C ICONCT=1 C CONCATENATION AND LEFT SHIFT (LS) WORK ON WHOLE ROWS IF(KLASS.EQ.19.OR.KLASS.EQ.205) ICONCT=2 C C MISSING INDEX MEANINGLESS (POSSIBLE IN SYSFU OF 2 ARGUMENTS) CALL SISTAK(0,MP,MN) IF(MN.EQ.888) CALL SINERR(18) IF(IERRNO.NE.0)RETURN C--- MASK3 IN MSTACK NOW MSTACK(2,)=888 --- FNCO(1,2)=1.0 CALL SINGET(ISI,0,FNCO(1,2)) IF(IERRNO.NE.0)RETURN IF(ISI.GE.3) GO TO 965 C IF ITEM ON STACK IS NOT AN ARRAY IDIMB=NDIM IMODB=MODE IADB=IADDR-IMODB LA1=IADB IADBSV=IADB C C MISSING INDEX MEANINGLESS (POSSIBLE IN SYSFU OF 2 ARGUMENTS) CALL SISTAK(1,MP,MN) IF(MN.EQ.888) CALL SINERR(18) IF(IERRNO.NE.0)RETURN FNCO(1,1)=1.0 CALL SINGET(ISI,1,FNCO(1,1)) IF(IERRNO.NE.0)RETURN IF(ISI.GE.3) GO TO 965 C IF ITEM ON STACK IS NOT AN ARRAY IDIMA=NDIM IMODA=MODE IADA=IADDR-IMODA LA2=IADA IADASV=IADA C C C C MAKE NCO OF RESULT IN FNCO( ,3) C NDIM=MAX0(IDIMA,IDIMB) FNCO(1,3)=FNCO(1,2)+FNCO(1,1) C IF(KLASS.NE.205) GOTO 10 C IF LS, RESULT ROW-LENGTH IS SET BY ARG1 FNCO(1,3)=FNCO(1,1) IF(FNCO(1,2).NE.1.) CALL SINERR(77) IF(IERRNO.NE.0)RETURN C 10 CONTINUE C START THIS LOOP AT 2 FOR & AND AT 1 FOR ANY OTHER CALL C IF ICONCT=1,ABOVE SET OF FNCO(1,3) IS CORRECTLY OVERWRITTEN C DO 20 I=ICONCT,NDIM IF(FNCO(I,2).EQ.FNCO(I,1).OR.(FNCO(I,2).EQ.1.).OR.FNCO(I,1).EQ.1.) 1 GOTO 25 C IF INCOMPATIBLE ARGUMENTS CALL SINERR(69) IF(IERRNO.NE.0)RETURN 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 MAKE ALL THREE DOPE VECTORS C C MODE IS EQUIVALENCED TO JMIP(3) MODE=1 IF((IMODA+IMODB).GT.2) MODE=2 C IF AT LEAST ONE ARG CPLX,ANSWER IS CPLX C C FORCE MODE=1 FOR RELATIONALS AND LOGICALS TO HANDLE THEM IN OP2 ONLY C BUT DO NOT FORCE MODE ON CONCATENATION IF(KLASS.GE.13.AND.KLASS.LE.21.AND.KLASS.NE.19) MODE=1 C CPLX MAY HAVE TWO REAL ARGS HENCE FORCE MODE TO TWO (SEE SYSFUN) IF(KLASS.EQ.204) MODE=2 C C 26 CONTINUE C IF NOT AN USUCCESSFUL RETURN FROM BELOW IF(IZADA.GT.0) GOTO 28 C C SOME OPERAND DEMANDS A COMPLEX RESULT IZADA=IADASV IZADB=IADBSV C IF NOT A ONECOMP ARRAY WITHOUT STACK ENTRY IF(LENGTH.NE.MODE) CALL SIUSTK MODE=2 C C 28 CONTINUE 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) IF(SITRAK(3).EQ.1)PRINT *,' LEN IN SIOPR2 ',LENGTH C CALL SIGTT2(IADDR,LENGTH,NDIM,FNCO(1,3)) IF(IERRNO.NE.0)RETURN IADDR=IADDR-MODE IADB=LA1 IADA=LA2 C C CONCATENATE ROWS BUT OPER2 ON SINGLE ARRAY ELEMENTS C M3=MODE IF(ICONCT.EQ.2) M3=IFIX(FNCO(1,3))*MODE C IF CONCATENATION,HANDLE A WHOLE ROW AT A TIME CA=0. CB=0. C SET IMAGINARY PARTS FOR COP2 IN CASE REAL-CPLX OR CPLX-REAL ARGS C C C MAIN LOOP FOR GENERALIZED ARRAY ARITHMETIC C DO 50 IPC=M3,LENGTH,M3 I=ICONCT IF(ICONCT.NE.2) GOTO 300 C IF LS LS LS LS LS IF(KLASS.EQ.205) GOTO 260 C C CONCATENATION OF ROWS OF TWO ARRAYS C DO 150 K=1,2 M2=IFIX(FNCO(1,K)) C DO 251 J=1,M2 IADDR=IADDR+MODE IAD(K)=IAD(K)+JMIP(K) DYNA(IADDR)=DYNA(IAD(K)) IF(MODE.EQ.1) GOTO 250 C IF REAL ANSWER, ARGS MUST BE REAL-REAL IMADR=IADDR+1 IF(JMIP(K).GT.1)GOTO 256 C IF ARG REAL,CONCAT ZERO IMAG PART,ELSE CONCAT ACTUAL IMAG PART C C 254 DYNA(IMADR)=0. GOTO 250 C C 256 DYNA(IMADR)=DYNA(IAD(K)+1) 250 CONTINUE 251 CONTINUE C 150 CONTINUE C C GOTO 55 C C 260 CONTINUE C LS C LS C LS IGNORES THE IMAGINARY PART OF THE SECOND ARGUMENT NSHIFT=IFIX(SIROUN(DYNA(IADB+IMODB)))*MODE LENROW=IFIX(FNCO(1,1))*MODE NSHIFT=MOD(NSHIFT,LENROW) IF(NSHIFT.LT.0) NSHIFT=NSHIFT+LENROW C C DO 265 J=MODE,LENROW,MODE DYNA(IADDR+J)=DYNA(IADA+IMODA+NSHIFT) IF(MODE.EQ.2)DYNA(IADDR+1+J)=DYNA(IADA+IMODA+1+NSHIFT) NSHIFT=MOD(NSHIFT+MODE,LENROW) 265 CONTINUE C C IADDR=IADDR+LENROW IADA=IADA+LENROW IADB=IADB+IMODB C C GOTO 55 C C 300 CONTINUE C C OPER2 REAL-REAL PROCESSING C IADDR=IADDR+MODE IADA=IADA+IMODA IADB=IADB+IMODB * PRINT *,'IADA ETC.',IADA,IMODA,IADB,IMODB RA=DYNA(IADA) RB=DYNA(IADB) IF(MODE.EQ.1) CALL SIGOP2(DYNA(IADA),DYNA(IADB),DYNA(IADDR)) IF(IERRNO.NE.0) RETURN IF(MODE.EQ.2) CALL SIOP2C IF(IZADA.LT.0) GOTO 26 C C 55 CONTINUE IF(MOD(IPC,IDOPE(I+1,3)).NE.0) GOTO 57 C CHECK WHICH SUBSTRUCTURE IS COMPLETED I=I+1 IF(IPC.LT.LENGTH) GOTO 55 57 CONTINUE C DO 157 K=1,2 IF(FNCO(I,K).EQ.1.) IAD(K)=IAD(K)-IDOPE(I,K) C REPEAT A SUBSTRUCTURE IF NECESSARY 157 CONTINUE C 50 CONTINUE C C CALL SISTR2(2) RETURN C 965 CALL SINERR(65) C C 999 END