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

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:22  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE RCA (MM, X, IX, Y, IY)
C     ANALYSIS OR SYNTHESIS OF A REAL EVEN 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 = 1
      NFWA = NI
      NLWA = NI + N2
      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
      W(NO1) = W(NI1) + W(NI2)
      W(NO2) = W(NI1) - W(NI2)
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
      NOR1 = NO1 + IT
      NOR2 = NO2 + IT
      NIR1 = NI1 + IT
      NIR2 = NI2 - IT
      NOI1 = NOR1 + NQ2
      NOI2 = NOR2 + NQ2
      NII1 = NIR1 + NQ
      NII2 = NIR2 + 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 W(NO1) = W(NI1)
C
      IF(NQ2M1) 160, 150, 130
C
  130 DO 140 IT = 1, NQ2M1
      NOR1 = NO1 + IT
      NOI1 = NOR1 + 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
      KY = 1
      NFWA = NI
      NLWA = NI + N2
      DO 180 I = NFWA, NLWA
      Y(KY) = W(I) * F
  180 KY = KY + IY
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 RCA (MM, X, IX, Y, IY)
	11	C ANALYSIS OR SYNTHESIS OF A REAL EVEN 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 = 1
	26	NFWA = NI
	27	NLWA = NI + N2
	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	W(NO1) = W(NI1) + W(NI2)
	42	W(NO2) = W(NI1) - W(NI2)
	43	C
	44	IF(NQ2M1) 50, 40, 20
	45	C
	46	20 DO 30 IT = 1, NQ2M1
	47	NOR1 = NO1 + IT
	48	NOR2 = NO1 + NQ2 + IT
	49	NIR1 = NI1 + IT
	50	NIR2 = NI2 - IT
	51	W(NOR1) = W(NIR1) + W(NIR2)
	52	W(NOR2) = W(NIR1) - W(NIR2)
	53	30 CONTINUE
	54	C
	55	40 NOR1 = NO1 + NQ2
	56	NIR1 = NI1 + NQ2
	57	W(NOR1) = W(NIR1) + W(NIR1)
	58	C
	59	50 NO1 = NO1 + NQ
	60	NO2 = NO2 - NQ
	61	NI1 = NI2 + NQ
	62	NI2 = NI1 + NQ
	63	IF(NO1 - NO2) 60, 120, 160
	64	C
65	60 NC = 0
66	NS = N4
67	KC = 0
68	KS = N4
69	C
70	70 CONTINUE
71	W(NO1) = W(NI1) + W(NI2)
72	W(NO2) = W(NI1) - W(NI2)
73	C
74	IF(NQ2M1) 110, 100, 80
75	C
76	80 NC = NC + NQ
77	NS = NS - NQ
78	CC = W(NC)
79	SS = W(NS)
80	DO 90 IT = 1, NQ2M1
81	NOR1 = NO1 + IT
82	NOR2 = NO2 + IT
83	NIR1 = NI1 + IT
84	NIR2 = NI2 - IT
85	NOI1 = NOR1 + NQ2
86	NOI2 = NOR2 + NQ2
87	NII1 = NIR1 + NQ
88	NII2 = NIR2 + NQ
89	RE = CC * W(NIR2) - SS * W(NII2)
90	AI = SS * W(NIR2) + CC * W(NII2)
91	W(NOR1) = W(NIR1) + RE
92	W(NOR2) = W(NIR1) - RE
93	W(NOI1) = + W(NII1) - AI
94	W(NOI2) = - W(NII1) - AI
95	90 CONTINUE
96	C
97	100 KC = KC + NQ2
98	KS = KS - NQ2
99	NOR1 = NO1 + NQ2
100	NOR2 = NO2 + NQ2
101	NIR1 = NI1 + NQ2
102	NIR2 = NI2 + NQ2
103	W(NOR1) = 2.0 * (W(KC) * W(NIR1) - W(KS) * W(NIR2))
104	W(NOR2) = 2.0 * (W(KS) * W(NIR1) + W(KC) * W(NIR2))
105	C
106	110 NO1 = NO1 + NQ
107	NO2 = NO2 - NQ
108	NI1 = NI2 + NQ
109	NI2 = NI1 + NQ
110	IF(NO1 - NO2) 70, 120, 160
111	C
112	120 W(NO1) = W(NI1)
113	C
114	IF(NQ2M1) 160, 150, 130
115	C
116	130 DO 140 IT = 1, NQ2M1
117	NOR1 = NO1 + IT
118	NOI1 = NOR1 + NQ2
119	NIR1 = NI + NQ + IT
120	NIR2 = NI + NQ + NQ - IT
121	W(NOR1) = + W(NIR1)
122	W(NOI1) = - W(NIR2)
123	140 CONTINUE
124	C
125	150 NOR1 = NO1 + NQ2
126	NIR1 = NI + NQ + NQ2
127	W(NOR1) = RTTWO * W(NIR1)
128	C
129	160 NT = NI
130	NI = NO
131	NO = NT
132	NQ = NQ2
133	170 CONTINUE
134	C
135	KY = 1
136	NFWA = NI
137	NLWA = NI + N2
138	DO 180 I = NFWA, NLWA
139	Y(KY) = W(I) * F
140	180 KY = KY + IY
141	C
142	RETURN
143	END