[u/mrichter/AliRoot.git] / MINICERN / mathlib / gen / d / rsa.F

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:22  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE RSA (MM, X, IX, Y, IY)
C     ANALYSIS OR SYNTHESIS OF A REAL ODD FUNCTION.
C
      REAL X(128), Y(128)
      COMMON /D700DT/ N, N2, N4, M, F, RTTWO
      COMMON /FWORK/ W(321)
      DATA MLOC / - 1 /
C
      M = MM + 1
      IF(M .NE. MLOC) CALL D700SU
      MLOC = M
C
      NI = N4
      NO = N4 + N2 + 1
C
      KX = IX + 1
      NFWA = NI + 1
      NLWA = NI + N2 - 1
      DO 10 I = NFWA, NLWA
      W(I) = X(KX)
   10 KX = KX + IX
C
      NQ = N2
      DO 170 L = 1, M
      NQ2 = NQ / 2
      NQ2M1 = NQ2 - 1
C
      NO1 = NO
      NO2 = NO + N2
      NI1 = NI
      NI2 = NI + NQ
C
      IF(NQ2M1) 50, 40, 20
C
   20 DO 30 IT = 1, NQ2M1
      NOR1 = NO1 + IT
      NOR2 = NO1 + NQ2 + IT
      NIR1 = NI1 + IT
      NIR2 = NI2 - IT
      W(NOR1) = W(NIR1) - W(NIR2)
      W(NOR2) = W(NIR1) + W(NIR2)
   30 CONTINUE
C
   40 NOR1 = NO1 + NQ2
      NIR1 = NI1 + NQ2
      W(NOR1) = W(NIR1) + W(NIR1)
C
   50 NO1 = NO1 + NQ
      NO2 = NO2 - NQ
      NI1 = NI2 + NQ
      NI2 = NI1 + NQ
      IF(NO1 - NO2) 60, 120, 160
C
   60 NC = 0
      NS = N4
      KC = 0
      KS = N4
C
   70 CONTINUE
      W(NO1) = + W(NI1) + W(NI2)
      W(NO2) = - W(NI1) + W(NI2)
C
      IF(NQ2M1) 110, 100, 80
C
   80 NC = NC + NQ
      NS = NS - NQ
      CC = W(NC)
      SS = W(NS)
      DO 90 IT = 1, NQ2M1
      NOI1 = NO1 + IT
      NOI2 = NO2 + IT
      NII1 = NI1 + IT
      NII2 = NI2 - IT
      NOR1 = NOI1 + NQ2
      NOR2 = NOI2 + NQ2
      NIR1 = NII1 + NQ
      NIR2 = NII2 + NQ
      RE = CC * W(NIR2) - SS * W(NII2)
      AI = SS * W(NIR2) + CC * W(NII2)
      W(NOR1) = W(NIR1) - RE
      W(NOR2) = W(NIR1) + RE
      W(NOI1) = + W(NII1) + AI
      W(NOI2) = - W(NII1) + AI
   90 CONTINUE
C
  100 KC = KC + NQ2
      KS = KS - NQ2
      NOR1 = NO1 + NQ2
      NOR2 = NO2 + NQ2
      NIR1 = NI1 + NQ2
      NIR2 = NI2 + NQ2
      W(NOR1) = 2.0 * (+ W(KC) * W(NIR1) + W(KS) * W(NIR2))
      W(NOR2) = 2.0 * (- W(KS) * W(NIR1) + W(KC) * W(NIR2))
C
  110 NO1 = NO1 + NQ
      NO2 = NO2 - NQ
      NI1 = NI2 + NQ
      NI2 = NI1 + NQ
      IF(NO1 - NO2) 70, 120, 160
C
  120 NIR1 = NI + NQ
      W(NO1) = W(NIR1)
C
      IF(NQ2M1) 160, 150, 130
C
  130 DO 140 IT = 1, NQ2M1
      NOI1 = NO1 + IT
      NOR1 = NOI1 + NQ2
      NIR1 = NI + NQ + IT
      NIR2 = NI + NQ + NQ - IT
      W(NOR1) = W(NIR1)
      W(NOI1) = W(NIR2)
  140 CONTINUE
C
  150 NOR1 = NO1 + NQ2
      NIR1 = NI + NQ + NQ2
      W(NOR1) = RTTWO * W(NIR1)
C
  160 NT = NI
      NI = NO
      NO = NT
      NQ = NQ2
  170 CONTINUE
C
      Y(1) = X(1)
      KY = IY + 1
      NFWA = NI + 1
      NLWA = NI + N2 - 1
      DO 180 I = NFWA, NLWA
      Y(KY) = W(I) * F
  180 KY = KY + IY
      Y(KY) = X(KX)
C
      RETURN
      END
Commit	Line	Data
fe4da5cc	1	*
	2	* $Id$
	3	*
	4	* $Log$
	5	* Revision 1.1.1.1 1996/04/01 15:02:22 mclareni
	6	* Mathlib gen
	7	*
	8	*
	9	#include "gen/pilot.h"
	10	SUBROUTINE RSA (MM, X, IX, Y, IY)
	11	C ANALYSIS OR SYNTHESIS OF A REAL ODD FUNCTION.
	12	C
	13	REAL X(128), Y(128)
	14	COMMON /D700DT/ N, N2, N4, M, F, RTTWO
	15	COMMON /FWORK/ W(321)
	16	DATA MLOC / - 1 /
	17	C
	18	M = MM + 1
	19	IF(M .NE. MLOC) CALL D700SU
	20	MLOC = M
	21	C
	22	NI = N4
	23	NO = N4 + N2 + 1
	24	C
	25	KX = IX + 1
	26	NFWA = NI + 1
	27	NLWA = NI + N2 - 1
	28	DO 10 I = NFWA, NLWA
	29	W(I) = X(KX)
	30	10 KX = KX + IX
	31	C
	32	NQ = N2
	33	DO 170 L = 1, M
	34	NQ2 = NQ / 2
	35	NQ2M1 = NQ2 - 1
	36	C
	37	NO1 = NO
	38	NO2 = NO + N2
	39	NI1 = NI
	40	NI2 = NI + NQ
	41	C
	42	IF(NQ2M1) 50, 40, 20
	43	C
	44	20 DO 30 IT = 1, NQ2M1
	45	NOR1 = NO1 + IT
	46	NOR2 = NO1 + NQ2 + IT
	47	NIR1 = NI1 + IT
	48	NIR2 = NI2 - IT
	49	W(NOR1) = W(NIR1) - W(NIR2)
	50	W(NOR2) = W(NIR1) + W(NIR2)
	51	30 CONTINUE
	52	C
	53	40 NOR1 = NO1 + NQ2
	54	NIR1 = NI1 + NQ2
	55	W(NOR1) = W(NIR1) + W(NIR1)
	56	C
	57	50 NO1 = NO1 + NQ
	58	NO2 = NO2 - NQ
	59	NI1 = NI2 + NQ
	60	NI2 = NI1 + NQ
	61	IF(NO1 - NO2) 60, 120, 160
	62	C
	63	60 NC = 0
	64	NS = N4
65	KC = 0
66	KS = N4
67	C
68	70 CONTINUE
69	W(NO1) = + W(NI1) + W(NI2)
70	W(NO2) = - W(NI1) + W(NI2)
71	C
72	IF(NQ2M1) 110, 100, 80
73	C
74	80 NC = NC + NQ
75	NS = NS - NQ
76	CC = W(NC)
77	SS = W(NS)
78	DO 90 IT = 1, NQ2M1
79	NOI1 = NO1 + IT
80	NOI2 = NO2 + IT
81	NII1 = NI1 + IT
82	NII2 = NI2 - IT
83	NOR1 = NOI1 + NQ2
84	NOR2 = NOI2 + NQ2
85	NIR1 = NII1 + NQ
86	NIR2 = NII2 + NQ
87	RE = CC * W(NIR2) - SS * W(NII2)
88	AI = SS * W(NIR2) + CC * W(NII2)
89	W(NOR1) = W(NIR1) - RE
90	W(NOR2) = W(NIR1) + RE
91	W(NOI1) = + W(NII1) + AI
92	W(NOI2) = - W(NII1) + AI
93	90 CONTINUE
94	C
95	100 KC = KC + NQ2
96	KS = KS - NQ2
97	NOR1 = NO1 + NQ2
98	NOR2 = NO2 + NQ2
99	NIR1 = NI1 + NQ2
100	NIR2 = NI2 + NQ2
101	W(NOR1) = 2.0 * (+ W(KC) * W(NIR1) + W(KS) * W(NIR2))
102	W(NOR2) = 2.0 * (- W(KS) * W(NIR1) + W(KC) * W(NIR2))
103	C
104	110 NO1 = NO1 + NQ
105	NO2 = NO2 - NQ
106	NI1 = NI2 + NQ
107	NI2 = NI1 + NQ
108	IF(NO1 - NO2) 70, 120, 160
109	C
110	120 NIR1 = NI + NQ
111	W(NO1) = W(NIR1)
112	C
113	IF(NQ2M1) 160, 150, 130
114	C
115	130 DO 140 IT = 1, NQ2M1
116	NOI1 = NO1 + IT
117	NOR1 = NOI1 + NQ2
118	NIR1 = NI + NQ + IT
119	NIR2 = NI + NQ + NQ - IT
120	W(NOR1) = W(NIR1)
121	W(NOI1) = W(NIR2)
122	140 CONTINUE
123	C
124	150 NOR1 = NO1 + NQ2
125	NIR1 = NI + NQ + NQ2
126	W(NOR1) = RTTWO * W(NIR1)
127	C
128	160 NT = NI
129	NI = NO
130	NO = NT
131	NQ = NQ2
132	170 CONTINUE
133	C
134	Y(1) = X(1)
135	KY = IY + 1
136	NFWA = NI + 1
137	NLWA = NI + N2 - 1
138	DO 180 I = NFWA, NLWA
139	Y(KY) = W(I) * F
140	180 KY = KY + IY
141	Y(KY) = X(KX)
142	C
143	RETURN
144	END