MINICERN/mathlib/gen/d/rsa.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 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