******************************************************************
* Necessary set of routines for C06GCF and G06FJF
*
* C06FTEXT
* X01FTEXT
* P01FTEXT
*
* JLP Version 07-10-91
******************************************************************
*UPTODATE C06ECQTEXT
      SUBROUTINE C06ECQ(X, Y, PTS, M, P)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX PRIME COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M, P, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X(PTS), Y(PTS)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION ANGLE, IS, IU, RS, RU, T, TWOPI, XT, YT
      INTEGER J, JJ, K0, K, KS1, KS2, MOVER2, MP, PM, PP, U, V
      LOGICAL FOLD, ZERO
C     .. LOCAL ARRAYS ..
      DOUBLE PRECISION A(18), AA(9,9), B(18), BB(9,9), C(18), IA(9),
     * IB(9),RA(9), RB(9), S(18)
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      TWOPI = 2.0D0*X01AAF(0.0D0)
      MOVER2 = M/2 + 1
      MP = M*P
      PP = P/2
      PM = P - 1
      DO 20 U=1,PP
         JJ = P - U
         ANGLE = TWOPI*DBLE(U)/DBLE(P)
         A(U) = DCOS(ANGLE)
         B(U) = DSIN(ANGLE)
         A(JJ) = A(U)
         B(JJ) = -B(U)
   20 CONTINUE
      DO 60 U=1,PP
         DO 40 V=1,PP
            JJ = U*V - ((U*V)/P)*P
            AA(V,U) = A(JJ)
            BB(V,U) = B(JJ)
   40    CONTINUE
   60 CONTINUE
C
      DO 300 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(MP)
         ZERO = ANGLE.EQ.0.0D0
         C(1) = DCOS(ANGLE)
         S(1) = DSIN(ANGLE)
         DO 80 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)
   80    CONTINUE
         GO TO 140
  100    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         DO 120 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
  120    CONTINUE
  140    CONTINUE
C
         DO 280 K=K0,PTS,MP
            XT = X(K)
            YT = Y(K)
            KS1 = M + K
            KS2 = (P-1)*M + K
            RS = X(KS1) + X(KS2)
            IS = Y(KS1) + Y(KS2)
            RU = X(KS1) - X(KS2)
            IU = Y(KS1) - Y(KS2)
            DO 160 U=1,PP
               RA(U) = XT + RS*AA(U,1)
               IA(U) = YT + IS*AA(U,1)
               RB(U) = RU*BB(U,1)
               IB(U) = IU*BB(U,1)
  160       CONTINUE
            XT = XT + RS
            YT = YT + IS
            DO 200 U=2,PP
               JJ = P - U
               KS1 = U*M + K
               KS2 = JJ*M + K
               RS = X(KS1) + X(KS2)
               IS = Y(KS1) + Y(KS2)
               RU = X(KS1) - X(KS2)
               IU = Y(KS1) - Y(KS2)
               XT = XT + RS
               YT = YT + IS
               DO 180 V=1,PP
                  RA(V) = RA(V) + RS*AA(V,U)
                  IA(V) = IA(V) + IS*AA(V,U)
                  RB(V) = RB(V) + RU*BB(V,U)
                  IB(V) = IB(V) + IU*BB(V,U)
  180          CONTINUE
  200       CONTINUE
            X(K) = XT
            Y(K) = YT
            DO 260 U=1,PP
               JJ = P - U
               IF (ZERO) GO TO 220
               XT = RA(U) + IB(U)
               YT = IA(U) - RB(U)
               KS1 = U*M + K
               X(KS1) = XT*C(U) + YT*S(U)
               Y(KS1) = YT*C(U) - XT*S(U)
               XT = RA(U) - IB(U)
               YT = IA(U) + RB(U)
               KS1 = JJ*M + K
               X(KS1) = XT*C(JJ) + YT*S(JJ)
               Y(KS1) = YT*C(JJ) - XT*S(JJ)
               GO TO 240
  220          CONTINUE
               KS1 = U*M + K
               X(KS1) = RA(U) + IB(U)
               Y(KS1) = IA(U) - RB(U)
               KS1 = JJ*M + K
               X(KS1) = RA(U) - IB(U)
               Y(KS1) = IA(U) + RB(U)
  240          CONTINUE
  260       CONTINUE
  280    CONTINUE
         IF (FOLD) GO TO 100
  300 CONTINUE
C
      RETURN
      END
** END OF C06ECQTEXT
*UPTODATE C06ECRTEXT
      SUBROUTINE C06ECR(X0, Y0, PTS, X1, Y1, M1, X2, Y2, M2, X3,Y3, M3,
     * X4, Y4, M4, X5, Y5, M5, X6, Y6, M6, X7, Y7, M7, M)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX EIGHT COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M1, M2, M3, M4, M5, M6, M7, M, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X0(PTS), X1(M1), X2(M2), X3(M3), X4(M4), X5(M5),
     * X6(M6),X7(M7), Y0(PTS), Y1(M1), Y2(M2), Y3(M3), Y4(M4), Y5(M5),
     *Y6(M6), Y7(M7)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION ANGLE, C1, C2, C3, C4, C5, C6, C7, E, 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, K0, K, M8, MOVER2
      LOGICAL FOLD, ZERO
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      M8 = M*8
      MOVER2 = M/2 + 1
      TWOPI = 2.0D0*X01AAF(0.0D0)
      E = DCOS(TWOPI/8.0D0)
C
      DO 120 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(M8)
         ZERO = ANGLE.EQ.0.0D0
         C1 = DCOS(ANGLE)
         S1 = DSIN(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
         GO TO 40
   20    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         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
   40    CONTINUE
C
         DO 100 K=K0,PTS,M8
            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) GO TO 60
            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
            GO TO 80
   60       CONTINUE
            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
   80       CONTINUE
  100    CONTINUE
         IF (FOLD) GO TO 20
  120 CONTINUE
C
      RETURN
      END
** END OF C06ECRTEXT
*UPTODATE C06ECSTEXT
      SUBROUTINE C06ECS(X0, Y0, PTS, X1, Y1, M1, X2, Y2, M2, X3,Y3, M3,
     * X4, Y4, M4, M)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX FIVE COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M1, M2, M3, M4, M, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X0(PTS), X1(M1), X2(M2), X3(M3), X4(M4), Y0(PTS),
     *Y1(M1), Y2(M2), Y3(M3), Y4(M4)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION A1, A2, ANGLE, AS, AU, B1, B2, C1, C2, C3, C4,
     * I0, I1,I2, I3, I4, IA1, IA2, IAS, IAU, IB1, IB2, IS1, IS2, ISS,
     *IU1, IU2, R0, R1, R2, R3, R4, RA1, RA2, RAS, RAU, RB1, RB2,RS1,
     * RS2, RSS, RU1, RU2, S1, S2, S3, S4, T, TWOPI
      INTEGER J, K0, K, M5, MOVER2
      LOGICAL FOLD, ZERO
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, DSQRT, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      M5 = M*5
      MOVER2 = M/2 + 1
      TWOPI = 2.0D0*X01AAF(0.0D0)
      A1 = DCOS(TWOPI/5.0D0)
      B1 = DSIN(TWOPI/5.0D0)
      A2 = DCOS(2.0D0*TWOPI/5.0D0)
      B2 = DSIN(2.0D0*TWOPI/5.0D0)
      AS = -1.0D0/4.0D0
      AU = DSQRT(5.0D0)/4.0D0
C
      DO 120 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(M5)
         ZERO = ANGLE.EQ.0.0D0
         C1 = DCOS(ANGLE)
         S1 = DSIN(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
         GO TO 40
   20    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         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
   40    CONTINUE
C
         DO 100 K=K0,PTS,M5
            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)
            RSS = RS1 + RS2
            ISS = IS1 + IS2
            RAS = R0 + RSS*AS
            IAS = I0 + ISS*AS
            RAU = (RS1-RS2)*AU
            IAU = (IS1-IS2)*AU
            RA1 = RAS + RAU
            IA1 = IAS + IAU
            RA2 = RAS - RAU
            IA2 = IAS - IAU
            RB1 = RU1*B1 + RU2*B2
            IB1 = IU1*B1 + IU2*B2
            RB2 = RU1*B2 - RU2*B1
            IB2 = IU1*B2 - IU2*B1
            X0(K) = R0 + RSS
            Y0(K) = I0 + ISS
            IF (ZERO) GO TO 60
            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
            GO TO 80
   60       CONTINUE
            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
   80       CONTINUE
  100    CONTINUE
         IF (FOLD) GO TO 20
  120 CONTINUE
C
      RETURN
      END
** END OF C06ECSTEXT
*UPTODATE C06ECTTEXT
      SUBROUTINE C06ECT(X0, Y0, PTS, X1, Y1, M1, X2, Y2, M2, X3,Y3, M3,
     * M)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX FOUR COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M1, M2, M3, M, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X0(PTS), X1(M1), X2(M2), X3(M3), Y0(PTS), Y1(M1),
     *Y2(M2), Y3(M3)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION ANGLE, C1, C2, C3, I1, I2, I3, IS0, IS1, IU0,
     * IU1, R1,R2, R3, RS0, RS1, RU0, RU1, S1, S2, S3, T, TWOPI
      INTEGER J, K0, K, M4, MOVER2
      LOGICAL FOLD, ZERO
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      M4 = M*4
      MOVER2 = M/2 + 1
      TWOPI = 2.0D0*X01AAF(0.0D0)
C
      DO 120 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(M4)
         ZERO = ANGLE.EQ.0.0D0
         C1 = DCOS(ANGLE)
         S1 = DSIN(ANGLE)
         C2 = C1*C1 - S1*S1
         S2 = S1*C1 + C1*S1
         C3 = C2*C1 - S2*S1
         S3 = S2*C1 + C2*S1
         GO TO 40
   20    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         T = C1
         C1 = S1
         S1 = T
         C2 = -C2
         T = C3
         C3 = -S3
         S3 = -T
   40    CONTINUE
C
         DO 100 K=K0,PTS,M4
            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) GO TO 60
            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
            GO TO 80
   60       CONTINUE
            X2(K) = RU0 + IU1
            Y2(K) = IU0 - RU1
            X1(K) = RS0 - RS1
            Y1(K) = IS0 - IS1
            X3(K) = RU0 - IU1
            Y3(K) = IU0 + RU1
   80       CONTINUE
  100    CONTINUE
         IF (FOLD) GO TO 20
  120 CONTINUE
C
      RETURN
      END
** END OF C06ECTTEXT
*UPTODATE C06ECUTEXT
      SUBROUTINE C06ECU(X0, Y0, PTS, X1, Y1, M1, X2, Y2, M2, M)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX THREE COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M1, M2, M, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X0(PTS), X1(M1), X2(M2), Y0(PTS), Y1(M1), Y2(M2)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION A, ANGLE, B, C1, C2, I0, I1, I2, IA, IB, IS, R0,
     * R1, R2,RA, RB, RS, S1, S2, T, TWOPI
      INTEGER J, K0, K, M3, MOVER2
      LOGICAL FOLD, ZERO
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, DSQRT, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      M3 = M*3
      MOVER2 = M/2 + 1
      TWOPI = 2.0D0*X01AAF(0.0D0)
C     A = COS(TWOPI/3.0)
      A = -0.5D0
C     B = SIN(TWOPI/3.0)
      B = DSQRT(0.75D0)
C
      DO 120 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(M3)
         ZERO = ANGLE.EQ.0.0D0
         C1 = DCOS(ANGLE)
         S1 = DSIN(ANGLE)
         C2 = C1*C1 - S1*S1
         S2 = S1*C1 + C1*S1
         GO TO 40
   20    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         T = C1*A + S1*B
         S1 = C1*B - S1*A
         C1 = T
         T = C2*A - S2*B
         S2 = -C2*B - S2*A
         C2 = T
   40    CONTINUE
C
         DO 100 K=K0,PTS,M3
            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 = R0 + RS*A
            IA = I0 + IS*A
            RB = (X1(K)-X2(K))*B
            IB = (Y1(K)-Y2(K))*B
            IF (ZERO) GO TO 60
            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
            GO TO 80
   60       CONTINUE
            X1(K) = RA + IB
            Y1(K) = IA - RB
            X2(K) = RA - IB
            Y2(K) = IA + RB
   80       CONTINUE
  100    CONTINUE
         IF (FOLD) GO TO 20
  120 CONTINUE
C
      RETURN
      END
** END OF C06ECUTEXT
*UPTODATE C06ECVTEXT
      SUBROUTINE C06ECV(X0, Y0, PTS, X1, Y1, M1, M)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     RADIX TWO COMPLEX FOURIER TRANSFORM KERNEL
C     .. SCALAR ARGUMENTS ..
      INTEGER M1, M, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X0(PTS), X1(M1), Y0(PTS), Y1(M1)
C     ..
C     .. LOCAL SCALARS ..
      DOUBLE PRECISION ANGLE, C, IS, IU, RS, RU, S, TWOPI
      INTEGER J, K0, K, M2, MOVER2
      LOGICAL FOLD, ZERO
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DCOS, DSIN, X01AAF
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
C     ..
      M2 = M*2
      MOVER2 = M/2 + 1
      TWOPI = 2.0D0*X01AAF(0.0D0)
C
      DO 120 J=1,MOVER2
         FOLD = J.GT.1 .AND. 2*J.LT.M + 2
         K0 = J
         ANGLE = TWOPI*DBLE(J-1)/DBLE(M2)
         ZERO = ANGLE.EQ.0.0D0
         C = DCOS(ANGLE)
         S = DSIN(ANGLE)
         GO TO 40
   20    CONTINUE
         FOLD = .FALSE.
         K0 = M + 2 - J
         C = -C
   40    CONTINUE
C
         DO 100 K=K0,PTS,M2
            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) GO TO 60
            X1(K) = RU*C + IU*S
            Y1(K) = IU*C - RU*S
            GO TO 80
   60       CONTINUE
            X1(K) = RU
            Y1(K) = IU
   80       CONTINUE
  100    CONTINUE
         IF (FOLD) GO TO 20
  120 CONTINUE
C
      RETURN
      END
** END OF C06ECVTEXT
*UPTODATE C06ECWTEXT
      SUBROUTINE C06ECW(X, Y, PTS, FACTOR)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     COMPLEX FOURIER TRANSFORM KERNEL DRIVER
C     .. SCALAR ARGUMENTS ..
      INTEGER PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION X(PTS), Y(PTS)
      INTEGER FACTOR(21)
C     ..
C     .. LOCAL SCALARS ..
      INTEGER F, M1, M2, M3, M4, M5, M6, M7, M, P
C     .. SUBROUTINE REFERENCES ..
C     C06ECQ, C06ECR, C06ECS, C06ECT, C06ECU, C06ECV
C     ..
      F = 0
      M = PTS
   20 CONTINUE
      F = F + 1
      P = FACTOR(F)
      IF (P.EQ.0) RETURN
      IF (P.EQ.1) GO TO 20
      M = M/P
      M1 = PTS - M
      M2 = M1 - M
      M3 = M2 - M
      M4 = M3 - M
      M5 = M4 - M
      M6 = M5 - M
      M7 = M6 - M
      IF (P.EQ.2) GO TO 40
      IF (P.EQ.3) GO TO 60
      IF (P.EQ.4) GO TO 80
      IF (P.EQ.5) GO TO 100
      IF (P.EQ.8) GO TO 120
      GO TO 140
C
   40 CONTINUE
      CALL C06ECV(X(1), Y(1), PTS, X(M+1), Y(M+1), M1, M)
      GO TO 20
C
   60 CONTINUE
      CALL C06ECU(X(1), Y(1), PTS, X(M+1), Y(M+1), M1, X(2*M+1),Y(2*M+1)
     *, M2, M)
      GO TO 20
C
   80 CONTINUE
      CALL C06ECT(X(1), Y(1), PTS, X(M+1), Y(M+1), M1, X(2*M+1),Y(2*M+1)
     *, M2, X(3*M+1), Y(3*M+1), M3, M)
      GO TO 20
C
  100 CONTINUE
      CALL C06ECS(X(1), Y(1), PTS, X(M+1), Y(M+1), M1, X(2*M+1),Y(2*M+1)
     *, M2, X(3*M+1), Y(3*M+1), M3, X(4*M+1), Y(4*M+1),M4, M)
      GO TO 20
C
  120 CONTINUE
      CALL C06ECR(X(1), Y(1), PTS, X(M+1), Y(M+1), M1, X(2*M+1),Y(2*M+1)
     *, M2, X(3*M+1), Y(3*M+1), M3, X(4*M+1), Y(4*M+1),M4, X(5*M+1),
     * Y(5*M+1), M5, X(6*M+1), Y(6*M+1), M6,X(7*M+1), Y(7*M+1), M7, M)
      GO TO 20
C
  140 CONTINUE
      CALL C06ECQ(X, Y, PTS, M, P)
      GO TO 20
C
      END
** END OF C06ECWTEXT
*UPTODATE C06FAZTEXT
      SUBROUTINE C06FAZ(PTS, PMAX, TWOGRP, TFACT, RFACT, IERROR)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     COPY REORDERING FACTORING PROGRAMME
C     .. SCALAR ARGUMENTS ..
      INTEGER IERROR, PMAX, PTS, TWOGRP
C     .. ARRAY ARGUMENTS ..
      INTEGER RFACT(21), TFACT(21)
C     ..
C     .. LOCAL SCALARS ..
      INTEGER F, J, JJ, N, NEST, P, PTWO, Q
C     .. LOCAL ARRAYS ..
      INTEGER PP(10), QQ(20)
C     ..
      DATA NEST /20/
      N = PTS
      F = 2
      P = 0
      Q = 0
   20 CONTINUE
      IF (N.LE.1) GO TO 100
      DO 40 J=F,PMAX
         IF (N.EQ.(N/J)*J) GO TO 60
   40 CONTINUE
      GO TO 280
   60 CONTINUE
      IF (2*P+Q.GE.NEST) GO TO 300
      F = J
      N = N/F
      IF (N.EQ.(N/F)*F) GO TO 80
      Q = Q + 1
      QQ(Q) = F
      GO TO 20
   80 CONTINUE
      N = N/F
      P = P + 1
      PP(P) = F
      GO TO 20
C
  100 CONTINUE
      IF (P.LT.1) GO TO 140
      DO 120 J=1,P
         JJ = P + 1 - J
         TFACT(J) = PP(JJ)
         JJ = P + Q + J
         TFACT(JJ) = PP(J)
  120 CONTINUE
  140 CONTINUE
      IF (Q.LT.1) GO TO 180
      DO 160 J=1,Q
         JJ = P + J
         TFACT(JJ) = QQ(J)
  160 CONTINUE
  180 CONTINUE
      JJ = 2*P + Q
      TFACT(JJ+1) = 0
      RFACT(JJ+1) = 0
      DO 200 J=1,JJ
         RFACT(J) = TFACT(J)
  200 CONTINUE
      IF (JJ.EQ.1) RFACT(1) = 0
      PTWO = 1
      J = 0
  220 CONTINUE
      J = J + 1
      IF (TFACT(J).EQ.0) GO TO 260
      IF (TFACT(J).NE.2) GO TO 220
      PTWO = PTWO*2
      TFACT(J) = 1
      IF (PTWO.GE.TWOGRP) GO TO 240
      IF (TFACT(J+1).EQ.2) GO TO 220
  240 CONTINUE
      TFACT(J) = PTWO
      PTWO = 1
      GO TO 220
  260 CONTINUE
      IERROR = 0
      GO TO 320
  280 IERROR = 1
      GO TO 320
C
  300 IERROR = 2
  320 RETURN
      END
** END OF C06FAZTEXT
*UPTODATE C06FCFTEXT
      SUBROUTINE C06FCF(X, Y, PTS, WORK, IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     COMPLEX FOURIER TRANSFORM
C     .. SCALAR ARGUMENTS ..
      INTEGER IFAIL, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION WORK(PTS), X(PTS), Y(PTS)
C     ..
C     .. LOCAL SCALARS ..
C$P 1
      CHARACTER SRNAME*6
      DOUBLE PRECISION SQPTS
      INTEGER IERROR, IPTS, PMAX, TWOGRP
C     .. LOCAL ARRAYS ..
      INTEGER RFACT(21), TFACT(21)
C     .. FUNCTION REFERENCES ..
      DOUBLE PRECISION DSQRT
C     *** IMPLEMENTATION DEPENDENT DECLARATION ***
C     DOUBLE PRECISION DBLE
      INTEGER P01AAF
C     .. SUBROUTINE REFERENCES ..
C     C06ECW, C06FAY, C06FAZ
C     ..
C JLP91:
      DATA SRNAME /'C06FCF'/
      DATA PMAX /19/
      DATA TWOGRP /8/
      IF (PTS.LE.1) GO TO 40
      CALL C06FAZ(PTS, PMAX, TWOGRP, TFACT, RFACT, IERROR)
      IF (IERROR.NE.0) GO TO 60
      CALL C06ECW(X, Y, PTS, TFACT)
      CALL C06FAY(X, PTS, RFACT, WORK)
      CALL C06FAY(Y, PTS, RFACT, WORK)
      SQPTS = DSQRT(DBLE(PTS))
      DO 20 IPTS=1,PTS
         X(IPTS) = X(IPTS)/SQPTS
         Y(IPTS) = Y(IPTS)/SQPTS
   20 CONTINUE
      IFAIL = 0
      GO TO 80
C
   40 IERROR = 3
   60 IFAIL = P01AAF(IFAIL,IERROR,SRNAME)
   80 RETURN
      END
** END OF C06FCFTEXT
*UPTODATE C06FFFTEXT
      SUBROUTINE C06FFF(NDIM, L, ND, N, X, Y, WORK, LWORK, IFAIL)
C     MARK 11 RELEASE. NAG COPYRIGHT 1984.
C
C     DISCRETE FOURIER TRANSFORM OF ONE VARIABLE IN A
C     MULTI-VARIABLE SEQUENCE OF COMPLEX DATA VALUES
C
C     .. SCALAR ARGUMENTS ..
      INTEGER IFAIL, L, LWORK, N, NDIM
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION WORK(LWORK), X(N), Y(N)
      INTEGER ND(NDIM)
C     ..
C     .. LOCAL SCALARS ..
C$P 1
      CHARACTER SRNAME*6
      INTEGER I, IFAIL1, NI, NK, NL
C     .. FUNCTION REFERENCES ..
      INTEGER P01AAF
C     .. SUBROUTINE REFERENCES ..
C     C06FFZ
C     ..
      DATA SRNAME /'C06FFF'/
      IF (NDIM.LT.1) GO TO 60
      IF (L.LT.1 .OR. L.GT.NDIM) GO TO 100
      NK = 1
      NI = 1
      DO 20 I=1,NDIM
         IF (ND(I).LT.1) GO TO 120
         IF (I.GT.L) NK = NK*ND(I)
         IF (I.LT.L) NI = NI*ND(I)
   20 CONTINUE
      NL = ND(L)
      IF (NI*NL*NK.NE.N) GO TO 80
      IF (NL.EQ.1) GO TO 40
      IF (LWORK.LT.3*NL) GO TO 160
      CALL C06FFZ(X, Y, NI, NL, NK, WORK, WORK(NL+1), WORK(2*NL+1),
     *IFAIL1)
      IF (IFAIL1.NE.0) GO TO 140
   40 IFAIL = 0
      RETURN
   60 IFAIL1 = 1
      GO TO 180
   80 IFAIL1 = 2
      GO TO 180
  100 IFAIL1 = 3
      GO TO 180
  120 IFAIL1 = 3 + 10*I
      GO TO 180
  140 IFAIL1 = IFAIL1 + 10*L
      GO TO 180
  160 IFAIL1 = 4 + 10*L
  180 IFAIL = P01AAF(IFAIL,IFAIL1,SRNAME)
      RETURN
      END
** END OF C06FFFTEXT
*UPTODATE C06FFZTEXT
      SUBROUTINE C06FFZ(X, Y, NI, NJ, NK, W1, W2, W3, IFAIL)
C     MARK 11 RELEASE. NAG COPYRIGHT 1984.
C
C     DISCRETE FOURIER TRANSFORM OF THE 2ND VARIABLE IN A
C     3-DIMENSIONAL SEQUENCE OF COMPLEX DATA VALUES
C
C     .. SCALAR ARGUMENTS ..
      INTEGER IFAIL, NI, NJ, NK
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION W1(NJ), W2(NJ), W3(NJ), X(NI,NJ,NK), Y(NI,NJ,NK)
C     ..
C     .. LOCAL SCALARS ..
      INTEGER I, J, K
C     .. SUBROUTINE REFERENCES ..
C     C06FCF
C     ..
      DO 80 K=1,NK
         DO 60 I=1,NI
            DO 20 J=1,NJ
               W1(J) = X(I,J,K)
               W2(J) = Y(I,J,K)
   20       CONTINUE
            IFAIL = 1
            CALL C06FCF(W1, W2, NJ, W3, IFAIL)
            DO 40 J=1,NJ
               X(I,J,K) = W1(J)
               Y(I,J,K) = W2(J)
   40       CONTINUE
   60    CONTINUE
   80 CONTINUE
      RETURN
      END
** END OF C06FFZTEXT
*UPTODATE C06FJFTEXT
      SUBROUTINE C06FJF(NDIM, ND, N, X, Y, WORK, LWORK, IFAIL)
C     MARK 11 RELEASE. NAG COPYRIGHT 1984.
C
C     MULTI-DIMENSIONAL DISCRETE FOURIER TRANSFORM OF A
C     MULTI-DIMENSIONAL SEQUENCE OF COMPLEX DATA VALUES
C
C     .. SCALAR ARGUMENTS ..
      INTEGER IFAIL, LWORK, N, NDIM
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION WORK(LWORK), X(N), Y(N)
      INTEGER ND(NDIM)
C     ..
C     .. LOCAL SCALARS ..
C$P 1
      CHARACTER SRNAME*6
      INTEGER IFAIL1, L
C     .. FUNCTION REFERENCES ..
      INTEGER P01AAF
C     .. SUBROUTINE REFERENCES ..
C     C06FFF
C     ..
      DATA SRNAME /'C06FJF'/
      IF (NDIM.LT.1) GO TO 40
      DO 20 L=1,NDIM
         IFAIL1 = 1
         CALL C06FFF(NDIM, L, ND, N, X, Y, WORK, LWORK, IFAIL1)
         IF (IFAIL1.NE.0) GO TO 60
   20 CONTINUE
      IFAIL = 0
      RETURN
   40 IFAIL1 = 1
   60 IFAIL = P01AAF(IFAIL,IFAIL1,SRNAME)
      RETURN
      END
** END OF C06FJFTEXT
*JLP91***********************************
*UPTODATE C06GCFTEXT
      SUBROUTINE C06GCF(Y, PTS, IFAIL)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     COMPLEX CONJUGATE
C     .. SCALAR ARGUMENTS ..
      INTEGER IFAIL, PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION Y(PTS)
C     ..
C     .. LOCAL SCALARS ..
C$P 1
      CHARACTER SRNAME*6
      INTEGER IERROR, J
C     .. FUNCTION REFERENCES ..
      INTEGER P01AAF
C     ..
      DATA SRNAME /'C06FCF'/
      IF (PTS.LE.0) GO TO 40
      IERROR = 0
      DO 20 J=1,PTS
         Y(J) = -Y(J)
   20 CONTINUE
      GO TO 60
C
   40 IERROR = 1
   60 IFAIL = P01AAF(IFAIL,IERROR,SRNAME)
      RETURN
      END
** END OF C06GCFTEXT
*UPTODATE C06FAYTEXT
      SUBROUTINE C06FAY(X, PTS, FACTOR, WORK)
C     MARK 8 RELEASE. NAG COPYRIGHT 1979.
C     MARK 11 REVISED. IER-444 (FEB 1984).
C     SINGLE COPY REORDERING PROGRAMME
C     EQUIVALENCE (I1,I(1)), (K1,K(1)), (L1,L(1))
C     EQUIVALENCE (I2,I(2)), (K2,K(2)), (L2,L(2))
C     EQUIVALENCE (I3,I(3)), (K3,K(3)), (L3,L(3))
C     EQUIVALENCE (I4,I(4)), (K4,K(4)), (L4,L(4))
C     EQUIVALENCE (I5,I(5)), (K5,K(5)), (L5,L(5))
C     EQUIVALENCE (I6,I(6)), (K6,K(6)), (L6,L(6))
C     EQUIVALENCE (I7,I(7)), (K7,K(7)), (L7,L(7))
C     EQUIVALENCE (I8,I(8)), (K8,K(8)), (L8,L(8))
C     EQUIVALENCE (I9,I(9)), (K9,K(9)), (L9,L(9))
C     EQUIVALENCE (I10,I(10)), (K10,K(10)), (L10,L(10))
C     EQUIVALENCE (K11,K(11))
C     .. SCALAR ARGUMENTS ..
      INTEGER PTS
C     .. ARRAY ARGUMENTS ..
      DOUBLE PRECISION WORK(PTS), X(PTS)
      INTEGER FACTOR(21)
C     ..
C     .. LOCAL SCALARS ..
      INTEGER I10, I1, I2, I3, I4, I5, I6, I7, I8, I9, J, JJ, K10,K11,
     * K1, K2, K3, K4, K5, K6, K7, K8, K9, KK, L10, L1, L2,L3, L4, L5,
     * L6, L7, L8, L9, LEVEL, LOOP, NEST
C     .. LOCAL ARRAYS ..
      INTEGER I(20), K(20), L(20)
C     ..
      DATA NEST /20/
      DATA LOOP /10/
      IF (FACTOR(1).EQ.0) GO TO 380
      DO 20 J=1,NEST
         L(J) = 1
         I(J) = 1
   20 CONTINUE
      KK = PTS
      DO 40 J=1,NEST
         IF (FACTOR(J).EQ.0) GO TO 60
         L(J) = KK
         I(J) = KK/FACTOR(J)
         KK = KK/FACTOR(J)
   40 CONTINUE
   60 CONTINUE
C
      L1 = L(1)
      L2 = L(2)
      L3 = L(3)
      L4 = L(4)
      L5 = L(5)
      L6 = L(6)
      L7 = L(7)
      L8 = L(8)
      L9 = L(9)
      L10 = L(10)
      I1 = I(1)
      I2 = I(2)
      I3 = I(3)
      I4 = I(4)
      I5 = I(5)
      I6 = I(6)
      I7 = I(7)
      I8 = I(8)
      I9 = I(9)
      I10 = I(10)
C
      KK = 0
      LEVEL = NEST
      K(LEVEL) = 1
      GO TO 100
   80 CONTINUE
      IF (LEVEL.GE.NEST) GO TO 340
      LEVEL = LEVEL + 1
      K(LEVEL) = K(LEVEL) + I(LEVEL)
      IF (K(LEVEL).GT.L(LEVEL)) GO TO 80
  100 CONTINUE
      LEVEL = LEVEL - 1
      DO 120 J=LOOP,LEVEL
         JJ = LEVEL + LOOP - J
         K(JJ) = K(JJ+1)
  120 CONTINUE
      K11 = K(11)
      DO 320 K10=K11,L10,I10
         DO 300 K9=K10,L9,I9
            DO 280 K8=K9,L8,I8
               DO 260 K7=K8,L7,I7
                  DO 240 K6=K7,L6,I6
                     DO 220 K5=K6,L5,I5
                        DO 200 K4=K5,L4,I4
                           DO 180 K3=K4,L3,I3
                              DO 160 K2=K3,L2,I2
                                 DO 140 K1=K2,L1,I1
                                    KK = KK + 1
                                    WORK(KK) = X(K1)
  140                            CONTINUE
  160                         CONTINUE
  180                      CONTINUE
  200                   CONTINUE
  220                CONTINUE
  240             CONTINUE
  260          CONTINUE
  280       CONTINUE
  300    CONTINUE
  320 CONTINUE
      LEVEL = LOOP
      GO TO 80
  340 CONTINUE
      DO 360 J=1,PTS
         X(J) = WORK(J)
  360 CONTINUE
C
  380 CONTINUE
      RETURN
      END
** END OF C06FAYTEXT
*****************************************************************
*****************************************************************
* X01FTEXT
*UPTODATE X01AAFTEXT
      DOUBLE PRECISION FUNCTION X01AAF(X)
C     NAG COPYRIGHT 1975
C     MARK 4.5 RELEASE
      DOUBLE PRECISION X
C     * PI *
C     RETURNS THE VALUE OF THE CONSTANT PI
C     THE X PARAMETER IS NOT USED
C     FOR DEC VAX 11/780
C     X01AAF = 3.14159265358979324D0
      X01AAF = 3.14159265358979324D0
      RETURN
      END
** END OF X01AAFTEXT
*UPTODATE X01ABFTEXT
      DOUBLE PRECISION FUNCTION X01ABF(X)
C     NAG COPYRIGHT 1975
C     MARK 4.5 RELEASE
      DOUBLE PRECISION X
C     * GAMMA *
C     RETURNS THE VALUE OF EULERS CONSTANT GAMMA WHERE
C     GAMMA = LIM(1+1/2+...+1/N - LOG(N)) AS N TENDS TO INFINITY
C     THE X PARAMETER IS NOT USED
C     FOR DEC VAX 11/780
C     X01ABF = 0.577215664901532861D0
      X01ABF = 0.577215664901532861D0
      RETURN
      END
** END OF X01ABFTEXT
*****************************************************************
*****************************************************************
* P01FTEXT
*UPTODATE P01AAFTEXT
      INTEGER FUNCTION P01AAF(IFAIL, ERROR, SRNAME)
C     MARK 1 RELEASE.  NAG COPYRIGHT 1971
C     MARK 3 REVISED
C     MARK 4A REVISED, IER-45
C     MARK 4.5 REVISED
C     MARK 7 REVISED (DEC 1978)
C     MARK 11 REVISED (FEB 1984)
C     RETURNS THE VALUE OF ERROR OR TERMINATES THE PROGRAM.
      INTEGER ERROR, IFAIL, NOUT
C$P 1
      CHARACTER SRNAME*6
C     TEST IF NO ERROR DETECTED
      IF (ERROR.EQ.0) GO TO 20
C     DETERMINE OUTPUT UNIT FOR MESSAGE
      NOUT=6
C      CALL X04AAF (0,NOUT)
C     TEST FOR SOFT FAILURE
      IF (MOD(IFAIL,10).EQ.1) GO TO 10
C     HARD FAILURE
      WRITE (NOUT,99999) SRNAME, ERROR
C     ******************** IMPLEMENTATION NOTE ********************
C     THE FOLLOWING STOP STATEMENT MAY BE REPLACED BY A CALL TO AN
C     IMPLEMENTATION-DEPENDENT ROUTINE TO DISPLAY A MESSAGE AND/OR
C     ABORT THE PROGRAM.
C     *************************************************************
      STOP
C     SOFT FAIL
C     TEST IF ERROR MESSAGES SUPPRESSED
   10 IF (MOD(IFAIL/10,10).EQ.0) GO TO 20
      WRITE (NOUT,99999) SRNAME, ERROR
   20 P01AAF = ERROR
      RETURN
99999 FORMAT (' ERROR DETECTED BY NAG LIBRARY ROUTINE ', A8,
     * ' - IFAIL = ', I5//)
      END
** END OF P01AAFTEXT


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine phonon_band_tst
  use global_variables
  implicit none
  real(8),parameter :: Udist = 1d-2
  integer,parameter :: Num=10
  complex(8),allocatable :: zWp_mat(:,:), zF_mat_t(:,:), zCt(:)
  complex(8),allocatable :: zDw(:,:,:)
  real(8) :: x
  integer :: ik1,ik2,ib1,ib2,is1,is2
  integer :: aion,bion,cion,icell,icell2,icell3,ix
  complex(8) :: zs
  real(8) :: la_full
  integer :: Nmat
  integer :: iflag_cell(NK,Nion)
  real(8) :: tmp,ss,a,b2,c
  real(8) :: Eii_tmp,E_gs
!LAPACK ==
  integer :: lwork
  complex(8),allocatable :: work_lp(:)
  real(8),allocatable :: rwork(:),w(:)
  integer :: info
  lwork=6*(NK*NB)**2
  allocate(work_lp(lwork),rwork(3*NK*NB-2),w(NK*NB))
!LAPACK ==

  if(myrank == 0)write(*,"(A)")"!Start Phonon band calculation"
  Nmat = NK*NB
  allocate(zCt(NK*NB), zDw(Nion,Nion,NK))
  la_full = lattice_a*dble(NK)

! GS
  zpsi_Ct = 0d0
  Uion = 0d0

  call prep_Hmat
  Call zheev('V', 'U', Nmat, zH_mat, Nmat, w, work_lp, lwork, rwork, info)
  zpsi_Ct(1:Nmat,1:NK) = zH_mat(1:Nmat,1:NK)
  call prep_Hmat
  call total_energy
  call force_ion

  E_gs = E_tot

  if(myrank == 0) open(21,file="ef_tst.out")
  do is1 = 0,Num
    Uion(1,1) = dble(is1)*Udist/dble(Num)

    call prep_Hmat
    Call zheev('V', 'U', Nmat, zH_mat, Nmat, w, work_lp, lwork, rwork, info)
    zpsi_Ct(1:Nmat,1:NK) = zH_mat(1:Nmat,1:NK)
    call prep_Hmat
    call total_energy
    call force_ion

    if(myrank==0)write(21,"(999e26.16e3)")Uion(1,1),E_tot-E_gs,Fion(1,1),E_tot,E_elec,E_ii
  end do
  if(myrank==0)close(21)

  if(myrank==0)then
    write(*,*)"f-sum",sum(Fion(:,:)),sum(Fion(:,1)),sum(Fion(:,2))
    do is1 = 1,NK
      write(*,"(I6,2x,999e16.6e3)")is1,Fion(is1,1),Fion(is1,2)
    end do
  end if

! phonon calculation
  Phi_FC(:,:,:,:) = 0d0
  do aion = 1,Nion
    Uion(:,:) = 0d0
    Uion(1,aion) = Udist
    call prep_Hmat
    Call zheev('V', 'U', Nmat, zH_mat, Nmat, w, work_lp, lwork, rwork, info)
    zpsi_Ct(1:Nmat,1:NK) = zH_mat(1:Nmat,1:NK)
    call prep_Hmat
    call total_energy
    call force_ion

    Phi_FC(:,:,1,aion) = - Fion(:,:) /Udist
  end do

  do icell = 2,NK
    do icell2 = 1,NK
      icell3 = icell2 + (icell-1)
      if(icell3 > NK)icell3 = icell3-NK
      Phi_FC(icell3,:,icell,:) = Phi_FC(icell2,:,1,:)
    end do
  end do

  do ik1 = 1,NK
    do aion = 1,Nion
      do bion = 1,Nion
        zs = 0d0
        do icell = 1,NK
          zs = zs + Phi_FC(1,aion,icell,bion) &
          *exp(-zI*kx(ik1)*(Rion(aion) - Rion(bion) - lattice_a*(icell-1)))
        end do
        zDw(aion,bion,ik1)=zs/sqrt(Mion(aion)*Mion(bion))
      end do
    end do
  end do
! phonon band; assuming Nion = 2

  do ik1 = 1,NK
    a = real(zDw(1,1,ik1)); c = real(zDw(2,2,ik1)); b2 = abs(zDw(1,2,ik1))**2
    w2_ph(1,ik1) = 0.5d0*(a+c-sqrt((a-c)**2+4d0*b2))
    w2_ph(2,ik1) = 0.5d0*(a+c+sqrt((a-c)**2+4d0*b2))
    if(w2_ph(1,ik1) < 0d0) w2_ph(1,ik1) = 0d0
    if(w2_ph(2,ik1) < 0d0) w2_ph(2,ik1) = 0d0
  end do
  w_ph = sqrt(w2_ph)

  if(myrank == 0)then
    open(10,file=trim(filename)//'_phonon_band_tst.out')
    do ik1=1,NK
      write(10,'(100e26.16E3)')kx(ik1),w_ph(:,ik1),w2_ph(:,ik1)
    end do
    write(10,'(100e26.16E3)')-kx(1),w_ph(:,1),w2_ph(:,1)
    close(10)
  end if

  return
end subroutine phonon_band_tst
!-------10--------20--------30--------40--------50--------60--------70--------80--------90


      SUBROUTINE ZGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
*
*  -- LAPACK routine (version 3.2) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      COMPLEX*16         B( LDB, * ), D( * ), DL( * ), DU( * )
*     ..
*
*  Purpose
*  =======
*
*  ZGTSV  solves the equation
*
*     A*X = B,
*
*  where A is an N-by-N tridiagonal matrix, by Gaussian elimination with
*  partial pivoting.
*
*  Note that the equation  A'*X = B  may be solved by interchanging the
*  order of the arguments DU and DL.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  DL      (input/output) COMPLEX*16 array, dimension (N-1)
*          On entry, DL must contain the (n-1) subdiagonal elements of
*          A.
*          On exit, DL is overwritten by the (n-2) elements of the
*          second superdiagonal of the upper triangular matrix U from
*          the LU factorization of A, in DL(1), ..., DL(n-2).
*
*  D       (input/output) COMPLEX*16 array, dimension (N)
*          On entry, D must contain the diagonal elements of A.
*          On exit, D is overwritten by the n diagonal elements of U.
*
*  DU      (input/output) COMPLEX*16 array, dimension (N-1)
*          On entry, DU must contain the (n-1) superdiagonal elements
*          of A.
*          On exit, DU is overwritten by the (n-1) elements of the first
*          superdiagonal of U.
*
*  B       (input/output) COMPLEX*16 array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero, and the solution
*                has not been computed.  The factorization has not been
*                completed unless i = N.
*
*  =====================================================================
*
*     .. Parameters ..
      COMPLEX*16         ZERO
      PARAMETER          ( ZERO = ( 0.0D+0, 0.0D+0 ) )
*     ..
*     .. Local Scalars ..
      INTEGER            J, K
      COMPLEX*16         MULT, TEMP, ZDUM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, DIMAG, MAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Statement Functions ..
      DOUBLE PRECISION   CABS1
*     ..
*     .. Statement Function definitions ..
      CABS1( ZDUM ) = ABS( DBLE( ZDUM ) ) + ABS( DIMAG( ZDUM ) )
*     ..
*     .. Executable Statements ..
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZGTSV ', -INFO )
         RETURN
      END IF
*
      IF( N.EQ.0 )
     $   RETURN
*
      DO 30 K = 1, N - 1
         IF( DL( K ).EQ.ZERO ) THEN
*
*           Subdiagonal is zero, no elimination is required.
*
            IF( D( K ).EQ.ZERO ) THEN
*
*              Diagonal is zero: set INFO = K and return; a unique
*              solution can not be found.
*
               INFO = K
               RETURN
            END IF
         ELSE IF( CABS1( D( K ) ).GE.CABS1( DL( K ) ) ) THEN
*
*           No row interchange required
*
            MULT = DL( K ) / D( K )
            D( K+1 ) = D( K+1 ) - MULT*DU( K )
            DO 10 J = 1, NRHS
               B( K+1, J ) = B( K+1, J ) - MULT*B( K, J )
   10       CONTINUE
            IF( K.LT.( N-1 ) )
     $         DL( K ) = ZERO
         ELSE
*
*           Interchange rows K and K+1
*
            MULT = D( K ) / DL( K )
            D( K ) = DL( K )
            TEMP = D( K+1 )
            D( K+1 ) = DU( K ) - MULT*TEMP
            IF( K.LT.( N-1 ) ) THEN
               DL( K ) = DU( K+1 )
               DU( K+1 ) = -MULT*DL( K )
            END IF
            DU( K ) = TEMP
            DO 20 J = 1, NRHS
               TEMP = B( K, J )
               B( K, J ) = B( K+1, J )
               B( K+1, J ) = TEMP - MULT*B( K+1, J )
   20       CONTINUE
         END IF
   30 CONTINUE
      IF( D( N ).EQ.ZERO ) THEN
         INFO = N
         RETURN
      END IF
*
*     Back solve with the matrix U from the factorization.
*
      DO 50 J = 1, NRHS
         B( N, J ) = B( N, J ) / D( N )
         IF( N.GT.1 )
     $      B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
         DO 40 K = N - 2, 1, -1
            B( K, J ) = ( B( K, J )-DU( K )*B( K+1, J )-DL( K )*
     $                  B( K+2, J ) ) / D( K )
   40    CONTINUE
   50 CONTINUE
*
      RETURN
*
*     End of ZGTSV
*
      END


!                  ___                         ___
!    ___          /  /\                       /  /\
!   /  /\        /  /:/                      /  /:/_
!  /  /:/       /  /:/       ___     ___    /  /:/ /\
! /__/::\      /  /:/  ___  /__/\   /  /\  /  /:/ /::\
! \__\/\:\__  /__/:/  /  /\ \  \:\ /  /:/ /__/:/ /:/\:\
!    \  \:\/\ \  \:\ /  /:/  \  \:\  /:/  \  \:\/:/~/:/
!     \__\::/  \  \:\  /:/    \  \:\/:/    \  \::/ /:/
!     /__/:/    \  \:\/:/      \  \::/      \__\/ /:/
!     \__\/      \  \::/        \__\/         /__/:/
!                 \__\/                       \__\/
!
!
! ICLS - Interface-Correction Level Set
!------------------------------------------------------

program ICLS

  use mod_param
  use mod_param_ls
  use mod_common
  use mod_common_mpi
  use mod_initmpi
  use mod_init
  use mod_bound
  use mod_chkdiv
  use mod_chkdt
  use mod_loadflds
  use mod_mom
  use mod_ab
  use mod_levelset
  use mod_interface
  use mod_gfm
  use mod_solver
  use mod_fillps
  use mod_correc
  use mod_output
  use mod_write_vtk
  use mod_stopwatch
  use mod_misc

  implicit none

  integer :: i,j,k,l
  integer :: iopt, begin,nstep,istep

  real :: dtmax
  real :: ls_time, ls_time_max, ls_stopwatch_max
  real :: ab2_time, ab2_time_max, ab2_stopwatch_max
  real :: pj_time, pj_time_max, pj_stopwatch_max
  real :: comp_time, comp_time_min,comp_time_max
  real :: stopwatch_min,stopwatch_max
  real :: norm,norm_all,norm_old
  real :: v_bulk_all, massloss, quck, vel_max

  real, dimension(1:imax,1:jmax,1:kmax) :: duold,dvold,dwold
  real, dimension(0:i1,0:j1,0:k1) :: pold,p_jump, curv_restart

  real, pointer, dimension(:,:,:) :: pp2 ! uncomment iff solver2d is used
  real, target,  dimension(0:i1,0:j1,0:k1) :: p

  !--------------------------------------------!
  !              INITIALIZATION                !
  !--------------------------------------------!

  iopt = 0
  if(iopt .eq. 1) then
     call MPI_INIT(error)
     call decomp_2d_init(itot, jtot, ktot, 0,0)
     call MPI_FINALIZE(error)
     stop
  else
     call initmpi
  endif

  begin = 0
  nstep = 4000

  call init_program(begin, duold,dvold,dwold,pold,curv_restart)

  pp2 => p(1:imax,1:jmax,1:kmax) ! uncomment iff solver2d is used

  !---- Output initial conditions ----!

  call post2d(begin)
  !call write_vtk(begin)

  !---- MPI timer ----!

  ls_stopwatch_max = 0.
  ab2_stopwatch_max = 0.
  pj_stopwatch_max = 0.
  stopwatch_min = 0.
  stopwatch_max = 0.
  total_time = 0.

  !--------------------------------------------!
  !                 MAIN LOOP                  !
  !--------------------------------------------!

  do istep = begin+1,nstep

     if (myid .eq. 0) write(6,*) 'istep =', istep
     comp_time = mpi_wtime()
     time = time + dt

     !---- Level Set ----!

     if (solveLS) then

        call ls_main(istep)

        ls_time = mpi_wtime() - comp_time
        call mpi_allreduce(ls_time,ls_time_max,1,mpi_real8,mpi_max,comm_cart,error)

     endif

     !---- Navier-Stokes ----!

     if (solveNS) then

        call average_stream_vel(v_bulk)  ! calculate average streamwise velocity

        !-- Intermediate Velocity --!

        ab2_time = mpi_wtime()

        call ab2(duold,dvold,dwold,pold)

        ab2_time = mpi_wtime() - ab2_time
        call mpi_allreduce(ab2_time,ab2_time_max,1,mpi_real8,mpi_max,comm_cart,error)

        !-- RHS of Poisson --!

        pj_time = mpi_wtime()

        call fillps(p)
        if (solveLS) then
           call gfm4p(p_jump)
           p = p + p_jump
        endif

        !-- Pressure --!

        select case(BC_in_y)
        case ('Periodic')
           call solver2d(pp2)  ! pp2 => p
           !      call solver1d(p)
        case ('InOut','Walls','OutOut')
           call solver2d_cos(pp2)
        end select

        call boundp(p)

        !-- New Velocity --!

        call correc(p)
        call bounduvw(unew,vnew,wnew)

        !-- Update & Normalize Pressure --!

        pold(:,:,:) = pnew(:,:,:)
        pnew(:,:,:) = p(:,:,:)

        call boundp(pnew)

        select case(BC_in_y)
        case('Periodic','Walls')

           k=1 ! near bottom wall
           norm = sum(sum(pnew(:,:,k),2),1)
           call mpi_allreduce(norm,norm_all,1,mpi_real8,mpi_sum,comm_cart,error)
           norm = norm_all/(1.*itot*jtot)
           pnew(:,:,:) = pnew(:,:,:) - norm

           if (istep .eq. begin+1) then
              pold(:,:,:) = pold(:,:,:) - norm
           else
              pold(:,:,:) = pold(:,:,:) + norm_old - norm  ! re-normalize pold with the new norm
           endif
           norm_old = norm  ! update norm_old after correcting pold

        end select

        pj_time = mpi_wtime() - pj_time
        call mpi_allreduce(pj_time,pj_time_max,1,mpi_real8,mpi_max,comm_cart,error)

        call average_vel_at_center ! update center velocities
        if (stop_at_steady) call check_steady_state(istep)

     else

        select case (iniu)
        case('sep')
           call serpentine(time)  ! 2D periodic deformation (purely level set)
        end select

     endif

     !--------------------------------------------!
     !                   OUTPUT                   !
     !--------------------------------------------!

     if (isnan(vnew(1,1,1))) then
        if (myid .eq. 0) write(6,*) 'Got NaN... Terminate brutally. :('
        stop
     endif

     if (mod(istep,ioutchk) .eq. 0) then
        call chkdiv(istep)
        call chkdt(dtmax)
        if (myid .eq. 0) write(6,'(A,1ES12.4)') '! dt calculated by chkdt =', dtmax
        dt = timestep

        !-- Dispersed file --!

        if (.false.) then
           call disp_cg     ! center of gravity
           call disp_speed  ! average velocity

           if (myid .eq. 0) then
             open(61,file=datadir//'dispersed.txt',position='append')
             write(61,'(7ES16.8)') 1.*istep,x_disp_avr,y_disp_avr,z_disp_avr,&
                                            u_disp_avr,v_disp_avr,w_disp_avr
             close(61)
           endif
        endif

        !-- Timestep file (quick check) --!

        quck = 0.
        !call Prosperetti(quck)
        !call spurious_currents(quck)
        !call Grace(quck)
        !quck = v_bulk
        !quck = maxval(dmin)/dz  ! max distance between droplets
        quck = dmin(1,2)/dz
        !call Taylor(quck)

        call max_vel_at_center(vel_max)

        if (myid .eq. 0) then
           write(6,'(A,1ES12.4,A,1ES12.4)') '! Actual dt              =',dt,'  max CFL =', CFL*vel_max
           write(6,'(A,1ES12.4)') '! Time =', time

           massloss = 0.
           do l = 1,lmax
              massloss = massloss + (1. - volume(l)/init_volume(l))
           enddo

           open(29,file=datadir//'timestep.txt',position='append')
           write(29,'(6ES16.8)') 1.*istep,time,dt, massloss, quck, maxchk_glb
           close(29)
        endif
     endif

     !-- 2D file (mid-yz plane) --!

     if (mod((istep),iout2d) .eq. 0) then
        call post2d(istep)
     endif

     !-- 3D file --!

     if (mod(istep,iout3d) .eq. 0) then
        !      call post3d(istep)
        call write_vtk(istep)   ! read in paraview
     endif

     !-- Restarting file --!

     if (mod(istep,ioutfld) .eq. 0) then
        call loadflds(1,istep)  ! flow field and level set field
     endif

     !-- Timing --!

     comp_time = MPI_WTIME()-comp_time
     call mpi_allreduce(comp_time,comp_time_min,1,mpi_real8,mpi_min,comm_cart,error)
     call mpi_allreduce(comp_time,comp_time_max,1,mpi_real8,mpi_max,comm_cart,error)

     call stopwatch(istep,'Total', comp_time_min,comp_time_max, stopwatch_min,stopwatch_max)
     call time_breakdown(istep,'LvSet', ls_time_max, ls_stopwatch_max, stopwatch_max)
     call time_breakdown(istep,'exAB2',ab2_time_max,ab2_stopwatch_max, stopwatch_max)
     call time_breakdown(istep,'Projt', pj_time_max, pj_stopwatch_max, stopwatch_max)

  enddo  ! end of main loop

  if(myid .eq. 0) then
     write(6,'(A)') ' '
     write(6,'(A)') '************** Simulation completed. Congrats! \o/ *************'
  end if

  call decomp_2d_finalize
  call MPI_FINALIZE(error)

  stop
end program


      subroutine NODEOPLAP(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1,ilofphilo2
     &           ,ilofphihi0,ilofphihi1,ilofphihi2
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1,ilofphilo2
      integer ilofphihi0,ilofphihi1,ilofphihi2
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           ilofphilo2:ilofphihi2,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 dxinv2, lphi
      integer var, ncomp
      integer  i, j, k
      ncomp = nphicomp
      if(ncomp .ne. nlofphicomp) then
         call MAYDAY_ERROR()
      endif
      dxinv2 = (1.0d0) / (dx*dx)
      do var = 0, ncomp-1
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
            lphi = ( (phi(i+1 , j  , k  , var)
     &              - phi(i   , j  , k  , var) )
     &            -  (phi(i   , j  , k  , var)
     &              - phi(i-1 , j  , k  , var) ) ) * dxinv2
     &         +   ( (phi(i   , j+1, k  , var)
     &              - phi(i   , j  , k  , var) )
     &            -  (phi(i   , j  , k  , var)
     &              - phi(i   , j-1, k  , var) ) ) * dxinv2
     &         +   ( (phi(i   , j  , k+1, var)
     &              - phi(i   , j  , k  , var) )
     &            -  (phi(i   , j  , k  , var)
     &              - phi(i   , j  , k-1, var) ) ) * dxinv2
            lofphi(i, j, k, var) =  lphi
      enddo
      enddo
      enddo
      end do
      return
      end
      subroutine NODEOPLAPPOINT(
     &           lofphi
     &           ,ilofphilo0,ilofphilo1,ilofphilo2
     &           ,ilofphihi0,ilofphihi1,ilofphihi2
     &           ,nlofphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,pt
     &           ,dx
     &           )
      implicit none
      integer nlofphicomp
      integer ilofphilo0,ilofphilo1,ilofphilo2
      integer ilofphihi0,ilofphihi1,ilofphihi2
      REAL*8 lofphi(
     &           ilofphilo0:ilofphihi0,
     &           ilofphilo1:ilofphihi1,
     &           ilofphilo2:ilofphihi2,
     &           0:nlofphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer pt(0:2)
      REAL*8 dx
      REAL*8 dxinv2, lphi
      integer var, ncomp
      integer  i, j, k
      ncomp = nphicomp
      if(ncomp .ne. nlofphicomp) then
         call MAYDAY_ERROR()
      endif
      dxinv2 = (1.0d0) / (dx*dx)
      i = pt(0)
      j = pt(1)
      k = pt(2)
      do var = 0, ncomp-1
         lphi = ( (phi(i+1 , j  , k  , var)
     &           - phi(i   , j  , k  , var) )
     &         -  (phi(i   , j  , k  , var)
     &           - phi(i-1 , j  , k  , var) ) ) * dxinv2
     &      +   ( (phi(i   , j+1, k  , var)
     &           - phi(i   , j  , k  , var) )
     &         -  (phi(i   , j  , k  , var)
     &           - phi(i   , j-1, k  , var) ) ) * dxinv2
     &      +   ( (phi(i   , j  , k+1, var)
     &           - phi(i   , j  , k  , var) )
     &         -  (phi(i   , j  , k  , var)
     &           - phi(i   , j  , k-1, var) ) ) * dxinv2
         lofphi(i, j, k, var) =  lphi
      end do
      return
      end
      subroutine NODEGRAD(
     &           grdphi
     &           ,igrdphilo0,igrdphilo1,igrdphilo2
     &           ,igrdphihi0,igrdphihi1,igrdphihi2
     &           ,ngrdphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           )
      implicit none
      integer ngrdphicomp
      integer igrdphilo0,igrdphilo1,igrdphilo2
      integer igrdphihi0,igrdphihi1,igrdphihi2
      REAL*8 grdphi(
     &           igrdphilo0:igrdphihi0,
     &           igrdphilo1:igrdphihi1,
     &           igrdphilo2:igrdphihi2,
     &           0:ngrdphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      REAL*8 dxinvh
      integer var, ncomp, gbase
      integer  i, j, k
      ncomp = nphicomp
      if (3 * ncomp .ne. ngrdphicomp) then
         call MAYDAY_ERROR()
      endif
      dxinvh = (0.500d0) / dx
      do var = 0, ncomp-1
         gbase = 3 * var
      do k = iregionlo2,iregionhi2
      do j = iregionlo1,iregionhi1
      do i = iregionlo0,iregionhi0
            grdphi(i, j, k, gbase) =
     &           ( phi(i+1 , j   , k   , var)
     &           - phi(i-1 , j   , k   , var) ) * dxinvh
            grdphi(i, j, k, gbase + 1) =
     &           ( phi(i   , j+1 , k   , var)
     &           - phi(i   , j-1 , k   , var) ) * dxinvh
            grdphi(i, j, k, gbase + 2) =
     &           ( phi(i   , j   , k+1 , var)
     &           - phi(i   , j   , k-1 , var) ) * dxinvh
      enddo
      enddo
      enddo
      end do
      return
      end
      subroutine NODEGRADPOINT(
     &           grdphi
     &           ,igrdphilo0,igrdphilo1,igrdphilo2
     &           ,igrdphihi0,igrdphihi1,igrdphihi2
     &           ,ngrdphicomp
     &           ,phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,pt
     &           ,dx
     &           )
      implicit none
      integer ngrdphicomp
      integer igrdphilo0,igrdphilo1,igrdphilo2
      integer igrdphihi0,igrdphihi1,igrdphihi2
      REAL*8 grdphi(
     &           igrdphilo0:igrdphihi0,
     &           igrdphilo1:igrdphihi1,
     &           igrdphilo2:igrdphihi2,
     &           0:ngrdphicomp-1)
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer pt(0:2)
      REAL*8 dx
      REAL*8 dxinvh
      integer var, ncomp, gbase
      integer  i, j, k
      ncomp = nphicomp
      if (3 * ncomp .ne. ngrdphicomp) then
         call MAYDAY_ERROR()
      endif
      dxinvh = (0.500d0) / dx
      i = pt(0)
      j = pt(1)
      k = pt(2)
      do var = 0, ncomp-1
         gbase = 3 * var
            grdphi(i, j, k, gbase) =
     &           ( phi(i+1 , j   , k   , var)
     &           - phi(i-1 , j   , k   , var) ) * dxinvh
            grdphi(i, j, k, gbase + 1) =
     &           ( phi(i   , j+1 , k   , var)
     &           - phi(i   , j-1 , k   , var) ) * dxinvh
            grdphi(i, j, k, gbase + 2) =
     &           ( phi(i   , j   , k+1 , var)
     &           - phi(i   , j   , k-1 , var) ) * dxinvh
      end do
      return
      end
      subroutine NODEGSRBLEVELLAP(
     &           phi
     &           ,iphilo0,iphilo1,iphilo2
     &           ,iphihi0,iphihi1,iphihi2
     &           ,nphicomp
     &           ,rhs
     &           ,irhslo0,irhslo1,irhslo2
     &           ,irhshi0,irhshi1,irhshi2
     &           ,nrhscomp
     &           ,iregionlo0,iregionlo1,iregionlo2
     &           ,iregionhi0,iregionhi1,iregionhi2
     &           ,dx
     &           ,redBlack
     &           )
      implicit none
      integer nphicomp
      integer iphilo0,iphilo1,iphilo2
      integer iphihi0,iphihi1,iphihi2
      REAL*8 phi(
     &           iphilo0:iphihi0,
     &           iphilo1:iphihi1,
     &           iphilo2:iphihi2,
     &           0:nphicomp-1)
      integer nrhscomp
      integer irhslo0,irhslo1,irhslo2
      integer irhshi0,irhshi1,irhshi2
      REAL*8 rhs(
     &           irhslo0:irhshi0,
     &           irhslo1:irhshi1,
     &           irhslo2:irhshi2,
     &           0:nrhscomp-1)
      integer iregionlo0,iregionlo1,iregionlo2
      integer iregionhi0,iregionhi1,iregionhi2
      REAL*8 dx
      integer redBlack
      REAL*8 lambda
      REAL*8 dxinv2, lphi
      integer i, j, k
      integer imin, imax, var, ncomp, indtot
      dxinv2 = (1.0d0)/(dx*dx)
      lambda = (dx*dx) / ((2.0d0)*3)
      ncomp = nphicomp
      if(ncomp .ne. nrhscomp) then
         call MAYDAY_ERROR()
      endif
      do var = 0, ncomp - 1
         do k = iregionlo2, iregionhi2
            do j = iregionlo1, iregionhi1
               imin = iregionlo0
               indtot = imin  + j  + k
               imin = imin + mod(indtot + redBlack, 2)
               imax = iregionhi0
               do i = imin, imax, 2
                  if (mod(i +j +k, 2) .ne. redBlack) then
                     print *, 'NODEGSRBLEVELLAP:  computing ',
     &                    i,  j,  k,
     &                    ' at pass ', redBlack
                  endif
            lphi = ( (phi(i+1 , j  , k  , var)
     &              + phi(i-1 , j  , k  , var) ) ) * dxinv2
     &         +   ( (phi(i   , j+1, k  , var)
     &              + phi(i   , j-1, k  , var) ) ) * dxinv2
     &         +   ( (phi(i   , j  , k+1, var)
     &              + phi(i   , j  , k-1, var) ) ) * dxinv2
                  phi(i,j,k, var) =
     &                 lambda * (lphi - rhs(i,j,k, var))
               enddo
            enddo
         enddo
      enddo
      return
      end


subroutine drc3jj_int(two_l2, two_l3, two_m2, two_m3, l1min, l1max, &
                      thrcof, ndim, ier)
! evaluate wigner's 3j symbol
  implicit none
  integer two_l2, two_l3, two_m2, two_m3, ndim, ier, l1min, l1max
  double precision l1min_d, l1max_d
  double precision thrcof(ndim)

  call drc3jj(0.5D0 * two_l2, 0.5D0 * two_l3, 0.5D0 * two_m2, 0.5D0 * two_m3, &
              l1min_d, l1max_d, thrcof, ndim, ier)
  l1min = nint(l1min_d*2)
  l1max = nint(l1max_d*2)

end subroutine drc3jj_int

subroutine drc6j_int(two_l2, two_l3, two_l4, two_l5, two_l6, l1min, l1max, &
                     sixcof, ndim, ier)
! evaluate wigner's 6j symbol
  implicit none
  integer two_l2, two_l3, two_l4, two_l5, two_l6, ndim, ier, l1min, l1max
  double precision l1min_d, l1max_d
  double precision sixcof(ndim)

  call drc6j(0.5D0 * two_l2, 0.5D0 * two_l3, 0.5D0 * two_l4, 0.5D0 * two_l5, &
             0.5D0 * two_l6, l1min_d, l1max_d, sixcof, ndim, ier)
  l1min = nint(l1min_d*2)
  l1max = nint(l1max_d*2)

end subroutine drc6j_int

subroutine drc3jj_vec(two_l2, two_l3, two_m2, two_m3, nvec, thrcof, ndim, ier)
  ! evaluate wigner's 3j symbol with vectorized input
  implicit none
  integer nvec, ier, ndim
  integer two_l2(nvec), two_l3(nvec), two_m2(nvec), two_m3(nvec), l1min, l1max
  double precision, dimension(nvec, ndim) :: thrcof
  double precision, dimension(nvec, ndim) :: thrcof_tmp
  double precision l2(nvec), l3(nvec), m2(nvec), m3(nvec)
  integer :: indexes(nvec)
  integer :: indexes_max
  integer, dimension(nvec) :: ier_v
  double precision :: l1min_d(nvec), l1max_d(nvec)
  integer i, j, dl
  logical is_new

  indexes_max = 0
  indexes(:) = -1
  l1min_d(:) = 0
  l1max_d(:) = 0
  thrcof(:, :) = 0
  thrcof_tmp(:, :) = 0
  ier = 0

  do i=1, nvec
    is_new = .true.
    ! if invalid, skip it
    if (mod(two_l2(i)+abs(two_m2(i)), 2)==1) then
      is_new = .false.
    elseif (mod(two_l3(i)+abs(two_m3(i)), 2)==1) then
      is_new = .false.
    elseif (max(abs(two_l2(i)-two_l3(i)), abs(two_m2(i) + two_m3(i))) &
            > (two_l2(i) + two_l3(i))) then
      is_new = .false.
    else
      do j=1, i-1
        ! if there is duplicate input, we skip this
        if (two_l2(i)==two_l2(j) .and. two_l3(i)==two_l3(j)) then
          if (two_m2(i)==two_m2(j) .and. two_m3(i)==two_m3(j)) then
            indexes(i) = indexes(j)
            is_new=.false.
            exit
          endif
        endif
      enddo
    endif
    if (is_new) then
      ! new data
      indexes_max=indexes_max+1
      l2(indexes_max) = 0.5D0 * two_l2(i)
      l3(indexes_max) = 0.5D0 * two_l3(i)
      m2(indexes_max) = 0.5D0 * two_m2(i)
      m3(indexes_max) = 0.5D0 * two_m3(i)
      indexes(i)=indexes_max
    endif
  enddo

  ! core part
  !$omp parallel
  !$omp do
  do i=1, indexes_max
    call drc3jj(l2(i), l3(i), m2(i), m3(i), l1min_d(i), l1max_d(i), &
                thrcof_tmp(i, :), ndim, ier_v(i))
  enddo
  !$omp end do
  !$omp end parallel
  ! end of core part

  do i=1, indexes_max
    if (ier_v(i) > 0) then
      ier = ier_v(i)
      exit
    end if
  end do

  do i=1, nvec
    if (indexes(i) .ge. 0) then
      l1min = nint(real(l1min_d(indexes(i))) * 2)
      l1max = nint(real(l1max_d(indexes(i))) * 2)
      if (l1max > ndim) l1max = ndim
      dl = (l1max-l1min)/2+1
      thrcof(i, l1min+1:l1max+1:2) = thrcof_tmp(indexes(i), :dl)
    endif
  enddo

  return
end subroutine drc3jj_vec

subroutine drc6j_vec(two_l2, two_l3, two_l4, two_l5, two_l6, nvec, sixcof, &
                     ndim, ier)
  ! evaluate wigner's 3j symbol with vectorized input
  implicit none
  integer nvec, ier, ndim
  integer two_l2(nvec), two_l3(nvec), two_l4(nvec), two_l5(nvec), two_l6(nvec)
  integer l1min, l1max
  double precision, dimension(nvec, ndim) :: sixcof
  double precision, dimension(nvec, ndim) :: sixcof_tmp
  double precision l2(nvec), l3(nvec), l4(nvec), l5(nvec), l6(nvec)
  integer :: indexes(nvec)
  integer :: indexes_max
  integer, dimension(nvec) :: ier_v
  double precision :: l1min_d(nvec), l1max_d(nvec)
  integer i, j, dl
  logical is_new

  indexes_max = 0
  indexes(:) = -1
  l1min_d(:) = 0
  l1max_d(:) = 0
  sixcof(:, :) = 0
  sixcof_tmp(:, :) = 0
  ier = 0

  do i=1, nvec
    is_new = .true.
    ! if invalid, skip it
    if (mod(two_l2(i)+two_l3(i)+two_l5(i)+two_l6(i), 2)==1) then
      is_new = .false.
    elseif (mod(two_l2(i)+two_l4(i)+two_l6(i), 2)==1) then
      is_new = .false.
    elseif (abs(two_l2(i)-two_l4(i)) > two_l6(i)) then
      is_new = .false.
    elseif (two_l6(i) > two_l2(i) + two_l4(i)) then
      is_new = .false.
    else
      do j=1, i-1
        ! if there is duplicate input, we skip this
        if (two_l2(i)==two_l2(j) .and. two_l3(i)==two_l3(j)) then
          if (two_l4(i)==two_l4(j) .and. two_l5(i)==two_l5(j)) then
            if (two_l6(i)==two_l6(j)) then
              indexes(i) = indexes(j)
              is_new=.false.
              exit
            endif
          endif
        endif
      enddo
    endif
    if (is_new) then
      ! new data
      indexes_max=indexes_max+1
      l2(indexes_max) = 0.5D0 * two_l2(i)
      l3(indexes_max) = 0.5D0 * two_l3(i)
      l4(indexes_max) = 0.5D0 * two_l4(i)
      l5(indexes_max) = 0.5D0 * two_l5(i)
      l6(indexes_max) = 0.5D0 * two_l6(i)
      indexes(i)=indexes_max
    endif
  enddo

  ! core part
  !$omp parallel
  !$omp do
  do i=1, indexes_max
    call drc6j(l2(i), l3(i), l4(i), l5(i), l6(i), l1min_d(i), l1max_d(i), &
               sixcof_tmp(i, :), ndim, ier_v(i))
  enddo
  !$omp end do
  !$omp end parallel
  ! end of core part

  do i=1, indexes_max
    if (ier_v(i) > 0) then
      ier = ier_v(i)
      exit
    end if
  end do

  do i=1, nvec
    if (indexes(i) .ge. 0) then
      l1min = nint(real(l1min_d(indexes(i))) * 2)
      l1max = nint(real(l1max_d(indexes(i))) * 2)
      if (l1max > ndim) l1max = ndim
      dl = (l1max-l1min)/2+1
      sixcof(i, l1min+1:l1max+1:2) = sixcof_tmp(indexes(i), :dl)
    endif
  enddo

  return
end subroutine drc6j_vec


! sample compile command to generate *.o object file:
!      gfortran -fopenmp -c Fig_10.3_runtimeEx.f90

subroutine forces(npart, x, f, side, rcoff)
   use omp_lib
   implicit none

   interface
      ! external function for potential energy term
      function pot (dist) result(res)
         real*8 :: dist
         real*8 :: res
      end function pot
   end interface

   integer(kind=omp_sched_kind) :: kind
   integer :: chunk_size
   logical :: DEBUG

   integer :: npart, i, j
   real*8 :: x(0:npart*3+2), f(0:npart*3+2)
   real*8 :: side, rcoff
   real*8 :: fxi, fyi, fzi
   real*8 :: xx, yy, zz, rd, fcomp

   character (len=:), allocatable :: schdKind(:)
   allocate (character(8) :: schdKind(0:4))
   ! map schedule kind enum values to strings for printing

   schdKind(0) = "ERR"
   schdKind(1) = "static"
   schdKind(2) = "dynamic"
   schdKind(3) = "guided"
   schdKind(4) = "auto"

   DEBUG = .true.

   !$omp parallel do schedule(runtime) private(fxi,fyi,fzi,j,xx,yy,zz,rd,fcomp)

      do i = 0, npart*3-1, 3
      ! zero force components on particle i
       fxi = 0.0
       fyi = 0.0
       fzi = 0.0

      ! loop over all particles with index > i
         do j = i+3, npart*3-1, 3

	    ! compute distance between i and j with wraparound
            xx = x(i) - x(j)
            yy = x(i+1) - x(j+1)
            zz = x(i+2) - x(j+2)

            if (xx < (-0.5*side)) xx = xx + side
            if (xx > (0.5*side)) xx = xx - side
            if (yy < (-0.5*side)) yy = yy + side
            if (yy > (0.5*side)) yy = yy - side
            if (zz < (-0.5*side)) zz = zz + side
            if (zz > (0.5*side)) zz = zz - side
            rd = xx * xx + yy * yy + zz * zz

	    ! if distance is inside cutoff radius, compute forces
            if (rd <= rcoff*rcoff) then
               fcomp = pot(rd)
               fxi = fxi + xx*fcomp
               fyi = fyi + yy*fcomp
               fzi = fzi + zz*fcomp
               f(j) = f(j) - xx*fcomp
               f(j+1) = f(j+1) - yy*fcomp
               f(j+2) = f(j+2) - zz*fcomp
            endif
         enddo
         ! update forces on particle i
         f(i) = f(i) + fxi
         f(i+1) = f(i+1) + fyi
         f(i+2) = f(i+2) + fzi
      enddo
   !$omp end parallel do

   if (DEBUG) then
      call omp_get_schedule(kind, chunk_size)
      print *, "schedule ",schdKind(kind),"chunk_size=",chunk_size
   endif
end subroutine forces


!-------------------------------------------------------------------
! class-hpc-smoke-ring: A simple sample field solver.
!
!    by Akira Kageyama, Kobe University, Japan.
!       email: sgks@mac.com
!
!    Copyright 2018 Akira Kageyama
!
!    This software is released under the MIT License.
!
!-------------------------------------------------------------------
!    src/grid.f90
!-------------------------------------------------------------------

module grid_m
  use constants_m
  use ut_m
  implicit none
  private
! public :: & !<< type >>!
!           grid__pos_t,  &
!           grid__delta_t,  &
!           grid__derivative_operator_1st_t,  &
!           grid__derivative_operator_2nd_t
! public :: & !<< variable >>!
!           grid__pos,  &
!           grid__delta,  &
!           grid__d1,  &
!           grid__d2,  &
!           grid__delta_min
! public :: & !<< routine >>!
!           grid__initialize
  public :: grid

  type grid__pos_t
    real(DR), dimension(NX) :: x
    real(DR), dimension(NY) :: y
    real(DR), dimension(NZ) :: z
  end type grid__pos_t

! type(grid__pos_t) :: grid__pos

  type grid__delta_t
    real(DR) :: x, y, z
  end type grid__delta_t

! real(DR) :: grid__delta_min

! type(grid__delta_t) :: grid__delta

  type grid__derivative_operator_1st_t
    real(DR) :: x, y, z
  end type grid__derivative_operator_1st_t

! type(grid__derivative_operator_1st_t) :: grid__d1

  type grid__derivative_operator_2nd_t
    real(DR) :: x, y, z
  end type grid__derivative_operator_2nd_t

! type(grid__derivative_operator_2nd_t) :: grid__d2

  type, public :: grid__t
    type(grid__pos_t) :: pos
    real(DR) :: delta_min
    type(grid__delta_t) :: delta
    type(grid__derivative_operator_1st_t) :: d1
    type(grid__derivative_operator_2nd_t) :: d2
  contains
    procedure :: initialize => grid__initialize
  end type grid__t

  type(grid__t) :: grid

contains

  subroutine grid__initialize(self)
    class(grid__t), intent(out) :: self
    !
    !  Here we suppose the periodic boundary condition in all directions.
    !
    integer(SI) :: i, j, k
    real(DR) :: dx, dy, dz

    real(DR), parameter :: NEARLY_ZERO = 1.e-10_DR
    !
    ! Periodic boundary condition.
    !
    !    --+-----+-----|                             |-----+-----+---
    !      6     7     8                             1     2     3
    !            |-----+-----+-----+-----+-----+-----+-----|
    !            1     2     3     4     5     6     7     8
    !               |===================================|
    !              XMIN                                XMAX
    !
    dx = (XMAX-XMIN)/(NX-2)  ! from (1.5) to (NX-0.5), see above figure.
    dy = (YMAX-YMIN)/(NY-2)
    dz = (ZMAX-ZMIN)/(NZ-2)

    self%delta%x = dx
    self%delta%y = dy
    self%delta%z = dz

    self%delta_min = min(self%delta%x,self%delta%y,self%delta%z)

    self%d1%x = 1.0_DR/(2*dx)   ! factor for 1st derivative
    self%d1%y = 1.0_DR/(2*dy)
    self%d1%z = 1.0_DR/(2*dz)

    self%d2%x = 1.0_DR/(dx**2)  ! factor for 2nd derivative
    self%d2%y = 1.0_DR/(dy**2)
    self%d2%z = 1.0_DR/(dz**2)

    do i = 1 , NX
      self%pos%x(i) = XMIN + dx*(real(i,DR)-1.5_DR)
    end do

    do j = 1 , NY
      self%pos%y(j) = YMIN + dy*(real(j,DR)-1.5_DR)
    end do

    do k = 1 , NZ
      self%pos%z(k) = ZMIN + dz*(real(k,DR)-1.5_DR)
    end do

    call ut__assert(abs(self%pos%x( 1)-XMIN+dx/2) +                 &
                    abs(self%pos%x(NX)-XMAX-dx/2) +                 &
                    abs(self%pos%y( 1)-YMIN+dy/2) +                 &
                    abs(self%pos%y(NY)-YMAX-dy/2) +                 &
                    abs(self%pos%z( 1)-ZMIN+dz/2) +                 &
                    abs(self%pos%z(NZ)-ZMAX-dz/2)  < NEARLY_ZERO,   &
                   "<grid__initialize> grid min/max inconsistent?")
  end subroutine grid__initialize

end module grid_m


      SUBROUTINE rebin(rc,nd,r,xin,xi)
      INTEGER nd
      REAL rc,r(*),xi(*),xin(*)
      INTEGER i,k
      REAL dr,xn,xo
      k=0
      xo=0.
      dr=0.
      do 11 i=1,nd-1
1       if(rc.gt.dr)then
          k=k+1
          dr=dr+r(k)
        goto 1
        endif
        if(k.gt.1) xo=xi(k-1)
        xn=xi(k)
        dr=dr-rc
        xin(i)=xn-(xn-xo)*dr/r(k)
11    continue
      do 12 i=1,nd-1
        xi(i)=xin(i)
12    continue
      xi(nd)=1.
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/rebin.for


! { dg-do "compile" }
!
! PR fortran/37203 - check RESHAPE arguments
!

  integer, dimension(6) :: source1 = (/ 1, 2, 3, 4, 5, 6 /)
  integer, dimension(2) :: pad1 = (/ 0, 0/)
  integer, dimension(2) :: t(2,5)
  integer :: i

  t = reshape(source1, SHAPE(0), pad1, (/2, 1/))      ! { dg-error "is empty" }
  t = reshape(source1, (/(i,i=1,32)/), pad1, (/2, 1/))    ! { dg-error "has more than" }
  t = reshape(source1, (/ 2, -5/), pad1, (/2, 1/))    ! { dg-error "negative element" }
end


      SUBROUTINE IBM2FP( idatin, n, datout)
c    IBM2FP converts an array of IBM floating point words to native floating
c  point words.
c    The IBM floating point word is (bit 0 on the left!):
c  bit 0 = the sign bit
c  bits 1-7 is the hex based exponent
c  bits 8-31 is the mantissa
c  The beauty of this algorithm is that a) it should be fairly machine
c  independent (at the loss of execution speed)  and b) a table look up is
c  used instead of doing an exponentiation ( this was suggested by Chris
c  Garrod - thanks Chris).
c
c  ARGUMEWNTS:
c  idatin - the array of IBM floating point values to be converted.
c  n      - the number of values in idatin to convert
c  datout - the array to receive the output floating point.  This may be the
c           same array as idatin.
c
C
c decimal       IBM (as a base 10 number)              IBM F.P. as a hex number
c 0             0                                      00000000
c 1.0           1091567616                             41100000
c .1            1075419545                             40199999
c 1.1           1091672473                             41119999
c -.1           -1072064103                            C0199999
c
C  WRITTEN AND COPYRIGHTED (C) BY:
C  PAUL HENKART, SCRIPPS INSTITUTION OF OCEANOGRAPHY, 13 November 1985
C  ALL RIGHTS ARE RESERVED BY THE AUTHOR.  PERMISSION TO COPY OR REPRODUCE THIS
C  SUBROUTINE, BY COMPUTER OR OTHER MEANS, MAY BE OBTAINED ONLY FROM THE AUTHOR.
c
c  mod 14 June 2006 - Use LRSHIFT rather than RSHIFT because int vs long in shifts.c
c  mad 18 July 2011 - AND out the vacated bit when doing a right shift
c****    rshift (  >> in c ) may fill vacated bit with garbage
c****    rshift_sio and lrshift (see shifts.c) zero the vacated bits.
c
      DIMENSION idatin(n),datout(n)
      DIMENSION expo(127)                                                ! the table of IBM exponent values
      SAVE
      LOGICAL first
      DATA first/.TRUE./
c
      IF( first ) THEN
          first = .FALSE.
          shift = 1. / 1048576.                                          ! 1/1000000 (HEX)
          expo(64) = 1./16.                                              ! set the center value
c  16**32 is too big for most computers - lets hope we never see it!
          DO 10 i = 1, 32                                                ! build the lookup table only once
              expo(64+i) = expo(64+i-1) * 16.
              expo(64-i) = expo(64 -i+1) / 16.
   10     CONTINUE
      ENDIF
      DO 100 i = 1,n
         jsign = 1
         IF( idatin(i) .LT. 0 ) jsign = -1
         iexp = IAND( idatin(i), 2130706432)                              ! get the exponent by AND 7F000000
         iexp = LRSHIFT( iexp,24 )                                        ! right shift 24 bits
         iexp = IAND( iexp,255 )
         IF( iexp .EQ. 0 ) THEN
             datout(i) = 0.
             GOTO 100
         ENDIF
         IF( iexp .LT. 32 .OR. iexp .GT. 96 ) THEN
             IF( iexp .GT. 96 )
     *       PRINT *,' ***  ERROR  ***  The',i,'th IBM value is out of',
     *       ' range for this computer.'
c             PRINT 11, idatin(i)
   11        FORMAT(1x,Z8)
             datout(i) = 0.
             GOTO 100
         ENDIF
         mantis = IAND(idatin(i), 16777215)                               ! get the mantissa by AND with FFFFFF
         mantis = jsign * mantis                                         ! put the sign back on
         temp = FLOAT( mantis ) * shift                                  ! normalize the mantissa
         datout(i) = temp * expo(iexp)                                   ! apply the converted exponent
  100 CONTINUE
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2019 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine attach_1d(pneigh,pnode,nterms,ratio,dist,xil)
!
!     ataches node with coordinates in "pnode" to the line containing
!     "nterms" nodes with coordinates in field "pneigh" (nterms < 9).
!     cave: the coordinates are stored in pneigh(1..3,*)
!
      implicit none
!
      integer nterms,i,k,imin,im
!
      real*8 ratio(3),pneigh(3,3),pnode(3),a,xi(-1:1),
     &  p(3),distmin,d1,dist,xil
!
      intent(in) pneigh,nterms
!
      intent(inout) xil,pnode,dist,ratio
!
      d1=1.d0
!
      xi(0)=0.d0
      call distattach_1d(xi(0),pneigh,pnode,a,p,
     &     ratio,nterms)
      distmin=a
      imin=0
!
      do k=1,8
!
!     initialisation
!
         d1=d1/10.d0
!
         do i=-1,1
            if(i.eq.0) cycle
!
            xi(i)=xi(0)+i*d1
!
!              check whether inside the (-1,1) domain
!
            if((xi(i).le.1.d0).and.
     &           (xi(i).ge.-1.d0)) then
               call distattach_1d(xi(i),pneigh,pnode,a,p,
     &              ratio,nterms)
!
!                 checking for smallest initial distance
!
               if(a.lt.distmin) then
                  distmin=a
                  imin=i
               endif
            endif
!
         enddo
!
!     minimizing the distance from the face to the node
!
         do
!
!     exit if minimum found
!
            if(imin.eq.0) exit
!
!           new center of 3 vector
!
            xi(0)=xi(imin)
!
            im=imin
!
            imin=0
!
            do i=-1,1
               if((i+im.lt.-1).or.(i+im.gt.1)) then
!
                  xi(i)=xi(0)+i*d1
!
!              check whether inside the (-1,1) domain
!
                  if((xi(i).le.1.d0).and.
     &                 (xi(i).ge.-1.d0)) then
                     call distattach_1d(xi(i),pneigh,
     &                    pnode,a,p,ratio,nterms)
!
!                       check for new minimum
!
                     if(a.lt.distmin) then
                        distmin=a
                        imin=i
                     endif
                  endif
!
               endif
            enddo
         enddo
      enddo
!
      call distattach_1d(xi(0),pneigh,pnode,a,p,
     &     ratio,nterms)
!
      do i=1,3
        pnode(i)=p(i)
      enddo
!
      dist=dsqrt(a)
      xil=xi(0)
!
      return
      end


c
c      TESTING SUITE FOR STOKES FMM:  June 18th, 2020
c
c

c$    use omp_lib
      implicit real *8 (a-h,o-z)

      real *8, allocatable :: pot(:,:), pre(:), grad(:,:,:)
      real *8, allocatable :: source(:,:), targ(:,:)
      real *8, allocatable :: pottarg(:,:), pretarg(:), gradtarg(:,:,:)

      real *8, allocatable :: stoklet(:,:), strslet(:,:)
      real *8, allocatable :: strsvec(:,:)

      integer ipass(10)
      complex *16 eye
c
      data eye/(0.0d0,1.0d0)/
c
      done=1
      pi=4.0*atan(done)
      call prini(6,13)

      ns = 4000
      nt = 4200

      allocate(source(3,ns),targ(3,nt))
      allocate(stoklet(3,ns),strslet(3,ns),strsvec(3,ns))

c
c  Generate random collection of soruces
c
c  Interaction: stokeslet + stresslet
c  Evaluation: potential + pressure at sources
c

      do i = 1,ns
         source(1,i) = cos(i*done)
         source(2,i) = cos(10*i*done)
         source(3,i) = cos(100*i*done)
         stoklet(1,i) = sin(2*i*done)
         stoklet(2,i) = sin(22*i*done)
         stoklet(3,i) = sin(222*i*done)
         strslet(1,i) = sin(4*i*done)
         strslet(2,i) = sin(44*i*done)
         strslet(3,i) = sin(444*i*done)
         strsvec(1,i) = sin(5*i*done)
         strsvec(2,i) = sin(55*i*done)
         strsvec(3,i) = sin(555*i*done)
      enddo

      do i = 1,nt
         targ(1,i) = cos(7*i*done+1.2)
         targ(2,i) = cos(77*i*done+1.2)
         targ(3,i) = cos(777*i*done+1.2)
      enddo

      allocate(pot(3,ns),pre(ns),grad(3,3,ns))
      allocate(pottarg(3,nt),pretarg(nt),gradtarg(3,3,nt))

      nd = 1
      eps = 1d-9
      ifstoklet = 1
      ifstrslet = 1
      ifppreg = 2
      ifppregtarg = 0

      call cpu_time(t1)
c$    t1 = omp_get_wtime()
      call stfmm3d(nd,eps,ns,source,ifstoklet,stoklet,
     1     ifstrslet,strslet,strsvec,ifppreg,pot,pre,grad,
     2     nt,targ,ifppregtarg,pottarg,pretarg,gradtarg,ier)
      call cpu_time(t2)
c$    t2 = omp_get_wtime()

      call prin2('pot=*',pot,12)
      call prin2('pre=*',pre,12)

      stop
      end
c


module au_cnsts
  ! Values of various physical constants in atomic units (au)

  use iso_fortran_env, only: sp=>real32, dp=>real64

  implicit none

  ! Fundamental units: m_e = q_e = h_bar = k_e = 1

  ! Electron mass (m_e)
  real(dp), parameter :: me_dp = 1.0_dp
  real(sp), parameter :: me_sp = real(me_dp, kind=sp)

  ! Electron charge (q_e)
  real(dp), parameter :: qe_dp = 1.0_dp
  real(sp), parameter :: qe_sp = real(qe_dp, kind=sp)

  ! Reduced Planck's constant (hbar)
  real(dp), parameter :: hbar_dp = 1.0_dp
  real(sp), parameter :: hbar_sp = real(hbar_dp, kind=sp)

  ! Coulomb force constant (k_e)
  real(dp), parameter :: ke_dp = 1.0_dp
  real(sp), parameter :: ke_sp = real(ke_dp, kind=sp)

  ! Bohr radius for atomic hydrogen in infinite nuclear mass approximation
  real(dp), parameter :: a0_dp = 1.0_dp
  real(dp), parameter :: a0_sp = real(a0_dp, kind=sp)

  ! Fine structure constant
  ! alpha qe^2 / (4 pi eps0 hbar c)
  real(dp), parameter :: alpha_dp = 7.29735e-3_dp
  real(sp), parameter :: alpha_sp = real(alpha_dp, kind=sp)

  ! Speed of light
  ! c = 1 / alpha
  real(dp), parameter :: c_dp = 137.036_dp
  real(sp), parameter :: c_sp = real(c_dp, kind=sp)

  ! Vacuum permittivity
  ! eps0 = 1 / (4 pi)
  real(dp), parameter :: eps0_dp = 7.957741e-2_dp
  real(sp), parameter :: eps0_sp = real(eps0_dp, kind=sp)

  ! Vacuum permeability
  ! mu0 = 4 pi / c^2 = 4 pi alpha^2
  real(dp), parameter :: mu0_dp = 6.69176e-4_dp
  real(sp), parameter :: mu0_sp = real(mu0_dp, kind=sp)

end module au_cnsts


c
c*****************************
c
        subroutine rdcndwt(w,psiprime)

        parameter (u0=2.8)

        if (w.gt. 4) then
        w=0.0
        psiprime=0.0
        return
        end if

        t=(-exp(u0*(w-u0)))
        u=w
        w=exp(t)
        t=u0*t*u

        if((t+1.).lt.(1.e-20)) then
           psiprime=0.
           return
        end if

        psiprime=(w*(1.+t))

        return
        end


module residuotri_interface
  interface
    subroutine residuotri(ad, al, au, u, b, r)
      real(8), dimension(:), intent(in) :: ad, al, au, u, b
      real(8), dimension(:), intent(out) :: r
    end subroutine
  end interface
end module


module setup_boundary_mod

use constants_mod

contains

subroutine setup_side_boundary(side,inner,outer)

    use setup_config_mod
    use equations_const_mod
    use mesh_types_mod, only: side_t
    use quad_utils_mod, only: side_get_coords
    use equations_mod, only: pressure

    type(side_t), intent(in)    :: side
    real(dp), intent(in)        :: inner(N_NODES,N_VARS)
    real(dp), intent(out)       :: outer(N_NODES,N_VARS)

    real(dp) :: coords(N_NODES,2), center(2)

    real(dp) :: dens(N_NODES)
    real(dp) :: velx(N_NODES)
    real(dp) :: vely(N_NODES)
    real(dp) :: pres(N_NODES)

    outer = inner

# if 0
    pres = pressure(inner)

    outer(:,DENS_VAR) = inner(:,DENS_VAR)
    outer(:,MOMX_VAR) = 0.0_dp ! inner(:,MOMX_VAR)
    outer(:,MOMY_VAR) = 0.0_dp ! inner(:,MOMY_VAR)
    outer(:,ENER_VAR) = pres/(kappa-1.0_dp)

    return

    coords = side_get_coords(side)
    center = sum(coords,dim=1) / REAL(N_NODES,dp)

    if ((side%boundary == NOR .and. center(2) < 0.5_dp) .or. (side%boundary == WES .and. center(1) < 0.5_dp)) then
        outer(:,DENS_VAR) = dens_UL
        outer(:,MOMX_VAR) = velx_UL * dens_UL
        outer(:,MOMY_VAR) = vely_UL * dens_UL
        outer(:,ENER_VAR) = pres_UL/(kappa-1.0_dp) + 0.5_dp*dens_UL*(velx_UL**2 + vely_UL**2)

    else if ((side%boundary == NOR .and. center(2) > 0.5_dp) .or. (side%boundary == EAS .and. center(1) < 0.5_dp)) then
        outer(:,DENS_VAR) = dens_UR
        outer(:,MOMX_VAR) = velx_UR * dens_UR
        outer(:,MOMY_VAR) = vely_UR * dens_UR
        outer(:,ENER_VAR) = pres_UR/(kappa-1.0_dp) + 0.5_dp*dens_UR*(velx_UR**2 + vely_UR**2)

    else if ((side%boundary == SOU .and. center(2) < 0.5_dp) .or. (side%boundary == WES .and. center(1) > 0.5_dp)) then
        outer(:,DENS_VAR) = dens_LL
        outer(:,MOMX_VAR) = velx_LL * dens_LL
        outer(:,MOMY_VAR) = vely_LL * dens_LL
        outer(:,ENER_VAR) = pres_LL/(kappa-1.0_dp) + 0.5_dp*dens_LL*(velx_LL**2 + vely_LL**2)

    else
        outer(:,DENS_VAR) = dens_LR
        outer(:,MOMX_VAR) = velx_LR * dens_LR
        outer(:,MOMY_VAR) = vely_LR * dens_LR
        outer(:,ENER_VAR) = pres_LR/(kappa-1.0_dp) + 0.5_dp*dens_LR*(velx_LR**2 + vely_LR**2)
    end if
# endif

end subroutine

end module


      double precision function  fdisc(blockno,xc,yc)
      implicit none

      double precision xc,yc, xp, yp, zp
      integer blockno
      integer*8 cont, get_context
      logical fclaw2d_map_is_used

      double precision dxc, xm, ym, w, wx, wy

      double precision r

      double precision pi, r2
      integer example

      common /compi/ pi
      common /comex/ example

      cont = get_context()

      if (fclaw2d_map_is_used(cont)) then
         call fclaw2d_map_c2m(cont,
     &         blockno,xc,yc,xp,yp,zp)
      else
         xp = xc
         yp = yc
      endif

      dxc = 0.25d0
      xm = 0.5d0
      ym = 0.5d0
      w = 0.3d0
      wx = 0.3d0
      wy = 0.3d0
      r2 = (xp-0.625d0)**2 + (yp-0.5d0)**2
      fdisc = r2 - 0.1**2
c      if (abs(xp-xm) .le. wx .and. abs(yp-ym) .le. wy) then
c         fdisc = -1
c      else
c         fdisc = 1
c      endif

      end


     subroutine soil_nutcarb_init (isol)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine initializes soil chemical properties

      use soil_module
      use basin_module
      use organic_mineral_mass_module

      integer :: nly, j
      real :: actp, solp, ssp, zdst

      nly = sol(isol)%s%nly

      !calculate percent carbon for lower layers if only have upper layer
      do j = 2, nly
        if (sol1(isol)%cbn(j) == 0.) then
          sol1(isol)%cbn(j) = sol1(isol)%cbn(j-1) * Exp(-.001 * sol(isol)%phys(j)%d)
        end if
      end do

      !calculate initial nutrient contents of layers, profile and
      !average in soil for the entire watershed

      do j = 1, nly
        sol(isol)%phys(j)%conv_wt = sol(isol)%phys(j)%bd * sol(isol)%phys(j)%thick / 100.    ! mg/kg => kg/ha
        wt1 = sol(isol)%phys(j)%conv_wt

        !! set initial mineral pools
        !set initial no3 pools
        if (sol1(isol)%mn(j)%no3 <= 0.) then
          zdst = Exp(-sol(isol)%phys(j)%d / 1000.)
          sol1(isol)%mn(j)%no3 = 10. * zdst * .7
        end if
        sol1(isol)%mn(j)%no3 =  sol1(isol)%mn(j)%no3 * wt1      !! mg/kg => kg/ha

        !set initial labile P pool
        if (sol1(isol)%mp(j)%lab > 0.0001) then
          sol1(isol)%mp(j)%lab = sol1(isol)%mp(j)%lab * wt1   !! mg/kg => kg/ha
        else
          !! assume initial concentration of 5 mg/kg
          sol1(isol)%mp(j)%lab = 5. * wt1
        end if

        !! set active P pool based on dynamic PSP MJW
	    if (bsn_cc%sol_P_model == 0) then
	      !! Allow Dynamic PSP Ratio
            !! convert to concentration
            solp = sol1(isol)%mp(j)%lab / sol(isol)%phys(j)%conv_wt * 1000000.
	      !! PSP = -0.045*log (% clay) + 0.001*(Solution P, mg kg-1) - 0.035*(% Organic C) + 0.43
	      if (sol(isol)%phys(j)%clay > 0.) then
              bsn_prm%psp = -0.045 * log(sol(isol)%phys(j)%clay) + (0.001 * solp)
              bsn_prm%psp = bsn_prm%psp - (0.035 * sol1(isol)%tot(j)%c) + 0.43
            else
              bsn_prm%psp = 0.4
            endif
            !! Limit PSP range
            if (bsn_prm%psp < .05) then
              bsn_prm%psp = 0.05
	      else if (bsn_prm%psp > 0.9) then
              bsn_prm%psp = 0.9
            end if
        end if
        sol1(isol)%mp(j)%act = sol1(isol)%mp(j)%lab * (1. - bsn_prm%psp) / bsn_prm%psp

        !! Set Stable pool based on dynamic coefficient
	    if (bsn_cc%sol_P_model == 0) then  !! From White et al 2009
            !! convert to concentration for ssp calculation
	        actp = sol1(isol)%mp(j)%act / sol(isol)%phys(j)%conv_wt * 1000000.
		    solp = sol1(isol)%mp(j)%lab / sol(isol)%phys(j)%conv_wt * 1000000.
            !! estimate Total Mineral P in this soil based on data from sharpley 2004
		    ssp = 25.044 * (actp + solp)** (-0.3833)
		    !!limit SSP Range
		    if (ssp > 7.) ssp = 7.
		    if (ssp < 1.) ssp = 1.
		    sol1(isol)%mp(j)%sta = ssp * (sol1(isol)%mp(j)%act + sol1(isol)%mp(j)%lab)
         else
	      !! the original code
		  sol1(isol)%mp(j)%sta = 4. * sol1(isol)%mp(j)%act
	   end if
      end do

      !! set initial organic pools - originally by Zhang
	  do j = 1, nly

        !set soil humus fractions from DSSAT
        frac_hum_microb = 0.02
        frac_hum_slow = 0.54
        frac_hum_passive = 0.44

        !initialize total soil organic pool - no litter
        !kg/ha = mm * t/m3 * m/1,000 mm * 1,000 kg/t * 10,000 m2/ha
        sol1(isol)%tot(j)%m = 10000. * sol(isol)%phys(j)%thick * sol(isol)%phys(j)%bd
        sol1(isol)%tot(j)%c = sol1(isol)%tot(j)%m * sol1(isol)%cbn(j) / 100.
        sol1(isol)%tot(j)%n = sol1(isol)%tot(j)%c / 10.     !assume 10:1 C:N ratio
        sol1(isol)%tot(j)%p = sol1(isol)%tot(j)%c / 100.    !assume 100:1 C:P ratio

        !initialize passive humus pool
        sol1(isol)%hp(j)%m = frac_hum_passive * sol1(isol)%tot(j)%m
        sol1(isol)%hp(j)%c = .42 * frac_hum_passive * sol1(isol)%tot(j)%c   !assume 42% C
        sol1(isol)%hp(j)%n = sol1(isol)%hp(j)%c / 10.                       !assume 10:1 C:N ratio
        sol1(isol)%hp(j)%p = sol1(isol)%hp(j)%c / 80.                       !assume 80:1 C:P ratio

        !initialize stable humus pool
        sol1(isol)%hs(j)%m = frac_hum_slow * sol1(isol)%tot(j)%m
        sol1(isol)%hs(j)%c = .42 * frac_hum_slow * sol1(isol)%tot(j)%c  !assume 42% C
        sol1(isol)%hs(j)%n = sol1(isol)%hs(j)%c / 10.                   !assume 10:1 C:N ratio
        sol1(isol)%hs(j)%p = sol1(isol)%hs(j)%c / 80.                   !assume 80:1 C:P ratio

        !initialize microbial pool
        sol1(isol)%microb(j)%m = frac_hum_microb * sol1(isol)%tot(j)%m
        sol1(isol)%microb(j)%c = .42 * frac_hum_microb * sol1(isol)%tot(j)%c    !assume 42% C
        sol1(isol)%microb(j)%n = sol1(isol)%microb(j)%c / 8.                    !assume 8:1 C:N ratio
        sol1(isol)%microb(j)%p = sol1(isol)%microb(j)%c / 80.                   !assume 80:1 C:P ratio

        !initialize metabolic litter pool
        sol1(isol)%meta(j)%m = sol1(isol)%tot(j)%m / 1000.      !t/ha - kg/ha
        sol1(isol)%meta(j)%c = .42 * sol1(isol)%meta(j)%c       !assume 42% C
        sol1(isol)%meta(j)%n = sol1(isol)%meta(j)%c / 150.      !assume 150:1 C:N ratio
        sol1(isol)%meta(j)%p = sol1(isol)%meta(j)%c / 1500.     !assume 1500:1 C:P ratio

        !initialize structural litter pool
        sol1(isol)%str(j)%m = sol1(isol)%meta(j)%m
        sol1(isol)%str(j)%c = .42 * sol1(isol)%str(j)%c         !assume 42% C
        sol1(isol)%str(j)%n = sol1(isol)%lig(j)%c / 150.        !assume 150:1 C:N ratio
        sol1(isol)%str(j)%p = sol1(isol)%lig(j)%c / 1500.       !assume 1500:1 C:P ratio

        !initialize lignon litter pool
        sol1(isol)%lig(j)%m = .8 * sol1(isol)%str(j)%m
        sol1(isol)%lig(j)%c = .8 * sol1(isol)%str(j)%c
        sol1(isol)%lig(j)%n = .2 * sol1(isol)%str(j)%c
        sol1(isol)%lig(j)%p = .02 * sol1(isol)%str(j)%c

        !initialize water soluble pool
        !sol1(isol)%water(j)%m =
        !sol1(isol)%water(j)%c =
        !sol1(isol)%water(j)%n =
        !sol1(isol)%water(j)%p =

	  end do

      return
      end subroutine soil_nutcarb_init


C
C $Id: mdptre.f,v 1.9 2008-09-18 00:42:17 kennison Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE MDPTRE (UINS,VINS,UOUT,VOUT,UINT,VINT)
C
        DOUBLE PRECISION UINS,VINS,UOUT,VOUT,UINT,VINT
C
C This routine finds the point of intersection (UINT,VINT) of the line
C from (UINS,VINS) to (UOUT,VOUT) with the edge of an elliptical frame.
C The first point is inside the frame and the second outside the frame.
C
C Because MDPTRE can be called with the same actual arguments for UINT
C and VINT as for UOUT and VOUT, respectively, UINT and VINT must not
C be reset until all use of UOUT and VOUT is complete.
C
C Declare required common blocks.  See MAPBDX for descriptions of these
C common blocks and the variables in them.
C
        COMMON /MAPCM2/  BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG,ISSL
        DOUBLE PRECISION BLAM,BLOM,PEPS,SLAM,SLOM,UCEN,UMAX,UMIN,UOFF,
     +                   URNG,VCEN,VMAX,VMIN,VOFF,VRNG
        INTEGER          ISSL
        SAVE   /MAPCM2/
C
C Declare local variables.
C
        DOUBLE PRECISION A,B,C,P,Q,UTM1,UTM2,UTM3,VTM1,VTM2,VTM3
C
C What's involved is just a lot of algebra.
C
        IF (ABS(UOUT-UINS).GT.ABS(VOUT-VINS)) THEN
          P=(VOUT-VINS)/(UOUT-UINS)
          Q=(UOUT*VINS-UINS*VOUT)/(UOUT-UINS)
          A=VRNG*VRNG+P*P*URNG*URNG
          B=2.D0*(P*Q*URNG*URNG-UCEN*VRNG*VRNG-P*URNG*URNG*VCEN)
          C=UCEN*UCEN*VRNG*VRNG+Q*Q*URNG*URNG-2.D0*Q*URNG*URNG*VCEN+
     +                           URNG*URNG*VCEN*VCEN-URNG*URNG*VRNG*VRNG
          UTM1=SQRT(MAX(B*B-4.D0*A*C,0.D0))
          UTM2=.5D0*(-B-UTM1)/A
          UTM3=.5D0*(-B+UTM1)/A
          IF (ABS(UTM2-(UINS+UOUT)/2.D0).LT.
     +        ABS(UTM3-(UINS+UOUT)/2.D0)) THEN
            UINT=UTM2
          ELSE
            UINT=UTM3
          END IF
          VINT=P*UINT+Q
        ELSE
          P=(UOUT-UINS)/(VOUT-VINS)
          Q=(UINS*VOUT-UOUT*VINS)/(VOUT-VINS)
          A=URNG*URNG+P*P*VRNG*VRNG
          B=2.D0*(P*Q*VRNG*VRNG-URNG*URNG*VCEN-P*UCEN*VRNG*VRNG)
          C=URNG*URNG*VCEN*VCEN+Q*Q*VRNG*VRNG-2.D0*Q*UCEN*VRNG*VRNG+
     +                           UCEN*UCEN*VRNG*VRNG-URNG*URNG*VRNG*VRNG
          VTM1=SQRT(MAX(B*B-4.D0*A*C,0.D0))
          VTM2=.5D0*(-B-VTM1)/A
          VTM3=.5D0*(-B+VTM1)/A
          IF (ABS(VTM2-(VINS+VOUT)/2.D0).LT.
     +        ABS(VTM3-(VINS+VOUT)/2.D0)) THEN
            VINT=VTM2
          ELSE
            VINT=VTM3
          END IF
          UINT=P*VINT+Q
        END IF
C
C Done.
C
        RETURN
C
      END