C
C     This code is distributed under the terms and conditions of the
C     CCP4 licence agreement as `Part i)' software.  See the conditions
C     in the CCP4 manual for a copyright statement.
C
C-- FFT81       F77TRNFM.FOR                        13/09/85    JWC
C
C
C**** FOLLOWING ARE ROUTINES USED BY TEN EYCK'S FFT PROGRAMS***
C
C
      SUBROUTINE CMPLFT(X,Y,N,D)
C     ===============================
C
C
C     Complex finite discrete fourier transform
C     transforms one dimension of multi-dimensional data
C     modified by L. F. TEN EYCK from a one-dimensional version written
C     by G. T. SANDE, 1969.
C
C     This program calculates the transform
C               (X(T) + I*Y(T))*(COS(2*PI*T/N) - I*SIN(2*PI*T/N))
C
C     INDEXING -- the arrangement of the multi-dimensional data is
C     specified by the integer array D, the values of which are used as
C     control parameters in do loops.  when it is desired to cover all
C     elements of the data for which the subscript being transformed has
C     the value I0, the following is used.
C
C               I1 = (I0 - 1)*D(2) + 1
C               DO 100 I2 = I1, D(1), D(3)
C               I3 = I2 + D(4) - 1
C               DO 100 I = I2, I3, D(5)
C                  .
C                  .
C           100 CONTINUE
C
C     with this indexing it is possible to use a number of arrangements
C     of the data, including normal fortran complex numbers (d(5) = 2)
C     or separate storage of real and imaginary parts.
C
C
C---- PMAX is the largest prime factor that will be tolerated by this
C     program.
C
C---- TWOGRP is the largest power of two that is treated as a special
C     case.
C
C     .. Scalar Arguments ..
      INTEGER           N
C     ..
C     .. Array Arguments ..
      REAL              X(*),Y(*)
      INTEGER           D(5)
C     ..
C     .. Local Scalars ..
      INTEGER           PMAX,PSYM,TWOGRP
      LOGICAL           ERROR
C     ..
C     .. Local Arrays ..
      INTEGER           FACTOR(15),SYM(15),UNSYM(15)
C     ..
C     .. External Subroutines ..
      EXTERNAL          DIPRP,MDFTKD,SRFP
C     ..
      PMAX = 19
      TWOGRP = 8
C
      IF (N.GT.1) THEN
          CALL SRFP(N,PMAX,TWOGRP,FACTOR,SYM,PSYM,UNSYM,ERROR)
          IF (ERROR) THEN
C
              WRITE (6,FMT=9000) N
              call ccperr(1,' stop in fftlib.for 1000')
          ELSE
C
              CALL MDFTKD(N,FACTOR,D,X,Y)
              CALL DIPRP(N,SYM,PSYM,UNSYM,D,X,Y)
          END IF
      END IF
C
C---- Format statements
C
 9000 FORMAT ('0INVALID NUMBER OF POINTS FOR CMPL FT.  N =',I10,//)
      END
C
C
      SUBROUTINE SRFP(PTS,PMAX,TWOGRP,FACTOR,SYM,PSYM,UNSYM,ERROR)
C     ==================================================================
C
C
C---- Symmetrized reordering factoring programme
C
C
C     .. Scalar Arguments ..
      INTEGER         PMAX,PSYM,PTS,TWOGRP
      LOGICAL         ERROR
C     ..
C     .. Array Arguments ..
      INTEGER         FACTOR(10),SYM(10),UNSYM(10)
C     ..
C     .. Local Scalars ..
      INTEGER         F,J,JJ,N,NEST,P,PTWO,Q,R
C     ..
C     .. Local Arrays ..
      INTEGER         PP(14),QQ(7)
C     ..
      NEST = 14
C
      N = PTS
      PSYM = 1
      F = 2
      P = 0
      Q = 0
   10 CONTINUE
      IF (N.LE.1) THEN
          GO TO 60
      ELSE
          DO 20 J = F,PMAX
              IF (N.EQ. (N/J)*J) GO TO 30
   20         CONTINUE
          GO TO 40
   30     IF (2*P+Q.GE.NEST) THEN
              GO TO 50
          ELSE
              F = J
              N = N/F
              IF (N.EQ. (N/F)*F) THEN
                  N = N/F
                  P = P + 1
                  PP(P) = F
                  PSYM = PSYM*F
              ELSE
                  Q = Q + 1
                  QQ(Q) = F
              END IF
              GO TO 10
          END IF
      END IF
C
   40 CONTINUE
      WRITE (6,FMT=9000) PMAX,PTS
      ERROR = .TRUE.
      GO TO 100
C
   50 CONTINUE
      WRITE (6,FMT=9010) NEST,PTS
      ERROR = .TRUE.
      GO TO 100
C
   60 CONTINUE
      R = 1
      IF (Q.EQ.0) R = 0
      IF (P.GE.1) THEN
          DO 70 J = 1,P
              JJ = P + 1 - J
              SYM(J) = PP(JJ)
              FACTOR(J) = PP(JJ)
              JJ = P + Q + J
              FACTOR(JJ) = PP(J)
              JJ = P + R + J
              SYM(JJ) = PP(J)
   70         CONTINUE
      END IF
      IF (Q.GE.1) THEN
          DO 80 J = 1,Q
              JJ = P + J
              UNSYM(J) = QQ(J)
              FACTOR(JJ) = QQ(J)
   80         CONTINUE
          SYM(P+1) = PTS/PSYM**2
      END IF
      JJ = 2*P + Q
      FACTOR(JJ+1) = 0
      PTWO = 1
      J = 0
   90 CONTINUE
      J = J + 1
      IF (FACTOR(J).NE.0) THEN
          IF (FACTOR(J).EQ.2) THEN
              PTWO = PTWO*2
              FACTOR(J) = 1
              IF (PTWO.LT.TWOGRP) THEN
                  IF (FACTOR(J+1).EQ.2) GO TO 90
              END IF
              FACTOR(J) = PTWO
              PTWO = 1
          END IF
          GO TO 90
      END IF
      IF (P.EQ.0) R = 0
      JJ = 2*P + R
      SYM(JJ+1) = 0
      IF (Q.LE.1) Q = 0
      UNSYM(Q+1) = 0
      ERROR = .FALSE.
C
  100 CONTINUE
C
C---- Format statements
C
 9000 FORMAT ('0LARGEST FACTOR EXCEEDS ',I3,'.  N = ',I6,'.')
 9010 FORMAT ('0FACTOR COUNT EXCEEDS ',I3,'.  N = ',I6,'.')
      END
C
C
      SUBROUTINE MDFTKD(N,FACTOR,DIM,X,Y)
C     ==========================================
C
C
C---- Multi-dimensional complex fourier transform kernel driver
C
C
C     .. Scalar Arguments ..
      INTEGER           N
C     ..
C     .. Array Arguments ..
      REAL              X(*),Y(*)
      INTEGER           DIM(5),FACTOR(10)
C     ..
C     .. Local Scalars ..
      INTEGER           F,M,P,R,S
C     ..
C     .. External Subroutines ..
      EXTERNAL          R2CFTK,R3CFTK,R4CFTK,R5CFTK,R8CFTK,RPCFTK
C     ..
      S = DIM(2)
      F = 0
      M = N
   10 CONTINUE
      F = F + 1
      P = FACTOR(F)
      IF (P.EQ.0) THEN
          RETURN
      ELSE
          M = M/P
          R = M*S
          IF (P.LE.8) THEN
              GO TO (10,20,30,40,50,80,70,60) P
              GO TO 80
C
   20         CONTINUE
              CALL R2CFTK(N,M,X(1),Y(1),X(R+1),Y(R+1),DIM)
              GO TO 10
C
   30         CONTINUE
              CALL R3CFTK(N,M,X(1),Y(1),X(R+1),Y(R+1),X(2*R+1),Y(2*R+1),
     +                    DIM)
              GO TO 10
C
   40         CONTINUE
              CALL R4CFTK(N,M,X(1),Y(1),X(R+1),Y(R+1),X(2*R+1),Y(2*R+1),
     +                    X(3*R+1),Y(3*R+1),DIM)
              GO TO 10
C
   50         CONTINUE
              CALL R5CFTK(N,M,X(1),Y(1),X(R+1),Y(R+1),X(2*R+1),Y(2*R+1),
     +                    X(3*R+1),Y(3*R+1),X(4*R+1),Y(4*R+1),DIM)
              GO TO 10
C
   60         CONTINUE
              CALL R8CFTK(N,M,X(1),Y(1),X(R+1),Y(R+1),X(2*R+1),Y(2*R+1),
     +                    X(3*R+1),Y(3*R+1),X(4*R+1),Y(4*R+1),X(5*R+1),
     +                    Y(5*R+1),X(6*R+1),Y(6*R+1),X(7*R+1),Y(7*R+1),
     +                    DIM)
              GO TO 10
          END IF
C
   70     CONTINUE
          CALL RPCFTK(N,M,P,R,X,Y,DIM)
          GO TO 10
      END IF
C
   80 CONTINUE
      WRITE (6,FMT=9000)
C
C---- Format statements
C
 9000 FORMAT ('0TRANSFER ERROR DETECTED IN MDFTKD',//)
      END
C
C
      SUBROUTINE R2CFTK(N,M,X0,Y0,X1,Y1,DIM)
C     ==============================================
C
C
C---- Radix 2 multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N
C     ..
C     .. Array Arguments ..
      REAL              X0(10),X1(10),Y0(10),Y1(10)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              ANGLE,C,FJM1,FM2,IS,IU,RS,RU,S,TWOPI
      INTEGER           J,K,K0,K1,K2,KK,L,L1,M2,MM2,MOVER2,NS,NT,SEP,
     +                  SIZE
      LOGICAL           FOLD,ZERO
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/
C     ..
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      M2 = M*2
      FM2 = REAL(M2)
      MOVER2 = M/2 + 1
      MM2 = SEP*M2
C
      FJM1 = -1.0
      DO 50 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FM2
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C = COS(ANGLE)
              S = SIN(ANGLE)
          END IF
   10     CONTINUE
C
          DO 40 KK = K0,NS,MM2
              DO 30 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 20 K = L,K1,K2
                      RS = X0(K) + X1(K)
                      IS = Y0(K) + Y1(K)
                      RU = X0(K) - X1(K)
                      IU = Y0(K) - Y1(K)
                      X0(K) = RS
                      Y0(K) = IS
                      IF (ZERO) THEN
                          X1(K) = RU
                          Y1(K) = IU
                      ELSE
                          X1(K) = RU*C + IU*S
                          Y1(K) = IU*C - RU*S
                      END IF
   20                 CONTINUE
   30             CONTINUE
   40         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              C = -C
              GO TO 10
          END IF
   50     CONTINUE
C
      END
C
C
      SUBROUTINE R3CFTK(N,M,X0,Y0,X1,Y1,X2,Y2,DIM)
C     ======================================================
C
C
C---- Radix 3 multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N
C     ..
C     .. Array Arguments ..
      REAL              X0(10),X1(10),X2(10),Y0(10),Y1(10),Y2(10)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              A,ANGLE,B,C1,C2,FJM1,FM3,I0,I1,I2,IA,IB,IS,R0,
     +                  R1,R2,RA,RB,RS,S1,S2,T,TWOPI
      INTEGER           J,K,K0,K1,K2,KK,L,L1,M3,MM3,MOVER2,NS,NT,SEP,
     +                  SIZE
      LOGICAL           FOLD,ZERO
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/,A/-0.5/,B/0.86602540/
C     ..
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      M3 = M*3
      FM3 = REAL(M3)
      MM3 = SEP*M3
      MOVER2 = M/2 + 1
C
      FJM1 = -1.0
      DO 50 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FM3
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C1 = COS(ANGLE)
              S1 = SIN(ANGLE)
              C2 = C1*C1 - S1*S1
              S2 = S1*C1 + C1*S1
          END IF
   10     CONTINUE
C
          DO 40 KK = K0,NS,MM3
              DO 30 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 20 K = L,K1,K2
                      R0 = X0(K)
                      I0 = Y0(K)
                      RS = X1(K) + X2(K)
                      IS = Y1(K) + Y2(K)
                      X0(K) = R0 + RS
                      Y0(K) = I0 + IS
                      RA = RS*A + R0
                      IA = IS*A + I0
                      RB = (X1(K)-X2(K))*B
                      IB = (Y1(K)-Y2(K))*B
                      IF (ZERO) THEN
                          X1(K) = RA + IB
                          Y1(K) = IA - RB
                          X2(K) = RA - IB
                          Y2(K) = IA + RB
                      ELSE
                          R1 = RA + IB
                          I1 = IA - RB
                          R2 = RA - IB
                          I2 = IA + RB
                          X1(K) = R1*C1 + I1*S1
                          Y1(K) = I1*C1 - R1*S1
                          X2(K) = R2*C2 + I2*S2
                          Y2(K) = I2*C2 - R2*S2
                      END IF
   20                 CONTINUE
   30             CONTINUE
   40         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              T = C1*A + S1*B
              S1 = C1*B - S1*A
              C1 = T
              T = C2*A - S2*B
              S2 = -C2*B - S2*A
              C2 = T
              GO TO 10
          END IF
   50     CONTINUE
C
      END
C
C
      SUBROUTINE R4CFTK(N,M,X0,Y0,X1,Y1,X2,Y2,X3,Y3,DIM)
C     ==============================================================
C
C
C---- Radix 4 multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N
C     ..
C     .. Array Arguments ..
      REAL              X0(10),X1(10),X2(10),X3(10),Y0(10),Y1(10),
     +                  Y2(10),Y3(10)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              ANGLE,C1,C2,C3,FJM1,FM4,I1,I2,I3,IS0,IS1,IU0,
     +                  IU1,R1,R2,R3,RS0,RS1,RU0,RU1,S1,S2,S3,T,TWOPI
      INTEGER           J,K,K0,K1,K2,KK,L,L1,M4,MM4,MOVER2,NS,NT,SEP,
     +                  SIZE
      LOGICAL           FOLD,ZERO
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/
C     ..
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      M4 = M*4
      FM4 = REAL(M4)
      MM4 = SEP*M4
      MOVER2 = M/2 + 1
C
      FJM1 = -1.0
      DO 50 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FM4
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C1 = COS(ANGLE)
              S1 = SIN(ANGLE)
              C2 = C1*C1 - S1*S1
              S2 = S1*C1 + C1*S1
              C3 = C2*C1 - S2*S1
              S3 = S2*C1 + C2*S1
          END IF
   10     CONTINUE
C
          DO 40 KK = K0,NS,MM4
              DO 30 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 20 K = L,K1,K2
                      RS0 = X0(K) + X2(K)
                      IS0 = Y0(K) + Y2(K)
                      RU0 = X0(K) - X2(K)
                      IU0 = Y0(K) - Y2(K)
                      RS1 = X1(K) + X3(K)
                      IS1 = Y1(K) + Y3(K)
                      RU1 = X1(K) - X3(K)
                      IU1 = Y1(K) - Y3(K)
                      X0(K) = RS0 + RS1
                      Y0(K) = IS0 + IS1
                      IF (ZERO) THEN
                          X2(K) = RU0 + IU1
                          Y2(K) = IU0 - RU1
                          X1(K) = RS0 - RS1
                          Y1(K) = IS0 - IS1
                          X3(K) = RU0 - IU1
                          Y3(K) = IU0 + RU1
                      ELSE
                          R1 = RU0 + IU1
                          I1 = IU0 - RU1
                          R2 = RS0 - RS1
                          I2 = IS0 - IS1
                          R3 = RU0 - IU1
                          I3 = IU0 + RU1
                          X2(K) = R1*C1 + I1*S1
                          Y2(K) = I1*C1 - R1*S1
                          X1(K) = R2*C2 + I2*S2
                          Y1(K) = I2*C2 - R2*S2
                          X3(K) = R3*C3 + I3*S3
                          Y3(K) = I3*C3 - R3*S3
                      END IF
   20                 CONTINUE
   30             CONTINUE
   40         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              T = C1
              C1 = S1
              S1 = T
              C2 = -C2
              T = C3
              C3 = -S3
              S3 = -T
              GO TO 10
          END IF
   50     CONTINUE
C
      END
C
C
      SUBROUTINE R5CFTK(N,M,X0,Y0,X1,Y1,X2,Y2,X3,Y3,X4,Y4,DIM)
C     =================================================================
C
C
C---- Radix 5 multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N
C     ..
C     .. Array Arguments ..
      REAL              X0(10),X1(10),X2(10),X3(10),X4(10),Y0(10),
     +                  Y1(10),Y2(10),Y3(10),Y4(10)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              A1,A2,ANGLE,B1,B2,C1,C2,C3,C4,FJM1,FM5,I0,I1,I2,
     +                  I3,I4,IA1,IA2,IB1,IB2,IS1,IS2,IU1,IU2,R0,R1,R2,
     +                  R3,R4,RA1,RA2,RB1,RB2,RS1,RS2,RU1,RU2,S1,S2,S3,
     +                  S4,T,TWOPI
      INTEGER           J,K,K0,K1,K2,KK,L,L1,M5,MM5,MOVER2,NS,NT,SEP,
     +                  SIZE
      LOGICAL           FOLD,ZERO
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/,A1/0.30901699/,B1/0.95105652/,
     +                  A2/-0.80901699/,B2/0.58778525/
C     ..
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      M5 = M*5
      FM5 = REAL(M5)
      MM5 = SEP*M5
      MOVER2 = M/2 + 1
C
      FJM1 = -1.0
      DO 50 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FM5
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C1 = COS(ANGLE)
              S1 = SIN(ANGLE)
              C2 = C1*C1 - S1*S1
              S2 = S1*C1 + C1*S1
              C3 = C2*C1 - S2*S1
              S3 = S2*C1 + C2*S1
              C4 = C2*C2 - S2*S2
              S4 = S2*C2 + C2*S2
          END IF
   10     CONTINUE
C
          DO 40 KK = K0,NS,MM5
              DO 30 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 20 K = L,K1,K2
                      R0 = X0(K)
                      I0 = Y0(K)
                      RS1 = X1(K) + X4(K)
                      IS1 = Y1(K) + Y4(K)
                      RU1 = X1(K) - X4(K)
                      IU1 = Y1(K) - Y4(K)
                      RS2 = X2(K) + X3(K)
                      IS2 = Y2(K) + Y3(K)
                      RU2 = X2(K) - X3(K)
                      IU2 = Y2(K) - Y3(K)
                      X0(K) = R0 + RS1 + RS2
                      Y0(K) = I0 + IS1 + IS2
                      RA1 = RS1*A1 + R0 + RS2*A2
                      IA1 = IS1*A1 + I0 + IS2*A2
                      RA2 = RS1*A2 + R0 + RS2*A1
                      IA2 = IS1*A2 + I0 + IS2*A1
                      RB1 = RU1*B1 + RU2*B2
                      IB1 = IU1*B1 + IU2*B2
                      RB2 = RU1*B2 - RU2*B1
                      IB2 = IU1*B2 - IU2*B1
                      IF (ZERO) THEN
                          X1(K) = RA1 + IB1
                          Y1(K) = IA1 - RB1
                          X2(K) = RA2 + IB2
                          Y2(K) = IA2 - RB2
                          X3(K) = RA2 - IB2
                          Y3(K) = IA2 + RB2
                          X4(K) = RA1 - IB1
                          Y4(K) = IA1 + RB1
                      ELSE
                          R1 = RA1 + IB1
                          I1 = IA1 - RB1
                          R2 = RA2 + IB2
                          I2 = IA2 - RB2
                          R3 = RA2 - IB2
                          I3 = IA2 + RB2
                          R4 = RA1 - IB1
                          I4 = IA1 + RB1
                          X1(K) = R1*C1 + I1*S1
                          Y1(K) = I1*C1 - R1*S1
                          X2(K) = R2*C2 + I2*S2
                          Y2(K) = I2*C2 - R2*S2
                          X3(K) = R3*C3 + I3*S3
                          Y3(K) = I3*C3 - R3*S3
                          X4(K) = R4*C4 + I4*S4
                          Y4(K) = I4*C4 - R4*S4
                      END IF
   20                 CONTINUE
   30             CONTINUE
   40         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              T = C1*A1 + S1*B1
              S1 = C1*B1 - S1*A1
              C1 = T
              T = C2*A2 + S2*B2
              S2 = C2*B2 - S2*A2
              C2 = T
              T = C3*A2 - S3*B2
              S3 = -C3*B2 - S3*A2
              C3 = T
              T = C4*A1 - S4*B1
              S4 = -C4*B1 - S4*A1
              C4 = T
              GO TO 10
          END IF
   50     CONTINUE
C
      END
C
C
      SUBROUTINE R8CFTK(N,M,X0,Y0,X1,Y1,X2,Y2,X3,Y3,X4,Y4,X5,Y5,X6,Y6,
     +                  X7,Y7,DIM)
C      ===============================================================
C
C
C---- Radix 8 multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N
C     ..
C     .. Array Arguments ..
      REAL              X0(10),X1(10),X2(10),X3(10),X4(10),X5(10),
     +                  X6(10),X7(10),Y0(10),Y1(10),Y2(10),Y3(10),
     +                  Y4(10),Y5(10),Y6(10),Y7(10)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              ANGLE,C1,C2,C3,C4,C5,C6,C7,E,FJM1,FM8,I1,I2,I3,
     +                  I4,I5,I6,I7,IS0,IS1,IS2,IS3,ISS0,ISS1,ISU0,ISU1,
     +                  IU0,IU1,IU2,IU3,IUS0,IUS1,IUU0,IUU1,R1,R2,R3,R4,
     +                  R5,R6,R7,RS0,RS1,RS2,RS3,RSS0,RSS1,RSU0,RSU1,
     +                  RU0,RU1,RU2,RU3,RUS0,RUS1,RUU0,RUU1,S1,S2,S3,S4,
     +                  S5,S6,S7,T,TWOPI
      INTEGER           J,K,K0,K1,K2,KK,L,L1,M8,MM8,MOVER2,NS,NT,SEP,
     +                  SIZE
      LOGICAL           FOLD,ZERO
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/,E/0.70710678/
C     ..
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      M8 = M*8
      FM8 = REAL(M8)
      MM8 = SEP*M8
      MOVER2 = M/2 + 1
C
      FJM1 = -1.0
      DO 50 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FM8
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C1 = COS(ANGLE)
              S1 = SIN(ANGLE)
              C2 = C1*C1 - S1*S1
              S2 = S1*C1 + C1*S1
              C3 = C2*C1 - S2*S1
              S3 = S2*C1 + C2*S1
              C4 = C2*C2 - S2*S2
              S4 = S2*C2 + C2*S2
              C5 = C4*C1 - S4*S1
              S5 = S4*C1 + C4*S1
              C6 = C4*C2 - S4*S2
              S6 = S4*C2 + C4*S2
              C7 = C4*C3 - S4*S3
              S7 = S4*C3 + C4*S3
          END IF
   10     CONTINUE
C
          DO 40 KK = K0,NS,MM8
              DO 30 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 20 K = L,K1,K2
                      RS0 = X0(K) + X4(K)
                      IS0 = Y0(K) + Y4(K)
                      RU0 = X0(K) - X4(K)
                      IU0 = Y0(K) - Y4(K)
                      RS1 = X1(K) + X5(K)
                      IS1 = Y1(K) + Y5(K)
                      RU1 = X1(K) - X5(K)
                      IU1 = Y1(K) - Y5(K)
                      RS2 = X2(K) + X6(K)
                      IS2 = Y2(K) + Y6(K)
                      RU2 = X2(K) - X6(K)
                      IU2 = Y2(K) - Y6(K)
                      RS3 = X3(K) + X7(K)
                      IS3 = Y3(K) + Y7(K)
                      RU3 = X3(K) - X7(K)
                      IU3 = Y3(K) - Y7(K)
                      RSS0 = RS0 + RS2
                      ISS0 = IS0 + IS2
                      RSU0 = RS0 - RS2
                      ISU0 = IS0 - IS2
                      RSS1 = RS1 + RS3
                      ISS1 = IS1 + IS3
                      RSU1 = RS1 - RS3
                      ISU1 = IS1 - IS3
                      RUS0 = RU0 - IU2
                      IUS0 = IU0 + RU2
                      RUU0 = RU0 + IU2
                      IUU0 = IU0 - RU2
                      RUS1 = RU1 - IU3
                      IUS1 = IU1 + RU3
                      RUU1 = RU1 + IU3
                      IUU1 = IU1 - RU3
                      T = (RUS1+IUS1)*E
                      IUS1 = (IUS1-RUS1)*E
                      RUS1 = T
                      T = (RUU1+IUU1)*E
                      IUU1 = (IUU1-RUU1)*E
                      RUU1 = T
                      X0(K) = RSS0 + RSS1
                      Y0(K) = ISS0 + ISS1
                      IF (ZERO) THEN
                          X4(K) = RUU0 + RUU1
                          Y4(K) = IUU0 + IUU1
                          X2(K) = RSU0 + ISU1
                          Y2(K) = ISU0 - RSU1
                          X6(K) = RUS0 + IUS1
                          Y6(K) = IUS0 - RUS1
                          X1(K) = RSS0 - RSS1
                          Y1(K) = ISS0 - ISS1
                          X5(K) = RUU0 - RUU1
                          Y5(K) = IUU0 - IUU1
                          X3(K) = RSU0 - ISU1
                          Y3(K) = ISU0 + RSU1
                          X7(K) = RUS0 - IUS1
                          Y7(K) = IUS0 + RUS1
                      ELSE
                          R1 = RUU0 + RUU1
                          I1 = IUU0 + IUU1
                          R2 = RSU0 + ISU1
                          I2 = ISU0 - RSU1
                          R3 = RUS0 + IUS1
                          I3 = IUS0 - RUS1
                          R4 = RSS0 - RSS1
                          I4 = ISS0 - ISS1
                          R5 = RUU0 - RUU1
                          I5 = IUU0 - IUU1
                          R6 = RSU0 - ISU1
                          I6 = ISU0 + RSU1
                          R7 = RUS0 - IUS1
                          I7 = IUS0 + RUS1
                          X4(K) = R1*C1 + I1*S1
                          Y4(K) = I1*C1 - R1*S1
                          X2(K) = R2*C2 + I2*S2
                          Y2(K) = I2*C2 - R2*S2
                          X6(K) = R3*C3 + I3*S3
                          Y6(K) = I3*C3 - R3*S3
                          X1(K) = R4*C4 + I4*S4
                          Y1(K) = I4*C4 - R4*S4
                          X5(K) = R5*C5 + I5*S5
                          Y5(K) = I5*C5 - R5*S5
                          X3(K) = R6*C6 + I6*S6
                          Y3(K) = I6*C6 - R6*S6
                          X7(K) = R7*C7 + I7*S7
                          Y7(K) = I7*C7 - R7*S7
                      END IF
   20                 CONTINUE
   30             CONTINUE
   40         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              T = (C1+S1)*E
              S1 = (C1-S1)*E
              C1 = T
              T = S2
              S2 = C2
              C2 = T
              T = (-C3+S3)*E
              S3 = (C3+S3)*E
              C3 = T
              C4 = -C4
              T = - (C5+S5)*E
              S5 = (-C5+S5)*E
              C5 = T
              T = -S6
              S6 = -C6
              C6 = T
              T = (C7-S7)*E
              S7 = - (C7+S7)*E
              C7 = T
              GO TO 10
          END IF
   50     CONTINUE
C
      END
C
C
      SUBROUTINE RPCFTK(N,M,P,R,X,Y,DIM)
C     ==========================================
C
C
C---- Radix prime multi-dimensional complex fourier transform kernel
C
C     .. Scalar Arguments ..
      INTEGER           M,N,P,R
C     ..
C     .. Array Arguments ..
      REAL              X(R,P),Y(R,P)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              ANGLE,FJM1,FMP,FP,FU,IS,IU,RS,RU,T,TWOPI,XT,YT
      INTEGER           J,JJ,K,K0,K1,K2,KK,L,L1,MMP,MOVER2,MP,NS,NT,PM,
     +                  PP,SEP,SIZE,U,V
      LOGICAL           FOLD,ZERO
C     ..
C     .. Local Arrays ..
      REAL              A(18),AA(9,9),B(18),BB(9,9),C(18),IA(9),IB(9),
     +                  RA(9),RB(9),S(18)
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
C     .. Data statements ..
      DATA              TWOPI/6.283185/
C     ..
C
C
      NT = DIM(1)
      SEP = DIM(2)
      L1 = DIM(3)
      SIZE = DIM(4) - 1
      K2 = DIM(5)
      NS = N*SEP
      MOVER2 = M/2 + 1
      MP = M*P
      FMP = REAL(MP)
      MMP = SEP*MP
      PP = P/2
      PM = P - 1
      FP = REAL(P)
      FU = 0.0
      DO 10 U = 1,PP
          FU = FU + 1.0
          ANGLE = TWOPI*FU/FP
          JJ = P - U
          A(U) = COS(ANGLE)
          B(U) = SIN(ANGLE)
          A(JJ) = A(U)
          B(JJ) = -B(U)
   10     CONTINUE
      DO 30 U = 1,PP
          DO 20 V = 1,PP
              JJ = U*V - U*V/P*P
              AA(V,U) = A(JJ)
              BB(V,U) = B(JJ)
   20         CONTINUE
   30     CONTINUE
C
      FJM1 = -1.0
      DO 140 J = 1,MOVER2
          FOLD = J .GT. 1 .AND. 2*J .LT. M + 2
          K0 = (J-1)*SEP + 1
          FJM1 = FJM1 + 1.0
          ANGLE = TWOPI*FJM1/FMP
          ZERO = ANGLE .EQ. 0.0
          IF (.NOT.ZERO) THEN
              C(1) = COS(ANGLE)
              S(1) = SIN(ANGLE)
              DO 40 U = 2,PM
                  C(U) = C(U-1)*C(1) - S(U-1)*S(1)
                  S(U) = S(U-1)*C(1) + C(U-1)*S(1)
   40             CONTINUE
          END IF
   50     CONTINUE
C
          DO 120 KK = K0,NS,MMP
              DO 110 L = KK,NT,L1
                  K1 = L + SIZE
                  DO 100 K = L,K1,K2
                      XT = X(K,1)
                      YT = Y(K,1)
                      RS = X(K,2) + X(K,P)
                      IS = Y(K,2) + Y(K,P)
                      RU = X(K,2) - X(K,P)
                      IU = Y(K,2) - Y(K,P)
                      DO 60 U = 1,PP
                          RA(U) = AA(U,1)*RS + XT
                          IA(U) = AA(U,1)*IS + YT
                          RB(U) = BB(U,1)*RU
                          IB(U) = BB(U,1)*IU
   60                     CONTINUE
                      XT = XT + RS
                      YT = YT + IS
                      DO 80 U = 2,PP
                          JJ = P - U
                          RS = X(K,U+1) + X(K,JJ+1)
                          IS = Y(K,U+1) + Y(K,JJ+1)
                          RU = X(K,U+1) - X(K,JJ+1)
                          IU = Y(K,U+1) - Y(K,JJ+1)
                          XT = XT + RS
                          YT = YT + IS
                          DO 70 V = 1,PP
                              RA(V) = AA(V,U)*RS + RA(V)
                              IA(V) = AA(V,U)*IS + IA(V)
                              RB(V) = BB(V,U)*RU + RB(V)
                              IB(V) = BB(V,U)*IU + IB(V)
   70                         CONTINUE
   80                     CONTINUE
                      X(K,1) = XT
                      Y(K,1) = YT
                      DO 90 U = 1,PP
                          JJ = P - U
                          IF (ZERO) THEN
                              X(K,U+1) = RA(U) + IB(U)
                              Y(K,U+1) = IA(U) - RB(U)
                              X(K,JJ+1) = RA(U) - IB(U)
                              Y(K,JJ+1) = IA(U) + RB(U)
                          ELSE
                              XT = RA(U) + IB(U)
                              YT = IA(U) - RB(U)
                              X(K,U+1) = C(U)*XT + S(U)*YT
                              Y(K,U+1) = C(U)*YT - S(U)*XT
                              XT = RA(U) - IB(U)
                              YT = IA(U) + RB(U)
                              X(K,JJ+1) = C(JJ)*XT + S(JJ)*YT
                              Y(K,JJ+1) = C(JJ)*YT - S(JJ)*XT
                          END IF
   90                     CONTINUE
  100                 CONTINUE
  110             CONTINUE
  120         CONTINUE
          IF (FOLD) THEN
              FOLD = .FALSE.
              K0 = (M+1-J)*SEP + 1
              DO 130 U = 1,PM
                  T = C(U)*A(U) + S(U)*B(U)
                  S(U) = -S(U)*A(U) + C(U)*B(U)
                  C(U) = T
  130             CONTINUE
              GO TO 50
          END IF
  140     CONTINUE
C
      END
C
C
      SUBROUTINE HERMFT(X,Y,N,DIM)
C     ==================================
C
C
C
C---- Hermitian symmetric fourier transform
C
C     Given the unique terms of a hermitian symmetric sequence of length
C     2N this subroutine calculates the 2N real numbers which are its
C     fourier transform.  The even numbered elements of the transform
C     (0, 2, 4, . . ., 2n-2) are returned in X and the odd numbered
C     elements (1, 3, 5, . . ., 2n-1) in Y.
C
C     A finite hermitian sequence of length 2n contains n + 1 unique
C     real numbers and n - 1 unique imaginary numbers.  For convenience
C     the real value for X(n) is stored at Y(0).
C
C
C     .. Scalar Arguments ..
      INTEGER           N
C     ..
C     .. Array Arguments ..
      REAL              X(*),Y(*)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              A,ANGLE,B,C,CO,D,E,F,SI,TWON,TWOPI
      INTEGER           D2,D3,D4,D5,I,I0,I1,I2,J,K,K1,NOVER2,NT
C     ..
C     .. External Subroutines ..
      EXTERNAL          CMPLFT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
      TWOPI = 6.283185
      TWON = REAL(2*N)
C
      NT = DIM(1)
      D2 = DIM(2)
      D3 = DIM(3)
      D4 = DIM(4) - 1
      D5 = DIM(5)
C
      DO 20 I0 = 1,NT,D3
          I1 = I0 + D4
          DO 10 I = I0,I1,D5
              A = X(I)
              B = Y(I)
              X(I) = A + B
              Y(I) = A - B
   10         CONTINUE
   20     CONTINUE
C
      NOVER2 = N/2 + 1
      IF (NOVER2.GE.2) THEN
          DO 50 I0 = 2,NOVER2
              ANGLE = REAL(I0-1)*TWOPI/TWON
              CO = COS(ANGLE)
              SI = SIN(ANGLE)
              K = (N+2-2*I0)*D2
              K1 = (I0-1)*D2 + 1
              DO 40 I1 = K1,NT,D3
                  I2 = I1 + D4
                  DO 30 I = I1,I2,D5
                      J = I + K
                      A = X(I) + X(J)
                      B = X(I) - X(J)
                      C = Y(I) + Y(J)
                      D = Y(I) - Y(J)
                      E = B*CO + C*SI
                      F = B*SI - C*CO
                      X(I) = A + F
                      X(J) = A - F
                      Y(I) = E + D
                      Y(J) = E - D
   30                 CONTINUE
   40             CONTINUE
   50         CONTINUE
C
          CALL CMPLFT(X,Y,N,DIM)
      END IF
C
C
      END
C
C
      SUBROUTINE INV21(X,Y,N,D)
C      =========================
C
C
C
C---- Inverts fourier transform along a screw
C     diad. the result is scaled by n.
C
C
C     .. Scalar Arguments ..
      INTEGER          N
C     ..
C     .. Array Arguments ..
      REAL             X(*),Y(*)
      INTEGER          D(5)
C     ..
C     .. Local Scalars ..
      REAL             A,B,C,C1,PI,R,S,S1
      INTEGER          D1,D2,D3,D4,D5,I,J,J1,J2,J3,K,KK,L,LL,M,NOVER2
C     ..
C     .. External Subroutines ..
      EXTERNAL         CMPLFT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC        COS,REAL,SIN
C     ..
      PI = 3.141593
C
      D1 = D(1)
      D2 = D(2)
      D3 = D(3)
      D4 = D(4) - 1
      D5 = D(5)
C
      NOVER2 = N/2
      LL = N*D2
      KK = NOVER2*D2
      DO 20 J1 = 1,D1,D3
          J2 = J1 + D4
          DO 10 J = J1,J2,D5
              L = LL + J
              K = KK + J
              X(L) = X(J) + X(K)
              X(K) = X(K) + Y(K)
              Y(L) = 0.0
              Y(K) = 0.0
   10         CONTINUE
   20     CONTINUE
C
      C1 = COS(PI/REAL(N))
      S1 = SIN(PI/REAL(N))
      C = 1.0
      S = 0.0
      DO 50 I = 2,NOVER2
          KK = (N+2-2*I)*D2
          LL = (N+1-I)*D2
          R = C*C1 - S*S1
          S = C*S1 + S*C1
          C = R
          J1 = (I-1)*D2 + 1
          DO 40 J2 = J1,D1,D3
              J3 = J2 + D4
              DO 30 J = J2,J3,D5
                  L = J + LL
                  K = J + KK
                  X(L) = X(L) + X(J) + X(K)
                  X(J) = Y(J)*S + X(J)
                  X(K) = Y(K)*S + X(K)
                  Y(J) = Y(J)*C
                  Y(K) = -Y(K)*C
   30             CONTINUE
   40         CONTINUE
   50     CONTINUE
C
      CALL CMPLFT(X,Y,N,D)
C
      DO 80 I = 1,NOVER2
          KK = (N+1-2*I)*D2
          LL = I*D2 + KK
          J1 = (I-1)*D2 + 1
          DO 70 J2 = J1,D1,D3
              J3 = J2 + D4
              DO 60 J = J2,J3,D5
                  K = J + KK
                  L = J + LL
                  A = X(J) - X(L)
                  B = Y(J) + Y(L)
                  X(J) = X(L)
                  Y(J) = -Y(L)
                  X(L) = X(K) + A
                  Y(L) = Y(K) - B
                  X(K) = A
                  Y(K) = B
   60             CONTINUE
   70         CONTINUE
   80     CONTINUE
C
      M = N - 2
      DO 130 I = 1,M
          K = I
   90     CONTINUE
          J = K
          K = J/2
          IF (2*K.NE.J) K = N - 1 - K
          IF (K-I) 90,130,100
  100     KK = (K-I)*D2
          J1 = I*D2 + 1
          DO 120 J2 = J1,D1,D3
              J3 = J2 + D4
              DO 110 J = J2,J3,D5
                  K = J + KK
                  A = X(K)
                  B = Y(K)
                  X(K) = X(J)
                  Y(K) = Y(J)
                  X(J) = A
                  Y(J) = B
  110             CONTINUE
  120         CONTINUE
  130     CONTINUE
C
C
      END
C
C
      SUBROUTINE REALFT(EVEN,ODD,N,DIM)
C      ======================================
C
C
C
C     REAL FOURIER TRANSFORM
C
C     Given a real sequence of length 2n this subroutine calculates the
C     unique part of the fourier transform.  The fourier transform has
C     n + 1 unique real parts and n - 1 unique imaginary parts.  Since
C     the real part at x(n) is frequently of interest, this subroutine
C     stores it at x(n) rather than in y(0).  Therefore x and y must be
C     of length n + 1 instead of n.  Note that this storage arrangement
C     is different from that employed by the hermitian fourier transform
C     subroutine.
C
C     For convenience the data is presented in two parts, the first
C     containing the even numbered real terms and the second containing
C     the odd numbered terms (numbering starting at 0).  On return the
C     real part of the transform replaces the even terms and the
C     imaginary part of the transform replaces the odd terms.
C
C
C     .. Scalar Arguments ..
      INTEGER           N
C     ..
C     .. Array Arguments ..
      REAL              EVEN(*),ODD(*)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              A,ANGLE,B,C,CO,D,E,F,SI,TWON,TWOPI
      INTEGER           D2,D3,D4,D5,I,I0,I1,I2,J,K,L,NOVER2,NT
C     ..
C     .. External Subroutines ..
      EXTERNAL          CMPLFT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
      TWOPI = 6.283185
      TWON = REAL(2*N)
C
      CALL CMPLFT(EVEN,ODD,N,DIM)
C
      NT = DIM(1)
      D2 = DIM(2)
      D3 = DIM(3)
      D4 = DIM(4) - 1
      D5 = DIM(5)
      NOVER2 = N/2 + 1
C
      IF (NOVER2.GE.2) THEN
          DO 30 I = 2,NOVER2
              ANGLE = REAL(I-1)*TWOPI/TWON
              CO = COS(ANGLE)
              SI = SIN(ANGLE)
              I0 = (I-1)*D2 + 1
              J = (N+2-2*I)*D2
              DO 20 I1 = I0,NT,D3
                  I2 = I1 + D4
                  DO 10 K = I1,I2,D5
                      L = K + J
                      A = (EVEN(L)+EVEN(K))/2.0
                      C = (EVEN(L)-EVEN(K))/2.0
                      B = (ODD(L)+ODD(K))/2.0
                      D = (ODD(L)-ODD(K))/2.0
                      E = C*SI + B*CO
                      F = C*CO - B*SI
                      EVEN(K) = A + E
                      EVEN(L) = A - E
                      ODD(K) = F - D
                      ODD(L) = F + D
   10                 CONTINUE
   20             CONTINUE
   30         CONTINUE
      END IF
C
      IF (N.GE.1) THEN
          J = N*D2
          DO 50 I1 = 1,NT,D3
              I2 = I1 + D4
              DO 40 K = I1,I2,D5
                  L = K + J
                  EVEN(L) = EVEN(K) - ODD(K)
                  ODD(L) = 0.0
                  EVEN(K) = EVEN(K) + ODD(K)
                  ODD(K) = 0.0
   40             CONTINUE
   50         CONTINUE
      END IF
C
C
      END
C
C
      SUBROUTINE RSYMFT(X,N,DIM)
C      ===============================
C
C
C
C     REAL SYMMETRIC MULTIDIMENSIONAL FOURIER TRANSFORM
C
C     N must be a multiple of 4.  The two unique elements are stored at
C     X(1) and X(n+1).
C
C     Decimation in frequency applied to a real symmetric sequence of
C     length 2n gives a real symmetric sequence of length n, the
C     transform of which gives the even numbered fourier coefficients,
C     and a hermitian symmetric sequence of length n, the transform of
C     which gives the odd numbered fourier coefficients.  The sum of
C     the two sequences is a hermitian symmetric sequence of length n,
C     which may be stored in n/2 complex locations.  The transform of
C     this sequence is n real numbers representing the term by term sum
C     of the even and odd numbered fourier coefficients.  This symmetric
C     sequence may be solved if any of the fourier coefficients are
C     known.  For this purpose x0, which is simply the sum of the
C     original sequence, is computed and saved in x(n+1).
C
C
C     .. Scalar Arguments ..
      INTEGER           N
C     ..
C     .. Array Arguments ..
      REAL              X(*)
      INTEGER           DIM(5)
C     ..
C     .. Local Scalars ..
      REAL              A,ANGLE,B,C,CO,D,SI,TWON,TWOPI
      INTEGER           D1,D2,D3,D4,D5,I,I0,I1,I2,II,J,J0,J1,J2,K,K0,K1,
     +                  K2,L,M,MJ,MK,ML,MM,MOD,N2,NN,NOVER2,NOVER4,TEST,
     +                  TWOD2
C     ..
C     .. External Subroutines ..
      EXTERNAL          HERMFT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC         COS,REAL,SIN
C     ..
      IF (N.NE.1) THEN
          NOVER2 = N/2
          NOVER4 = N/4
          IF (4*NOVER4.NE.N) THEN
C
              WRITE (6,FMT=9000) N
              call ccperr(1,' stop in fftlib.for 2000')
          ELSE
              D1 = DIM(1)
              D2 = DIM(2)
              D3 = DIM(3)
              D4 = DIM(4) - 1
              D5 = DIM(5)
              TWOPI = 6.283185
              TWON = REAL(2*N)
              TWOD2 = 2*D2
C
              K0 = N*D2 + 1
              DO 20 K1 = K0,D1,D3
                  K2 = K1 + D4
                  DO 10 K = K1,K2,D5
                      X(K) = X(K)/2.0
   10                 CONTINUE
   20             CONTINUE
C
              DO 50 I = 2,NOVER2
                  ANGLE = REAL(I-1)*TWOPI/TWON
                  CO = COS(ANGLE)
                  SI = SIN(ANGLE)
                  K0 = (I-1)*D2 + 1
                  J0 = (N+2-2*I)*D2
                  J1 = (N+1-I)*D2
                  DO 40 K1 = K0,D1,D3
                      K2 = K1 + D4
                      DO 30 K = K1,K2,D5
                          L = K + J0
                          NN = K + J1
                          A = X(L) + X(K)
                          B = X(L) - X(K)
                          X(K) = A - B*CO
                          X(L) = B*SI
                          X(NN) = X(NN) + A
   30                     CONTINUE
   40                 CONTINUE
   50             CONTINUE
C
              IF (NOVER4.NE.1) THEN
                  J0 = NOVER4 - 1
                  DO 80 I = 1,J0
                      K0 = (NOVER2+I)*D2 + 1
                      J1 = (NOVER2-2*I)*D2
                      DO 70 K1 = K0,D1,D3
                          K2 = K1 + D4
                          DO 60 K = K1,K2,D5
                              L = K + J1
                              A = X(K)
                              X(K) = X(L)
                              X(L) = A
   60                         CONTINUE
   70                     CONTINUE
   80                 CONTINUE
              END IF
C
              J0 = NOVER2*D2
              J1 = N*D2
              DO 100 K1 = 1,D1,D3
                  K2 = K1 + D4
                  DO 90 K = K1,K2,D5
                      I = K + J0
                      L = K + J1
                      X(I) = X(I)*2.0
                      X(L) = X(K) + X(I) + X(L)*2.0
                      X(K) = X(K)*2.0
   90                 CONTINUE
  100             CONTINUE
C
              K = NOVER2*D2 + 1
              CALL HERMFT(X(1),X(K),NOVER2,DIM)
C
C---- Solve the equations for all of the sequences
C
              I0 = 1 - D2
              MK = NOVER2*D2
              MJ = MK + D2
              ML = N*D2 + D2
              MM = ML
              DO 130 II = 1,NOVER4
                  I0 = I0 + D2
                  MJ = MJ - TWOD2
                  ML = ML - TWOD2
                  MM = MM - D2
                  DO 120 I1 = I0,D1,D3
                      I2 = I1 + D4
                      DO 110 I = I1,I2,D5
                          J = I + MJ
                          K = I + MK
                          L = I + ML
                          M = I + MM
                          A = X(I) - X(M)
                          B = X(L) - A
                          C = X(K) - B
                          D = X(J) - C
                          X(I) = X(M)
                          X(J) = A
                          X(K) = B
                          X(L) = C
                          X(M) = D
  110                     CONTINUE
  120                 CONTINUE
  130             CONTINUE
C
C---- The results are now in a scrambled digit reversed order, i.e.
C     x(1), x(5), x(9), ..., x(10), x(6), x(2), ..., x(3), x(7), x(11),
C     ..., x(12), x(8), x(4).  the following section of program follows
C     the permutation cycles and does the necessary interchanges.
C
              IF (NOVER4.NE.1) THEN
                  NN = N - 2
                  DO 170 I = 1,NN
                      K = I
  140                 CONTINUE
C
                      K0 = K/4
                      L = K - K0*4
                      IF (L.NE. (L/2)*2) K0 = NOVER4 - 1 - K0
                      K = L*NOVER4 + K0
                      IF (K.LT.I) GO TO 140
                      IF (K.NE.I) THEN
C
                          K0 = I*D2 + 1
                          J0 = (K-I)*D2
                          DO 160 K1 = K0,D1,D3
                              K2 = K1 + D4
                              DO 150 K = K1,K2,D5
                                  L = K + J0
                                  A = X(K)
                                  X(K) = X(L)
                                  X(L) = A
  150                             CONTINUE
  160                         CONTINUE
                      END IF
  170                 CONTINUE
              END IF
          END IF
      END IF
C
C---- Format statements
C
 9000 FORMAT ('0N NOT A MULTIPLE OF 4 IN R SYM FT.  N =',I10,//)
      END
C
C
      SUBROUTINE SDIAD(X,Y,N,DIM)
C      ===============================
C
C
C
C     This subroutine computes half the fourier synthesis along a screw
C     diad lying along a crystallographic axis given half the fourier
C     coefficients.  That is, it assumes that f(t) = conjg(f(-t)) for t
C     even and f(t) = -conjg(f(-t)) for t odd.  n is the length of the
C     desired half of the transform.  The location x(n+1) is required as
C     a scratch location and therefore a value is also returned in
C     x(n+1) and y(n+1).  The value of the second half of the transform
C     may be generated from the first half by the formula x(n+t) = x(t),
C     y(n+t) = -y(t).  In other words, the last half of the transform is
C     the complex conjugate of the first half.
C
C     The transform is calculated by forming the sum of the even terms
C     and the odd terms in place, using the symmetry relations to
C     obtain the values for negative subscripts.  The transform of the
C     resulting sequence may be separated by using the fact that the
C     transform of the even terms is real, while the prodct of the
C     transform of the odd terms and (cos(pi*t/n) - i*sin(pi*t/n)) is
C     imaginary.  The scratch location is required because the formula
C     for separating the two transforms breaks down when t = n/2.
C
C
C Corrections from A.D.MCLACHLAN 1980, put here sep 1985
C errors in original algorithm for the scratch location which
C assumed f(n)=0
C
C
C
C     .. Scalar Arguments ..
      INTEGER          N
C     ..
C     .. Array Arguments ..
      REAL             X(*),Y(*)
      INTEGER          DIM(5)
C     ..
C     .. Local Scalars ..
      REAL             A,ANGLE,C,S,TWON,TWOPI
      INTEGER          D1,D2,D3,D4,D5,I,J,K,K0,K1,K2,L,M,MM,MN,NN,NOVER2
      LOGICAL          FOLD
C     ..
C     .. External Subroutines ..
      EXTERNAL         CMPLFT
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC        COS,REAL,SIN
C     ..
      NOVER2 = N/2
      IF (2*NOVER2.NE.N) THEN
C
          WRITE (6,FMT=9000) N
          call ccperr(1,' stop in fftlib.for 3000')
      ELSE
          TWON = REAL(2*N)
          TWOPI = 6.2831852
          D1 = DIM(1)
          D2 = DIM(2)
          D3 = DIM(3)
          D4 = DIM(4) - 1
          D5 = DIM(5)
C
          S = -1.0
          IF (NOVER2.EQ. (2* (NOVER2/2))) S = -S
          K0 = (N-1)*D2 + 1
          DO 20 K1 = K0,D1,D3
              K2 = K1 + D4
              DO 10 K = K1,K2,D5
                  L = K + D2
                  Y(L) = X(K)*S
   10             CONTINUE
   20         CONTINUE
          S = 1.0
          NN = N - 2
          DO 50 I = 1,NN,2
              S = -S
              MN = (N+1-I)*D2
              K0 = (I-1)*D2 + 1
              DO 40 K1 = K0,D1,D3
                  K2 = K1 + D4
                  DO 30 K = K1,K2,D5
                      J = K + D2
                      L = 2*D2 + K
                      M = K + MN
                      Y(M) = X(J)*S + Y(M)
                      X(K) = X(K) + X(J)
                      X(J) = X(L) - X(J)
                      Y(K) = Y(K) + Y(J)
                      Y(J) = Y(J) - Y(L)
   30                 CONTINUE
   40             CONTINUE
   50         CONTINUE
          K0 = (N-2)*D2 + 1
          DO 70 K1 = K0,D1,D3
              K2 = K1 + D4
              DO 60 K = K1,K2,D5
                  L = K + D2
                  X(K) = X(K) + X(L)
                  Y(K) = Y(K) + Y(L)
                  J = L + D2
                  X(L) = X(J) - X(L)
   60             CONTINUE
   70         CONTINUE
C
C---- Reorder scrambled fourier coefficients
C
          DO 110 I = 1,NN
              K = I
   80         CONTINUE
              K = 2*K
              IF (K.GT.N-1) K = 2*N - 1 - K
              IF (K.LT.I) GO TO 80
              IF (K.NE.I) THEN
                  J = (K-I)*D2
                  K0 = I*D2 + 1
                  DO 100 K1 = K0,D1,D3
                      K2 = K1 + D4
                      DO 90 K = K1,K2,D5
                          L = K + J
                          A = X(K)
                          X(K) = X(L)
                          X(L) = A
                          A = Y(K)
                          Y(K) = Y(L)
                          Y(L) = A
   90                     CONTINUE
  100                 CONTINUE
              END IF
  110         CONTINUE
C
          CALL CMPLFT(X,Y,N,DIM)
C
          M = NOVER2 - 1
          DO 150 I = 1,M
              ANGLE = REAL(I)*TWOPI/TWON
              C = COS(ANGLE)
              S = SIN(ANGLE)
              K0 = I*D2 + 1
              FOLD = .TRUE.
  120         CONTINUE
C
              DO 140 K1 = K0,D1,D3
                  K2 = K1 + D4
                  DO 130 K = K1,K2,D5
                      A = Y(K)/C
                      X(K) = X(K) + S*A
                      Y(K) = A
  130                 CONTINUE
  140             CONTINUE
              IF (FOLD) THEN
C
                  C = -C
                  K0 = (N-I)*D2 + 1
                  FOLD = .FALSE.
                  GO TO 120
              END IF
  150         CONTINUE
C
          M = NOVER2*D2
          K0 = M + 1
          DO 170 K1 = K0,D1,D3
              K2 = K1 + D4
              DO 160 K = K1,K2,D5
                  J = K - M
                  L = K + M
                  A = Y(L)*2.0
                  X(K) = X(K) + A
                  Y(K) = A
                  X(L) = X(J)
                  Y(L) = -Y(J)
  160             CONTINUE
  170         CONTINUE
C
      END IF
C
C---- Format statements
C
 9000 FORMAT ('0SDIAD N ODD.  N =',I10)
      END
C
C
      SUBROUTINE DIPRP(PTS,SYM,PSYM,UNSYM,DIM,X,Y)
C     =================================================
C
C
C---- Double in place reordering programme
C
C
C     .. Scalar Arguments ..
      INTEGER          PSYM,PTS
C     ..
C     .. Array Arguments ..
      REAL             X(10),Y(10)
      INTEGER          DIM(5),SYM(10),UNSYM(10)
C     ..
C     .. Local Scalars ..
      REAL             T
      INTEGER          A,AL,B,BL,BS,C,CL,CS,D,DELTA,DK,DL,DS,E,EL,ES,F,
     +                 FL,FS,G,GL,GS,H,HL,HS,I,IL,IS,J,JJ,JL,JS,K,KK,KL,
     +                 KS,L,LK,LL,LS,M,ML,MODS,MS,MULT,N,NEST,NL,NS,NT,
     +                 P,P0,P1,P2,P3,P4,P5,PUNSYM,SEP,SIZE,TEST
      LOGICAL          ONEMOD
C     ..
C     .. Local Arrays ..
      INTEGER          MODULO(14),S(14),U(14)
C     ..
C     .. Equivalences ..
      EQUIVALENCE      (AL,U(1)), (BS,S(2)), (BL,U(2))
      EQUIVALENCE      (CS,S(3)), (CL,U(3)), (DS,S(4)), (DL,U(4))
      EQUIVALENCE      (ES,S(5)), (EL,U(5)), (FS,S(6)), (FL,U(6))
      EQUIVALENCE      (GS,S(7)), (GL,U(7)), (HS,S(8)), (HL,U(8))
      EQUIVALENCE      (IS,S(9)), (IL,U(9)), (JS,S(10)), (JL,U(10))
      EQUIVALENCE      (KS,S(11)), (KL,U(11)), (LS,S(12)), (LL,U(12))
      EQUIVALENCE      (MS,S(13)), (ML,U(13)), (NS,S(14)), (NL,U(14))
C     ..
      NEST = 14
C
      NT = DIM(1)
      SEP = DIM(2)
      P2 = DIM(3)
      SIZE = DIM(4) - 1
      P4 = DIM(5)
      IF (SYM(1).NE.0) THEN
          DO 10 J = 1,NEST
              U(J) = 1
              S(J) = 1
   10         CONTINUE
          N = PTS
          DO 20 J = 1,NEST
              IF (SYM(J).EQ.0) THEN
                  GO TO 30
              ELSE
                  JJ = NEST + 1 - J
                  U(JJ) = N
                  S(JJ) = N/SYM(J)
                  N = N/SYM(J)
              END IF
   20         CONTINUE
C
   30     JJ = 0
          DO 190 A = 1,AL
              DO 180 B = A,BL,BS
                  DO 170 C = B,CL,CS
                      DO 160 D = C,DL,DS
                          DO 150 E = D,EL,ES
                              DO 140 F = E,FL,FS
                                  DO 130 G = F,GL,GS
                                      DO 120 H = G,HL,HS
                                          DO 110 I = H,IL,IS
                                              DO 100 J = I,JL,JS
                                                 DO 90 K = J,KL,KS
                                                 DO 80 L = K,LL,LS
                                                 DO 70 M = L,ML,MS
                                                 DO 60 N = M,NL,NS
                                                 JJ = JJ + 1
                                                 IF (JJ.LT.N) THEN
                                                 DELTA = (N-JJ)*SEP
                                                 P1 = (JJ-1)*SEP + 1
                                                 DO 50 P0 = P1,NT,P2
                                                 P3 = P0 + SIZE
                                                 DO 40 P = P0,P3,P4
                                                 P5 = P + DELTA
                                                 T = X(P)
                                                 X(P) = X(P5)
                                                 X(P5) = T
                                                 T = Y(P)
                                                 Y(P) = Y(P5)
                                                 Y(P5) = T
   40                                            CONTINUE
   50                                            CONTINUE
                                                 END IF
   60                                            CONTINUE
   70                                            CONTINUE
   80                                            CONTINUE
   90                                            CONTINUE
  100                                            CONTINUE
  110                                         CONTINUE
  120                                     CONTINUE
  130                                 CONTINUE
  140                             CONTINUE
  150                         CONTINUE
  160                     CONTINUE
  170                 CONTINUE
  180             CONTINUE
  190         CONTINUE
      END IF
C
      IF (UNSYM(1).NE.0) THEN
          PUNSYM = PTS/PSYM**2
          MULT = PUNSYM/UNSYM(1)
          TEST = (UNSYM(1)*UNSYM(2)-1)*MULT*PSYM
          LK = MULT
          DK = MULT
          DO 200 K = 2,NEST
              IF (UNSYM(K).EQ.0) THEN
                  GO TO 210
              ELSE
                  LK = UNSYM(K-1)*LK
                  DK = DK/UNSYM(K)
                  U(K) = (LK-DK)*PSYM
                  MODS = K
              END IF
  200         CONTINUE
  210     ONEMOD = MODS .LT. 3
          IF (.NOT.ONEMOD) THEN
              DO 220 J = 3,MODS
                  JJ = MODS + 3 - J
                  MODULO(JJ) = U(J)
  220             CONTINUE
          END IF
          MODULO(2) = U(2)
          JL = (PUNSYM-3)*PSYM
          MS = PUNSYM*PSYM
C
          DO 290 J = PSYM,JL,PSYM
              K = J
  230         CONTINUE
C
              K = K*MULT
              IF (.NOT.ONEMOD) THEN
                  DO 240 I = 3,MODS
                      K = K - (K/MODULO(I))*MODULO(I)
  240                 CONTINUE
              END IF
              IF (K.GE.TEST) THEN
                  K = K - (K/MODULO(2))*MODULO(2) + MODULO(2)
              ELSE
                  K = K - (K/MODULO(2))*MODULO(2)
              END IF
              IF (K.LT.J) GO TO 230
C
              IF (K.NE.J) THEN
                  DELTA = (K-J)*SEP
                  DO 280 L = 1,PSYM
                      DO 270 M = L,PTS,MS
                          P1 = (M+J-1)*SEP + 1
                          DO 260 P0 = P1,NT,P2
                              P3 = P0 + SIZE
                              DO 250 JJ = P0,P3,P4
                                  KK = JJ + DELTA
                                  T = X(JJ)
                                  X(JJ) = X(KK)
                                  X(KK) = T
                                  T = Y(JJ)
                                  Y(JJ) = Y(KK)
                                  Y(KK) = T
  250                             CONTINUE
  260                         CONTINUE
  270                     CONTINUE
  280                 CONTINUE
              END IF
  290         CONTINUE
      END IF
C
      END


subroutine dos_calc

   use mpi
   use para
   implicit none

   !> the integration k space
   real(dp) :: kxmin
   real(dp) :: kxmax
   real(dp) :: kymin
   real(dp) :: kymax
   real(dp) :: kzmin
   real(dp) :: kzmax
   real(dp) :: emin
   real(dp) :: emax

   integer :: ik
   integer :: ie
   integer :: ib
   integer :: ikx
   integer :: iky
   integer :: ikz
   integer :: knv3
   integer :: NE
   integer :: ierr

   !> integration for band
   integer :: iband_low
   integer :: iband_high

   real(dp) :: x
   real(dp) :: dkx
   real(dp) :: dky
   real(dp) :: dkz

   real(dp) :: k(3)

   real(dp), allocatable :: kpoints(:, :)
   real(dp), allocatable :: eigval(:, :)
   real(dp), allocatable :: eigval_mpi(:, :)
   real(dp), allocatable :: W(:)
   real(dp), allocatable :: omega(:)
   real(dp), allocatable :: dos(:)
   complex(dp), allocatable :: Hk(:, :)

   !> delta function
   real(dp), external :: delta

   knv3= Nk*Nk*Nk
   NE= 100

   allocate(W(Num_wann))
   allocate(Hk(Num_wann, Num_wann))
   allocate(eigval(Num_wann, knv3))
   allocate(eigval_mpi(Num_wann, knv3))
   allocate(kpoints(3, knv3))
   allocate(dos(NE))
   allocate(omega(NE))
   kpoints= 0d0
   eigval= 0d0
   eigval_mpi= 0d0

   iband_low= 56
   iband_high= 57
   !> around (0.1225, 0.012)
   kxmin= 0.12d0
   kxmax= 0.125d0
   kymin= 0.005d0
   kymax= 0.018d0
   kzmin= -0.010d0
   kzmax=  0.01d0

   !> around (0.1140, 0.038)
  !kxmin= 0.11d0
  !kxmax= 0.120d0
  !kymin= 0.032d0
  !kymax= 0.045d0
  !kzmin= -0.010d0
  !kzmax=  0.01d0

   !> around (0.1140, 0.038)
  !kxmin= 0.11d0
  !kxmax= 0.125d0
  !kymin= 0.005d0
  !kymax= 0.045d0
  !kzmin= -0.010d0
  !kzmax=  0.01d0

   ik= 0
   do ikx= 1, Nk
   do iky= 1, Nk
   do ikz= 1, Nk
      ik= ik+ 1
      kpoints(1, ik)= kxmin+ (kxmax-kxmin)*(ikx-1d0)/dble(Nk)
      kpoints(2, ik)= kymin+ (kymax-kymin)*(iky-1d0)/dble(Nk)
      kpoints(3, ik)= kzmin+ (kzmax-kzmin)*(ikz-1d0)/dble(Nk)
   enddo
   enddo
   enddo
   dkx= (kxmax-kxmin)/dble(Nk)
   dky= (kymax-kymin)/dble(Nk)
   dkz= (kzmax-kzmin)/dble(Nk)

   !> get eigenvalue
   do ik=1+cpuid, knv3, num_cpu
      if (cpuid.eq.0) print *, 'ik, knv3', ik, knv3
      k= kpoints(:, ik)
      call ham_bulk(k, Hk)
      W= 0d0
      call eigensystem_c( 'N', 'U', Num_wann ,Hk, W)
      eigval_mpi(:, ik)= W
   enddo
   call mpi_allreduce(eigval_mpi,eigval,size(eigval),&
                      mpi_dp,mpi_sum,mpi_cmw,ierr)

   emin= minval(eigval(iband_low,:))
   emax= maxval(eigval(iband_high,:))
   eta= (emax- emin)/ dble(NE)*3d0

   !> energy
   do ie=1, NE
      omega(ie)= emin+ (emax-emin)* (ie-1d0)/dble(NE-1)
   enddo ! ie

   !> get density of state
   dos= 0d0
   do ie= 1, NE
      if (cpuid.eq.0) print *, 'ie, NE', ie, NE
      !> intergrate with k
      do ik= 1, knv3
         do ib= iband_low, iband_high
            x= omega(ie)- eigval(ib, ik)
            dos(ie) = dos(ie)+ delta(eta, x)
         enddo ! ib
      enddo ! ik
      dos(ie)= dos(ie)*dkx*dky*dkz
   enddo ! ie

   if (cpuid.eq.0) then
      open(unit=100, file='dos.dat')
      do ie=1, NE
         write(100, *)omega(ie), dos(ie)
      enddo ! ie
      close(100)
   endif

   return
end subroutine dos_calc

function delta(eta, x)
   implicit none
   integer, parameter :: dp=kind(1d0)
   integer, parameter :: pi= 3.1415926535d0
   real(dp), intent(in) :: eta
   real(dp), intent(in) :: x
   real(dp) :: delta

   delta= 1d0/pi*eta/(eta*eta+x*x)
  !delta= exp(-x*x/eta/eta/2d0)/sqrt(2d0*pi)/eta

end function


C****************************************************************
C BISPECT.FOR
C Program to compute the bispectrum of a single frame
C and test the routines used in DECODE_MAMA
C JLP
C Version: 10-06-92
C****************************************************************
	PROGRAM BISPECT

C  POUR IR=25
	PARAMETER(IDIM=256,NGMAX=187566)

C  POUR IR=30
C	PARAMETER(IDIM=256,NGMAX=388400)

	REAL IMAGE(IDIM,IDIM),IM(IDIM,IDIM),SNRM(IDIM,IDIM)
	REAL YCE1(NGMAX,4),PSF(IDIM,IDIM),MODSQ(IDIM,IDIM)
	INTEGER IR,NBETA,NGAMMA
	CHARACTER NAME1*40,NAME2*40,NAME*40,COMMENTS*80
C
	CALL JLP_BEGIN

	OPEN(2,FILE='bispect.log',STATUS='UNKNOWN',
     1	ACCESS='SEQUENTIAL')

C UV coverage:
	WRITE(6,*) ' Radius of uv-coverage (IR) ?'
	READ(5,*) IR
	CALL COVERA(IR,NBETA,NGAMMA)

C FORMAT FICHIER
	CALL JLP_INQUIFMT

C Input image:
	WRITE(6,37) IDIM,IDIM
37	FORMAT(' Input object : (max size :',I4,'x',I4,')')
	NAME1=' '
	CALL JLP_READIMAG(IMAGE,NX,NY,IDIM,NAME1,COMMENTS)

C Simulates the effects of the telescope on the modulus of the FFT:
C@	WRITE(6,38)
C@ 38	FORMAT(' Input psf (modulus squared): (same size as object)')
C@	NAME2=' '
C2	CALL JLP_READIMAG(PSF,NX,NY,IDIM,NAME2,COMMENTS)

C@	CALL SIMU_PSF(IMAGE,MIM,PSF,NX,NY,IDIM)

C Null imaginary part:
	CALL ERASE(IM,NX,NY,IDIM)

C Spectrum by FFT:
        CALL FFT_2D(IMAGE,IM,NX,NY,IDIM,1)

C Preparing the next step:
	CALL ERASE(MODSQ,NX,NY,IDIM)
	CALL ERASE(SNRM,NX,NY,IDIM)
	CALL ERASE(YCE1,NGAMMA,4,NGMAX)

C Bispectrum:
C Processing this image now:  bispec1 is with photon noise correction
C bispec2 is without
C	CALL BISPEC1(IMAGE,IM,MODSQ,SNRM,NX,NY,IDIM,
C     1	YCE1,IR,NBETA,NGAMMA)
	IFRAME=1
	CALL BISPEC2(IMAGE,IM,MODSQ,SNRM,NX,NY,IDIM,
     1	YCE1,IR,NBETA,NGAMMA,IFRAME)

C Output:
	WRITE(6,42)
	WRITE(2,42)
42	FORMAT(' Squared modulus: output in b_modsq ',/,
     1	' Real part:      b_real',/,
     1	' Imaginary part: b_imag')

	CALL RECENTRE(MODSQ,MODSQ,NX,NY,IDIM)
	CALL RECENTRE(IMAGE,IMAGE,NX,NY,IDIM)
	CALL RECENTRE(IM,IM,NX,NY,IDIM)

	WRITE(COMMENTS,43) NAME1(1:20)
43	FORMAT(' MODSQ of ',A20)
	NAME='b_modsq'
	CALL JLP_WRITEIMAG(MODSQ,NX,NY,IDIM,NAME,COMMENTS)

	WRITE(COMMENTS,44) NAME1(1:20)
C@	WRITE(COMMENTS,44) NAME1(1:20),NAME2(1:14)
44	FORMAT(' Real part of ',A20)
C244	FORMAT(' Real part of ',A20,' PSF: ',A14)
	NAME='b_real'
	CALL JLP_WRITEIMAG(IMAGE,NX,NY,IDIM,NAME,COMMENTS)

	WRITE(COMMENTS,45) NAME1(1:20)
C@45	FORMAT(' Imag. part of ',A20,' PSF: ',A14)
45	FORMAT(' Imag. part of ',A20)
	NAME='b_imag'
	CALL JLP_WRITEIMAG(IM,NX,NY,IDIM,NAME,COMMENTS)

C	WRITE(COMMENTS,46) NAME1(1:20)
C46	FORMAT(' Transformation of: ',A20)
C@46	FORMAT(' Transformation of: ',A20,' PSF: ',A14)
C	NAME='b_object'
C	CALL JLP_WRITEIMAG(IMAGE,NX,NY,IDIM,NAME,COMMENTS)

C Bispectrum : YCE1
	DO I=1,NGAMMA
	  YCE1(I,3)=1.
	  YCE1(I,4)=1.
	END DO
	WRITE(2,41)
	WRITE(6,41)
41	FORMAT(' BISPECTRUM (List) in b_bisp ')
	WRITE(2,51) NAME1(1:20)
	WRITE(COMMENTS,51) NAME1(1:20)
C@51	FORMAT(' Bispectrum of ',A20,' PSF: ',A14)
51	FORMAT(' Bispectrum of ',A20)
	NAME='b_bisp'
	CALL JLP_WRITEIMAG(YCE1,NGAMMA,4,NGMAX,NAME,COMMENTS)

	WRITE(6,*) ' Log File in "bispect.log"'
	CLOSE(2)
	CALL JLP_END
	STOP
	END
C******************************************************************
	SUBROUTINE ERASE(ARRAY,NX,NY,IDIM)
	REAL ARRAY(IDIM,*)
	INTEGER NX,NY

	DO J=1,NY
	  DO I=1,NX
	    ARRAY(I,J)=0.
	  END DO
	END DO

	RETURN
	END
C******************************************************************
C Subroutine SIMU_PSF
C To take into account the effects of the PSF of the telescope
C******************************************************************
	SUBROUTINE SIMU_PSF(IMAGE,MIM,PSF,NX,NY,IDIM)
	REAL IMAGE(IDIM,*),MIM(IDIM,*),PSF(IDIM,*)
	INTEGER NX,NY

C FFT of the image:
	CALL FFT_2D(IMAGE,MIM,NX,NY,IDIM,1)

C Effect of PSF (PSF normalized to 1. in the center):
	IXC=NX/2+1
	IYC=NY/2+1
	XPSF=SQRT(PSF(IXC,IYC))
	DO J=1,NY
	  DO I=1,NX
	      RR=MAX(0.,PSF(I,J))
	      RR=SQRT(RR)/XPSF
	      IMAGE(I,J)=IMAGE(I,J)*RR
	      MIM(I,J)=MIM(I,J)*RR
	  END DO
	END DO

C Inverse FFT:
	CALL FFT_2D(IMAGE,MIM,NX,NY,IDIM,-1)

	RETURN
	END
C******************************************************************
	include 'jlp_cover.for'
	include 'fft_jlp.for'
	include 'jlp_bispec1.for'


	SUBROUTINE WINDFFT(IFFTCH)
C
C	THIS WINDFFT DOES FFT AS IN FLIGHT SOFTWARE
C
	COMMON /WINBLK/ WINDOW(1024)
	common /fftblk/ nexpt(1024),mantissa(1024),ipwrw(1024),data(1024)
c
	REAL PWRW(1024),PWRNW(1024),DATA,AR(1024),OFFS(4,10)
	DATA TWOPI /6.2831853/
	DATA WINDOW /1024*1./
C
C	OFFSETS IN FLIGHT PROMS, ACCORDING TO RED NOTEBOOK
C
	DATA OFFS /2048. ,2050. ,2046. ,2048.,   ! CH 1 GN STP 0-3
     2             2048. ,2050. ,2046. ,2051.,   ! CH 2 GN STP 0-3
     3             2048. ,2082. ,2041. ,2043.,   ! etc.
     4             2048. ,2078. ,2042. ,2046.,
     5             2048. ,2048. ,2048. ,2047.,
     6             2048. ,2075. ,2043. ,2045.,
     7             2048. ,2048. ,2048. ,2037.,
     8             2048. ,2048. ,2048. ,2040.,
     9             2048. ,2048. ,2048. ,2036.,
     X             2048. ,2048. ,2287. ,2048./
C
	NPROS = 1024
	NFRQ = NPROS/2
C
	IWINDW = 1
	CALL FWINDW(IWINDW)
C
	datamax = 0.
	DO IK = 1,1024
	  NTEMP = MANTISSA(IK).AND.4095
	  NEX = NEXPT(IK).AND.3
	  TEMP = -(NTEMP-OFFS(NEX+1,IFFTCH))
	  DATA(IK) = TEMP*(-16.3)**NEX
	  datamax = amax1(abs(data(ik)),datamax)
	ENDDO
C	print*,'max data',datamax
C
	DO N = 1,NPROS
	   AR(N) = WINDOW(N)*DATA(N)
	ENDDO
        CALL REALFT(AR,NFRQ,1)
C?	  FFTAVR = AR(1)/1024.
C?	  AVR = AR(1)
	  AVR = AR(1)
C
	IF(AVR.GT.0.) THEN
	    IPWRW(1) = 40.*ALOG10(AVR) - 124.
	ELSE
	    IPWRW(1) = 0.
	ENDIF
C
C	CALCULATE POWER
C
c	114.4 is 20.*log10(1024**2/2), to make fasfor normalization agree
c	with the flight norm which subtracts 124.
C
	DO N = 2,NFRQ+1
	  PWRW(N) = AR(2*N-1)**2 + AR(2*N)**2
	  IF(PWRW(N).GT.0.) THEN
	    IPWRW(N) = 20.*ALOG10(PWRW(N)) - 124.   ! .5 db steps,fl bias
	  ELSE
	    IPWRW(N) = 0.
	  ENDIF
	ENDDO
	RETURN
	END
	SUBROUTINE FWINDW(IWINDW)
C
	COMMON /WINBLK/ WINDOW(1024)
	DATA TWOPI /6.2831853/
C
	GO TO (100,200,300) IWINDW+1
	PRINT*,'REQUESTED WINDOW DOES NOT EXIST'
 100	CONTINUE
	PRINT*,'IWINDW =',IWINDW,'  NO WINDOWING'
	DO N = 1,1024
	  WINDOW(N) = 1.
	ENDDO
	RETURN
 200	CONTINUE
C	PRINT*,'IWINDW =',IWINDW,'  HAMMING'
	ALPHA = .54
	GO TO 310
 300	CONTINUE
	ALPHA = .5
	PRINT*,'IWINDW =',IWINDW,'  HANNING'
 310	CONTINUE
	SUMSQ = 0.
	DO N = 1,1024
	  WINDOW(N) = ALPHA + (ALPHA-1.)*COS(TWOPI*(N-1)/1024.)
	  SUMSQ = SUMSQ + WINDOW(N)**2
	ENDDO
	RMS = SQRT(SUMSQ/1024.)
	DO N = 1,1024
	  WINDOW(N) = WINDOW(N)/RMS
	ENDDO
	RETURN
	END


C      +----------------------+
C      !     LITT splines     !
C      +----------------------+
C                      14.03.95

C      Partie 3: Tete, nez, patte
C

       integer n,I,m
       parameter (n=14)
       parameter (m=200)
       double precision x(m+1),y(m+1),XN(n),YN(n),DN(n),W(3*n),x1,y1

C      ------------------------
C               Data
C      ------------------------

       data YN/1.45 , 1.5 , 1.48 , 1.44 ,
     *         1.2, 1.1 , 1.0 ,
     *         0.8, 0.55, 0.4, 0.4, 0.3 , 0.2 , 0.0/

       data XN/ 7.6, 7.7, 7.8,
     *         7.9 , 8.15, 8.25, 8.5 , 9.5 ,
     *         10.0,10.25, 10.3, 10.7, 10.85, 11.0/

C      ------------------------
C        Interpolation spline
C      ------------------------
       call TB04AD(n,XN,YN,DN,W)

       x1=XN(1)
       do 10 I=1,m+1
          y1=TG01BD(1,n,XN,YN,DN,x1)
          x(I)=x1
          y(I)=y1
          x1=x1+(XN(n)-XN(1))/m
10     continue

       call tomat(n,m,XN,YN,x,y)

       end

C      ------------------------
C        Graphique -> Matlab
C      ------------------------

       subroutine tomat(n,m,XX,YY,X,Y)

       integer m,n,I
       double precision X(m),Y(m),XX(n),YY(n)

       open(UNIT = 2, FILE = 'snoo3.m')
          do 100 I=1,m+1
             write(2,*)'x3(',I,')=',X(I),';'
             write(2,*)'y3(',I,')=',Y(I),';'
100       continue

          do 200 I=1,n
             write(2,*)'xn3(',I,')=',XX(I),';'
             write(2,*)'yn3(',I,')=',YY(I),';'
200       continue

          write(2,*)'plot(xn3,yn3,''w+'',x3,y3,''w-'')'
          write(2,*)'axis(''equal'');grid'
       close (UNIT = 2)

       return
       end


      MODULE ZECKENDORF ARITHMETIC	!Using the Fibonacci series, rather than powers of some base.
       INTEGER ZLAST		!The standard 32-bit two's complement integers
       PARAMETER (ZLAST = 45)	!only get so far, just as there's a limit to the highest power.
       INTEGER F1B(ZLAST)	!I want the Fibonacci series, and, starting with its second one.
c       PARAMETER (F1B = (/1,2,	!But alas, the compiler doesn't allow
c     3  F1B(1) + F1B(2),		!for this sort of carpet-unrolling
c     4  F1B(2) + F1B(3), 		!initialisation sequence.
       INTEGER,PRIVATE:: F01,F02,F03,F04,F05,F06,F07,F08,F09,F10,	!So, not bothering with F00,
     1  F11,F12,F13,F14,F15,F16,F17,F18,F19,F20,	!Prepare a horde of simple names,
     2  F21,F22,F23,F24,F25,F26,F27,F28,F29,F30,	!which can be initialised
     3  F31,F32,F33,F34,F35,F36,F37,F38,F39,F40,	!in a certain way,
     4  F41,F42,F43,F44,F45				!without scaring the compiler.
       PARAMETER (F01 = 1, F02 = 2, F03 = F02 + F01, F04 = F03 + F02,	!Thusly.
     1  F05=F04+F03,F06=F05+F04,F07=F06+F05,F08=F07+F06,F09=F08+F07,	!Typing all this
     2  F10=F09+F08,F11=F10+F09,F12=F11+F10,F13=F12+F11,F14=F13+F12,	!is an invitation
     3  F15=F14+F13,F16=F15+F14,F17=F16+F15,F18=F17+F16,F19=F18+F17,	!for mistypes.
     4  F20=F19+F18,F21=F20+F19,F22=F21+F20,F23=F22+F21,F24=F23+F22,	!So a regular layout
     5  F25=F24+F23,F26=F25+F24,F27=F26+F25,F28=F27+F26,F29=F28+F27,	!helps a little.
     6  F30=F29+F28,F31=F30+F29,F32=F31+F30,F33=F32+F31,F34=F33+F32,	!Otherwise,
     7  F35=F34+F33,F36=F35+F34,F37=F36+F35,F38=F37+F36,F39=F38+F37,	!devise a prog.
     8  F40=F39+F38,F41=F40+F39,F42=F41+F40,F43=F42+F41,F44=F43+F42,	!to generate these texts...
     9  F45=F44+F43)	!The next is 2971215073. Too big for 32-bit two's complement integers.
       PARAMETER (F1B = (/F01,F02,F03,F04,F05,F06,F07,F08,F09,F10,	!And now,
     1  F11, F12, F13, F14, F15, F16, F17, F18, F19, F20,		!Here is the desired
     2  F21, F22, F23, F24, F25, F26, F27, F28, F29, F30,		!array of constants.
     3  F31, F32, F33, F34, F35, F36, F37, F38, F39, F40,		!And as such, possibly
     4  F41, F42, F43, F44, F45/))					!protected from alteration.
       CONTAINS	!After all that, here we go.
        SUBROUTINE ZECK(N,D)	!Convert N to a "Zeckendorf" digit sequence.
Counts upwards from digit one. D(i) ~ F1B(i). D(0) fingers the high-order digit.
         INTEGER N	!The normal number, in the computer's base.
         INTEGER D(0:)	!The digits, to be determined.
         INTEGER R	!The remnant.
         INTEGER L	!A finger, similar to the power of the base.
          IF (N.LT.0) STOP "ZECK! No negative numbers!"	!I'm not thinking about them.
          R = N		!Grab a copy that I can mess with.
          D = 0		!Scrub the lot in one go.
          L = ZLAST	!As if starting with BASE**MAX, rather than BASE**0.
   10     IF (R.GE.F1B(L)) THEN	!Has the remnant sufficient for this digit?
            R = R - F1B(L)		!Yes! Remove that amount.
            IF (D(0).EQ.0) THEN		!Is this the first non-zero digit?
              IF (L.GT.UBOUND(D,DIM=1)) STOP "ZECK! Not enough digits!"	!Yes.
              D(0) = L			!Remember the location of the high-order digit.
            END IF			!Two loops instead, to avoid repeated testing?
            D(L) = 1			!Place the digit, knowing a place awaits.
            L = L - 1			!Never need a ...11... sequence because F1B(i) + F1B(i+1) = F1B(i+2).
          END IF		!So much for that digit "power".
          L = L - 1		!Down a digit.
          IF (L.GT.0 .AND. R.GT.0) GO TO 10	!Are we there yet?
          IF (N.EQ.0) D(0) = 1	!Zero has one digit.
        END SUBROUTINE ZECK	!That was fun.

        INTEGER FUNCTION ZECKN(D)	!Converts a "Zeckendorf" digit sequence to a number.
         INTEGER D(0:)	!The digits. D(0) fingers the high-order digit.
          IF (D(0).LE.0) STOP "ZECKN! Empty number!"	!General paranoia.
          IF (D(0).GT.ZLAST) STOP "ZECKN! Oversize number!"	!I hate array bound hiccoughs.
          ZECKN = SUM(D(1:D(0))*F1B(1:D(0)))	!This is what positional notation means.
          IF (ZECKN.LT.0) STOP "ZECKN! Integer overflow!"	!Oh for IF OVERFLOW as in First Fortran.
        END FUNCTION ZECKN	!Overflows by a small amount will produce a negative number.
      END MODULE ZECKENDORF ARITHMETIC	!Odd stuff.

      PROGRAM POKE
      USE ZECKENDORF ARITHMETIC	!Please.
      INTEGER ZD(0:ZLAST)	!A scratchpad.
      INTEGER I,J,W
      CHARACTER*1 DIGIT(0:1)	!Assistance for the output.
      PARAMETER (DIGIT = (/"0","1"/), W = 6)	!This field width suffices.
c      WRITE (6,*) F1B
c      WRITE (6,*) INT8(F1B(44)) + INT8(F1B(45))
      WRITE (6,1) F1B(1:4),ZLAST,ZLAST,F1B(ZLAST),HUGE(I)	!Show some provenance.
    1 FORMAT ("Converts integers to their Zeckendorf digit string "
     1 "using the Fib1nacci sequence (",4(I0,","),
     2 " ...) as the equivalent of powers."/
     3 "At most, ",I0," digits because Fib1nacci(",I0,") = ",I0,
     4 " and the integer limit is ",I0,".",//,"  N     ZN")	!Ends with a heading.

      DO I = 0,20	!Step through the specified range.
        CALL ZECK(I,ZD)		!Convert I to ZD.
c       WRITE (6,2) I,ZD(ZD(0):1:-1)	!Show digits from high-order to low.
c   2   FORMAT (I3,1X,66I1)		!Or, WRITE (6,2) I,(ZD(J), J = ZD(0),1,-1)
        WRITE (6,3) I,(" ",J = ZD(0) + 1,W),DIGIT(ZD(ZD(0):1:-1))	!Right-aligned in field width W.
    3   FORMAT (I3,1X,66A1)		!The digits appear as characters.
        IF (I.NE.ZECKN(ZD)) STOP "Huh?"	!Should never happen...
      END DO		!On to the next.

      END


c program bestfocus

      include 'VICMAIN_FOR'
      subroutine main44

      parameter (nlmax=1100,nsmax=1100,maxpix=10)
      real*4 buf(nsmax,nlmax),obuf(nsmax,nlmax,maxpix)
      real*4 inbuf(nsmax,nlmax,maxpix)
      integer*4 sborder,count,def,status,unit(maxpix),ounit(2)
      real*8 sum(nsmax),sumc(nsmax),sumc2(nsmax),normalize
      real*8 sum2(nsmax)
      logical inverse,xvptst

c parameters
      call xveaction('SA',' ')
      call xvpcnt('INP',nin)
      if(nin.gt.maxpix)then
        write(*,*)'Too many input images, increase maxpix'
        call abend
      endif
      call xvpcnt('OUT',nout)
      call xvparm('NLW',nlw,count,def,1)
      if(nlw.eq.(nlw/2)*2)nlw=nlw+1
      call xvparm('NSW',nsw,count,def,1)
      if(nsw.eq.(nsw/2)*2)nsw=nsw+1
      inverse=xvptst('INVERSE')

c open inputs
      do i=1,nin
        call xvunit(unit(i),'INP',i,status,' ')
        call xvopen(unit(i),status,'U_FORMAT','REAL',' ')
        call xvget(unit(i),status,'NL',nl,'NS',ns,' ')
        if(ns.gt.nsmax)then
          call xvmessage('Line length too long',' ')
          call abend
        endif
        if(nl.gt.nlmax)then
          call xvmessage('Line column too long',' ')
          call abend
        endif
      enddo

c open outputs
        call xvunit(ounit(1),'OUT',1,status,' ')
        call xvopen(ounit(1),status,'U_FORMAT','REAL',
     +              'OP','WRITE',' ')
        call xvunit(ounit(2),'OUT',2,status,' ')
        call xvopen(ounit(2),status,'U_FORMAT','REAL',
     +              'OP','WRITE','O_FORMAT','REAL',' ')

      normalize=nlw*nsw
      sborder=(nsw-1)/2
      lborder=(nlw-1)/2
      nlo=nl+2*lborder
      nso=ns+2*sborder
      if(nlo.gt.nlmax.or.nso.gt.nsmax)then
        write(*,*)'internal image buffer too small'
        stop
      endif

      image=0
10    image=image+1
      do j=1,nl
        call xvread(unit(image),buf(1,j),status,'LINE',j,' ')
      enddo

c save inputs
      do j=1,nl
        do i=1,ns
          inbuf(i,j,image)=buf(i,j)
        enddo
      enddo

c shift image area to leave a border around it.
      do j=nl,1,-1
        do i=ns,1,-1
          buf(i+sborder,j+lborder)=buf(i,j)
        enddo
      enddo

c reflect the image into the borders
      k=lborder
      do j=lborder,1,-1
        k=k+1
        do i=1,nso
          buf(i,j)=buf(i,k)
        enddo
      enddo
      k=nlo-lborder+1
      do j=nlo-lborder+1,nlo
        k=k-1
        do i=1,nso
          buf(i,j)=buf(i,k)
        enddo
      enddo
      k=sborder
      do i=sborder,1,-1
        k=k+1
        do j=1,nlo
          buf(i,j)=buf(k,j)
        enddo
      enddo
      k=nso-sborder+1
      do i=nso-sborder+1,nso
        k=k-1
        do j=1,nlo
          buf(i,j)=buf(k,j)
        enddo
      enddo

c collect first sums of columns to get started.
      do i=1,nso
        sumc(i)=0.d0
        sumc2(i)=0.d0
        do j=1,nlw
          sumc(i)=sumc(i)+buf(i,j)
          sumc2(i)=sumc2(i)+dble(buf(i,j))**2
        enddo
      enddo

      do j=1,nl

c compute low pass
        sum(1)=0.d0
        sum2(1)=0.d0
        do i=1,nsw
          sum(1)=sum(1)+sumc(i)
          sum2(1)=sum2(1)+sumc2(i)
        enddo
        do i=2,ns
          sum(i)=sum(i-1)+sumc(i+nsw-1)-sumc(i-1)
          sum2(i)=sum2(i-1)+sumc2(i+nsw-1)-sumc2(i-1)
        enddo

c update column sums
        do i=1,nso
          sumc(i)=sumc(i)+buf(i,j+nlw)-buf(i,j)
          sumc2(i)=sumc2(i)+dble(buf(i,j+nlw))**2-dble(buf(i,j))**2
        enddo

c compute standard deviation
        do i=1,ns
          obuf(i,j,image)=sqrt(sum2(i)/normalize-(sum(i)/normalize)**2)
        enddo

      enddo

      if(image.lt.nin)goto 10

c create best focus image
      do j=1,nl
        do i=1,ns
          best=-1.0
          do k=1,nin
            if(obuf(i,j,k).gt.best)then
              best=obuf(i,j,k)
              n=k
            endif
          enddo
          buf(i,j)=inbuf(i,j,n)
        enddo
        call xvwrit(ounit(1),buf(1,j),status,' ')
      enddo

      if(nout.lt.2)return

c create relative topographic image
      nlow=0
      nhigh=0
      do j=1,nl
        do i=1,ns
          best=-1.0
          do k=1,nin
            if(obuf(i,j,k).gt.best)then
              best=obuf(i,j,k)
              n=k ! the index of the highest point
            endif
          enddo
          if(n.eq.1)then
            buf(i,j)=n
            nlow=nlow+1
          else if(n.eq.nin)then
            buf(i,j)=nin
            nhigh=nhigh+1
          else
            a1=obuf(i,j,n-1)
            b1=obuf(i,j,n)
            c1=obuf(i,j,n+1)
            d=2.0*b1-c1-a1
            if(d.ne.0.0)then
              buf(i,j)=n-0.5*(a1-c1)/d
            else
              buf(i,j)=n
            endif
          endif
          if(inverse)buf(i,j)=nin-buf(i,j)+1
        enddo
        call xvwrit(ounit(2),buf(1,j),status,' ')
      enddo
      if(nlow.gt.0)then
        write(*,*)100.*real(nlow)/real(nl*ns),
     +  ' % of points had a solution below image 1, set to 1'
      endif
      if(nhigh.gt.0)then
        write(*,*)100.*real(nhigh)/real(nl*ns),
     +  ' % of points had a solution above image ',nin,
     +  ' ,set to ',nin
      endif

      end


!*==ctrevc.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b CTREVC
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download CTREVC + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE CTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
!                          LDVR, MM, M, WORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       CHARACTER          HOWMNY, SIDE
!       INTEGER            INFO, LDT, LDVL, LDVR, M, MM, N
!       ..
!       .. Array Arguments ..
!       LOGICAL            SELECT( * )
!       REAL               RWORK( * )
!       COMPLEX            T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
!      $                   WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> CTREVC computes some or all of the right and/or left eigenvectors of
!> a complex upper triangular matrix T.
!> Matrices of this type are produced by the Schur factorization of
!> a complex general matrix:  A = Q*T*Q**H, as computed by CHSEQR.
!>
!> The right eigenvector x and the left eigenvector y of T corresponding
!> to an eigenvalue w are defined by:
!>
!>              T*x = w*x,     (y**H)*T = w*(y**H)
!>
!> where y**H denotes the conjugate transpose of the vector y.
!> The eigenvalues are not input to this routine, but are read directly
!> from the diagonal of T.
!>
!> This routine returns the matrices X and/or Y of right and left
!> eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
!> input matrix.  If Q is the unitary factor that reduces a matrix A to
!> Schur form T, then Q*X and Q*Y are the matrices of right and left
!> eigenvectors of A.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] SIDE
!> \verbatim
!>          SIDE is CHARACTER*1
!>          = 'R':  compute right eigenvectors only;
!>          = 'L':  compute left eigenvectors only;
!>          = 'B':  compute both right and left eigenvectors.
!> \endverbatim
!>
!> \param[in] HOWMNY
!> \verbatim
!>          HOWMNY is CHARACTER*1
!>          = 'A':  compute all right and/or left eigenvectors;
!>          = 'B':  compute all right and/or left eigenvectors,
!>                  backtransformed using the matrices supplied in
!>                  VR and/or VL;
!>          = 'S':  compute selected right and/or left eigenvectors,
!>                  as indicated by the logical array SELECT.
!> \endverbatim
!>
!> \param[in] SELECT
!> \verbatim
!>          SELECT is LOGICAL array, dimension (N)
!>          If HOWMNY = 'S', SELECT specifies the eigenvectors to be
!>          computed.
!>          The eigenvector corresponding to the j-th eigenvalue is
!>          computed if SELECT(j) = .TRUE..
!>          Not referenced if HOWMNY = 'A' or 'B'.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix T. N >= 0.
!> \endverbatim
!>
!> \param[in,out] T
!> \verbatim
!>          T is COMPLEX array, dimension (LDT,N)
!>          The upper triangular matrix T.  T is modified, but restored
!>          on exit.
!> \endverbatim
!>
!> \param[in] LDT
!> \verbatim
!>          LDT is INTEGER
!>          The leading dimension of the array T. LDT >= max(1,N).
!> \endverbatim
!>
!> \param[in,out] VL
!> \verbatim
!>          VL is COMPLEX array, dimension (LDVL,MM)
!>          On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by CHSEQR).
!>          On exit, if SIDE = 'L' or 'B', VL contains:
!>          if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*Y;
!>          if HOWMNY = 'S', the left eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VL, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'R'.
!> \endverbatim
!>
!> \param[in] LDVL
!> \verbatim
!>          LDVL is INTEGER
!>          The leading dimension of the array VL.  LDVL >= 1, and if
!>          SIDE = 'L' or 'B', LDVL >= N.
!> \endverbatim
!>
!> \param[in,out] VR
!> \verbatim
!>          VR is COMPLEX array, dimension (LDVR,MM)
!>          On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
!>          contain an N-by-N matrix Q (usually the unitary matrix Q of
!>          Schur vectors returned by CHSEQR).
!>          On exit, if SIDE = 'R' or 'B', VR contains:
!>          if HOWMNY = 'A', the matrix X of right eigenvectors of T;
!>          if HOWMNY = 'B', the matrix Q*X;
!>          if HOWMNY = 'S', the right eigenvectors of T specified by
!>                           SELECT, stored consecutively in the columns
!>                           of VR, in the same order as their
!>                           eigenvalues.
!>          Not referenced if SIDE = 'L'.
!> \endverbatim
!>
!> \param[in] LDVR
!> \verbatim
!>          LDVR is INTEGER
!>          The leading dimension of the array VR.  LDVR >= 1, and if
!>          SIDE = 'R' or 'B'; LDVR >= N.
!> \endverbatim
!>
!> \param[in] MM
!> \verbatim
!>          MM is INTEGER
!>          The number of columns in the arrays VL and/or VR. MM >= M.
!> \endverbatim
!>
!> \param[out] M
!> \verbatim
!>          M is INTEGER
!>          The number of columns in the arrays VL and/or VR actually
!>          used to store the eigenvectors.  If HOWMNY = 'A' or 'B', M
!>          is set to N.  Each selected eigenvector occupies one
!>          column.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX array, dimension (2*N)
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is REAL array, dimension (N)
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup complexOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  The algorithm used in this program is basically backward (forward)
!>  substitution, with scaling to make the the code robust against
!>  possible overflow.
!>
!>  Each eigenvector is normalized so that the element of largest
!>  magnitude has magnitude 1; here the magnitude of a complex number
!>  (x,y) is taken to be |x| + |y|.
!> \endverbatim
!>
!  =====================================================================
      SUBROUTINE CTREVC(Side,Howmny,Select,N,T,Ldt,Vl,Ldvl,Vr,Ldvr,Mm,M,&
     &                  Work,Rwork,Info)
      IMPLICIT NONE
!*--CTREVC222
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Howmny , Side
      INTEGER Info , Ldt , Ldvl , Ldvr , M , Mm , N
!     ..
!     .. Array Arguments ..
      LOGICAL Select(*)
      REAL Rwork(*)
      COMPLEX T(Ldt,*) , Vl(Ldvl,*) , Vr(Ldvr,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ZERO , ONE
      PARAMETER (ZERO=0.0E+0,ONE=1.0E+0)
      COMPLEX CMZERO , CMONE
      PARAMETER (CMZERO=(0.0E+0,0.0E+0),CMONE=(1.0E+0,0.0E+0))
!     ..
!     .. Local Scalars ..
      LOGICAL allv , bothv , leftv , over , rightv , somev
      INTEGER i , ii , is , j , k , ki
      REAL ovfl , remax , scale , smin , smlnum , ulp , unfl
      COMPLEX cdum
!     ..
!     .. External Functions ..
      LOGICAL LSAME
      INTEGER ICAMAX
      REAL SCASUM , SLAMCH
      EXTERNAL LSAME , ICAMAX , SCASUM , SLAMCH
!     ..
!     .. External Subroutines ..
      EXTERNAL CCOPY , CGEMV , CLATRS , CSSCAL , SLABAD , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , AIMAG , CMPLX , CONJG , MAX , REAL
!     ..
!     .. Statement Functions ..
      REAL CABS1
!     ..
!     .. Statement Function definitions ..
      CABS1(cdum) = ABS(REAL(cdum)) + ABS(AIMAG(cdum))
!     ..
!     .. Executable Statements ..
!
!     Decode and test the input parameters
!
      bothv = LSAME(Side,'B')
      rightv = LSAME(Side,'R') .OR. bothv
      leftv = LSAME(Side,'L') .OR. bothv
!
      allv = LSAME(Howmny,'A')
      over = LSAME(Howmny,'B')
      somev = LSAME(Howmny,'S')
!
!     Set M to the number of columns required to store the selected
!     eigenvectors.
!
      IF ( somev ) THEN
         M = 0
         DO j = 1 , N
            IF ( Select(j) ) M = M + 1
         ENDDO
      ELSE
         M = N
      ENDIF
!
      Info = 0
      IF ( .NOT.rightv .AND. .NOT.leftv ) THEN
         Info = -1
      ELSEIF ( .NOT.allv .AND. .NOT.over .AND. .NOT.somev ) THEN
         Info = -2
      ELSEIF ( N<0 ) THEN
         Info = -4
      ELSEIF ( Ldt<MAX(1,N) ) THEN
         Info = -6
      ELSEIF ( Ldvl<1 .OR. (leftv .AND. Ldvl<N) ) THEN
         Info = -8
      ELSEIF ( Ldvr<1 .OR. (rightv .AND. Ldvr<N) ) THEN
         Info = -10
      ELSEIF ( Mm<M ) THEN
         Info = -11
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('CTREVC',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible.
!
      IF ( N==0 ) RETURN
!
!     Set the constants to control overflow.
!
      unfl = SLAMCH('Safe minimum')
      ovfl = ONE/unfl
      CALL SLABAD(unfl,ovfl)
      ulp = SLAMCH('Precision')
      smlnum = unfl*(N/ulp)
!
!     Store the diagonal elements of T in working array WORK.
!
      DO i = 1 , N
         Work(i+N) = T(i,i)
      ENDDO
!
!     Compute 1-norm of each column of strictly upper triangular
!     part of T to control overflow in triangular solver.
!
      Rwork(1) = ZERO
      DO j = 2 , N
         Rwork(j) = SCASUM(j-1,T(1,j),1)
      ENDDO
!
      IF ( rightv ) THEN
!
!        Compute right eigenvectors.
!
         is = M
         DO ki = N , 1 , -1
!
            IF ( somev ) THEN
               IF ( .NOT.Select(ki) ) CYCLE
            ENDIF
            smin = MAX(ulp*(CABS1(T(ki,ki))),smlnum)
!
            Work(1) = CMONE
!
!           Form right-hand side.
!
            DO k = 1 , ki - 1
               Work(k) = -T(k,ki)
            ENDDO
!
!           Solve the triangular system:
!              (T(1:KI-1,1:KI-1) - T(KI,KI))*X = SCALE*WORK.
!
            DO k = 1 , ki - 1
               T(k,k) = T(k,k) - T(ki,ki)
               IF ( CABS1(T(k,k))<smin ) T(k,k) = smin
            ENDDO
!
            IF ( ki>1 ) THEN
               CALL CLATRS('Upper','No transpose','Non-unit','Y',ki-1,T,&
     &                     Ldt,Work(1),scale,Rwork,Info)
               Work(ki) = scale
            ENDIF
!
!           Copy the vector x or Q*x to VR and normalize.
!
            IF ( .NOT.over ) THEN
               CALL CCOPY(ki,Work(1),1,Vr(1,is),1)
!
               ii = ICAMAX(ki,Vr(1,is),1)
               remax = ONE/CABS1(Vr(ii,is))
               CALL CSSCAL(ki,remax,Vr(1,is),1)
!
               DO k = ki + 1 , N
                  Vr(k,is) = CMZERO
               ENDDO
            ELSE
               IF ( ki>1 ) CALL CGEMV('N',N,ki-1,CMONE,Vr,Ldvr,Work(1), &
     &                                1,CMPLX(scale),Vr(1,ki),1)
!
               ii = ICAMAX(N,Vr(1,ki),1)
               remax = ONE/CABS1(Vr(ii,ki))
               CALL CSSCAL(N,remax,Vr(1,ki),1)
            ENDIF
!
!           Set back the original diagonal elements of T.
!
            DO k = 1 , ki - 1
               T(k,k) = Work(k+N)
            ENDDO
!
            is = is - 1
         ENDDO
      ENDIF
!
      IF ( leftv ) THEN
!
!        Compute left eigenvectors.
!
         is = 1
         DO ki = 1 , N
!
            IF ( somev ) THEN
               IF ( .NOT.Select(ki) ) CYCLE
            ENDIF
            smin = MAX(ulp*(CABS1(T(ki,ki))),smlnum)
!
            Work(N) = CMONE
!
!           Form right-hand side.
!
            DO k = ki + 1 , N
               Work(k) = -CONJG(T(ki,k))
            ENDDO
!
!           Solve the triangular system:
!              (T(KI+1:N,KI+1:N) - T(KI,KI))**H*X = SCALE*WORK.
!
            DO k = ki + 1 , N
               T(k,k) = T(k,k) - T(ki,ki)
               IF ( CABS1(T(k,k))<smin ) T(k,k) = smin
            ENDDO
!
            IF ( ki<N ) THEN
               CALL CLATRS('Upper','Conjugate transpose','Non-unit','Y',&
     &                     N-ki,T(ki+1,ki+1),Ldt,Work(ki+1),scale,Rwork,&
     &                     Info)
               Work(ki) = scale
            ENDIF
!
!           Copy the vector x or Q*x to VL and normalize.
!
            IF ( .NOT.over ) THEN
               CALL CCOPY(N-ki+1,Work(ki),1,Vl(ki,is),1)
!
               ii = ICAMAX(N-ki+1,Vl(ki,is),1) + ki - 1
               remax = ONE/CABS1(Vl(ii,is))
               CALL CSSCAL(N-ki+1,remax,Vl(ki,is),1)
!
               DO k = 1 , ki - 1
                  Vl(k,is) = CMZERO
               ENDDO
            ELSE
               IF ( ki<N ) CALL CGEMV('N',N,N-ki,CMONE,Vl(1,ki+1),Ldvl, &
     &                                Work(ki+1),1,CMPLX(scale),Vl(1,ki)&
     &                                ,1)
!
               ii = ICAMAX(N,Vl(1,ki),1)
               remax = ONE/CABS1(Vl(ii,ki))
               CALL CSSCAL(N,remax,Vl(1,ki),1)
            ENDIF
!
!           Set back the original diagonal elements of T.
!
            DO k = ki + 1 , N
               T(k,k) = Work(k+N)
            ENDDO
!
            is = is + 1
         ENDDO
      ENDIF
!
!
!     End of CTREVC
!
      END SUBROUTINE CTREVC