* * $Id: sigmtp.F,v 1.1.1.1 1995/12/12 14:36:17 mclareni Exp $ * * $Log: sigmtp.F,v $ * Revision 1.1.1.1 1995/12/12 14:36:17 mclareni * Imported sources * * #include "sigma/pilot.h" *CMZ : 1.09/02 13/08/93 17.46.43 by Carlo E. Vandoni *-- Author : SUBROUTINE SIGMTP C C C .................................................. C PURPOSE C TO PERFORM GENERALIZED TRANSPOSITION OF ANY ARRAY C AND/OR SELECT COMPONENTS WITH TWO OR MORE EQUAL INDICES C C USAGE C CALL SIGMTP C C TRACKS USED C TRACK 37 GENERAL TRACE OF IMPORTANT PARAMETERS C TRACK 38 OFF-SET AND INDICES OF EVERY ELEMENT AS IT IS C TRANSFERRED TO THE RESULT C C COMM. BLOCKS USED C COM1 C C REMARKS C REPLACES THE ORIGINAL VERSIONS C TP BY HEINZ JEDLICKA AND DIAG BY THE UGA SIGMA GROUP C BY A SINGLE TP WHICH DOES BOTH AS SUGGESTED BY C SASKATOON SIGMA C C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED C SISTAK C NGET C NEXT C IGETT2 C SISTR2 C C METHOD C PICK THE ELEMENTS OF THE RESULT IN INDEX ORDER BY C STEPPING THROUGH THE ELEMENTS OF 1-ST ARG IN A SEQUENCE C DETERMINED BY THE MAPPING CONTAINED IN THE 2-ND ARG C C AUTHOR. JURIS REINFELDS DATE 24/11/74 C C C... PAW VERSION ... MAY 1988 C C C .................................................. #include "sigma/sicsig.inc" #include "sigma/sigc.inc" #include "sigma/pawc.inc" C C DIMENSION DIM(10),NCO(10),IDOPE(11) DIMENSION NXSTAR(10),MAPPIN(10) C C CALL SITRAC (' SIGMTP') C C GET NUMBER OF ARGS AND CHECK IF TOO MANY CALL SINEXT(NUARG) IF(NUARG.GT.2) GOTO 916 IF(NUARG.NE.2) GOTO 10 C C NUARG IS 2, PROCESS SECOND ARG C MISSING INDEX IS MEANINGLESS, MUST BE NUMERICAL CALL SISTAK(0,MP,MN) IF(MN.EQ.MISIDX) GOTO 918 DIM(1)=0.0 CALL SINGET(ISI,0,DIM) IF(IERRNO.NE.0)RETURN IF(ISI.GE.3) GOTO 9108 C C ACCEPT NO MORE THAN THE FIRST 10 ELEMENTS OF ARG TWO NINDIC=LENGTH/MODE IF(NINDIC.GT.10) NINDIC=10 NDIMRS=NINDIC C DO 4 I=1,NINDIC C REVERSE THE SEQUENCE,ROUND, FIX,STRIP IMAG. PART JJ=IFIX(SIROUN(DYNA(IADDR+(NINDIC-I)*MODE))) C IF ELEMENT IS NEG OR ZERO IT IS ILLEGAL C REMOVE IT HERE SO AS SUBSEQUENT SIGN REVERSAL SCHEME CAN WORK IF(JJ.LT.1) CALL SINERR(76) IF(IERRNO.NE.0) RETURN MAPPIN(I)=JJ C C CHECK FOR DUPLICATE INDICES, INDICATING DIAGS DO 5 J=1,I IF(J.EQ.I) GOTO 5 IF(MAPPIN(J).NE.MAPPIN(I)) GOTO 5 C MAPPING IS EQUAL TO A PREVIOUS VALUE MAPPIN(J)=-MAPPIN(J) NDIMRS=NDIMRS-1 5 CONTINUE C 4 CONTINUE C C 10 CONTINUE C PROCESS FIRST ARG C MISSING INDEX IS MEANINGLESS, MUST BE NUMERICAL CALL SISTAK(NUARG-1,MP,MN) IF(MN.EQ.MISIDX) GOTO 918 DIM(1)=1.0 CALL SINGET(ISI,NUARG-1,DIM) IF(IERRNO.NE.0)RETURN IF(ISI.GE.3) GOTO 9108 C C IF ONLY ONE ARG GIVEN, SET IMPLIED ARG INTO MAPPIN IF(NUARG.EQ.2) GOTO 20 JJ=NDIM IF(JJ.EQ.1)JJ=2 NINDIC=JJ NDIMRS=JJ C DO 15 I=1,JJ MAPPIN(I)=NINDIC+1-I 15 CONTINUE MAPPIN(1)=NINDIC-1 MAPPIN(2)=NINDIC C C 20 CONTINUE IF(SITRAK(37).EQ.1)WRITE(NPRINT,1090)(MAPPIN(KK),KK=1,NINDIC) C IF MAPPIN IS NOT COMPLETELY SPECIFIED IF(NINDIC.LT.NDIM) CALL SINERR(74) IF(IERRNO.NE.0) RETURN C C CONVERT NCO OF A TO INTEGER, CALCULATE IDOPE, SET NXSTAR C IDOPE(1)=MODE DO 30 I=1,10 NCO(I)=IFIX(DIM(I)) IDOPE(I+1)=IDOPE(I)*NCO(I) NXSTAR(I)=0 DIM(I)=1. 30 CONTINUE C C THERE ARE ONLY NDIMRS POSITIVE, UNEQUAL ELEMENTS C HENCE THEY MUST BE 1 2 3...NDIMRS IF THEY ARE ALL LE NDIMRS C EACH NEGATIVE MUST HAVE A CORRESPONDING POSITIVE OF SAME ABS VAL. C DO 36 I=1,NINDIC IF(MAPPIN(I).GT.NDIMRS) CALL SINERR(76) IF(IERRNO.NE.0) RETURN IF(MAPPIN(I).LT.0) GOTO 36 C USER NUMBERS THE DIMENSIONS BACKWARDS, REVERSE THEM W. R. TO (B) MAPPIN(I)=NDIMRS+1-MAPPIN(I) C FILL DIM WITH NCO OF RESULT (B) EXCEPT FOR DIAGS DIM(MAPPIN(I))=FLOAT(NCO(I)) IF(SITRAK(37).EQ.1)WRITE(NPRINT,1096)(DIM(KK),KK=1,NDIMRS) 36 CONTINUE IF(SITRAK(37).EQ.1)WRITE(NPRINT,1090)(MAPPIN(KK),KK=1,NINDIC) C C PICK UP THE SMALLEST NCO ELEMENT FOR DIAGONALIZED DIMENSIONS C DO 38 I=1,NINDIC IF(MAPPIN(I).GT.0) GOTO 38 C USER NUMBERS THE DIMENSIONS BACKWARDS, REVERSE THEM W. R. TO (B) C ALSO MAKE NEG ELEMENTS OF MAPPIN POSITIVE AGAIN MAPPIN(I)=NDIMRS+1+MAPPIN(I) IF(DIM(MAPPIN(I)).GT.FLOAT(NCO(I)))DIM(MAPPIN(I))= ,FLOAT(NCO(I)) IF(SITRAK(37).EQ.1)WRITE(NPRINT,1096)(DIM(KK),KK=1,NDIMRS) 38 CONTINUE C C IF(SITRAK(37).NE.1) GOTO 39 WRITE(NPRINT,1090)(MAPPIN(I),I=1,NINDIC) 1090 FORMAT(' MAPPING=',10I4) WRITE(NPRINT,1092) (NCO(I),I=1,NDIM) 1092 FORMAT(' NCOA= ',10I4) JJ=NDIM+1 WRITE(NPRINT,1094)(IDOPE(I),I=1,JJ) 1094 FORMAT(' IDOPEA= ',11I4) WRITE(NPRINT,1096)(DIM(I),I=1,NDIMRS) 1096 FORMAT(' DIMEB= ',10G9.1) C C 39 CONTINUE C ELIMINATE LEADING ONES BY RECALCULATING NDIMRS FROM NCO OF RESULT NDIMRS=10 DO 37 I=1,9 IF(DIM(11-I).GT.1.5) GOTO 3701 C WE HAVE A LEADING ONE HERE NDIMRS=NDIMRS-1 37 CONTINUE C 3701 CONTINUE C C CALCULATE LENGTH OF RESULT IN LENGTH LENGTH=MODE DO 40 I=1,NDIMRS LENGTH=LENGTH*IFIX(DIM(I)) 40 CONTINUE C C * GET AREA FOR THE RESULT CALL SIGTT2(IADRES,LENGTH+NDIMRS,NDIMRS,DIM) C 100 CONTINUE C CALCULATE THE OFFSET OF THE A-POSITION OF THE NEXT B-ELEMENT IOFFSE=0 DO 110 I=1,NINDIC IOFFSE=IOFFSE+IDOPE(I)*NXSTAR(I) 110 CONTINUE C C IF(SITRAK(38).EQ.1)WRITE(NPRINT,1002)IOFFSE,(NXSTAR(J),J=1 ,,NINDIC) 1002 FORMAT(' IOFFSET=',I4,3X,' NXSTART= ',10I4) C C C TRANSFER THE D A T A TO THE RESULT DYNA(IADRES)=DYNA(IADDR+IOFFSE) IF(MODE.EQ.2) DYNA(IADRES+1)=DYNA(IADDR+IOFFSE+1) IADRES=IADRES+MODE C C DECIDE IF THERE IS A NEXT ELEMENT C INCREMENT THE INDEX SEQUENCE OF A TO GIVE THE NEXT ELEM OF B C DO 130 I=1,NDIMRS NOPEYP=0 C DO 134 J=1,NINDIC IF(MAPPIN(J).EQ.I) NXSTAR(J)=NXSTAR(J)+1 IF(NXSTAR(J).GE.NCO(J)) NOPEYP=1 134 CONTINUE C IF(NOPEYP.EQ.0) GOTO 100 C C RESET ALL CONCERNED INDICES AND TRY NEXT DIMENSION (IN ORDER OF B) DO 136 J=1,NINDIC IF(MAPPIN(J).EQ.I) NXSTAR(J)=0 136 CONTINUE C 130 CONTINUE C C ALL ELEMENTS NEEDED BY B ARE TRANSFERED C C IADDR=IADRES-LENGTH CALL SISTR2(NUARG) RETURN C C 916 CONTINUE CNAME='TP ' CALL SINERR(16) RETURN C 918 CONTINUE CNAME='TP ' CALL SINERR(18) RETURN C 9108 CONTINUE CNAME='TP ' CALL SINERR(58) END