MINICERN/mathlib/gen/d/rps.F

   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 RPS (MM, X, IX, Y, IY)
  11 C     SYNTHESIS 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 = 1
  33       DO 80 L = 1, M
  34 C
  35       NO1 = NO
  36       NO2 = NO + NQ
  37       NI1 = NI
  38       NI2 = NI + N2
  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 = NO2 + NQ
  52       NO2 = NO1 + NQ
  53       NI1 = NI1 + NQ
  54       NI2 = NI2 - NQ
  55       IF(NI1 - NI2) 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       W(NOR1) = W(NIR1) + W(NIR2)
  72       RE      = W(NIR1) - W(NIR2)
  73       W(NOI1) = W(NII1) - W(NII2)
  74       AI      = W(NII1) + W(NII2)
  75       W(NOR2) = CC * RE + SS * AI
  76       W(NOI2) = CC * AI - SS * RE
  77    40 CONTINUE
  78 C
  79       NO1 = NO2 + NQ
  80       NO2 = NO1 + NQ
  81       NI1 = NI1 + NQ
  82       NI2 = NI2 - NQ
  83       IF(NI1 - NI2) 30, 50, 70
  84 C
  85    50 DO 60 IT = 1, NQ
  86       NOR1 = NO1 + IT
  87       NOR2 = NO2 + IT
  88       NIR1 = NI1 + IT
  89       NII1 = NIR1 + N2
  90       W(NOR1) = W(NIR1) + W(NIR1)
  91       W(NOR2) = W(NII1) + W(NII1)
  92    60 CONTINUE
  93 C
  94    70 NT = NI
  95       NI = NO
  96       NO = NT
  97       NQ = NQ + NQ
  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) = Y(1)
 108 C
 109       RETURN
 110       END