*
* $Id: siorde.F,v 1.1.1.1 1995/12/12 14:36:19 mclareni Exp $
*
* $Log: siorde.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 SIORDE
C
C
C    ..................................................
C
C
C         PURPOSE
C            TO SORT FIRST ARGUMENT TOGETHER WITH SECOND ARGUMENT
C            SUCH THAT SECOND ARG APPEARS IN ASCENDING ORDER
C
C         USAGE
C            CALL ORDER
C
C         COMM. BLOCKS USED
C            COM1
C
C         REMARKS
C            TRACK 37 FOR GENERAL TRACKING
C            TRACK 38 TO WRITE EACH NUMBER TRANSFERED
C
C            SINGLE NUMBERS CANNOT BE SORTED
C            GENERALIZED ARITH. RULES APPLY TO THE ARGS
C
C         SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C            NGET
C            IGETT2
C            SISTR2
C
C         METHOD
C            Z=ORDER(Y,X)
C            C=ORDER(A,B)
C            SORTS EACH ROW INDEPENDENTLY
C            USE ONLY THE TWO ARGS AND THE RESULT AREA
C            SET ROW OF INDICES, 1 TO ROWLENGTH IN RESULT AREA
C            SWAP THE INDICES UNTIL THEY REPRESENT AN ASCENDING
C            SEQUENCE WHEN APPLIED TO THE SECOND ARG.
C
C            INDICES CORRESPONDING TO EQUAL ELEMENTS OF 2-ND ARG
C            ARE NOT SWAPPED
C
C         AUTHOR.   W. MAJOR             DATE 02/08/74
C
C
C...  PAW VERSION  ...  MAY 1988
C
C
C    ..................................................
C
C
#include "sigma/sicsig.inc"
#include "sigma/sigc.inc"
#include "sigma/siclin.inc"
#include "sigma/pawc.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
      CALL SITRAC(' SIORDE   ')
C
C
C   IN C=ORDER(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
      ICONCT=1
C
C   IF ITEM ON STACK IS NOT AN ARRAY
      FNCO(1,2)=1.0
      CALL SINGET(ISI,0,FNCO(1,2))
      IF(IERRNO.NE.0)RETURN
      IF(ISI.GE.3) GO TO 8999
C   A SINGLE NUMBER CANNOT BE SORTED
      IF(ITYPE.LE.1) CALL SINERR(78)
      IF(IERRNO.NE.0)RETURN
      IDIMB=NDIM
      IMODB=MODE
      IADB=IADDR-IMODB
C BUG FIX (MISSING LINK)
      LA2=IADB
C
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)RETURN
      IF(ISI.GE.3) GO TO 8999
C   A SINGLE NUMBER CANNOT BE SORTED
      IF(ITYPE.LE.1) CALL SINERR(78)
      IF(IERRNO.NE.0)RETURN
      IDIMA=NDIM
      IMODA=MODE
      IADA=IADDR-IMODA
      LA1=IADA
C
C
C
C   MAKE NCO OF RESULT IN FNCO( ,3)
C
      NDIM=MAX0(IDIMA,IDIMB)
      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
      CNAME='ORDER   '
      CALL SINERR(68)
      CONTINUE
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
      IF(SITRAK(37).EQ.1)WRITE(NPRINT,1024)((FNCO(I,J),I=1,10),J=1,3)
1024  FORMAT(' FNCO=',10F5.1)
C
C
C
C   MAKE ALL THREE DOPE VECTORS
C
C   MODE IS EQUIVALENCED TO JMIP(3)
      MODE=1
C   IF FIRST ARG IS COMPLEX,ANSWER IS COMPLEX
      IF(IMODA.EQ.2) MODE=2
C
      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
C
      IF(SITRAK(37).EQ.1)WRITE(NPRINT,1030)((IDOPE(I,J),I=1,11),J=1,3)
1030  FORMAT(' IDOPE=',11I5)
C
C
      LENGTH=IDOPE(NDIM+1,3)
C
C
       CALL SIGTT2(IADDR,LENGTH,NDIM,FNCO(1,3))
      IF(IERRNO.NE.0)RETURN
       IADDR=IADDR-MODE
C BUG FIX (CONT.)
       IADA=LA1
       IADB=LA2
C
C
C   HANDLE A WHOLE ROW AT A TIME FOR SORTING
C   SINGLE ELEMENT ROWS DISALLOWED ABOVE
      ICONCT=2
      M3=IFIX(FNCO(1,3))*MODE
      IZMODC=JMIP(3)
      M2=M3-IZMODC
C
C
C   MAIN LOOP FOR GENERALIZED ARRAY ARITHMETIC
C
      DO 50 IPC=M3,LENGTH,M3
      I=ICONCT
      IROW=M3
C
C    GENERATE ROW OF SUCCESSIVE INTEGERS FROM 1 TO M3 IN ANSWER
C
      DO 150 J=IZMODC,M3,IZMODC
      IDYNA(IAD(3)+J)=(J*IZMODB)/IZMODC
150   CONTINUE
C
C
      IF(SITRAK(37).NE.1)GOTO 1520
      WRITE(NPRINT,1150) IAD(3),IROW
1150  FORMAT(' IAD(3)',I5,' IROW ',I5)
C
C    ORDERING OF THE ELEMENTS OF THE SECOND ARGUMENT
C
1520  DO 152 K=IZMODC,M2,IZMODC
      JUMP=0
      IROW=IROW-IZMODC
C
      DO 250 J=IZMODC,IROW,IZMODC
C
C    IF IT IS A SMALLER NUMBER THAN THE NEXT ONE
C
      IDYN1=IDYNA(IAD(3)+J)
      IDYN2=IDYNA(IAD(3)+J+IZMODC)
      IF(DYNA(IAD(2)+IDYN1).LE.DYNA(IAD(2)+IDYN2)) GOTO 250
C
C    IF IT IS NOT
      JUMP=1
      IDYNA(IAD(3)+J+IZMODC)=IDYN1
      IDYNA(IAD(3)+J)=IDYN2
250   CONTINUE
C
C
      IF(SITRAK(38).NE.1)GOTO 260
      IB=IAD(3)+IZMODC
      IS=IAD(3)+M3
      WRITE(NPRINT,1250) (IDYNA(J),J=IB,IS,IZMODC)
1250  FORMAT(1X,10I6)
260   CONTINUE
C
      IF(JUMP.EQ.0) GOTO 300
152   CONTINUE
C
C    NOW GENERATE ROW OF ANSWER
C
300   DO 155 KK=IZMODC,M3,IZMODC
      IDYN1=(IDYNA(IAD(3)+KK)*IZMODA)/IZMODB
      DYNA(IAD(3)+KK)=DYNA(IAD(1)+IDYN1)
      IF(IZMODC.EQ.1) GOTO 1550
      DYNA(IAD(3)+KK+1)=DYNA(IAD(1)+IDYN1+1)
C
C
1550  CONTINUE
      IF(SITRAK(38).NE.1)GOTO 155
      IADTO=IAD(3)+KK
      IADFRO=IAD(1)+IDYN1
      WRITE(NPRINT,1155) IADTO,IADFRO,DYNA(IADTO),DYNA(IADTO+1)
1155  FORMAT(' IADTO',I6,' IADFRO',I6,3X,2E14.4)
C
155   CONTINUE
C
C    CALCULATE THE ADDRESS OF THE FIRST ELEMENT OF THE NEXT ROW
C
      DO 156 J=1,3
      IAD(J)=IAD(J)+IFIX(FNCO(1,J))*JMIP(J)
156   CONTINUE
C
C
55    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 55
57    CONTINUE
C
      DO 157 K=1,2
C   REPEAT A SUBSTRUCTURE IF NECESSARY
      IF(FNCO(I,K).EQ.1.) IAD(K)=IAD(K)-IDOPE(I,K)
157   CONTINUE
C
50    CONTINUE
      CALL SISTR2(2)
      RETURN
C   A PROGRAM CANNOT BE SORTED
8999   CALL SINERR(79)
      END