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

*
* $Id$
*
* $Log$
* Revision 1.1.1.1  1996/04/01 15:02:22  mclareni
* Mathlib gen
*
*
#include "gen/pilot.h"
      SUBROUTINE RPA (MM, X, IX, Y, IY)
C     ANALYSIS OF A REAL PERIODIC 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
      IF(M .NE. MLOC) CALL D700SU
      MLOC = M
C
      NI = N4 - 1
      NO = NI + N
C
      KX = 1
      NFWA = NI + 1
      NLWA = NI + N
      DO 10 I = NFWA, NLWA
      W(I) = X(KX)
   10 KX = KX + IX
C
      NQ = N2
      DO 80 L = 1, M
C
      NO1 = NO
      NO2 = NO + N2
      NI1 = NI
      NI2 = NI + NQ
C
      DO 20 IT = 1, NQ
      NOR1 = NO1 + IT
      NOR2 = NO2 + IT
      NIR1 = NI1 + IT
      NIR2 = NI2 + IT
      W(NOR1) = W(NIR1) + W(NIR2)
      W(NOR2) = W(NIR1) - W(NIR2)
   20 CONTINUE
C
      NC = 0
      NS = N4
      NO1 = NO1 + NQ
      NO2 = NO2 - NQ
      NI1 = NI2 + NQ
      NI2 = NI1 + NQ
      IF(NO1 - NO2) 30, 50, 70
C
   30 NC = NC + NQ
      NS = NS - NQ
      CC = W(NC)
      SS = W(NS)
C
      DO 40 IT = 1, NQ
      NOR1 = NO1 + IT
      NOI1 = NOR1 + N2
      NOR2 = NO2 + IT
      NOI2 = NOR2 + N2
      NIR1 = NI1 + IT
      NII1 = NIR1 + N2
      NIR2 = NI2 + IT
      NII2 = NIR2 + N2
      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
   40 CONTINUE
C
      NO1 = NO1 + NQ
      NO2 = NO2 - NQ
      NI1 = NI2 + NQ
      NI2 = NI1 + NQ
      IF(NO1 - NO2) 30, 50, 70
C
   50 DO 60 IT = 1, NQ
      NOR1 = NO1 + IT
      NOI1 = NOR1 + N2
      NIR1 = NI1 + IT
      NIR2 = NI2 + IT
      W(NOR1) = W(NIR1)
      W(NOI1) = W(NIR2)
   60 CONTINUE
C
   70 NT = NI
      NI = NO
      NO = NT
      NQ = NQ / 2
C
   80 CONTINUE
C
      KY = 1
      NFWA = NI + 1
      NLWA = NI + N
      DO 90 I = NFWA, NLWA
      Y(KY) = W(I) * F
   90 KY = KY + IY
      Y(KY) = 0.0
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 RPA (MM, X, IX, Y, IY)
	11	C ANALYSIS OF A REAL PERIODIC 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
	19	IF(M .NE. MLOC) CALL D700SU
	20	MLOC = M
	21	C
	22	NI = N4 - 1
	23	NO = NI + N
	24	C
	25	KX = 1
	26	NFWA = NI + 1
	27	NLWA = NI + N
	28	DO 10 I = NFWA, NLWA
	29	W(I) = X(KX)
	30	10 KX = KX + IX
	31	C
	32	NQ = N2
	33	DO 80 L = 1, M
	34	C
	35	NO1 = NO
	36	NO2 = NO + N2
	37	NI1 = NI
	38	NI2 = NI + NQ
	39	C
	40	DO 20 IT = 1, NQ
	41	NOR1 = NO1 + IT
	42	NOR2 = NO2 + IT
	43	NIR1 = NI1 + IT
	44	NIR2 = NI2 + IT
	45	W(NOR1) = W(NIR1) + W(NIR2)
	46	W(NOR2) = W(NIR1) - W(NIR2)
	47	20 CONTINUE
	48	C
	49	NC = 0
	50	NS = N4
	51	NO1 = NO1 + NQ
	52	NO2 = NO2 - NQ
	53	NI1 = NI2 + NQ
	54	NI2 = NI1 + NQ
	55	IF(NO1 - NO2) 30, 50, 70
	56	C
	57	30 NC = NC + NQ
	58	NS = NS - NQ
	59	CC = W(NC)
	60	SS = W(NS)
	61	C
	62	DO 40 IT = 1, NQ
	63	NOR1 = NO1 + IT
	64	NOI1 = NOR1 + N2
65	NOR2 = NO2 + IT
66	NOI2 = NOR2 + N2
67	NIR1 = NI1 + IT
68	NII1 = NIR1 + N2
69	NIR2 = NI2 + IT
70	NII2 = NIR2 + N2
71	RE = CC * W(NIR2) - SS * W(NII2)
72	AI = SS * W(NIR2) + CC * W(NII2)
73	W(NOR1) = W(NIR1) + RE
74	W(NOR2) = W(NIR1) - RE
75	W(NOI1) = + W(NII1) + AI
76	W(NOI2) = - W(NII1) + AI
77	40 CONTINUE
78	C
79	NO1 = NO1 + NQ
80	NO2 = NO2 - NQ
81	NI1 = NI2 + NQ
82	NI2 = NI1 + NQ
83	IF(NO1 - NO2) 30, 50, 70
84	C
85	50 DO 60 IT = 1, NQ
86	NOR1 = NO1 + IT
87	NOI1 = NOR1 + N2
88	NIR1 = NI1 + IT
89	NIR2 = NI2 + IT
90	W(NOR1) = W(NIR1)
91	W(NOI1) = W(NIR2)
92	60 CONTINUE
93	C
94	70 NT = NI
95	NI = NO
96	NO = NT
97	NQ = NQ / 2
98	C
99	80 CONTINUE
100	C
101	KY = 1
102	NFWA = NI + 1
103	NLWA = NI + N
104	DO 90 I = NFWA, NLWA
105	Y(KY) = W(I) * F
106	90 KY = KY + IY
107	Y(KY) = 0.0
108	C
109	RETURN
110	END