C     ALGORITHM 651, COLLECTED ALGORITHMS FROM ACM.
C     THIS WORK PUBLISHED IN TRANSACTIONS ON MATHEMATICAL SOFTWARE,
C     VOL. 13, NO. 3, P. 235.
      SUBROUTINE HFFT3 (COEFU, PRHS, BRHS, AX, BX, AY, BY, AZ, BZ,
     *                  NX, NY, NZ, BCTY, IORDER, U, LDXU, LDYU, WORK,
     *                  NWORK, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C       HFFT2   =  2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT2A  =  2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C       HFFT3   =  3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT3A  =  3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C                             *
C
C   P U R P O S E
C   -------------
C
C   HFFT3 SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES
C   ON A THREE-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION
C   OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS.
C
C
C   D E S C R I P T I O N
C   ---------------------
C
C  HFFT3 SOLVES THE EQUATION
C
C               2       2       2
C              D U     D U     D U
C              ---  +  ---  +  ---  + COEFU*U   =   G
C                2       2       2
C              DX      DY      DZ
C
C
C   IN THE BOX (AX,BX)X(AY,BY)X(AZ,BZ)
C
C
C                       ----------------------------.
C                      /                           /:
C                     /                           / :
C                    /           TOP             /  :
C                   /            (4)            /   :
C                  /                           /    :
C                 /             Y=BY          /     :
C                /                           /      :
C                ----------------------------       :
C                :                          :       :
C                :                          :       :
C                :                          : RIGHT :
C                :                          :  (1)  :
C                :          FRONT           :       :
C           LEFT :           (5)            : X=BX  :
C            (3) :                          :       :
C                :          Z=BZ            :       /
C           X=AX :                          :      /
C                :                          :     /
C                :                          :    /
C                :                          :   /
C                :                          :  /
C                :                          : /
C                ----------------------------/
C                     BOTTOM (2) Y=AY
C
C
C   WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN
C   (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS.
C
C   THE OUTPUT OF THIS PROGRAM IS A THREE-DIMENSIONAL ARRAY GIVING
C   ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J),Z(K)),
C   FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ, WHERE
C
C                      X(I) = AX + (I-1)*HX
C                      Y(J) = AY + (J-1)*HY
C                      Z(K) = AZ + (K-1)*HZ
C                        HX = (BX-AX)/(NX-1)
C                        HY = (BY-AY)/(NY-1)
C                        HZ = (BZ-AZ)/(NZ-1)
C
C   THE USER MUST CHOOSE NX, NY, AND NZ SO THAT THE GRID SPACING IS
C   THE SAME IN EACH OF X, Y, AND Z, I.E., HX = HY = HZ.
C
C   WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE
C   PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO
C   OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION
C   OF MINIMUM INFINITY NORM IS RETURNED.
C
C   THE SOLUTION IS COMPUTED USING A FOURTH ORDER ACCURATE FINITE
C   DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. THE RESULTING
C   SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING FAST FOURIER
C   TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE FACT THAT
C   NX-1 AND NZ-1 ARE HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES).
C
C
C   P A R A M E T E R S
C   -------------------
C
C   COEFU    REAL SCALAR (INPUT)
C            THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION.
C
C   PRHS     REAL FUNCTION OF X,Y,Z (INPUT)
C            RETURNS THE RIGHT-HAND SIDE OF THE DIFFERENTIAL EQUATION
C            FOR ANY (X,Y,Z) IN THE DOMAIN OR ON THE BOUNDARY (SEE
C            DESCRIPTION BELOW).  THE NAME OF THIS FUNCTION MUST BE
C            DECLARED EXTERNAL IN THE CALLING PROGRAM.
C
C   BRHS     REAL FUNCTION OF K,X,Y,Z (INPUT)
C            RETURNS THE RIGHT-HAND SIDE OF THE BOUNDARY CONDITION AT
C            THE POINT (X,Y,Z) ON THE K-TH SIDE OF THE DOMAIN (SEE
C            DESCRIPTION BELOW).  THE NAME OF THIS FUNCTION MUST BE
C            DECLARED EXTERNAL IN THE CALLING PROGRAM.
C
C   AX       REAL SCALAR (INPUT) .LT. BX
C            THE VALUE OF X ALONG THE LEFT SIDE OF THE DOMAIN.
C
C   BX       REAL SCALAR (INPUT)
C            THE VALUE OF X ALONG THE RIGHT SIDE OF THE DOMAIN.
C
C   AY       REAL SCALAR (INPUT) .LT. BY
C            THE VALUE OF Y ALONG THE BOTTOM SIDE OF THE DOMAIN.
C
C   BY       REAL SCALAR (INPUT)
C            THE VALUE OF Y ALONG THE TOP SIDE OF THE DOMAIN.
C
C   AZ       REAL SCALAR (INPUT) .LT. BZ
C            THE VALUE OF Z ALONG THE FRONT SIDE OF THE DOMAIN.
C
C   BZ       REAL SCALAR (INPUT)
C            THE VALUE OF Z ALONG THE BACK SIDE OF THE DOMAIN.
C
C   NX       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN X.
C            (THE NUMBER OF SUB-INTERVALS IN X IS THEN NX-1.)
C            NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   NY       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Y.
C            (THE NUMBER OF SUB-INTERVALS IN Y IS THEN NY-1.)
C
C   NZ       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Z.
C            (THE NUMBER OF SUB-INTERVALS IN Z IS THEN NZ-1.)
C            NZ SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   BCTY     INTEGER ARRAY OF SIZE 6 (INPUT)
C            INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE
C            DOMAIN AS FOLLOWS.
C
C               BCTY(1) = TYPE ON RIGHT SIDE  (X=BX)
C               BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY)
C               BCTY(3) = TYPE ON LEFT SIDE   (X=AX)
C               BCTY(4) = TYPE ON TOP SIDE    (Y=BY)
C               BCTY(5) = TYPE ON FRONT SIDE  (Z=BZ)
C               BCTY(6) = TYPE ON BACK SIDE   (Z=AZ)
C
C            POSSIBLE VALUES ARE
C
C               1 == U PRESCRIBED
C               2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR
C                    DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) OR
C                    DU/DZ PRESCRIBED (FOR BCTY(5) AND BCTY(6))
C               3 == PERIODIC
C
C   IORDER   INTEGER SCALAR (INPUT)
C            THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE
C            APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE
C
C              2 == SECOND ORDER ACCURATE COMPACT 9-POINT DIFFERENCES
C              4 == FOURTH ORDER ACCURATE COMPACT 9-POINT DIFFERENCES
C
C   U        REAL ARRAY OF SIZE LDXU BY LDYU BY NZ+2 (INPUT/OUTPUT)
C            ON INPUT, U(I,J,K) CONTAINS THE VALUE OF THE RIGHT HAND
C            SIDE OF THE PARTIAL DIFFERENTAIL EQUATION AT THE (I,J,K)TH
C            GRID POINT.  THAT IS,
C
C                       U(I,J,K) = G(X(I),Y(J),Z(K))
C
C            FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ.
C            ON OUTPUT, U(I,J,K) IS THE VALUE OF THE COMPUTED SOLUTION
C            AT THE POINT (X(I),Y(J),Z(K)).  THE PLANES U(NX+1,*,*),
C            U(NX+2,*,*), U(*,NY+1,*), U(*,NY+2,*), U(*,*,NZ+1), AND
C            U(*,*,NZ+2) ARE USED AS WORKING STORAGE.
C
C   LDXU     INTEGER SCALAR (INPUT) .GE. NX+2
C            THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   LDYU     INTEGER SCALAR (INPUT) .GE. NY+2
C            THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   WORK     REAL ARRAY OF SIZE NWORK.
C            WORKING STORAGE REQUIRED BY HFFT3.
C
C   NWORK    INTEGER SCALAR (INPUT)
C            .GE. (NX+1)*(NY+1)*(NZ+1)*(IORDER-2)/2
C            + 2*(NX*NY+NX*NZ+NY*NZ)
C            + MAX( (NX+1)*(NY+1)*(IORDER-2),
C                   (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 )
C            THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING
C            PROGRAM. THIS MAY BE REDUCED BY 4*NY IF COEFU.LE.0.
C
C   INFO     INTEGER SCALAR (OUTPUT)
C            INDICATES STATUS OF COMPUTED SOLUTION.
C            POSSIBLE VALUES ARE
C
C               2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY
C                    CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE
C                    PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE
C                    RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED.
C                    THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT
C                    SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN
C                    ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN
C                    ADDITIVE CONSTANT.
C               1 == WARNING. COEFU.GT.0  A SOLUTION MAY NOT EXIST IF
C                    COEFU IS AN EIGENVALUE OF THE LAPLACIAN.  IF COEFU
C                    IS NEAR ONE OF THESE VALUES THEN THE COMPUTED
C                    SOLUTION MAY BE UNRELIABLE.
C               0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION.
C              -1 == ERROR. NX.LT.4
C              -2 == ERROR. NY.LT.4
C              -3 == ERROR. NZ.LT.4
C              -4 == ERROR. LDXU.LT.NX+2
C              -5 == ERROR. LDYU.LT.NY+2
C              -6 == ERROR. IORDER NOT 2 OR 4.
C              -7 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3.
C              -8 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON
C                           ONE SIDE OF DOMAIN BUT NOT ON THE OPPOSITE.
C              -9 == ERROR. NWORK TOO SMALL.
C             -10 == ERROR. BX.LT.AX
C             -11 == ERROR. BY.LT.AY
C             -12 == ERROR. BZ.LT.AZ
C             -13 == ERROR. GRID SIZE IN Y NOT SAME AS IN X.
C             -14 == ERROR. GRID SIZE IN Z NOT SAME AS IN X.
C
C
C   U S E R - D E F I N E D   F U N C T I O N S
C   -------------------------------------------
C
C   THE RIGHT HAND SIDE (FORCING FUNCTION) OF THE PARTIAL
C   DIFFERENTIAL EQUATION IS SPECIFIED BY THE FUNCTION PRHS.
C
C     REAL FUNCTION PRHS (X,Y,Z)
C     REAL X,Y,Z
C     PRHS = RIGHT SIDE OF THE PDE AT (X,Y,Z)
C     RETURN
C     END
C
C   THE VALUE OF THE SOLUTION OR ITS FIRST DERIVATIVE ALONG THE
C   EDGES OF THE DOMAIN WHERE BCTY=1 OR 2 IS SUPPLIED VIA THE
C   FUNCTION BRHS.
C
C     REAL FUNCTION BRHS (K,X,Y,Z)
C     INTEGER K
C     REAL X,Y,Z
C     BRHS = RIGHT HAND SIDE OF KTH BOUNDARY CONDITION
C            (SEE BCTY) AT THE POINT (X,Y,Z)
C     RETURN
C     END
C
C
C   E X T E R N A L   R E F E R E N C E S
C   -------------------------------------
C
C     HFFT3A,FDIS3,HDIS3,FD3N,
C     STORD3,FD3D,FD2D,FD2DA,HD3N,
C     REFL3,MDALG3,MDALG2,EVDISC,
C     TRISOL,TRSALL,TRSOLG,TRSOLP,
C     SGPSL,FFTI,FFTB,FFTF          -- THIS PACKAGE
C
C     RFFTI,RFFTF,RFFTB,
C     SINTI,SINT,COSTI,COST,
C     SINQI,SINQF,SINQB,
C     COSQI,COSQF,COSQB             -- FFTPACK (SEE REF. 2)
C
C     R1MACH                        -- MACHINE CONSTANTS (SEE REF. 3)
C
C     PRHS,BRHS                     -- USER-SUPPLIED
C
C
C   P O R T A B I L I T Y
C   ---------------------
C
C   THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977).
C   ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE
C   FUNCTION R1MACH (SEE REF. 3).
C
C
C   R E F E R E N C E S
C   -------------------
C
C     1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD
C        FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS
C        II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS,
C        ORLANDO, FLA., 1984, 35-44.
C
C     2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE
C        PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS
C        ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3).
C        FFTPACK IS DESCRIBED IN
C
C          P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL
C          COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,
C          PP. 51-83.
C
C        FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE,
C        COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH,
C        BOX 3000, BOULDER, CO 80303, USA.
C
C     3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK
C        FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978),
C        PP. 177-188.
C
C     4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS,
C        HOLT, RINEHART AND WINSTON, NEW YORK, 1967.
C
C
C   A U T H O R  /  V E R S I O N
C   -----------------------------
C
C     RONALD F. BOISVERT
C     CENTER FOR APPLIED MATHEMATICS
C     NATIONAL BUREAU OF STANDARDS
C     GAITHERSBURG, MD 20899
C     USA
C
C     ORIGINAL  DECEMBER 1985
C     REVISED   APRIL 1987
C
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, NZ, BCTY(6), IORDER, LDXU, LDYU, NWORK, INFO
      REAL
     *     COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,*), WORK(NWORK)
C
C     ... LOCAL VARIABLES
C
      INTEGER LOCGH, LOCBD1, LOCBD2, LOCBD3, LOCBD4, LOCBD5, LOCBD6,
     *        NEEDED, NWORKA, NXM1, NYM1, NZM1, NXP1, NYP1, NZP1
      REAL
     *     EPSM, R1MACH, PRHS, BRHS, H, HX, HY, HZ, AXH, AYH, AZH,
     *     X, Y, Z
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      EPSM = R1MACH(4)
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
      NXP1 = NX + 1
      NYP1 = NY + 1
      NZP1 = NZ + 1
C
      H = (BX-AX)/REAL(NXM1)
C
      LOC GH  = 1
      LOC BD1 = LOC GH
      IF (IORDER .EQ. 4)  LOC BD1 = LOC GH + NXP1*NYP1*NZP1
      LOC BD2 = LOC BD1 + NY*NZ
      LOC BD3 = LOC BD2 + NX*NZ
      LOC BD4 = LOC BD3 + NY*NZ
      LOC BD5 = LOC BD4 + NX*NZ
      LOC BD6 = LOC BD5 + NX*NY
      LOC WRK = LOC BD6 + NX*NY
      NEEDED  = LOC WRK + MAX( NXP1*NXP1*(IORDER-2),
     *              (NX+3)*(NY+5) + 5*NY + (NX+NZ)/2 + 15 ) - 1
      NWORKA = NWORK - LOCWRK + 1
C
C
C  ---------------------------
C  CHECK VALIDITY OF ARGUMENTS
C  ---------------------------
C
      INFO = 0
      IF (NX .LT. PRDC)  GO TO 901
      IF (NY .LT. PRDC)  GO TO 902
      IF (NZ .LT. PRDC)  GO TO 903
      IF (LDXU .LT. NX+2)  GO TO 904
      IF (LDYU .LT. NY+2)  GO TO 905
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 906
      DO 10 K=1,6
         IF ((BCTY(K) .LT. DRCH) .OR. (BCTY(K) .GT. PRDC))  GO TO 907
   10 CONTINUE
      IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT  ) .NE. PRDC)) .OR.
     *    ((BCTY(LEFT  ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR.
     *    ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP   ) .NE. PRDC)) .OR.
     *    ((BCTY(TOP   ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) .OR.
     *    ((BCTY(FRONT ) .EQ. PRDC) .AND. (BCTY(BACK  ) .NE. PRDC)) .OR.
     *    ((BCTY(BACK  ) .EQ. PRDC) .AND. (BCTY(FRONT ) .NE. PRDC))    )
     *    GO TO 908
      IF (NWORK .LT. NEEDED)  GO TO 909
      IF (BX .LE. AX)   GO TO 910
      IF (BY .LE. AY)   GO TO 911
      IF (BZ .LE. AZ)   GO TO 912
      HX = H
      HY = (BY-AY)/REAL(NYM1)
      HZ = (BZ-AZ)/REAL(NZM1)
      IF (ABS(HX-HY) .GT. EPSM)  GO TO 913
      IF (ABS(HX-HZ) .GT. EPSM)  GO TO 914
C
C
C  ------------------
C  COMPUTE RHS OF PDE
C  ------------------
C
C     ... AT GRID POINTS
C
      DO 100 K=1,NZ
         Z = AZ + REAL(K-1)*H
         DO 100 J=1,NY
            Y = AY + REAL(J-1)*H
            DO 100 I=1,NX
               X = AX + REAL(I-1)*H
               U(I,J,K) = PRHS(X,Y,Z)
  100 CONTINUE
C
C     ... AT HALF GRID POINTS
C
      IF (IORDER .EQ. 4) THEN
         AXH = AX + 0.50E0*H
         AYH = AY + 0.50E0*H
         AZH = AZ + 0.50E0*H
         DO 200 K=1,NZM1
            Z = AZH + REAL(K-1)*H
            DO 200 J=1,NYM1
               Y = AYH + REAL(J-1)*H
               LOC = LOC GH + (K*NYP1 + J)*NXP1
               DO 200 I=1,NXM1
                  X = AXH + REAL(I-1)*H
                  LOC = LOC + 1
                  WORK(LOC) = PRHS(X,Y,Z)
  200    CONTINUE
      ENDIF
C
C
C  -------------------
C  STORE BOUNDARY DATA
C  -------------------
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .NE. PRDC) THEN
         DO 265 K=1,NZ
            Z = AZ + REAL(K-1)*H
            LOC = LOC BD2 + (K-1)*NX - 1
            DO 265 I=1,NX
               X = AX + REAL(I-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(BOTTOM,X,AY,Z)
  265    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .NE. PRDC) THEN
         DO 275 K=1,NZ
            Z = AZ + REAL(K-1)*H
            LOC = LOC BD4 + (K-1)*NX - 1
            DO 275 I=1,NX
               X = AX + REAL(I-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(TOP,X,BY,Z)
  275    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .NE. PRDC) THEN
         DO 285 K=1,NZ
            Z = AZ + REAL(K-1)*H
            LOC = LOC BD3 + (K-1)*NY - 1
            DO 285 J=1,NY
               Y = AY + REAL(J-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(LEFT,AX,Y,Z)
  285    CONTINUE
      ENDIF
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .NE. PRDC) THEN
         DO 295 K=1,NZ
            Z = AZ + REAL(K-1)*H
            LOC = LOC BD1 + (K-1)*NY - 1
            DO 295 J=1,NY
               Y = AY + REAL(J-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(RIGHT,BX,Y,Z)
  295    CONTINUE
      ENDIF
C
C     ... FRONT SIDE
C
      IF (BCTY(FRONT) .NE. PRDC) THEN
         DO 305 J=1,NY
            Y = AY + REAL(J-1)*H
            LOC = LOC BD5 + (J-1)*NX - 1
            DO 305 I=1,NX
               X = AX + REAL(I-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(FRONT,X,Y,BZ)
  305    CONTINUE
      ENDIF
C
C     ... BACK SIDE
C
      IF (BCTY(BACK) .NE. PRDC) THEN
         DO 315 J=1,NY
            Y = AY + REAL(J-1)*H
            LOC = LOC BD6 + (J-1)*NX - 1
            DO 315 I=1,NX
               X = AX + REAL(I-1)*H
               LOC = LOC + 1
               WORK(LOC) = BRHS(BACK,X,Y,AZ)
  315    CONTINUE
      ENDIF
C
C
C  ----------------
C  CALL FAST SOLVER
C  ----------------
C
      CALL HFFT3A(COEFU,NX,NY,NZ,H,WORK(LOCGH),NXP1,NYP1,BCTY,
     *            WORK(LOCBD1),WORK(LOCBD2),WORK(LOCBD3),WORK(LOCBD4),
     *            WORK(LOCBD5),WORK(LOCBD6),NX,NY,IORDER,U,LDXU,LDYU,
     *            WORK(LOCWRK),NWORKA,INFO)
C
C
C  -----------
C  NORMAL EXIT
C  -----------
C
      WORK(1) = WORK(LOCWRK)
      GO TO 999
C
C
C  -----------
C  ERROR EXITS
C  -----------
C
  901 CONTINUE
      INFO = -1
      GO TO 999
C
  902 CONTINUE
      INFO = -2
      GO TO 999
C
  903 CONTINUE
      INFO = -3
      GO TO 999
C
  904 CONTINUE
      INFO = -4
      GO TO 999
C
  905 CONTINUE
      INFO = -5
      GO TO 999
C
  906 CONTINUE
      INFO = -6
      GO TO 999
C
  907 CONTINUE
      INFO = -7
      GO TO 999
C
  908 CONTINUE
      INFO = -8
      GO TO 999
C
  909 CONTINUE
      INFO = -9
      GO TO 999
C
  910 CONTINUE
      INFO = -10
      GO TO 999
C
  911 CONTINUE
      INFO = -11
      GO TO 999
C
  912 CONTINUE
      INFO = -12
      GO TO 999
C
  913 CONTINUE
      INFO = -13
      GO TO 999
C
  914 CONTINUE
      INFO = -14
      GO TO 999
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE HFFT3A (COEFU, NX, NY, NZ, H, GH, LDXGH, LDYGH, BCTY,
     *                   BD1, BD2, BD3, BD4, BD5, BD6, LDXBD, LDYBD,
     *                   IORDER, U, LDXU, LDYU, WORK, NWORK, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C       HFFT2   =  2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT2A  =  2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C       HFFT3   =  3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT3A  =  3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   P U R P O S E
C   -------------
C
C   HFFT3A SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES
C   ON A THREE-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION
C   OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS.
C
C
C   D E S C R I P T I O N
C   ---------------------
C
C   HFFT3A SOLVES THE EQUATION
C
C               2       2       2
C              D U     D U     D U
C              ---  +  ---  +  ---  + COEFU*U   =   G
C                2       2       2
C              DX      DY      DZ
C
C
C   IN THE BOX (AX,BX)X(AY,BY)X(AZ,BZ)
C
C
C                       ----------------------------.
C                      /                           /:
C                     /                           / :
C                    /           TOP             /  :
C                   /            (4)            /   :
C                  /                           /    :
C                 /             Y=BY          /     :
C                /                           /      :
C                ----------------------------       :
C                :                          :       :
C                :                          :       :
C                :                          : RIGHT :
C                :                          :  (1)  :
C                :          FRONT           :       :
C           LEFT :           (5)            : X=BX  :
C            (3) :                          :       :
C                :          Z=BZ            :       /
C           X=AX :                          :      /
C                :                          :     /
C                :                          :    /
C                :                          :   /
C                :                          :  /
C                :                          : /
C                ----------------------------
C                     BOTTOM (2) Y=AY
C
C
C   WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN
C   (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS.
C
C   THE OUTPUT OF THIS PROGRAM IS A THREE-DIMENSIONAL ARRAY GIVING
C   ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J),Z(K)),
C   FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ, WHERE
C
C                      X(I) = AX + (I-1)*H
C                      Y(J) = AY + (J-1)*H
C                      Z(K) = AZ + (K-1)*H
C
C   WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE
C   PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO
C   OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION
C   OF MINIMUM INFINITY NORM IS RETURNED.
C
C   THE SOLUTION IS COMPUTED USING A FOURTH ORDER ACCURATE FINITE
C   DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION. THE RESULTING
C   SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING FAST FOURIER
C   TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE FACT THAT
C   NX-1 AND NZ-1 ARE HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES).
C
C
C   P A R A M E T E R S
C   -------------------
C
C   COEFU    REAL SCALAR (INPUT)
C            THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION.
C
C   NX       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN X.
C            (THE NUMBER OF SUB-INTERVALS IN X IS THEN NX-1.)
C            NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   NY       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Y.
C            (THE NUMBER OF SUB-INTERVALS IN Y IS THEN NY-1.)
C
C   NZ       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Z.
C            (THE NUMBER OF SUB-INTERVALS IN Z IS THEN NZ-1.)
C            NZ SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   H        REAL SCALAR (INPUT)
C            THE SPACE BETWEEN ADJACENT GRID LINES (IN X, Y, AND Z).
C
C   GH       REAL ARRAY OF SIZE LDXGH BY LDYGH BY NZ+1 (INPUT)
C            THE RIGHT HAND SIDE OF THE PDE AT HALF GRID POINTS.
C            G(I+1,J+1,K+1) IS THE VALUE OF THE RIGHT HAND SIDE AT THE
C            (I,J,K)TH HALF GRID POINT, I=1,..,NX-1, J=1,..,NY-1,
C            K=1,..,NZ-1.  THAT IS,
C
C                    GH(I+1,J+1,K+1) = G(XH(I),YH(J),ZH(K))
C                              XH(I) = AX + (I-0.5)*H
C                              YH(J) = AY + (J-0.5)*H
C                              ZH(K) = AZ + (K-0.5)*H
C
C            PLANES GH(1,*,*), GH(NX+1,*,*), GH(*,1,*), GH(*,NY+1,*),
C            GH(*,*,1), AND GH(*,*,NZ+2) ARE USED FOR WORKING STORAGE.
C            GH IS NOT USED WHEN IORDER=2.
C
C   LDXGH    INTEGER SCALAR (INPUT) .GE. NX+1
C            THE LEADING DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   LDYGH    INTEGER SCALAR (INPUT) .GE. NY+1
C            THE SECOND DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   BCTY     INTEGER ARRAY OF SIZE 6 (INPUT)
C            INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE
C            DOMAIN AS FOLLOWS.
C
C               BCTY(1) = TYPE ON RIGHT SIDE  (X=BX)
C               BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY)
C               BCTY(3) = TYPE ON LEFT SIDE   (X=AX)
C               BCTY(4) = TYPE ON TOP SIDE    (Y=BY)
C               BCTY(5) = TYPE ON FRONT SIDE  (Z=BZ)
C               BCTY(6) = TYPE ON BACK SIDE   (Z=AZ)
C
C            POSSIBLE VALUES ARE
C
C               1 == U PRESCRIBED
C               2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR
C                    DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4)) OR
C                    DU/DZ PRESCRIBED (FOR BCTY(5) AND BCTY(6))
C               3 == PERIODIC
C
C   BD1      REAL ARRAY OF SIZE LDYBD BY NZ (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE RIGHT SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(1)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DX
C                         3             NONE
C
C            BD1(J,K) GIVES THE VALUE AT THE POINT (BX,Y(J),Z(K)).
C
C   BD2      REAL ARRAY OF SIZE LDXBD BY NZ (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE BOTTOM SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(2)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DY
C                         3             NONE
C
C            BD2(I,K) GIVES THE VALUE AT THE POINT (X(I),AY,Z(K)).
C
C   BD3      REAL ARRAY OF SIZE LDYBD BY NZ (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE LEFT SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(3)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DX
C                         3             NONE
C
C            BD3(J,K) GIVES THE VALUE AT THE POINT (AX,Y(J),Z(K)).
C
C   BD4      REAL ARRAY OF SIZE LDXBD BY NZ (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE TOP SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(4)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DY
C                         3             NONE
C
C            BD4(I,K) GIVES THE VALUE AT THE POINT (X(I),BY,Z(K)).
C
C   BD5      REAL ARRAY OF SIZE LDXBD BY NY (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE FRONT SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(5)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DZ
C                         3             NONE
C
C            BD5(I,J) GIVES THE VALUE AT THE POINT (X(I),Y(J),BZ).
C
C   BD6      REAL ARRAY OF SIYE LDXBD BY NY (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE BACK SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(6)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DZ
C                         3             NONE
C
C            BD6(I,J) GIVES THE VALUE AT THE POINT (X(I),Y(J),AZ).
C
C   LDXBD    INTEGER SCALAR (INPUT) .GE. NX
C            THE LEADING DIMENSION OF THE ARRAYS BD2, BD4, BD5, AND
C            BD6, EXACTLY AS SPECIFIED IN THE CALLING PROGRAM.
C
C   LDYBD    INTEGER SCALAR (INPUT) .GE. NY
C            THE LEADING DIMENSION OF THE ARRAYS BD1 AND BD3, EXACTLY
C            AS SPECIFIED IN THE CALLING PROGRAM.
C
C   IORDER   INTEGER SCALAR (INPUT)
C            THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE
C            APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE
C
C              2 == SECOND ORDER ACCURATE 9-POINT COMPACT DIFFERENCES
C              4 == FOURTH ORDER ACCURATE 9-POINT COMPACT DIFFERENCES
C
C   U        REAL ARRAY OF SIZE LDXU BY LDYU BY NZ+2 (INPUT/OUTPUT)
C            ON INPUT, U(I,J,K) CONTAINS THE VALUE OF THE RIGHT HAND
C            SIDE OF THE PARTIAL DIFFERENTAIL EQUATION AT THE (I,J,K)TH
C            GRID POINT.  THAT IS,
C
C                       U(I,J,K) = G(X(I),Y(J),Z(K))
C
C            FOR I=1,..,NX, J=1,..,NY, AND K=1,..,NZ.
C            ON OUTPUT, U(I,J,K) IS THE VALUE OF THE COMPUTED SOLUTION
C            AT THE POINT (X(I),Y(J),Z(K)).  THE PLANES U(NX+1,*,*),
C            U(NX+2,*,*), U(*,NY+1,*), U(*,NY+2,*), U(*,*,NZ+1), AND
C            U(*,*,NZ+2) ARE USED AS WORKING STORAGE.
C
C   LDXU     INTEGER SCALAR (INPUT) .GE. NX+2
C            THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   LDYU     INTEGER SCALAR (INPUT) .GE. NY+2
C            THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   WORK     REAL ARRAY OF SIZE NWORK.
C            WORKING STORAGE REQUIRED BY HFFT3A.
C
C   NWORK    INTEGER SCALAR (INPUT)
C            .GE. MAX( (NX+1)*(NY+1)*(IORDER-2),
C                      (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 )
C            THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING
C            PROGRAM. THIS MAY BE REDUCED BY 4*NY IF COEFU.LE.0.
C
C   INFO     INTEGER SCALAR (OUTPUT)
C            INDICATES STATUS OF COMPUTED SOLUTION.
C            POSSIBLE VALUES ARE
C
C               2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY
C                    CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE
C                    PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE
C                    RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED.
C                    THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT
C                    SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN
C                    ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN
C                    ADDITIVE CONSTANT.
C               1 == WARNING. COEFU.GT.0  A SOLUTION MAY NOT EXIST IF
C                    COEFU IS AN EIGENVALUE OF THE LAPLACIAN.  IF COEFU
C                    IS NEAR ONE OF THESE VALUES THEN THE COMPUTED
C                    SOLUTION MAY BE UNRELIABLE.
C               0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION.
C              -1 == ERROR. NX.LT.4
C              -2 == ERROR. NY.LT.4
C              -3 == ERROR. NZ.LT.4
C              -4 == ERROR. LDXU.LT.NX+2
C              -5 == ERROR. LDYU.LT.NY+2
C              -6 == ERROR. IORDER NOT 2 OR 4.
C              -7 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3.
C              -8 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON
C                           ONE SIDE OF DOMAIN BUT NOT ON THE OPPOSITE.
C              -9 == ERROR. NWORK TOO SMALL.
C             -10 == ERROR. LDXGH.LT.NX+1
C             -11 == ERROR. LDYGH.LT.NY+1
C
C
C
C   E X T E R N A L   R E F E R E N C E S
C   -------------------------------------
C
C     FDIS3,HDIS3,FD3N,STORD3,
C     FD3D,FD2D,FD2DA,HD3N,REFL3,
C     MDALG3,MDALG2,EVDISC,TRISOL,
C     TRSALL,TRSOLG,TRSOLP,
C     SGPSL,FFTI,FFTB,FFTF          -- THIS PACKAGE
C
C     RFFTI,RFFTF,RFFTB,
C     SINTI,SINT,COSTI,COST,
C     SINQI,SINQF,SINQB,
C     COSQI,COSQF,COSQB             -- FFTPACK (SEE REF. 2)
C
C     R1MACH                        -- MACHINE CONSTANTS (SEE REF. 3)
C
C
C   P O R T A B I L I T Y
C   ---------------------
C
C   THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977).
C   ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE
C   FUNCTION R1MACH (SEE REF. 3).
C
C
C   R E F E R E N C E S
C   -------------------
C
C     1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD
C        FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS
C        II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS,
C        ORLANDO, FLA., 1984, 35-44.
C
C     2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE
C        PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS
C        ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3).
C        FFTPACK IS DESCRIBED IN
C
C          P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL
C          COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,
C          PP. 51-83.
C
C        FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE,
C        COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH,
C        BOX 3000, BOULDER, CO 80303, USA.
C
C     3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK
C        FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978),
C        PP. 177-188.
C
C     4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS,
C        HOLT, RINEHART AND WINSTON, NEW YORK, 1967.
C
C
C   A U T H O R  /  V E R S I O N
C   -----------------------------
C
C     RONALD F. BOISVERT
C     CENTER FOR APPLIED MATHEMATICS
C     NATIONAL BUREAU OF STANDARDS
C     GAITHERSBURG, MD 20899
C     USA
C
C     ORIGINAL  DECEMBER 1985
C     REVISED   APRIL 1987
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, NZ, LDXGH, LDYGH, LDXBD, LDYBD, IORDER,
     *        LDXU, LDYU, BCTY(6)
      REAL
     *     H, COEFU, GH(LDXGH,LDYGH,*), U(LDXU,LDYU,*),
     *     BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ),
     *     BD5(LDXBD,NY), BD6(LDXBD,NY), WORK(NWORK)
C
C     ... LOCAL VARIABLES
C
      LOGICAL SNGULR, PRDX, PRDY, PRDZ
      INTEGER NXM1, NYM1, NZM1, NML
      REAL
     *     A, B, C, D, FX, FY, FZ, FYZ, FACTOR, PERTRB, SCALE, UNORM
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
C
      SNGULR = (BCTY(RIGHT ) .NE. DRCH) .AND.
     *         (BCTY(BOTTOM) .NE. DRCH) .AND.
     *         (BCTY(LEFT  ) .NE. DRCH) .AND.
     *         (BCTY(TOP   ) .NE. DRCH) .AND.
     *         (BCTY(FRONT ) .NE. DRCH) .AND.
     *         (BCTY(BACK  ) .NE. DRCH) .AND.
     *         (ABS(COEFU) .LT. R1MACH(4))
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
      PRDZ = BCTY(FRONT ) .EQ. PRDC
C
      IL = 1
      IR = NX
      JL = 1
      JR = NY
      KL = 1
      KR = NZ
      IF (BCTY(LEFT  ) .EQ. DRCH)  IL = 2
      IF (BCTY(RIGHT ) .EQ. DRCH)  IR = NXM1
      IF (BCTY(BOTTOM) .EQ. DRCH)  JL = 2
      IF (BCTY(TOP   ) .EQ. DRCH)  JR = NYM1
      IF (BCTY(BACK  ) .EQ. DRCH)  KL = 2
      IF (BCTY(FRONT ) .EQ. DRCH)  KR = NZM1
      IF (PRDX)  IR = NXM1
      IF (PRDY)  JR = NYM1
      IF (PRDZ)  KR = NZM1
      NML = (IR-IL+1)*(JR-JL+1)*(KR-KL+1)
C
C
C  ---------------------------
C  CHECK VALIDITY OF ARGUMENTS
C  ---------------------------
C
      INFO = 0
      IF (NX .LT. PRDC)  GO TO 901
      IF (NY .LT. PRDC)  GO TO 902
      IF (NZ .LT. PRDC)  GO TO 903
      IF (LDXU .LT. NX+2)  GO TO 904
      IF (LDYU .LT. NY+2)  GO TO 905
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 906
      DO 10 K=1,6
         IF ((BCTY(K) .LT. DRCH) .OR. (BCTY(K) .GT. PRDC))  GO TO 907
   10 CONTINUE
      IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT  ) .NE. PRDC)) .OR.
     *    ((BCTY(LEFT  ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR.
     *    ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP   ) .NE. PRDC)) .OR.
     *    ((BCTY(TOP   ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC)) .OR.
     *    ((BCTY(FRONT ) .EQ. PRDC) .AND. (BCTY(BACK  ) .NE. PRDC)) .OR.
     *    ((BCTY(BACK  ) .EQ. PRDC) .AND. (BCTY(FRONT ) .NE. PRDC))    )
     *    GO TO 908
      NEEDED = MAX( (NX+1)*(NY+1)*(IORDER-2),
     *              (NX+3)*(NZ+5) + 5*NY + (NX+NZ)/2 + 15 )
      IF (NWORK .LT. NEEDED)  GO TO 909
      IF (LDXGH .LT. NX+1)  GO TO 910
      IF (LDYGH .LT. NY+1)  GO TO 911
C
      IF (COEFU .GT. 0.0E0)  INFO = 1
      IF (SNGULR)  INFO = 2
C
C
C  ----------------------
C  COMPUTE DISCRETIZATION
C  ----------------------
C
      IF (IORDER .EQ. 4) THEN
         CALL HDIS3(NX,NY,NZ,H,COEFU,GH,LDXGH-1,LDYGH-1,BCTY,BD1,BD2,
     *              BD3,BD4,BD5,BD6,LDXBD,LDYBD,A,B,C,D,U,LDXU-1,LDYU-1,
     *              WORK)
      ELSE
         CALL FDIS3(NX,NY,NZ,H,COEFU,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,
     *              LDXBD,LDYBD,A,B,C,D,U,LDXU,LDYU)
      ENDIF
C
C  ---------------------------------------
C  ADJUST FOR CONSISTENCY IN SINGULAR CASE
C  ---------------------------------------
C
      PERTRB = 0.0E0
      IF (SNGULR) THEN
         SCALE = 0.0E0
         DO 100 K=KL,KR
            FZ = 1.0E0
            IF (.NOT.PRDZ.AND.(K.NE.1).AND.(K.NE.NZ)) FY = 2.0E0
            DO 100 J=JL,JR
               FY = 1.0E0
               IF (.NOT.PRDY.AND.(J.NE.1).AND.(J.NE.NY)) FY = 2.0E0
               FYZ = FY*FZ
               DO 100 I=IL,IR
                  FX = 1.0E0
                  IF (.NOT.PRDX.AND.(I.NE.1).AND.(I.NE.NX)) FX = 2.0E0
                  FACTOR = FX*FYZ
                  PERTRB = PERTRB + FACTOR*U(I,J,K)
                  SCALE = SCALE + FACTOR
  100    CONTINUE
         PERTRB = -PERTRB/SCALE
         DO 110 K=KL,KR
            DO 110 J=JL,JR
               DO 110 I=IL,IR
                  U(I,J,K) = U(I,J,K) + PERTRB
  110    CONTINUE
      ENDIF
C
C
C  ------------------------------
C  MATRIX DECOMPOSITION USING FFT
C  ------------------------------
C
      CALL MDALG3(A,B,C,D,BCTY,U,LDXU,LDYU,IL,IR,JL,JR,KL,KR,WORK)
C
C
C  -----------------------------------------
C  SELECT MIN NORM SOLUTION IN SINGULAR CASE
C  -----------------------------------------
C
      IF (SNGULR) THEN
         UNORM = 0.0E0
         DO 210 K=KL,KR
            DO 210 J=JL,JR
               DO 210 I=IL,IR
                  UNORM = UNORM + U(I,J,K)
  210    CONTINUE
         UNORM = UNORM/REAL(NML)
         DO 220 K=KL,KR
            DO 220 J=JL,JR
               DO 220 I=IL,IR
                  U(I,J,K) = U(I,J,K) - UNORM
  220    CONTINUE
      ENDIF
C
C
C  ---------------------------------------
C  COPY IDENTICAL PLANES IN PERIODIC CASES
C  ---------------------------------------
C
      IF (PRDX) THEN
         DO 325 K=1,NZ
            DO 325 J=1,NY
               U(NX,J,K) = U(1,J,K)
  325    CONTINUE
      ENDIF
C
      IF (PRDY) THEN
         DO 375 K=1,NZ
            DO 375 I=1,NX
               U(I,NY,K) = U(I,1,K)
  375    CONTINUE
      ENDIF
C
      IF (PRDZ) THEN
         DO 425 J=1,NY
            DO 425 I=1,NX
               U(I,J,NZ) = U(I,J,1)
  425    CONTINUE
      ENDIF
C
C
C  -----------
C  NORMAL EXIT
C  -----------
C
      WORK(1) = PERTRB
      GO TO 999
C
C
C  -----------
C  ERROR EXITS
C  -----------
C
  901 CONTINUE
      INFO = -1
      GO TO 999
C
  902 CONTINUE
      INFO = -2
      GO TO 999
C
  903 CONTINUE
      INFO = -3
      GO TO 999
C
  904 CONTINUE
      INFO = -4
      GO TO 999
C
  905 CONTINUE
      INFO = -5
      GO TO 999
C
  906 CONTINUE
      INFO = -6
      GO TO 999
C
  907 CONTINUE
      INFO = -7
      GO TO 999
C
  908 CONTINUE
      INFO = -8
      GO TO 999
C
  909 CONTINUE
      INFO = -9
      GO TO 999
C
  910 CONTINUE
      INFO = -10
      GO TO 999
C
  911 CONTINUE
      INFO = -11
      GO TO 999
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE FDIS3 (NX, NY, NZ, H, COEFU, BCTY, BD1, BD2, BD3, BD4,
     *                  BD5, BD6, LDXBD, LDYBD, A, B, C, D, U,
     *                  LDXU, LDYU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FDIS3 COMPUTES A SECOND ORDER FINITE DIFFERENCE DISCRETIZATION
C   FOR A THREE-DIMENSIONAL RECTANGULAR DOMAIN
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     H, COEFU  REAL SCALARS (INPUT)
C               SEE HFFT3A.
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD5, BD6  REAL ARRAYS OF SIZE LDXBD BY NY (INPUT)
C               SEE HFFT3A.
C
C     LDXBD     INTEGER SCALARS (INPUT)
C     LDYBD     SEE HFFT3A.
C
C     A,B,C,D   REAL SCALARS (OUTPUT)
C               GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL
C               (SCALED TO O(1))
C
C                               C
C                            C  B  C
C                               C
C
C                            C  B  C
C                            B  A  B    U  =  RIGHT SIDE
C                            C  B  C
C
C                               C
C                            C  B  C
C                               C
C
C     U         REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT)
C               ON INPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE PDE
C               EVALUATED AT THE (I,J,K)TH GRID POINT.
C               ON OUTPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE
C               DISCRETE PDE AT THE (I,J,K)TH GRID POINT.
C
C     LDXU      INTEGER SCALARS (INPUT)
C     LDYU      SEE HFFT3A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), NX, NY, NZ, LDXU, LDYU
      REAL
     *     BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ),
     *     BD5(LDXBD,NY), BD6(LDXBD,NY), U(LDXU,LDYU,*),
     *      COEFU, H, A, B, C, D
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY, PRDZ, HAVED, HAVEN
      INTEGER I, J, K, NXM1, NYM1, NZM1
      REAL
     *     BETA0, GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1
C
      COMMON /FD3COM/ GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
C
      HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR.
     *        (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP   ) .EQ. DRCH) .OR.
     *        (BCTY(FRONT) .EQ. DRCH) .OR. (BCTY(BACK  ) .EQ. DRCH)
      HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR.
     *        (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP   ) .EQ. NEUM) .OR.
     *        (BCTY(FRONT) .EQ. NEUM) .OR. (BCTY(BACK  ) .EQ. NEUM)
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
      PRDZ = BCTY(FRONT ) .EQ. PRDC
C
      H2 = H*H
      F = -H2*COEFU
      A = -(24.0E0 + 6.0E0*F)
      B =    2.0E0
      C =    1.0E0
      D = 0.0E0
      BETA0 = 6.0E0*H2
      GAMMA0 = -12.0E0*H
      GEDGE0 = -10.0E0*H
      GEDGE1 = -2.0E0*H
      GCORN0 = -8.0E0*H
      GCORN1 = -2.0E0*H
C
C
C  ----------------------------
C  DISCRETIZE RIGHT SIDE OF PDE
C  ----------------------------
C
      ISTRT = 2
      ISTOP = NXM1
      IF (BCTY(LEFT  ) .NE. DRCH)  ISTRT = 1
      IF (BCTY(RIGHT ) .EQ. NEUM)  ISTOP = NX
      JSTRT = 2
      JSTOP = NYM1
      IF (BCTY(BOTTOM) .NE. DRCH)  JSTRT = 1
      IF (BCTY(TOP   ) .EQ. NEUM)  JSTOP = NY
      KSTRT = 2
      KSTOP = NZM1
      IF (BCTY(BACK  ) .NE. DRCH)  KSTRT = 1
      IF (BCTY(FRONT ) .EQ. NEUM)  KSTOP = NZ
C
      DO 100 K=KSTRT,KSTOP
         DO 100 J=JSTRT,JSTOP
            DO 100 I=ISTRT,ISTOP
               U(I,J,K) =  BETA0*U(I,J,K)
  100 CONTINUE
C
C
C  ---------------------------------------
C  DISCRETIZE POINTS ON NEUMANN BOUNDARIES
C  ---------------------------------------
C
      IF (HAVEN)  CALL FD3N(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,
     *                      LDXBD,LDYBD,U,LDXU,LDYU)
C
C  ----------------------------------------------
C  ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES
C  ----------------------------------------------
C
      IF (HAVED) THEN
         CALL STORD3(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD,
     *               U,LDXU,LDYU)
         CALL FD3D(NX,NY,NZ,BCTY,B,C,D,U,LDXU,LDYU)
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FD2DA (NX, NY, UD, LDXU, BCTY, A, B, C, U)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FD2DA ELIMINATES TERMS FROM EQUATIONS CORRESPONDING TO ALL POINTS
C   OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN ACCORDING TO A GIVEN
C   STENCIL.
C
C   (THIS ROUTINE IS A UTILITY USED TO ELIMINATE AN ENTIRE DIRICHLET
C   PLANE IN THREE-DIMENSIONAL CALCULATIONS.)
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     UD        REAL ARRAY OF SIZE LDXU BY NY (INPUT)
C               ALL ENTRIES CONTAIN VALUES OF THE FUNCTION TO BE
C               ELIMINATED.
C
C     LDXU      INTEGER SCALAR (INPUT)
C               THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY
C               AS DECLARED IN THE CALLING PROGRAM.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     A,B,C     REAL SCALARS (INPUT)
C               FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE
C               ELIMINATION
C
C                             C B C
C                             B A B
C                             C B C
C
C     U         REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT)
C               ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE
C               SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND
C               SIDE OF A FINITE DIFFERENCE DISCRETIZATION.
C               ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT
C               THE GRID FUNCTION IN UD IS SUBTRACTED USING THE
C               GIVEN STENCIL.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY
      REAL
     *     UD(LDXU,NY), U(LDXU,NY), A, B, C
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY
      INTEGER I, J, NXM1, NYM1
      REAL
     *     TWOB, TWOC
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
C
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
      TWOB = 2.0E0*B
      TWOC = 2.0E0*C
      FORC = 4.0E0*C
C
C
C  -----------------------
C  PROCESS INTERIOR POINTS
C  -----------------------
C
      DO 100 J=2,NYM1
         DO 100 I=2,NXM1
            U(I,J) = U(I,J) - (C*UD(I-1,J+1)+B*UD(I,J+1)+C*UD(I+1,J+1)
     *                        +B*UD(I-1,J  )+A*UD(I,J  )+B*UD(I+1,J  )
     *                        +C*UD(I-1,J-1)+B*UD(I,J-1)+C*UD(I+1,J-1))
  100 CONTINUE
C
C
C  ----------------------
C  PROCESS NEUMANN POINTS
C  ----------------------
C
C     ... NEUMANN POINTS ON RIGHT EDGE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         DO 150 J=2,NYM1
            U(NX,J) = U(NX,J) - (TWOC*UD(NXM1,J+1)+B*UD(NX,J+1)
     *                          +TWOB*UD(NXM1,J  )+A*UD(NX,J  )
     *                          +TWOC*UD(NXM1,J-1)+B*UD(NX,J-1))
  150    CONTINUE
      ENDIF
C
C     ... NEUMANN POINTS ON LEFT EDGE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         DO 250 J=2,NYM1
            U(1,J) = U(1,J) - (B*UD(1,J+1)+TWOC*UD(2,J+1)
     *                        +A*UD(1,J  )+TWOB*UD(2,J  )
     *                        +B*UD(1,J-1)+TWOC*UD(2,J-1))
  250    CONTINUE
      ENDIF
C
C     ... NEUMANN POINTS ON BOTTOM EDGE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         DO 350 I=2,NXM1
            U(I,1) = U(I,1) - (TWOC*UD(I+1,2)+B*UD(I+1,1)
     *                        +TWOB*UD(I  ,2)+A*UD(I  ,1)
     *                        +TWOC*UD(I-1,2)+B*UD(I-1,1))
  350    CONTINUE
      ENDIF
C
C     ... NEUMANN POINTS ON TOP EDGE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         DO 450 I=2,NXM1
            U(I,NY) = U(I,NY) - (TWOC*UD(I+1,NYM1)+B*UD(I+1,NY)
     *                          +TWOB*UD(I  ,NYM1)+A*UD(I  ,NY)
     *                          +TWOC*UD(I-1,NYM1)+B*UD(I-1,NY))
  450    CONTINUE
      ENDIF
C
C     ... BOTTOM RIGHT NEUMANN CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(NX,1) = U(NX,1) - (TWOB*UD(NX  ,2)+   A*UD(NX  ,1)
     *                       +FORC*UD(NXM1,2)+TWOB*UD(NXM1,1))
C
C     ... BOTTOM LEFT NEUMANN CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(1,1) = U(1,1) - (TWOB*UD(1,2)+   A*UD(1,1)
     *                     +FORC*UD(2,2)+TWOB*UD(2,1))
C
C     ... TOP RIGHT NEUMANN CORNER
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM))
     *   U(NX,NY) = U(NX,NY) - (TWOB*UD(NXM1,NY  )+   A*UD(NX,NY  )
     *                         +FORC*UD(NXM1,NYM1)+TWOB*UD(NX,NYM1))
C
C     ... TOP LEFT NEUMANN CORNER
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM))
     *   U(1,NY) = U(1,NY) - (TWOB*UD(2,NY  )+   A*UD(1,NY  )
     *                       +FORC*UD(2,NYM1)+TWOB*UD(1,NYM1))
C
C
C  -----------------------
C  PROCESS PERIODIC POINTS
C  -----------------------
C
C     ... LEFT PERIODIC EDGE
C
      IF (PRDX) THEN
         DO 605 J=2,NYM1
            U(1,J) = U(1,J) - (C*UD(NXM1,J+1)+B*UD(1,J+1)+C*UD(2,J+1)
     *                        +B*UD(NXM1,J  )+A*UD(1,J  )+B*UD(2,J  )
     *                        +C*UD(NXM1,J-1)+B*UD(1,J-1)+C*UD(2,J-1))
  605    CONTINUE
      ENDIF
C
C     ... BOTTOM PERIODIC EDGE
C
      IF (PRDY) THEN
         DO 615 I=2,NXM1
            U(I,1) = U(I,1)-(C*UD(I-1,2   )+B*UD(I,2   )+C*UD(I+1,2   )
     *                      +B*UD(I-1,1   )+A*UD(I,1   )+B*UD(I+1,1   )
     *                      +C*UD(I-1,NYM1)+B*UD(I,NYM1)+C*UD(I+1,NYM1))
  615    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM PERIODIC CORNER
C
      IF (PRDX .AND. PRDY)
     *   U(1,1) = U(1,1) - (C*UD(NXM1,2   )+B*UD(1,2   )+C*UD(2,2   )
     *                     +B*UD(NXM1,1   )+A*UD(1,1   )+B*UD(2,1   )
     *                     +C*UD(NXM1,NYM1)+B*UD(1,NYM1)+C*UD(2,NYM1))
C
C     ... LEFT BOTTOM PERIODIC/NEUMANN CORNER
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(1,1) = U(1,1) - (TWOC*UD(2   ,2)+B*UD(2   ,1)
     *                     +TWOB*UD(1   ,2)+A*UD(1   ,1)
     *                     +TWOC*UD(NXM1,2)+B*UD(NXM1,1))
C
C     ... LEFT BOTTOM NEUMANN/PERIODIC CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY)
     *   U(1,1) = U(1,1) - (B*UD(1,2   )+TWOC*UD(2,2   )
     *                     +A*UD(1,1   )+TWOB*UD(2,1   )
     *                     +B*UD(1,NYM1)+TWOC*UD(2,NYM1))
C
C     ... LEFT TOP PERIODIC/NEUMANN CORNER
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM))
     *   U(1,NY) = U(1,NY) - (TWOC*UD(2   ,NYM1)+B*UD(2   ,NY)
     *                       +TWOB*UD(1   ,NYM1)+A*UD(1   ,NY)
     *                       +TWOC*UD(NXM1,NYM1)+B*UD(NXM1,NY))
C
C     ...  RIGHT BOTTOM NEUMANN/PERIODIC CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY)
     *   U(NX,1) = U(NX,1) - (TWOC*UD(NXM1,2   )+B*UD(NX,2   )
     *                       +TWOB*UD(NXM1,1   )+A*UD(NX,1   )
     *                       +TWOC*UD(NXM1,NYM1)+B*UD(NX,NYM1))
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FD3D (NX, NY, NZ, BCTY, B, C, D, U, LDXU, LDYU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FD3D ELIMINATES KNOWN TERMS FROM EQUATIONS CORRESPONDING TO POINTS
C   NEAR DIRICHLET BOUNDARIES OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     UD        REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT)
C               ENTRIES CORRESPONDING TO DIRICHLET POINTS CONTAIN
C               KNOWN VALUES OF THE SOLUTION.
C
C     B,C,D     REAL SCALARS (INPUT)
C               FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE
C               ELIMINATION
C
C                             D C D
C                             C B C
C                             D C D
C
C                             C B C
C                             B * B
C                             C B C
C
C                             D C D
C                             C B C
C                             D C D
C
C     U         REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT)
C               ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE
C               SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND
C               SIDE OF A FINITE DIFFERENCE DISCRETIZATION.
C               ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT KNOWN
C               TERMS (DIRICHLET POINTS) ARE ELIMINATED FROM THE
C               LEFT HAND SIDE OF THE EQUATION.
C
C     LDXU      INTEGER SCALAR (INPUT)
C               THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY
C               AS DECLARED IN THE CALLING PROGRAM.
C
C     LDYU      INTEGER SCALAR (INPUT)
C               THE SECOND DIMENSION OF THE ARRAYS UD AND U EXACTLY
C               AS DECLARED IN THE CALLING PROGRAM.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), NX, NY, NZ
      REAL
     *     U(LDXU,LDYU,NZ), B, C, D
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NZM1 = NZ - 1
      NZM2 = NZ - 2
C
      TWOC = 2.0E0*C
      TWOD = 2.0E0*D
C
C  ------------------------
C  PROCESS EACH (X,Y) PLANE
C  ------------------------
C
C     ... BACK PLANE
C
      IF (BCTY(BACK) .EQ. NEUM) THEN
         CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,B,C,U(1,1,1))
         CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,TWOC,TWOD,U(1,1,1))
      ENDIF
      IF (BCTY(BACK) .EQ. PRDC) THEN
         CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,C,D,U(1,1,1))
         CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,B,C,U(1,1,1))
         CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,C,D,U(1,1,1))
      ENDIF
C
C     ... INTERIOR PLANE NEAR BACK
C
      IF (BCTY(BACK) .EQ. DRCH)
     *   CALL FD2DA(NX,NY,U(1,1,1),LDXU,BCTY,B,C,D,U(1,1,2))
      IF (BCTY(BACK) .NE. DRCH)
     *   CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,C,D,U(1,1,2))
      CALL FD2D(NX,NY,U(1,1,2),LDXU,BCTY,B,C,U(1,1,2))
      CALL FD2D(NX,NY,U(1,1,3),LDXU,BCTY,C,D,U(1,1,2))
C
C     ... INTERIOR PLANES
C
      DO 100 K=3,NZM2
         CALL FD2D(NX,NY,U(1,1,K-1),LDXU,BCTY,C,D,U(1,1,K))
         CALL FD2D(NX,NY,U(1,1,K  ),LDXU,BCTY,B,C,U(1,1,K))
         CALL FD2D(NX,NY,U(1,1,K+1),LDXU,BCTY,C,D,U(1,1,K))
  100 CONTINUE
C
C     ... INTERIOR PLANE NEAR FRONT
C
      CALL FD2D(NX,NY,U(1,1,NZM2),LDXU,BCTY,C,D,U(1,1,NZM1))
      CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,B,C,U(1,1,NZM1))
      IF (BCTY(FRONT) .EQ. DRCH)
     *   CALL FD2DA(NX,NY,U(1,1,NZ),LDXU,BCTY,B,C,D,U(1,1,NZM1))
      IF (BCTY(FRONT) .EQ. NEUM)
     *   CALL FD2D(NX,NY,U(1,1,NZ),LDXU,BCTY,C,D,U(1,1,NZM1))
      IF (BCTY(FRONT) .EQ. PRDC)
     *   CALL FD2D(NX,NY,U(1,1,1),LDXU,BCTY,C,D,U(1,1,NZM1))
C
C     ... FRONT PLANE
C
      IF (BCTY(FRONT) .EQ. NEUM) THEN
         CALL FD2D(NX,NY,U(1,1,NZM1),LDXU,BCTY,TWOC,TWOD,U(1,1,NZ))
         CALL FD2D(NX,NY,U(1,1,NZ  ),LDXU,BCTY,B,C,U(1,1,NZ))
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FD3N (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6,
     *                 LDXBD, LDYBD, U, LDXU, LDYU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C  FD3N COMPUTES THE SECOND ORDER FINITE DIFFERENCE DISCRETIZATION
C  AT ALL BOUNDARY POINTS OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN
C  WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD5, BD6  REAL ARRAYS OF SIZE LDXBD BY NY (INPUT)
C               SEE HFFT3A.
C
C     LDXBD     INTEGER SCALARS (INPUT)
C     LDYBD     SEE HFFT3A.
C
C     U         REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (OUTPUT)
C               ON EXIT, ENTRIES OF U CORRESPONDING TO NEUMANN BOUNDARY
C               POINTS CONTAIN THE RIGHT HAND SIDE OF THE SECOND ORDER
C               FINITE DIFFERENCE DISCRETIZATION
C
C     LDXU      INTEGER SCALARS (INPUT)
C     LDYU      SEE HFFT3A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), NX, NY, NZ, LDXBD, LDYBD, LDXU, LDYU
      REAL
     *     U(LDXU,LDYU,NZ), BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ),
     *     BD4(LDXBD,NZ), BD5(LDXBD,NY), BD6(LDXBD,NY)
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY, PRDZ
      INTEGER I, J, K, NXM1, NYM1, NZM1
      REAL
     *     GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1
C
      COMMON /FD3COM/ GAMMA0, GEDGE0, GEDGE1, GCORN0, GCORN1
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
      PRDZ = BCTY(FRONT ) .EQ. PRDC
C
C
C  ------------------------------
C  HANDLE POINTS ON NEUMANN SIDES
C  ------------------------------
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         DO 205 K=2,NZM1
            DO 205 J=2,NYM1
               U(NX,J,K) = U(NX,J,K) + GAMMA0*BD1(J,K)
  205    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         DO 215 K=2,NZM1
            DO 215 J=2,NYM1
               U(1,J,K) = U(1,J,K) - GAMMA0*BD3(J,K)
  215    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         DO 225 K=2,NZM1
            DO 225 I=2,NXM1
               U(I,NY,K) = U(I,NY,K) + GAMMA0*BD4(I,K)
  225    CONTINUE
      ENDIF
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         DO 235 K=2,NZM1
            DO 235 I=2,NXM1
               U(I,1,K) = U(I,1,K) - GAMMA0*BD2(I,K)
  235    CONTINUE
      ENDIF
C
C     ... FRONT SIDE
C
      IF (BCTY(FRONT) .EQ. NEUM) THEN
         DO 245 J=2,NYM1
            DO 245 I=2,NXM1
               U(I,J,NZ) = U(I,J,NZ) + GAMMA0*BD5(I,J)
  245    CONTINUE
      ENDIF
C
C     ... BACK SIDE
C
      IF (BCTY(BACK) .EQ. NEUM) THEN
         DO 255 J=2,NYM1
            DO 255 I=2,NXM1
               U(I,J,1) = U(I,J,1) - GAMMA0*BD6(I,J)
  255    CONTINUE
      ENDIF
C
C
C  ------------------------------
C  HANDLE POINTS ON NEUMANN EDGES
C  ------------------------------
C
C     ... RIGHT TOP EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 265 K=2,NZM1
            U(NX,NY,K) = U(NX,NY,K)
     *                   + GEDGE0*( BD1(NY,K) + BD4(NX,K) )
     *                   + GEDGE1*( BD1(NYM1,K) + BD4(NXM1,K) )
  265    CONTINUE
      ENDIF
C
C     ... RIGHT BOTTOM EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN
         DO 275 K=2,NZM1
            U(NX,1,K) = U(NX,1,K)
     *                  + GEDGE0*( BD1(1,K) - BD2(NX,K) )
     *                  + GEDGE1*( BD1(2,K) - BD2(NXM1,K) )
  275    CONTINUE
      ENDIF
C
C     ... LEFT TOP EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 285 K=2,NZM1
            U(1,NY,K) = U(1,NY,K)
     *                  + GEDGE0*( -BD3(NY,K) + BD4(1,K) )
     *                  + GEDGE1*( -BD3(NYM1,K) + BD4(2,K) )
  285    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN
         DO 295 K=2,NZM1
            U(1,1,K) = U(1,1,K)
     *                 + GEDGE0*( -BD3(1,K) - BD2(1,K) )
     *                 + GEDGE1*( -BD3(2,K) - BD2(2,K) )
  295    CONTINUE
      ENDIF
C
C     ... RIGHT FRONT EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 305 J=2,NYM1
            U(NX,J,NZ) = U(NX,J,NZ)
     *                   + GEDGE0*( BD1(J,NZ) + BD5(NX,J) )
     *                   + GEDGE1*( BD1(J,NZM1) + BD5(NXM1,J) )
  305    CONTINUE
      ENDIF
C
C     ... RIGHT BACK EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 315 J=2,NYM1
            U(NX,J,1) = U(NX,J,1)
     *                  + GEDGE0*( BD1(J,1) - BD6(NX,J) )
     *                  + GEDGE1*( BD1(J,2) - BD6(NXM1,J) )
  315    CONTINUE
      ENDIF
C
C     ... LEFT FRONT EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 325 J=2,NYM1
            U(1,J,NZ) = U(1,J,NZ)
     *                  + GEDGE0*( -BD3(J,NZ) + BD5(1,J) )
     *                  + GEDGE1*( -BD3(J,NZM1) + BD5(2,J) )
  325    CONTINUE
      ENDIF
C
C     ... LEFT BACK EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 335 J=2,NYM1
            U(1,J,1) = U(1,J,1)
     *                 + GEDGE0*( -BD3(J,1) - BD6(1,J) )
     *                 + GEDGE1*( -BD3(J,2) - BD6(2,J) )
  335    CONTINUE
      ENDIF
C
C     ... TOP FRONT EDGE
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 345 I=2,NXM1
            U(I,NY,NZ) = U(I,NY,NZ)
     *                   + GEDGE0*( BD4(I,NZ) + BD5(I,NY) )
     *                   + GEDGE1*( BD4(I,NZM1) + BD5(I,NYM1) )
  345    CONTINUE
      ENDIF
C
C     ... TOP BACK EDGE
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 355 I=2,NXM1
            U(I,NY,1) = U(I,NY,1)
     *                  + GEDGE0*( BD4(I,1) - BD6(I,NY) )
     *                  + GEDGE1*( BD4(I,2) - BD6(I,NYM1) )
  355    CONTINUE
      ENDIF
C
C     ... BOTTOM FRONT EDGE
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 365 I=2,NXM1
            U(I,1,NZ) = U(I,1,NZ)
     *                  + GEDGE0*( -BD2(I,NZ) + BD5(I,1) )
     *                  + GEDGE1*( -BD2(I,NZM1) + BD5(I,2) )
  365    CONTINUE
      ENDIF
C
C     ... BOTTOM BACK EDGE
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 375 I=2,NXM1
            U(I,1,1) = U(I,1,1)
     *                 + GEDGE0*( -BD2(I,1) - BD6(I,1) )
     *                 + GEDGE1*( -BD2(I,2) - BD6(I,2) )
  375    CONTINUE
      ENDIF
C
C
C  --------------------------------
C  HANDLE POINTS AT NEUMANN CORNERS
C  --------------------------------
C
C     ... RIGHT TOP FRONT CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(NX,NY,NZ) = U(NX,NY,NZ)
     *                 + GCORN0*( BD1(NY,NZ)+BD4(NX,NZ)+BD5(NX,NY) )
     *                 + GCORN1*( BD1(NYM1,NZ) + BD1(NY,NZM1)
     *                          + BD4(NXM1,NZ) + BD4(NX,NZM1)
     *                          + BD5(NXM1,NY) + BD5(NX,NYM1) )
C
C     ... LEFT TOP FRONT CORNER
C
      IF ((BCTY(LEFT ) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(1,NY,NZ) = U(1,NY,NZ)
     *                + GCORN0*(-BD3(NY,NZ)+BD4(1,NZ)+BD5(1,NY) )
     *                + GCORN1*(-BD3(NYM1,NZ) - BD3(NY,NZM1)
     *                         + BD4(2,NZ) + BD4(1,NZM1)
     *                         + BD5(2,NY) + BD5(1,NYM1) )
C
C     ... RIGHT BOTTOM FRONT CORNER
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(FRONT ) .EQ. NEUM))
     *   U(NX,1,NZ) = U(NX,1,NZ)
     *                + GCORN0*( BD1(1,NZ)-BD2(NX,NZ)+BD5(NZ,1) )
     *                + GCORN1*( BD1(2,NZ) + BD1(1,NZM1)
     *                         - BD2(NXM1,NZ) - BD2(NX,NZM1)
     *                         + BD5(NXM1,1) + BD5(NX,2) )
C
C     ... LEFT BOTTOM FRONT CORNER
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(FRONT ) .EQ. NEUM))
     *   U(1,1,NZ) = U(1,1,NZ)
     *               + GCORN0*(-BD3(1,NZ)-BD2(1,NZ)+BD5(1,1) )
     *               + GCORN1*(-BD3(2,NZ) - BD3(1,NZM1)
     *                        - BD2(2,NZ) - BD2(1,NZM1)
     *                        + BD5(2,1) + BD5(1,2) )
C
C     ... RIGHT TOP BACK CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(BACK ) .EQ. NEUM))
     *   U(NX,NY,1) = U(NX,NY,1)
     *                + GCORN0*( BD1(NY,1)+BD4(NX,1)-BD6(NX,NY) )
     *                + GCORN1*( BD1(NYM1,1) + BD1(NY,2)
     *                         + BD4(NXM1,1) + BD4(NX,2)
     *                         - BD6(NXM1,NY) - BD6(NX,NYM1) )
C
C     ... LEFT TOP BACK CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND.
     *    (BCTY(TOP ) .EQ. NEUM) .AND.
     *    (BCTY(BACK) .EQ. NEUM))
     *   U(1,NY,1) = U(1,NY,1)
     *               + GCORN0*(-BD3(NY,1)+BD4(1,1)-BD6(1,NY) )
     *               + GCORN1*(-BD3(NYM1,1) - BD3(NY,2)
     *                        + BD4(2,1) + BD4(1,2)
     *                        - BD6(2,NY) - BD6(1,NYM1) )
C
C     ... RIGHT BOTTOM BACK CORNER
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(BACK  ) .EQ. NEUM))
     *   U(NX,1,1) = U(NX,1,1)
     *               + GCORN0*( BD1(1,1)-BD2(NX,1)-BD6(NX,1) )
     *               + GCORN1*( BD1(2,1) + BD1(1,2)
     *                        - BD2(NXM1,1) - BD2(NX,2)
     *                        - BD6(NXM1,1) - BD6(NX,2) )
C
C     ... LEFT BOTTOM BACK CORNER
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(BACK  ) .EQ. NEUM))
     *   U(1,1,1) = U(1,1,1)
     *              + GCORN0*(-BD3(1,1)-BD2(1,1)-BD6(1,1) )
     *              + GCORN1*(-BD3(2,1) - BD3(1,2)
     *                       - BD2(2,1) - BD2(1,2)
     *                       - BD6(2,1) - BD6(1,2) )
C
C
      IF (.NOT. (PRDX .OR. PRDY .OR. PRDZ))  GO TO 999
C
C
C  ---------------------------------------
C  HANDLE POINTS AT NEUMANN/PERIODIC EDGES
C  ---------------------------------------
C
C     ... BOTTOM BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN
         DO 405 I=2,NXM1
            U(I,1,1) =   U(I,1,1) - GAMMA0*BD2(I,1)
  405    CONTINUE
      ENDIF
C
C     ... BOTTOM BACK EDGE (PERIODIC/NEUMANN)
C
      IF (PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 415 I=2,NXM1
            U(I,1,1) =   U(I,1,1) - GAMMA0*BD6(I,1)
  415    CONTINUE
      ENDIF
C
C     ... LEFT BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDZ) THEN
         DO 425 J=2,NYM1
            U(1,J,1) =   U(1,J,1) - GAMMA0*BD3(J,1)
  425    CONTINUE
      ENDIF
C
C     ... LEFT BACK EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 435 J=2,NYM1
            U(1,J,1) =   U(1,J,1) - GAMMA0*BD6(1,J)
  435    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE (PERIODIC/NEUNANN)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN
         DO 445 K=2,NZM1
            U(1,1,K) =   U(1,1,K) - GAMMA0*BD2(1,K)
  445    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY) THEN
         DO 455 K=2,NZM1
            U(1,1,K) =   U(1,1,K) - GAMMA0*BD3(1,K)
  455    CONTINUE
      ENDIF
C
C     ... LEFT TOP EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 465 K=2,NZM1
            U(1,NY,K) =   U(1,NY,K) + GAMMA0*BD4(1,K)
  465    CONTINUE
      ENDIF
C
C     ... LEFT FRONT EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 475 J=2,NYM1
            U(1,J,NZ) =   U(1,J,NZ) + GAMMA0*BD5(1,J)
  475    CONTINUE
      ENDIF
C
C     ... RIGHT BOTTOM EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY) THEN
         DO 485 K=2,NZM1
            U(NX,1,K) =   U(NX,1,K) + GAMMA0*BD1(1,K)
  485    CONTINUE
      ENDIF
C
C     ... BOTTOM FRONT EDGE (PERIODIC/NEUMANN)
C
      IF (PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 495 I=2,NXM1
            U(I,1,NZ) =   U(I,1,NZ) + GAMMA0*BD5(I,1)
  495    CONTINUE
      ENDIF
C
C     ... RIGHT BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDZ) THEN
         DO 505 J=2,NYM1
            U(NX,J,1) =   U(NX,J,1) + GAMMA0*BD1(J,1)
  505    CONTINUE
      ENDIF
C
C     ... TOP BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN
         DO 515 I=2,NXM1
            U(I,NY,1) =   U(I,NY,1) + GAMMA0*BD4(I,1)
  515    CONTINUE
      ENDIF
C
C
C  -----------------------------------------
C  HANDLE POINTS AT NEUMANN/PERIODIC CORNERS
C  -----------------------------------------
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. PRDZ)
     *   U(1,1,1) =   U(1,1,1) - GAMMA0*BD3(1,1)
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/PERIODIC)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ)
     *   U(1,1,1) =   U(1,1,1) - GAMMA0*BD2(1,1)
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/PERIODIC/NEUMANN)
C
      IF (PRDX .AND. PRDY .AND. (BCTY(BACK) .EQ. NEUM))
     *   U(1,1,1) =   U(1,1,1) - GAMMA0*BD6(1,1)
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX                     .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(BACK  ) .EQ. NEUM))
     *   U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD2(1,1) - BD6(1,1) )
     *              + GEDGE1*( -BD2(1,2) - BD6(1,2) )
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(BACK) .EQ. NEUM))
     *   U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD3(1,1) - BD6(1,1) )
     *              + GEDGE1*( -BD3(1,2) - BD6(2,1) )
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ)
     *   U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD3(1,1) - BD2(1,1) )
     *              + GEDGE1*( -BD3(2,1) - BD2(2,1) )
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. PRDZ)
     *   U(NX,1,1) =   U(NX,1,1) + GAMMA0*BD1(1,1)
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ)
     *   U(NX,1,1) =   U(NX,1,1)
     *               + GEDGE0*( BD1(1,1) - BD2(NX,1) )
     *               + GEDGE1*( BD1(2,1) - BD2(NXM1,1) )
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(BACK ) .EQ. NEUM))
     *   U(NX,1,1) =   U(NX,1,1)
     *               + GEDGE0*( BD1(1,1) - BD6(NX,1) )
     *               + GEDGE1*( BD1(1,2) - BD6(NXM1,1) )
C
C     ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/PERIODIC)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND. PRDZ)
     *   U(1,NY,1) =   U(1,NY,1) + GAMMA0*BD4(1,1)
C
C     ... LEFT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND.
     *    (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ)
     *   U(1,NY,1) =   U(1,NY,1)
     *               + GEDGE0*( -BD3(NY,1) + BD4(1,1) )
     *               + GEDGE1*( -BD3(NYM1,1) + BD4(2,1) )
C
C     ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX                   .AND.
     *    (BCTY(TOP ) .EQ. NEUM) .AND.
     *    (BCTY(BACK) .EQ. NEUM))
     *   U(1,NY,1) =   U(1,NY,1)
     *               + GEDGE0*( BD4(1,1) - BD6(1,NY) )
     *               + GEDGE1*( BD4(1,2) - BD6(1,NYM1) )
C
C     ... LEFT BOTTOM FRONT CORNER (PERIODIC/PERIODIC/NEUMANN)
C
      IF (PRDX .AND. PRDY .AND. (BCTY(FRONT) .EQ. NEUM))
     *   U(1,1,NZ) =   U(1,1,NZ) + GAMMA0*BD5(1,1)
C
C     ... LEFT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(LEFT ) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(1,1,NZ) =   U(1,1,NZ)
     *               + GEDGE0*( -BD3(1,NZ) + BD5(1,1) )
     *               + GEDGE1*( -BD3(1,NZM1) + BD5(2,1) )
C
C     ... LEFT BOTTOM FRONT CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX                     .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(FRONT ) .EQ. NEUM))
     *   U(1,1,NZ) =   U(1,1,NZ)
     *               + GEDGE0*( -BD2(1,NZ) + BD5(1,1) )
     *               + GEDGE1*( -BD2(1,NZM1) + BD5(1,2) )
C
C     ... LEFT TOP FRONT CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX                    .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(1,NY,NZ) =   U(1,NY,NZ)
     *                + GEDGE0*( BD4(1,NZ) + BD5(1,NY) )
     *                + GEDGE1*( BD4(1,NZM1) + BD5(1,NYM1) )
C
C     ... RIGHT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *      U(NX,1,NZ) =   U(NX,1,NZ)
     *                   + GEDGE0*( BD1(1,NZ) + BD5(NX,1) )
     *                   + GEDGE1*( BD1(1,NZM1) + BD5(NXM1,1) )
C
C     ... RIGHT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND. PRDZ)
     *   U(NX,NY,1) =   U(NX,NY,1)
     *                + GEDGE0*( BD1(NY,1) + BD4(NX,1) )
     *                + GEDGE1*( BD1(NYM1,1) + BD4(NXM1,1) )
C
C
C  ----
C  EXIT
C  ----
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE HDIS3 (NX, NY, NZ, H, COEFU, GH, LMXGH, LMYGH, BCTY,
     *                  BD1, BD2, BD3, BD4, BD5, BD6, LDXBD, LDYBD,
     *                  A, B, C, D, U, LMXU, LMYU, WPLANE)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   HDIS3 COMPUTES A FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION
C   FOR A THREE-DIMENSIONAL RECTANGULAR DOMAIN
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     H, COEFU  REAL SCALARS (INPUT)
C               SEE HFFT3A.
C
C     GH        REAL ARRAY OF SIZE LMXGH+1 BY LMYGH+1 BY NZ+1 (INPUT)
C               SEE HFFT3A.
C
C     LMXGH     INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF FIRST DIMENSION OF ARRAY GH.  MUST BE
C               LDXGH-1 (LDXGH IS DEFINED IN HFFT3A).
C
C     LMYGH     INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF SECOND DIMENSION OF ARRAY GH.  MUST BE
C               LDYGH-1 (LDYGH IS DEFINED IN HFFT3A).
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD5, BD6  REAL ARRAYS OF SIZE LDXBD BY NY (INPUT)
C               SEE HFFT3A.
C
C     LDXBD     INTEGER SCALARS (INPUT)
C     LDYBD     SEE HFFT3A.
C
C
C     A,B,C,D   REAL SCALARS (OUTPUT)
C               GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL
C               (SCALED TO O(1))
C
C                               C
C                            C  B  C
C                               C
C
C                            C  B  C
C                            B  A  B    U  =  RIGHT SIDE
C                            C  B  C
C
C                               C
C                            C  B  C
C                               C
C
C     U         REAL ARRAY OF SIZE LMXU+1 BY LMYU+1 BY NZ+2
C               (INPUT/OUTPUT)
C               ON INPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE PDE
C               EVALUATED AT THE (I,J,K)TH GRID POINT.
C               ON OUTPUT, U(I,J,K) IS THE RIGHT HAND SIDE OF THE
C               DISCRETE PDE AT THE (I,J,K)TH GRID POINT.
C
C     LMXU      INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF FIRST DIMENSION OF ARRAY U.  MUST BE
C               LDXU-1 (LDXU IS DEFINED IN HFFT3A).
C
C     LMYU      INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF SECOND DIMENSION OF ARRAY U.  MUST BE
C               LDYU-1 (LDYU IS DEFINED IN HFFT3A).
C
C     WPLANE    REAL ARRAY OF SIZE NX+1 BY 2
C               WORKING STORAGE FOR HDIS3.
C
C
C     ******************************************************************
C     *                                                                *
C     *   NOTE -- THE ARRAYS U AND GH ARE INDEXED DIFFERENTLY IN       *
C     *           THIS ROUTINE:  U(0:LMXU,0:LMYU,0:*) AND              *
C     *                         GH(0:LMXGH,0:LMYGH,0:*)                *
C     *                                                                *
C     ******************************************************************
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), NX, NY, NZ, LMXGH, LMYGH, LDXBD, LDYBD,
     *        LMXU, LMYU
      REAL
     *     GH(0:LMXGH,0:LMYGH,0:*), U(0:LMXU,0:LMYU,0:*), BD1(LDYBD,NZ),
     *     BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ), BD5(LDXBD,NY),
     *     BD6(LDXBD,NY), WPLANE(0:NX,0:NY,0:1),
     *     COEFU, H, A, B, C, D
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY, PRDZ, HELMHZ, HAVED, HAVEN
      INTEGER I, J, K, NXM1, NYM1, NZM1, LDXU, LDYU, P0, PM1
      REAL
     *     F, F2, H2, BETA0, BETA1, BETA2, GAMMA0, GAMMA1,
     *     GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5,
     *     GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5
C
      COMMON /HD3COM/ GAMMA0, GAMMA1,
     *                GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5,
     *                GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      H2 = H*H
      F = H2*COEFU
      F2 = F*F
      A      = -24.0E0 +  5.0E0*F        - F2/4.0E0
      B      =   2.0E0 -        F/24.0E0 + F2/48.0E0
      C      =   1.0E0 +  5.0E0*F/48.0E0
      D      =   0.0E0
      BETA0  =   2.0E0 -        F/4.0E0
      BETA1  =  0.50E0
      BETA2  =                  F/48.0E0
      GAMMA0 = -12.0E0 + 11.0E0*F/12.0E0
      GAMMA1 =                  F/12.0E0
      GEDGE0 = -23.0E0/3.0E0 + 125.0E0*F/144.0E0
      GEDGE1 =  -6.0E0       +         F/4.0E0
      GEDGE2 =   2.0E0       -         F/48.0E0
      GEDGE3 =  -1.0E0/3.0E0 -         F/72.0E0
      GEDGE4 =  -0.50E0      +         F/48.0E0
      GEDGE5 =   0.50E0      +         F/16.0E0
      GCORN0 = (-2328.0E0 + 245.0E0*F)/144.0E0
      GCORN1 = (  141.0E0 -  14.0E0*F)/18.0E0
      GCORN2 = (  -24.0E0 -         F)/72.0E0
      GCORN3 = (  840.0E0 - 103.0E0*F)/36.0E0
      GCORN4 = (-1752.0E0 + 221.0E0*F)/144.0E0
      GCORN5 = (   57.0E0 -   7.0E0*F)/9.0E0
C
      BETA0 = H2*BETA0
      BETA1 = H2*BETA1
      BETA2 = H2*BETA2
      GAMMA0 = H*GAMMA0
      GAMMA1 = H*GAMMA1
      GEDGE0 = H*GEDGE0
      GEDGE1 = H*GEDGE1
      GEDGE2 = H*GEDGE2
      GEDGE3 = H*GEDGE3
      GEDGE4 = H*GEDGE4
      GEDGE5 = H*GEDGE5
      GCORN0 = H*GCORN0
      GCORN1 = H*GCORN1
      GCORN2 = H*GCORN2
      GCORN3 = H*GCORN3
      GCORN4 = H*GCORN4
      GCORN5 = H*GCORN5
C
      LDXU = LMXU + 1
      LDYU = LMYU + 1
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
C
      HELMHZ = COEFU .NE. 0.0E0
      HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR.
     *        (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP   ) .EQ. DRCH) .OR.
     *        (BCTY(FRONT) .EQ. DRCH) .OR. (BCTY(BACK  ) .EQ. DRCH)
      HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR.
     *        (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP   ) .EQ. NEUM) .OR.
     *        (BCTY(FRONT) .EQ. NEUM) .OR. (BCTY(BACK  ) .EQ. NEUM)
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
      PRDZ = BCTY(FRONT ) .EQ. PRDC
C
C
C  -----------------------------
C  SHIFT VALUES OF G STORED IN U
C  -----------------------------
C
      DO 50 K=NZ,1,-1
         DO 50 J=NY,1,-1
            DO 50 I=NX,1,-1
               U(I,J,K) = U(I-1,J-1,K-1)
   50 CONTINUE
C
C
C  -----------------------------------------
C  REFLECT FUNCTIONS G AND GH OUTSIDE DOMAIN
C  -----------------------------------------
C
      IF (HELMHZ)  CALL REFL3(1,NX,NY,NZ,PRDX,PRDY,PRDZ,U,LMXU,LMYU)
      CALL REFL3(0,NXM1,NYM1,NZM1,PRDX,PRDY,PRDZ,GH,LMXGH,LMYGH)
C
C
C  ----------------------------
C  DISCRETIZE RIGHT SIDE OF PDE
C  ----------------------------
C
      ISTRT = 2
      ISTOP = NXM1
      IF (BCTY(LEFT  ) .NE. DRCH)  ISTRT = 1
      IF (BCTY(RIGHT ) .EQ. NEUM)  ISTOP = NX
      JSTRT = 2
      JSTOP = NYM1
      IF (BCTY(BOTTOM) .NE. DRCH)  JSTRT = 1
      IF (BCTY(TOP   ) .EQ. NEUM)  JSTOP = NY
      KSTRT = 2
      KSTOP = NZM1
      IF (BCTY(BACK  ) .NE. DRCH)  KSTRT = 1
      IF (BCTY(FRONT ) .EQ. NEUM)  KSTOP = NZ
C
      IF (HELMHZ) THEN
C
C        CASE :  HELMHOLTZ EQUATION
C
         P0 = 0
         DO 60 J=0,NY
            DO 60 I=0,NX
               WPLANE(I,J,P0) = U(I,J,KSTRT-1)
   60    CONTINUE
         DO 100 K=KSTRT,KSTOP
            PM1 = P0
            P0  = 1 - PM1
            DO 70 J=0,NY
               DO 70 I=0,NX
                  WPLANE(I,J,P0) = U(I,J,K)
   70       CONTINUE
            DO 100 J=JSTRT,JSTOP
               DO 100 I=ISTRT,ISTOP
C
               U(I,J,K) =   BETA0*U(I,J,K)
     *                    + BETA1*( GH(I,J,K) + GH(I-1,J,K) +
     *                              GH(I,J-1,K) + GH(I-1,J,K-1) +
     *                              GH(I,J,K-1) + GH(I-1,J-1,K) +
     *                              GH(I,J-1,K-1) + GH(I-1,J-1,K-1) )
     *                    + BETA2*( U(I+1,J,K) + WPLANE(I-1,J,P0) +
     *                              U(I,J+1,K) + WPLANE(I,J-1,P0) +
     *                              U(I,J,K+1) + WPLANE(I,J,PM1) )
  100    CONTINUE
C
      ELSE
C
C        CASE :  POISSON EQUATION
C
         DO 200 K=KSTRT,KSTOP
            DO 200 J=JSTRT,JSTOP
               DO 200 I=ISTRT,ISTOP
C
               U(I,J,K) =   BETA0*U(I,J,K)
     *                    + BETA1*( GH(I,J,K) + GH(I-1,J,K) +
     *                              GH(I,J-1,K) + GH(I-1,J,K-1) +
     *                              GH(I,J,K-1) + GH(I-1,J-1,K) +
     *                              GH(I,J-1,K-1) + GH(I-1,J-1,K-1) )
  200    CONTINUE
C
      ENDIF
C
C
C  -------------------------
C  REMOVE SHIFT FROM ARRAY U
C  -------------------------
C
      DO 250 K=0,NZM1
         DO 250 J=0,NYM1
            DO 250 I=0,NXM1
               U(I,J,K) = U(I+1,J+1,K+1)
  250 CONTINUE
C
C
C  -----------------------------------
C  HANDLE POINTS ON NEUMANN BOUNDARIES
C  -----------------------------------
C
      IF (HAVEN)
     *   CALL HD3N(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD,
     *             U,LDXU,LDYU)
C
C
C  ----------------------------------------------
C  ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES
C  ----------------------------------------------
C
      IF (HAVED) THEN
         CALL STORD3(NX,NY,NZ,BCTY,BD1,BD2,BD3,BD4,BD5,BD6,LDXBD,LDYBD,
     *               U,LDXU,LDYU)
         CALL FD3D(NX,NY,NZ,BCTY,B,C,D,U,LDXU,LDYU)
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE HD3N (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6,
     *                 LDXBD, LDYBD, U, LDXU, LDYU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C  HD3N COMPUTES THE FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION
C  AT ALL BOUNDARY POINTS OF A THREE-DIMENSIONAL RECTANGULAR DOMAIN
C  WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD5, BD6  REAL ARRAYS OF SIZE LDXBD BY NY (INPUT)
C               SEE HFFT3A.
C
C     LDXBD     INTEGER SCALARS (INPUT)
C     LDYBD     SEE HFFT3A.
C
C     U         REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (OUTPUT)
C               ON EXIT, ENTRIES CORRESPONDING TO NEUMANN BOUNDARY
C               POINTS CONTAIN THE RIGHT HAND SIDE OF THE FINITE
C               DIFFERENCE DISCRETIZTION
C
C     LDXU      INTEGER SCALARS (INPUT)
C     LDYU      SEE HFFT3A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), NX, NY, NZ, LDXBD, LDYBD, LDXU, LDYU
      REAL
     *     U(LDXU,LDYU,NZ), BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ),
     *     BD4(LDXBD,NZ), BD5(LDXBD,NY), BD6(LDXBD,NY)
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY, PRDZ
      INTEGER I, J, K, NXM1, NYM1, NZM1, NXM2, NYM2, NZM2,
     *        NXM3, NYM3, NZM3
      REAL
     *     GAMMA0, GAMMA1,
     *     GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5,
     *     GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5
C
      COMMON /HD3COM/ GAMMA0, GAMMA1,
     *                GEDGE0, GEDGE1, GEDGE2, GEDGE3, GEDGE4, GEDGE5,
     *                GCORN0, GCORN1, GCORN2, GCORN3, GCORN4, GCORN5
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NZM1 = NZ - 1
      NXM2 = NX - 2
      NYM2 = NY - 2
      NZM2 = NZ - 2
      NXM3 = NX - 3
      NYM3 = NY - 3
      NZM3 = NZ - 3
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
      PRDZ = BCTY(FRONT ) .EQ. PRDC
C
C
C  ------------------------------
C  HANDLE POINTS ON NEUMANN SIDES
C  ------------------------------
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         DO 205 K=2,NZM1
            DO 205 J=2,NYM1
               U(NX,J,K) = U(NX,J,K)
     *                     + GAMMA0*BD1(J,K)
     *                     + GAMMA1*(BD1(J+1,K) + BD1(J-1,K) +
     *                               BD1(J,K+1) + BD1(J,K-1)  )
  205    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         DO 215 K=2,NZM1
            DO 215 J=2,NYM1
               U(1,J,K) = U(1,J,K)
     *                    - GAMMA0*BD3(J,K)
     *                    - GAMMA1*(BD3(J+1,K) + BD3(J-1,K) +
     *                              BD3(J,K+1) + BD3(J,K-1)  )
  215    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         DO 225 K=2,NZM1
            DO 225 I=2,NXM1
               U(I,NY,K) = U(I,NY,K)
     *                     + GAMMA0*BD4(I,K)
     *                     + GAMMA1*(BD4(I+1,K) + BD4(I-1,K) +
     *                               BD4(I,K+1) + BD4(I,K-1)  )
  225    CONTINUE
      ENDIF
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         DO 235 K=2,NZM1
            DO 235 I=2,NXM1
               U(I,1,K) = U(I,1,K)
     *                    - GAMMA0*BD2(I,K)
     *                    - GAMMA1*(BD2(I+1,K) + BD2(I-1,K) +
     *                              BD2(I,K+1) + BD2(I,K-1)  )
  235    CONTINUE
      ENDIF
C
C     ... FRONT SIDE
C
      IF (BCTY(FRONT) .EQ. NEUM) THEN
         DO 245 J=2,NYM1
            DO 245 I=2,NXM1
               U(I,J,NZ) = U(I,J,NZ)
     *                     + GAMMA0*BD5(I,J)
     *                     + GAMMA1*(BD5(I+1,J) + BD5(I-1,J) +
     *                               BD5(I,J+1) + BD5(I,J-1)  )
  245    CONTINUE
      ENDIF
C
C     ... BACK SIDE
C
      IF (BCTY(BACK) .EQ. NEUM) THEN
         DO 255 J=2,NYM1
            DO 255 I=2,NXM1
               U(I,J,1) = U(I,J,1)
     *                    - GAMMA0*BD6(I,J)
     *                    - GAMMA1*(BD6(I+1,J) + BD6(I-1,J) +
     *                              BD6(I,J+1) + BD6(I,J-1)  )
  255    CONTINUE
      ENDIF
C
C
C  ------------------------------
C  HANDLE POINTS ON NEUMANN EDGES
C  ------------------------------
C
C     ... RIGHT TOP EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 265 K=2,NZM1
            U(NX,NY,K) = U(NX,NY,K)
     *            + GEDGE0*( BD1(NY,K) + BD4(NX,K) )
     *            + GEDGE1*( BD1(NYM1,K) + BD4(NXM1,K) )
     *            + GEDGE2*( BD1(NYM2,K) + BD4(NXM2,K) )
     *            + GEDGE3*( BD1(NYM3,K) + BD4(NXM3,K) )
     *            + GEDGE4*( BD1(NY,K+1) + BD4(NX,K+1)
     *                     + BD1(NY,K-1) + BD4(NX,K-1) )
     *            + GEDGE5*( BD1(NYM1,K+1) + BD4(NXM1,K+1)
     *                     + BD1(NYM1,K-1) + BD4(NXM1,K-1) )
  265    CONTINUE
      ENDIF
C
C     ... RIGHT BOTTOM EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN
         DO 275 K=2,NZM1
            U(NX,1,K) = U(NX,1,K)
     *            + GEDGE0*( BD1(1,K) - BD2(NX,K) )
     *            + GEDGE1*( BD1(2,K) - BD2(NXM1,K) )
     *            + GEDGE2*( BD1(3,K) - BD2(NXM2,K) )
     *            + GEDGE3*( BD1(4,K) - BD2(NXM3,K) )
     *            + GEDGE4*( BD1(1,K+1) - BD2(NX,K+1)
     *                     + BD1(1,K-1) - BD2(NX,K-1) )
     *            + GEDGE5*( BD1(2,K+1) - BD2(NXM1,K+1)
     *                     + BD1(2,K-1) - BD2(NXM1,K-1) )
  275    CONTINUE
      ENDIF
C
C     ... LEFT TOP EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 285 K=2,NZM1
            U(1,NY,K) = U(1,NY,K)
     *            + GEDGE0*( -BD3(NY,K) + BD4(1,K) )
     *            + GEDGE1*( -BD3(NYM1,K) + BD4(2,K) )
     *            + GEDGE2*( -BD3(NYM2,K) + BD4(3,K) )
     *            + GEDGE3*( -BD3(NYM3,K) + BD4(4,K) )
     *            + GEDGE4*( -BD3(NY,K+1) + BD4(1,K+1)
     *                       -BD3(NY,K-1) + BD4(1,K-1) )
     *            + GEDGE5*( -BD3(NYM1,K+1) + BD4(2,K+1)
     *                       -BD3(NYM1,K-1) + BD4(2,K-1) )
  285    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM)) THEN
         DO 295 K=2,NZM1
            U(1,1,K) = U(1,1,K)
     *            + GEDGE0*( -BD3(1,K) - BD2(1,K) )
     *            + GEDGE1*( -BD3(2,K) - BD2(2,K) )
     *            + GEDGE2*( -BD3(3,K) - BD2(3,K) )
     *            + GEDGE3*( -BD3(4,K) - BD2(4,K) )
     *            + GEDGE4*( -BD3(1,K+1) - BD2(1,K+1)
     *                       -BD3(1,K-1) - BD2(1,K-1) )
     *            + GEDGE5*( -BD3(2,K+1) - BD2(2,K+1)
     *                       -BD3(2,K-1) - BD2(2,K-1) )
  295    CONTINUE
      ENDIF
C
C     ... RIGHT FRONT EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 305 J=2,NYM1
            U(NX,J,NZ) = U(NX,J,NZ)
     *            + GEDGE0*( BD1(J,NZ) + BD5(NX,J) )
     *            + GEDGE1*( BD1(J,NZM1) + BD5(NXM1,J) )
     *            + GEDGE2*( BD1(J,NZM2) + BD5(NXM2,J) )
     *            + GEDGE3*( BD1(J,NZM3) + BD5(NXM3,J) )
     *            + GEDGE4*( BD1(J+1,NZ) + BD5(NX,J+1)
     *                     + BD1(J-1,NZ) + BD5(NX,J-1) )
     *            + GEDGE5*( BD1(J+1,NZM1) + BD5(NXM1,J+1)
     *                     + BD1(J-1,NZM1) + BD5(NXM1,J-1) )
  305    CONTINUE
      ENDIF
C
C     ... RIGHT BACK EDGE
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 315 J=2,NYM1
            U(NX,J,1) = U(NX,J,1)
     *            + GEDGE0*( BD1(J,1) - BD6(NX,J) )
     *            + GEDGE1*( BD1(J,2) - BD6(NXM1,J) )
     *            + GEDGE2*( BD1(J,3) - BD6(NXM2,J) )
     *            + GEDGE3*( BD1(J,4) - BD6(NXM3,J) )
     *            + GEDGE4*( BD1(J+1,1) - BD6(NX,J+1)
     *                     + BD1(J-1,1) - BD6(NX,J-1) )
     *            + GEDGE5*( BD1(J+1,2) - BD6(NXM1,J+1)
     *                     + BD1(J-1,2) - BD6(NXM1,J-1) )
  315    CONTINUE
      ENDIF
C
C     ... LEFT FRONT EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 325 J=2,NYM1
            U(1,J,NZ) = U(1,J,NZ)
     *            + GEDGE0*( -BD3(J,NZ) + BD5(1,J) )
     *            + GEDGE1*( -BD3(J,NZM1) + BD5(2,J) )
     *            + GEDGE2*( -BD3(J,NZM2) + BD5(3,J) )
     *            + GEDGE3*( -BD3(J,NZM3) + BD5(4,J) )
     *            + GEDGE4*( -BD3(J+1,NZ) + BD5(1,J+1)
     *                       -BD3(J-1,NZ) + BD5(1,J-1) )
     *            + GEDGE5*( -BD3(J+1,NZM1) + BD5(2,J+1)
     *                       -BD3(J-1,NZM1) + BD5(2,J-1) )
  325    CONTINUE
      ENDIF
C
C     ... LEFT FRON EDGE
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 335 J=2,NYM1
            U(1,J,1) = U(1,J,1)
     *            + GEDGE0*( -BD3(J,1) - BD6(1,J) )
     *            + GEDGE1*( -BD3(J,2) - BD6(2,J) )
     *            + GEDGE2*( -BD3(J,3) - BD6(3,J) )
     *            + GEDGE3*( -BD3(J,4) - BD6(4,J) )
     *            + GEDGE4*( -BD3(J+1,1) - BD6(1,J+1)
     *                       -BD3(J-1,1) - BD6(1,J-1) )
     *            + GEDGE5*( -BD3(J+1,2) - BD6(2,J+1)
     *                       -BD3(J-1,2) - BD6(2,J-1) )
  335    CONTINUE
      ENDIF
C
C     ... TOP FRONT EDGE
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 345 I=2,NXM1
            U(I,NY,NZ) = U(I,NY,NZ)
     *            + GEDGE0*( BD4(I,NZ) + BD5(I,NY) )
     *            + GEDGE1*( BD4(I,NZM1) + BD5(I,NYM1) )
     *            + GEDGE2*( BD4(I,NZM2) + BD5(I,NYM2) )
     *            + GEDGE3*( BD4(I,NZM3) + BD5(I,NYM3) )
     *            + GEDGE4*( BD4(I+1,NZ) + BD5(I+1,NY)
     *                     + BD4(I-1,NZ) + BD5(I-1,NY) )
     *            + GEDGE5*( BD4(I+1,NZM1) + BD5(I+1,NYM1)
     *                     + BD4(I-1,NZM1) + BD5(I-1,NYM1) )
  345    CONTINUE
      ENDIF
C
C     ... TOP BACK EDGE
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 355 I=2,NXM1
            U(I,NY,1) = U(I,NY,1)
     *            + GEDGE0*( BD4(I,1) - BD6(I,NY) )
     *            + GEDGE1*( BD4(I,2) - BD6(I,NYM1) )
     *            + GEDGE2*( BD4(I,3) - BD6(I,NYM2) )
     *            + GEDGE3*( BD4(I,4) - BD6(I,NYM3) )
     *            + GEDGE4*( BD4(I+1,1) - BD6(I+1,NY)
     *                     + BD4(I-1,1) - BD6(I-1,NY) )
     *            + GEDGE5*( BD4(I+1,2) - BD6(I+1,NYM1)
     *                     + BD4(I-1,2) - BD6(I-1,NYM1) )
  355    CONTINUE
      ENDIF
C
C     ... BOTTOM FRONT EDGE
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 365 I=2,NXM1
            U(I,1,NZ) = U(I,1,NZ)
     *            + GEDGE0*( -BD2(I,NZ) + BD5(I,1) )
     *            + GEDGE1*( -BD2(I,NZM1) + BD5(I,2) )
     *            + GEDGE2*( -BD2(I,NZM2) + BD5(I,3) )
     *            + GEDGE3*( -BD2(I,NZM3) + BD5(I,4) )
     *            + GEDGE4*( -BD2(I+1,NZ) + BD5(I+1,1)
     *                       -BD2(I-1,NZ) + BD5(I-1,1) )
     *            + GEDGE5*( -BD2(I+1,NZM1) + BD5(I+1,2)
     *                       -BD2(I-1,NZM1) + BD5(I-1,2) )
  365    CONTINUE
      ENDIF
C
C     ... BOTTOM BACK EDGE
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 375 I=2,NXM1
            U(I,1,1) = U(I,1,1)
     *            + GEDGE0*( -BD2(I,1) - BD6(I,1) )
     *            + GEDGE1*( -BD2(I,2) - BD6(I,2) )
     *            + GEDGE2*( -BD2(I,3) - BD6(I,3) )
     *            + GEDGE3*( -BD2(I,4) - BD6(I,4) )
     *            + GEDGE4*( -BD2(I+1,1) - BD6(I+1,1)
     *                       -BD2(I-1,1) - BD6(I-1,1) )
     *            + GEDGE5*( -BD2(I+1,2) - BD6(I+1,2)
     *                       -BD2(I-1,2) - BD6(I-1,2) )
  375    CONTINUE
      ENDIF
C
C
C  --------------------------------
C  HANDLE POINTS AT NEUMANN CORNERS
C  --------------------------------
C
C     ... RIGHT TOP FRONT CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(NX,NY,NZ) =  U(NX,NY,NZ)
     *         + GCORN0*( BD1(NYM1,NZ) + BD1(NY,NZM1)
     *                  + BD4(NXM1,NZ) + BD4(NX,NZM1)
     *                  + BD5(NXM1,NY) + BD5(NX,NYM1) )
     *         + GCORN1*( BD1(NYM2,NZ) + BD1(NY,NZM2)
     *                  + BD4(NXM2,NZ) + BD4(NX,NZM2)
     *                  + BD5(NXM2,NY) + BD5(NX,NYM2) )
     *         + GCORN2*( BD1(NYM3,NZ) + BD1(NY,NZM3)
     *                  + BD4(NXM3,NZ) + BD4(NX,NZM3)
     *                  + BD5(NXM3,NY) + BD5(NX,NYM3) )
     *         + GCORN3*( BD1(NYM1,NZM1)+BD4(NXM1,NZM1)+BD5(NXM1,NYM1))
     *         + GCORN4*( BD1(NYM1,NZM2) + BD1(NYM2,NZM1)
     *                  + BD4(NXM1,NZM2) + BD4(NXM2,NZM1)
     *                  + BD5(NXM1,NYM2) + BD5(NXM2,NYM1) )
     *         + GCORN5*( BD1(NYM2,NZM2)+BD4(NXM2,NZM2)+BD5(NXM2,NYM2))
C
C     ... LEFT TOP FRONT CORNER
C
      IF ((BCTY(LEFT ) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(FRONT) .EQ. NEUM))
     *   U(1,NY,NZ) =  U(1,NY,NZ)
     *         + GCORN0*(-BD3(NYM1,NZ) - BD3(NY,NZM1)
     *                  + BD4(2,NZ) + BD4(1,NZM1)
     *                  + BD5(2,NY) + BD5(1,NYM1) )
     *         + GCORN1*(-BD3(NYM2,NZ) - BD3(NY,NZM2)
     *                  + BD4(3,NZ) + BD4(1,NZM2)
     *                  + BD5(3,NY) + BD5(1,NYM2) )
     *         + GCORN2*(-BD3(NYM3,NZ) - BD3(NY,NZM3)
     *                  + BD4(4,NZ) + BD4(1,NZM3)
     *                  + BD5(4,NY) + BD5(1,NYM3) )
     *         + GCORN3*(-BD3(NYM1,NZM1)+BD4(2,NZM1)+BD5(2,NYM1))
     *         + GCORN4*(-BD3(NYM1,NZM2) - BD3(NYM2,NZM1)
     *                  + BD4(2,NZM2) + BD4(3,NZM1)
     *                  + BD5(2,NYM2) + BD5(3,NYM1) )
     *         + GCORN5*(-BD3(NYM2,NZM2)+BD4(3,NZM2)+BD5(3,NYM2))
C
C     ... RIGHT BOTTOM FRONT CORNER
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(FRONT ) .EQ. NEUM))
     *   U(NX,1,NZ) = U(NX,1,NZ)
     *         + GCORN0*( BD1(2,NZ) + BD1(1,NZM1)
     *                  - BD2(NXM1,NZ) - BD2(NX,NZM1)
     *                  + BD5(NXM1,1) + BD5(NX,2) )
     *         + GCORN1*( BD1(3,NZ) + BD1(1,NZM2)
     *                  - BD2(NXM2,NZ) - BD2(NX,NZM2)
     *                  + BD5(NXM2,1) + BD5(NX,3) )
     *         + GCORN2*( BD1(4,NZ) + BD1(1,NZM3)
     *                  - BD2(NXM3,NZ) - BD2(NX,NZM3)
     *                  + BD5(NXM3,1) + BD5(NX,4) )
     *         + GCORN3*( BD1(2,NZM1)-BD2(NXM1,NZM1)+BD5(NXM1,2))
     *         + GCORN4*( BD1(2,NZM2) + BD1(3,NZM1)
     *                  - BD2(NXM1,NZM2) - BD2(NXM2,NZM1)
     *                  + BD5(NXM1,3) + BD5(NXM2,2) )
     *         + GCORN5*( BD1(3,NZM2)-BD2(NXM2,NZM2)+BD5(NXM2,3))
C
C     ... LEFT BOTTOM FRONT CORNER
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(FRONT ) .EQ. NEUM))
     *   U(1,1,NZ) =  U(1,1,NZ)
     *         + GCORN0*(-BD3(2,NZ) - BD3(1,NZM1)
     *                  - BD2(2,NZ) - BD2(1,NZM1)
     *                  + BD5(2,1) + BD5(1,2) )
     *         + GCORN1*(-BD3(3,NZ) - BD3(1,NZM2)
     *                  - BD2(3,NZ) - BD2(1,NZM2)
     *                  + BD5(3,1) + BD5(1,3) )
     *         + GCORN2*(-BD3(4,NZ) - BD3(1,NZM3)
     *                  - BD2(4,NZ) - BD2(1,NZM3)
     *                  + BD5(4,1) + BD5(1,4) )
     *         + GCORN3*(-BD3(2,NZM1)-BD2(2,NZM1)+BD5(2,2))
     *         + GCORN4*(-BD3(2,NZM2) - BD3(3,NZM1)
     *                  - BD2(2,NZM2) - BD2(3,NZM1)
     *                  + BD5(2,3) + BD5(3,2) )
     *         + GCORN5*(-BD3(3,NZM2)-BD2(3,NZM2)+BD5(3,3))
C
C     ... RIGHT TOP BACK CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND.
     *    (BCTY(BACK ) .EQ. NEUM))
     *   U(NX,NY,1) =  U(NX,NY,1)
     *         + GCORN0*( BD1(NYM1,1) + BD1(NY,2)
     *                  + BD4(NXM1,1) + BD4(NX,2)
     *                  - BD6(NXM1,NY) - BD6(NX,NYM1) )
     *         + GCORN1*( BD1(NYM2,1) + BD1(NY,3)
     *                  + BD4(NXM2,1) + BD4(NX,3)
     *                  - BD6(NXM2,NY) - BD6(NX,NYM2) )
     *         + GCORN2*( BD1(NYM3,1) + BD1(NY,4)
     *                  + BD4(NXM3,1) + BD4(NX,4)
     *                  - BD6(NXM3,NY) - BD6(NX,NYM3) )
     *         + GCORN3*( BD1(NYM1,2)+BD4(NXM1,2)-BD6(NXM1,NYM1))
     *         + GCORN4*( BD1(NYM1,3) + BD1(NYM2,2)
     *                  + BD4(NXM1,3) + BD4(NXM2,2)
     *                  - BD6(NXM1,NYM2) - BD6(NXM2,NYM1) )
     *         + GCORN5*( BD1(NYM2,3)+BD4(NXM2,3)-BD6(NXM2,NYM2))
C
C     ... LEFT TOP BACK CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND.
     *    (BCTY(TOP ) .EQ. NEUM) .AND.
     *    (BCTY(BACK) .EQ. NEUM))
     *   U(1,NY,1) =  U(1,NY,1)
     *         + GCORN0*(-BD3(NYM1,1) - BD3(NY,2)
     *                  + BD4(2,1) + BD4(1,2)
     *                  - BD6(2,NY) - BD6(1,NYM1) )
     *         + GCORN1*(-BD3(NYM2,1) - BD3(NY,3)
     *                  + BD4(3,1) + BD4(1,3)
     *                  - BD6(3,NY) - BD6(1,NYM2) )
     *         + GCORN2*(-BD3(NYM3,1) - BD3(NY,4)
     *                  + BD4(4,1) + BD4(1,4)
     *                  - BD6(4,NY) - BD6(1,NYM3) )
     *         + GCORN3*(-BD3(NYM1,2)+BD4(2,2)-BD6(2,NYM1))
     *         + GCORN4*(-BD3(NYM1,3) - BD3(NYM2,2)
     *                  + BD4(2,3) + BD4(3,2)
     *                  - BD6(2,NYM2) - BD6(3,NYM1) )
     *         + GCORN5*(-BD3(NYM2,3)+BD4(3,3)-BD6(3,NYM2))
C
C     ... RIGHT BOTTOM BACK CORNER
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(BACK  ) .EQ. NEUM))
     *   U(NX,1,1) =  U(NX,1,1)
     *         + GCORN0*( BD1(2,1) + BD1(1,2)
     *                  - BD2(NXM1,1) - BD2(NX,2)
     *                  - BD6(NXM1,1) - BD6(NX,2) )
     *         + GCORN1*( BD1(3,1) + BD1(1,3)
     *                  - BD2(NXM2,1) - BD2(NX,3)
     *                  - BD6(NXM2,1) - BD6(NX,3) )
     *         + GCORN2*( BD1(4,1) + BD1(1,4)
     *                  - BD2(NXM3,1) - BD2(NX,4)
     *                  - BD6(NXM3,1) - BD6(NX,4) )
     *         + GCORN3*( BD1(2,2)-BD2(NXM1,2)-BD6(NXM1,2))
     *         + GCORN4*( BD1(2,3) + BD1(3,2)
     *                  - BD2(NXM1,3) - BD2(NXM2,2)
     *                  - BD6(NXM1,3) - BD6(NXM2,2) )
     *         + GCORN5*( BD1(3,3)-BD2(NXM2,3)-BD6(NXM2,3))
C
C     ... LEFT BOTTOM BACK CORNER
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *    (BCTY(BACK  ) .EQ. NEUM))
     *   U(1,1,1) =  U(1,1,1)
     *         + GCORN0*(-BD3(2,1) - BD3(1,2)
     *                  - BD2(2,1) - BD2(1,2)
     *                  - BD6(2,1) - BD6(1,2) )
     *         + GCORN1*(-BD3(3,1) - BD3(1,3)
     *                  - BD2(3,1) - BD2(1,3)
     *                  - BD6(3,1) - BD6(1,3) )
     *         + GCORN2*(-BD3(4,1) - BD3(1,4)
     *                  - BD2(4,1) - BD2(1,4)
     *                  - BD6(4,1) - BD6(1,4) )
     *         + GCORN3*(-BD3(2,2)-BD2(2,2)-BD6(2,2))
     *         + GCORN4*(-BD3(2,3) - BD3(3,2)
     *                  - BD2(2,3) - BD2(3,2)
     *                  - BD6(2,3) - BD6(3,2) )
     *         + GCORN5*(-BD3(3,3)-BD2(3,3)-BD6(3,3))
C
C
      IF (.NOT. (PRDX .OR. PRDY .OR. PRDZ))  GO TO 999
C
C
C  ---------------------------------------
C  HANDLE POINTS ON NEUMANN/PERIODIC EDGES
C  ---------------------------------------
C
C     ... BOTTOM BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN
         DO 405 I=2,NXM1
            U(I,1,1) =   U(I,1,1)
     *                 - GAMMA0*BD2(I,1)
     *                 - GAMMA1*(BD2(I+1,1) + BD2(I-1,1) +
     *                           BD2(I,2) + BD2(I,NZM1)  )
  405    CONTINUE
      ENDIF
C
C     ... BOTTOM BACK EDGE (PERIODIC/NEUMANN)
C
      IF (PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 415 I=2,NXM1
            U(I,1,1) =   U(I,1,1)
     *                 - GAMMA0*BD6(I,1)
     *                 - GAMMA1*(BD6(I+1,1) + BD6(I-1,1) +
     *                           BD6(I,2) + BD6(I,NYM1)  )
  415    CONTINUE
      ENDIF
C
C     ... LEFT BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDZ) THEN
         DO 425 J=2,NYM1
            U(1,J,1) =   U(1,J,1)
     *                 - GAMMA0*BD3(J,1)
     *                 - GAMMA1*(BD3(J+1,1) + BD3(J-1,1) +
     *                           BD3(J,2) + BD3(J,NZM1)  )
  425    CONTINUE
      ENDIF
C
C     ... LEFT BACK EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         DO 435 J=2,NYM1
            U(1,J,1) =   U(1,J,1)
     *                 - GAMMA0*BD6(1,J)
     *                 - GAMMA1*(BD6(2,J) + BD6(NXM1,J) +
     *                           BD6(1,J+1) + BD6(1,J-1)  )
  435    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. PRDX) THEN
         DO 445 K=2,NZM1
            U(1,1,K) =   U(1,1,K)
     *                 - GAMMA0*BD2(1,K)
     *                 - GAMMA1*(BD2(2,K) + BD2(NXM1,K) +
     *                           BD2(1,K+1) + BD2(1,K-1)  )
  445    CONTINUE
      ENDIF
C
C     ... LEFT BOTTOM EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY) THEN
         DO 455 K=2,NZM1
            U(1,1,K) =   U(1,1,K)
     *                 - GAMMA0*BD3(1,K)
     *                 - GAMMA1*(BD3(2,K) + BD3(NYM1,K) +
     *                           BD3(1,K+1) + BD3(1,K-1)  )
  455    CONTINUE
      ENDIF
C
C     ... LEFT TOP EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM)) THEN
         DO 465 K=2,NZM1
            U(1,NY,K) =   U(1,NY,K)
     *                  + GAMMA0*BD4(1,K)
     *                  + GAMMA1*(BD4(2,K) + BD4(NXM1,K) +
     *                            BD4(1,K+1) + BD4(1,K-1)  )
  465    CONTINUE
      ENDIF
C
C     ... LEFT FRONT EDGE (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO  475 J=2,NYM1
            U(1,J,NZ) =   U(1,J,NZ)
     *                  + GAMMA0*BD5(1,J)
     *                  + GAMMA1*(BD5(2,J) + BD5(NXM1,J) +
     *                            BD5(1,J+1) + BD5(1,J-1)  )
  475    CONTINUE
      ENDIF
C
C     ... RIGHT BOTTOM EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY) THEN
         DO 485 K=2,NZM1
            U(NX,1,K) =   U(NX,1,K)
     *                  + GAMMA0*BD1(1,K)
     *                  + GAMMA1*(BD1(2,K) + BD1(NYM1,K) +
     *                            BD1(1,K+1) + BD1(1,K-1)  )
  485    CONTINUE
      ENDIF
C
C     ... BOTTOM FRONT EDGE (PERIODIC/NEUMANN)
C
      IF (PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         DO 495 I=2,NXM1
            U(I,1,NZ) =   U(I,1,NZ)
     *                  + GAMMA0*BD5(I,1)
     *                  + GAMMA1*(BD5(I+1,1) + BD5(I-1,1) +
     *                            BD5(I,2) + BD5(I,NYM1)  )
  495    CONTINUE
      ENDIF
C
C     ... RIGHT BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDZ) THEN
         DO 505 J=2,NYM1
            U(NX,J,1) =   U(NX,J,1)
     *                  + GAMMA0*BD1(J,1)
     *                  + GAMMA1*(BD1(J+1,1) + BD1(J-1,1) +
     *                            BD1(J,2) + BD1(J,NZM1)  )
  505    CONTINUE
      ENDIF
C
C     ... TOP BACK EDGE (NEUMANN/PERIODIC)
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN
         DO 515 I=2,NXM1
            U(I,NY,1) =   U(I,NY,1)
     *                  + GAMMA0*BD4(I,1)
     *                  + GAMMA1*(BD4(I+1,1) + BD4(I-1,1) +
     *                            BD4(I,2) + BD4(I,NZM1)  )
  515    CONTINUE
      ENDIF
C
C
C  -----------------------------------------
C  HANDLE NEUMANN/POINTS AT PERIODIC CORNERS
C  -----------------------------------------
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) THEN
         U(1,1,1) =   U(1,1,1)
     *              - GAMMA0*BD3(1,1)
     *              - GAMMA1*(BD3(2,1) + BD3(NYM1,1) +
     *                        BD3(1,2) + BD3(1,NZM1)  )
      ENDIF
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/PERIODIC)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN
         U(1,1,1) =   U(1,1,1)
     *              - GAMMA0*BD2(1,1)
     *              - GAMMA1*(BD2(2,1) + BD2(NXM1,1) +
     *                        BD2(1,2) + BD2(1,NZM1)  )
      ENDIF
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/PERIODIC/NEUMANN)
C
      IF (PRDX .AND. PRDY .AND. (BCTY(BACK) .EQ. NEUM)) THEN
         U(1,1,1) =   U(1,1,1)
     *              - GAMMA0*BD6(1,1)
     *              - GAMMA1*(BD6(2,1) + BD6(NXM1,1) +
     *                        BD6(1,2) + BD6(1,NYM1)  )
      ENDIF
C
C     ... LEFT BOTTOM BACK CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *               (BCTY(BACK) .EQ. NEUM)         )  THEN
         U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD2(1,1) - BD6(1,1) )
     *              + GEDGE1*( -BD2(1,2) - BD6(1,2) )
     *              + GEDGE2*( -BD2(1,3) - BD6(1,3) )
     *              + GEDGE3*( -BD2(1,4) - BD6(1,4) )
     *              + GEDGE4*( -BD2(2,1) - BD6(2,1)
     *                         -BD2(NXM1,1) - BD6(NXM1,1) )
     *              + GEDGE5*( -BD2(2,2) - BD6(2,2)
     *                         -BD2(NXM1,2) - BD6(NXM1,2) )
      ENDIF
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(BACK) .EQ. NEUM)                  ) THEN
         U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD3(1,1) - BD6(1,1) )
     *              + GEDGE1*( -BD3(1,2) - BD6(2,1) )
     *              + GEDGE2*( -BD3(1,3) - BD6(3,1) )
     *              + GEDGE3*( -BD3(1,4) - BD6(4,1) )
     *              + GEDGE4*( -BD3(2,1) - BD6(1,2)
     *                         -BD3(NYM1,1) - BD6(1,NYM1) )
     *              + GEDGE5*( -BD3(2,2) - BD6(2,2)
     *                         -BD3(NYM1,2) - BD6(2,NYM1) )
      ENDIF
C
C     ... LEFT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT  ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN
         U(1,1,1) =   U(1,1,1)
     *              + GEDGE0*( -BD3(1,1) - BD2(1,1) )
     *              + GEDGE1*( -BD3(2,1) - BD2(2,1) )
     *              + GEDGE2*( -BD3(3,1) - BD2(3,1) )
     *              + GEDGE3*( -BD3(4,1) - BD2(4,1) )
     *              + GEDGE4*( -BD3(1,2) - BD2(1,2)
     *                         -BD3(1,NZM1) - BD2(1,NZM1) )
     *              + GEDGE5*( -BD3(2,2) - BD2(2,2)
     *                         -BD3(2,NZM1) - BD2(2,NZM1) )
      ENDIF
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND. PRDZ) THEN
         U(NX,1,1) =   U(NX,1,1)
     *               + GAMMA0*BD1(1,1)
     *               + GAMMA1*(BD1(2,1) + BD1(NYM1,1) +
     *                         BD1(1,2) + BD1(1,NZM1)  )
      ENDIF
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT ) .EQ. NEUM) .AND.
     *    (BCTY(BOTTOM) .EQ. NEUM) .AND. PRDZ) THEN
         U(NX,1,1) =   U(NX,1,1)
     *               + GEDGE0*( BD1(1,1) - BD2(NX,1) )
     *               + GEDGE1*( BD1(2,1) - BD2(NXM1,1) )
     *               + GEDGE2*( BD1(3,1) - BD2(NXM2,1) )
     *               + GEDGE3*( BD1(4,1) - BD2(NXM3,1) )
     *               + GEDGE4*( BD1(1,2) - BD2(NX,2)
     *                        + BD1(1,NZM1) - BD2(NX,NZM1) )
     *               + GEDGE5*( BD1(2,2) - BD2(NXM1,2)
     *                        + BD1(2,NZM1) - BD2(NXM1,NZM1) )
      ENDIF
C
C     ... RIGHT BOTTOM BACK CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(BACK ) .EQ. NEUM)                  ) THEN
         U(NX,1,1) =   U(NX,1,1)
     *               + GEDGE0*( BD1(1,1) - BD6(NX,1) )
     *               + GEDGE1*( BD1(1,2) - BD6(NXM1,1) )
     *               + GEDGE2*( BD1(1,3) - BD6(NXM2,1) )
     *               + GEDGE3*( BD1(1,4) - BD6(NXM3,1) )
     *               + GEDGE4*( BD1(2,1) - BD6(NX,2)
     *                        + BD1(NYM1,1) - BD6(NX,NYM1) )
     *               + GEDGE5*( BD1(2,2) - BD6(NXM1,2)
     *                        + BD1(NYM1,2) - BD6(NXM1,NYM1) )
      ENDIF
C
C     ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/PERIODIC)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND. PRDZ) THEN
         U(1,NY,1) =   U(1,NY,1)
     *               + GAMMA0*BD4(1,1)
     *               + GAMMA1*(BD4(2,1) + BD4(NXM1,1) +
     *                         BD4(1,2) + BD4(1,NZM1)  )
      ENDIF
C
C     ... LEFT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND.
     *    (BCTY(TOP ) .EQ. NEUM) .AND. PRDZ) THEN
         U(1,NY,1) =   U(1,NY,1)
     *               + GEDGE0*( -BD3(NY,1) + BD4(1,1) )
     *               + GEDGE1*( -BD3(NYM1,1) + BD4(2,1) )
     *               + GEDGE2*( -BD3(NYM2,1) + BD4(3,1) )
     *               + GEDGE3*( -BD3(NYM3,1) + BD4(4,1) )
     *               + GEDGE4*( -BD3(NY,2) + BD4(1,2)
     *                          -BD3(NY,NZM1) + BD4(1,NZM1) )
     *               + GEDGE5*( -BD3(NYM1,2) + BD4(2,2)
     *                          -BD3(NYM1,NZM1) + BD4(2,NZM1) )
      ENDIF
C
C     ... LEFT TOP BACK CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM) .AND.
     *    (BCTY(BACK) .EQ. NEUM)                 ) THEN
         U(1,NY,1) =   U(1,NY,1)
     *               + GEDGE0*( BD4(1,1) - BD6(1,NY) )
     *               + GEDGE1*( BD4(1,2) - BD6(1,NYM1) )
     *               + GEDGE2*( BD4(1,3) - BD6(1,NYM2) )
     *               + GEDGE3*( BD4(1,4) - BD6(1,NYM3) )
     *               + GEDGE4*( BD4(2,1) - BD6(2,NY)
     *                        + BD4(NXM1,1) - BD6(NXM1,NY) )
     *               + GEDGE5*( BD4(2,2) - BD6(2,NYM1)
     *                        + BD4(NXM1,2) - BD6(NXM1,NYM1) )
      ENDIF
C
C     ... LEFT BOTTOM FRONT CORNER (PERIODIC/PERIODIC/NEUMANN)
C
      IF (PRDX .AND. PRDY .AND. (BCTY(FRONT) .EQ. NEUM)) THEN
         U(1,1,NZ) =   U(1,1,NZ)
     *               + GAMMA0*BD5(1,1)
     *               + GAMMA1*(BD5(2,1) + BD5(NXM1,1) +
     *                         BD5(1,2) + BD5(1,NYM1)  )
      ENDIF
C
C     ... LEFT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(LEFT ) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(FRONT) .EQ. NEUM)                  ) THEN
         U(1,1,NZ) =   U(1,1,NZ)
     *               + GEDGE0*( -BD3(1,NZ) + BD5(1,1) )
     *               + GEDGE1*( -BD3(1,NZM1) + BD5(2,1) )
     *               + GEDGE2*( -BD3(1,NZM2) + BD5(3,1) )
     *               + GEDGE3*( -BD3(1,NZM3) + BD5(4,1) )
     *               + GEDGE4*( -BD3(2,NZ) + BD5(1,2)
     *                          -BD3(NYM1,NZ) + BD5(1,NYM1) )
     *               + GEDGE5*( -BD3(2,NZM1) + BD5(2,2)
     *                          -BD3(NYM1,NZM1) + BD5(2,NYM1) )
      ENDIF
C
C     ... LEFT BOTTOM FRONT CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM) .AND.
     *               (BCTY(FRONT ) .EQ. NEUM)       ) THEN
         U(1,1,NZ) =   U(1,1,NZ)
     *               + GEDGE0*( -BD2(1,NZ) + BD5(1,1) )
     *               + GEDGE1*( -BD2(1,NZM1) + BD5(1,2) )
     *               + GEDGE2*( -BD2(1,NZM2) + BD5(1,3) )
     *               + GEDGE3*( -BD2(1,NZM3) + BD5(1,4) )
     *               + GEDGE4*( -BD2(2,NZ) + BD5(2,1)
     *                          -BD2(NXM1,NZ) + BD5(NXM1,1) )
     *               + GEDGE5*( -BD2(2,NZM1) + BD5(2,2)
     *                          -BD2(NXM1,NZM1) + BD5(NXM1,2) )
      ENDIF
C
C     ... LEFT TOP FRONT CORNER (PERIODIC/NEUMANN/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP  ) .EQ. NEUM) .AND.
     *               (BCTY(FRONT) .EQ. NEUM)       ) THEN
         U(1,NY,NZ) =   U(1,NY,NZ)
     *                + GEDGE0*( BD4(1,NZ) + BD5(1,NY) )
     *                + GEDGE1*( BD4(1,NZM1) + BD5(1,NYM1) )
     *                + GEDGE2*( BD4(1,NZM2) + BD5(1,NYM2) )
     *                + GEDGE3*( BD4(1,NZM3) + BD5(1,NYM3) )
     *                + GEDGE4*( BD4(2,NZ) + BD5(2,NY)
     *                         + BD4(NXM1,NZ) + BD5(NXM1,NY) )
     *                + GEDGE5*( BD4(2,NZM1) + BD5(2,NYM1)
     *                         + BD4(NXM1,NZM1) + BD5(NXM1,NYM1) )
      ENDIF
C
C     ... RIGHT BOTTOM FRONT CORNER (NEUMANN/PERIODIC/NEUMANN)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. PRDY .AND.
     *    (BCTY(FRONT) .EQ. NEUM)                  ) THEN
            U(NX,1,NZ) =   U(NX,1,NZ)
     *                   + GEDGE0*( BD1(1,NZ) + BD5(NX,1) )
     *                   + GEDGE1*( BD1(1,NZM1) + BD5(NXM1,1) )
     *                   + GEDGE2*( BD1(1,NZM2) + BD5(NXM2,1) )
     *                   + GEDGE3*( BD1(1,NZM3) + BD5(NXM3,1) )
     *                   + GEDGE4*( BD1(2,NZ) + BD5(NX,2)
     *                            + BD1(NYM1,NZ) + BD5(NX,NYM1) )
     *                   + GEDGE5*( BD1(2,NZM1) + BD5(NXM1,2)
     *                            + BD1(NYM1,NZM1) + BD5(NXM1,NYM1) )
      ENDIF
C
C     ... RIGHT TOP BACK CORNER (NEUMANN/NEUMANN/PERIODIC)
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND.
     *    (BCTY(TOP  ) .EQ. NEUM) .AND. PRDZ) THEN
         U(NX,NY,1) =   U(NX,NY,1)
     *                + GEDGE0*( BD1(NY,1) + BD4(NX,1) )
     *                + GEDGE1*( BD1(NYM1,1) + BD4(NXM1,1) )
     *                + GEDGE2*( BD1(NYM2,1) + BD4(NXM2,1) )
     *                + GEDGE3*( BD1(NYM3,1) + BD4(NXM3,1) )
     *                + GEDGE4*( BD1(NY,2) + BD4(NX,2)
     *                         + BD1(NY,NZM1) + BD4(NX,NZM1) )
     *                + GEDGE5*( BD1(NYM1,2) + BD4(NXM1,2)
     *                         + BD1(NYM1,NZM1) + BD4(NXM1,NZM1) )
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE MDALG3 (A, B, C, D, BCTY, U, LDXU, LDYU, IL, IR,
     *                   JL, JR, KL, KR, WORK)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C
C    DECEMBER 1985   (REVISED APRIL 1987)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   MDALG3 IMPLEMENTS THE MATRIX DECOMPOSITION ALGORITHM (FOURIER
C   METHOD FOR A NINE-POINT DIFFERENCE OPERATOR ON A THREE-DIMENSIONAL
C   RECTANGULAR GRID.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     A, B, C, D   REAL SCALARS (INPUT)
C                  GIVE THE BASIC FINITE DIFFERENCE STENCIL THAT IS
C                  USED TO APPROXIMATE THE PDE.
C
C                         D  C  D
C                         C  B  C
C                         D  C  D
C
C                         C  B  C
C                         B  A  B  U  = RIGHT HAND SIDE
C                         C  B  C
C
C                         D  C  D
C                         C  B  C
C                         D  C  D
C
C     BCTY         INTEGER ARRAY OF SIZE 6 (INPUT)
C                  SEE HFFT3A.
C
C     U            REAL ARRAY OF SIZE LDXU BY LDYU BY KR (INPUT/OUTPUT)
C                  ON INPUT, U CONTAINS THE RIGHT HAND SIDE OF THE
C                  DISCRETE APPROXIMATION TO THE PDE FOR EACH POINT
C                  POINT AT WHICH THE SOLUTION IS TO BE DETERMINED,
C                  I.E., (I,J,K), I=IL,..,IR, J=JL,..,JR, K=KL,..,KR.
C                  ON OUTPUT, THESE VALUES ARE REPLACED BY THE COMPUTED
C                  SOLUTION.
C
C     LDXU         INTEGER SCALAR (INPUT)
C                  THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                  SPECIFIED IN THE CALLING PROGRAM.
C
C     LDYU         INTEGER SCALAR (INPUT)
C                  THE SECOND DIMENSION OF THE ARRAY U EXACTLY AS
C                  SPECIFIED IN THE CALLING PROGRAM.
C
C     IL, IR,      INTEGER SCALARS (INPUT)
C     JL, JR,      GIVES THE SUBSET OF GRID POINTS AT WHICH THE
C     KL, KR       SOLUTION IS TO BE DETERMINED, I.E., THAT SET
C                  OF INDICES (I,J) WITH I=IL,..,IR, J=JL,..,JR, AND
C                  K=KL,..,KR.
C
C     WORK         REAL ARRAY OF SIZE N*L + 5N + 5M + 3L + N/2 + L/2 +30
C                  HERE N=IR-IL+1, M=JR-JL+1, AND L=KR-KL+1. THE LENGTH
C                  OF THIS ARRAY MAY BE REDUCED BY M WHEN THE SOLUTION
C                  IS NOT PERIODIC IN Y, AND MAY BE REDUCED BY 4M WHEN
C                  THE COEFFICIENT OF U IN THE PDE IS .LE. 0.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(6), LDXU, LDYU, IL, IR, JL, JR, KL, KR
      REAL
     *     A, B, C, D, U(LDXU,LDYU,*), WORK(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER N, M, L, LOCWSA, LOCMWK, TOTAL
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  --------------
C  INITIALIZATION
C  --------------
C
      N = IR - IL + 1
      M = JR - JL + 1
      L = KR - KL + 1
      LOC WSA = 1 + N*L
      LOC MWK = LOC WSA + (3*L + L/2 + 15)
      TOTAL   = LOC MWK + 5*N + 5*M + N/2 + 14
C
      CALL FFTI(BCTY(BACK),BCTY(FRONT),L,WORK(LOCWSA))
C
C
C  ------------------
C  FORWARD TRANSFORMS
C  ------------------
C
      DO 100 J=JL,JR
         KK = 0
         DO 25 I=IL,IR
            DO 25 K=KL,KR
               KK = KK + 1
               WORK(KK) = U(I,J,K)
   25    CONTINUE
         CALL FFTF(BCTY(BACK),BCTY(FRONT),WORK,L,1,L,1,N,WORK(LOCWSA))
         KK = 0
         DO 75 I=IL,IR
            DO 75 K=KL,KR
               KK = KK + 1
               U(I,J,K) = WORK(KK)
   75    CONTINUE
  100 CONTINUE
C
C
C  --------------------------------
C  SOLVE N TWO-DIMENSIONAL PROBLEMS
C  --------------------------------
C
      CALL EVDISC(BCTY(BACK),BCTY(FRONT),WORK(KL),L)
      DO 200 K=KL,KR
         EVA = A + B*WORK(K)
         EVB = B + C*WORK(K)
         EVC = C + D*WORK(K)
         CALL MDALG2(EVA,EVB,EVC,BCTY,U(1,1,K),LDXU,IL,IR,JL,JR,
     *               WORK(LOCMWK))
  200 CONTINUE
C
C  -------------------
C  BACKWARD TRANSFORMS
C  -------------------
C
      DO 300 J=JL,JR
         KK = 0
         DO 225 I=IL,IR
            DO 225 K=KL,KR
               KK = KK + 1
               WORK(KK) = U(I,J,K)
  225    CONTINUE
         CALL FFTB(BCTY(BACK),BCTY(FRONT),WORK,L,1,L,1,N,WORK(LOCWSA))
         KK = 0
         DO 275 I=IL,IR
            DO 275 K=KL,KR
               KK = KK + 1
               U(I,J,K) = WORK(KK)
  275    CONTINUE
  300 CONTINUE
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE REFL3 (KDIST, NX, NY, NZ, PRDX, PRDY, PRDZ, G,
     *                  LMXG, LMYG)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   REFL3 EXTENDS A THREE-DIMENSIONAL GRID FUNCTION SO THAT IT IS
C   DEFINED ONE GRID LINE OUTSIDE ITS ORIGINAL DOMAIN.  THE EXTENSION
C   IS DONE BY REFLECTION THROUGH THE BOUNDARY EXCEPT WHERE
C   PERIODICITY IS SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KDIST   INTEGER SCALAR (INPUT)
C             INDICATES HOW THE GRID FUNCTION IS DEFINED.
C             POSSIBLE VALUES ARE
C
C                1 == FUNCTION DEFINED AT CENTER OF GRID SQUARES
C                2 == FUNCTION DEFINED AT GRID POINTS
C
C     NX      INTEGER SCALAR (INPUT)
C             THE NUMBER OF GRID FUNCTION VALUES IN THE X DIRECTION.
C
C     NY      INTEGER SCALAR (INPUT)
C             THE NUMBER OF GRID FUNCTION VALUES IN THE Y DIRECTION.
C
C     NZ      INTEGER SCALAR (INPUT)
C             THE NUMBER OF GRID FUNCTION VALUES IN THE Z DIRECTION.
C
C     PRDX    LOGICAL SCALAR (INPUT)
C             .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY
C             IN X.
C
C     PRDY    LOGICAL SCALAR (INPUT)
C             .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY
C             IN Y.
C
C     PRDZ    LOGICAL SCALAR (INPUT)
C             .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY
C             IN Z.
C
C     G       REAL ARRAY OF SIZE LMXG+1 BY LMYG+1 BY NZ+1 (INPUT/OUTPUT)
C             ON INPUT, THE GRID FUNCTION OCCUPIES G(I,J,K), I=1,..,NX,
C             J=1,..,NY, K=1,..,NZ.
C             ON OUTPUT, THE FUNCTION HAS BEEN EXTENDED TO INCLUDE THE
C             POINTS G(0,J,K), G(NX+1,J,K), G(I,0,K), G(I,NY+1,K),
C             G(I,J,0), G(I,J,NZ+1), I=0,..,NX+1, J=0,..,NY+1,
C             K=0,..,NZ+1.
C
C     LMXG    INTEGER SCALAR (INPUT)
C             THE UPPER LIMIT OF THE FIRST DIMENSION OF THE ARRAY G.
C             MUST BE SET TO LDXU-1, WHERE LDXU IS THE ACTUAL LENGTH OF
C             THE FIRST DIMENSION OF G AS DECLARED IN THE CALLING
C             PROGRAM.
C
C     LMYG    INTEGER SCALAR (INPUT)
C             THE UPPER LIMIT OF THE SECOND DIMENSION OF THE ARRAY G.
C             MUST BE SET TO LDYU-1, WHERE LDYU IS THE ACTUAL LENGTH OF
C             THE SECOND DIMENSION OF G AS DECLARED IN THE CALLING
C             PROGRAM.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      LOGICAL PRDX, PRDY, PRDZ
      INTEGER KDIST, NX, NY, NZ, LMXG, LMYG
      REAL
     *     G(0:LMXG,0:LMYG,0:*)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXP1 = NX + 1
      NYP1 = NY + 1
      NZP1 = NZ + 1
C
      I0 = 1 + KDIST
      J0 = 1 + KDIST
      K0 = 1 + KDIST
      I1 = NX - KDIST
      J1 = NY - KDIST
      K1 = NZ - KDIST
C
C
C  -----------
C  REFLECTIONS
C  -----------
C
C     ... IN Z DIRECTION
C
      DO 10 I=1,NX
         DO 10 J=1,NY
            G(I,J,0) = G(I,J,K0)
            G(I,J,NZP1) = G(I,J,K1)
   10 CONTINUE
C
C     ... IN X DIRECTION
C
      DO 20 J=1,NY
         DO 20 K=0,NZP1
            G(0,J,K) = G(I0,J,K)
            G(NXP1,J,K) = G(I1,J,K)
   20 CONTINUE
C
C     ... IN Y DIRECTION
C
      DO 30 I=0,NXP1
         DO 30 K=0,NZP1
            G(I,0,K) = G(I,J0,K)
            G(I,NYP1,K) = G(I,J1,K)
   30 CONTINUE
C
C
C  -------------------
C  PERIODIC EXTENSIONS
C  -------------------
C
C     ... IN X DIRECTIONS
C
      IF (PRDX) THEN
         DO 40 J=0,NYP1
           DO 40 K=0,NZP1
               G(0,J,K) = G(NXP1,J,K)
   40     CONTINUE
      ENDIF
C
C     ... IN Y DIRECTION
C
      IF (PRDY) THEN
         DO 50 I=0,NXP1
            DO 50 K=0,NZP1
               G(I,0,K) = G(I,NYP1,K)
   50    CONTINUE
      ENDIF
C
C     ... IN Z DIRECTION
C
      IF (PRDZ) THEN
         DO 60 I=0,NXP1
            DO 60 J=0,NYP1
               G(I,J,0) = G(I,J,NZP1)
   60    CONTINUE
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE STORD3 (NX, NY, NZ, BCTY, BD1, BD2, BD3, BD4, BD5, BD6,
     *                   LDXBD, LDYBD, U, LDXU, LDYU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   STORD3 STORES GIVEN DIRICHLET BOUNDARY DATA INTO THE SOLUTION ARRAY.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX,NY,NZ  INTEGER SCALARS (INPUT)
C               SEE HFFT3A.
C
C     BCTY      INTEGER ARRAY OF SIZE 6 (INPUT)
C               SEE HFFT3A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE LDYBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE LDXBD BY NZ (INPUT)
C               SEE HFFT3A.
C
C     BD5, BD6  REAL ARRAYS OF SIZE LDXBD BY NY (INPUT)
C               SEE HFFT3A.
C
C     LDXBD     INTEGER SCALARS (INPUT)
C     LDYBD     SEE HFFT3A.
C
C     U         REAL ARRAY OF SIZE LDXU BY LDYU BY NZ (INPUT/OUTPUT)
C               ON OUTPUT, ELEMENTS CORRESPONDING TO DIRICHLET BOUNDARY
C               POINTS CONTAIN THE KNOWN VALUES OF THE SOLUTION THERE.
C
C     LDXU      INTEGER SCALARS (INPUT)
C     LDYU      SEE HFFT3A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, NZ, BCTY(6), LDXBD, LDYBD, LDXU, LDYU
      REAL
     *     BD1(LDYBD,NZ), BD2(LDXBD,NZ), BD3(LDYBD,NZ), BD4(LDXBD,NZ),
     *     BD5(LDXBD,NY), BD6(LDXBD,NY), U(LDXU,LDYU,NZ)
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM, FRONT, BACK
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2, FRONT=5, BACK=6)
C
C
C  ----------------------
C  HANDLE DIRICHLET SIDES
C  ----------------------
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .EQ. DRCH) THEN
         DO 205 K=1,NZ
            DO 205 I=1,NX
               U(I,1,K) = BD2(I,K)
  205    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .EQ. DRCH) THEN
         DO 215 K=1,NZ
            DO 215 I=1,NX
               U(I,NY,K) = BD4(I,K)
  215    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .EQ. DRCH) THEN
         DO 225 K=1,NZ
            DO 225 J=1,NY
               U(1,J,K) = BD3(J,K)
  225    CONTINUE
      ENDIF
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .EQ. DRCH) THEN
         DO 235 K=1,NZ
            DO 235 J=1,NY
               U(NX,J,K) = BD1(J,K)
  235    CONTINUE
      ENDIF
C
C     ... FRONT SIDE
C
      IF (BCTY(FRONT) .EQ. DRCH) THEN
         DO 245 J=1,NY
            DO 245 I=1,NX
               U(I,J,NZ) = BD5(I,J)
  245    CONTINUE
      ENDIF
C
C     ... BACK SIDE
C
      IF (BCTY(BACK) .EQ. DRCH) THEN
         DO 255 J=1,NY
            DO 255 I=1,NX
               U(I,J,1) = BD6(I,J)
  255    CONTINUE
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
*
      SUBROUTINE HFFT2 (COEFU, PRHS, BRHS, AX, BX, AY, BY, NX, NY,
     *                  BCTY, IORDER, U, LDXU, WORK, NWORK, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C       HFFT2   =  2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT2A  =  2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C       HFFT3   =  3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT3A  =  3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   P U R P O S E
C   -------------
C
C   HFFT2 SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES
C   ON A TWO-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION
C   OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS.
C
C
C   D E S C R I P T I O N
C   ---------------------
C
C   HFFT2 SOLVES THE EQUATION
C
C                  2       2
C                 D U  +  D U
C                 ---  +  ---  +  COEFU*U   =   G
C                   2       2
C                 DX      DY
C
C
C   ON THE RECTANGULAR DOMAIN (AX,BX)X(AY,BY)
C
C                         TOP  (SIDE 4)
C              Y=BY ----------------------------
C                   :                          :
C                   :                          :
C              LEFT :                          : RIGHT
C                   :                          :
C          (SIDE 3) :                          : (SIDE 1)
C                   :                          :
C                   :                          :
C              Y=AY ----------------------------
C                  X=AX   BOTTOM  (SIDE 2)   X=BX
C
C   WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN
C   (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS.
C
C   THE OUTPUT OF THIS PROGRAM IS A TWO-DIMENSIONAL ARRAY GIVING
C   ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J)), FOR
C   I=1,..,NX AND J=1,..,NY, WHERE
C
C                      X(I) = AX + (I-1)*HX
C                      Y(J) = AY + (J-1)*HY
C                        HX = (BX-AX)/(NX-1)
C                        HY = (BY-AY)/(NY-1)
C
C   THE USER MUST CHOOSE NX AND NY SO THAT THE GRID SPACING IS THE SAME
C   IN BOTH X AND Y, I.E., HX = HY.
C
C   WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE
C   PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO
C   OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION
C   OF MINIMUM INFINITY NORM IS RETURNED.
C
C   THE SOLUTION IS COMPUTED USING EITHER A SECOND OR FOURTH ORDER
C   ACCURATE FINITE DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION.
C   THE RESULTING SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING
C   FAST FOURIER TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE
C   FACT THAT NX-1 IS HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES).
C
C
C   P A R A M E T E R S
C   -------------------
C
C   COEFU    REAL SCALAR (INPUT)
C            THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION.
C
C   PRHS     REAL FUNCTION OF X,Y (INPUT)
C            RETURNS THE RIGHT-HAND SIDE OF THE DIFFERENTIAL EQUATION
C            FOR ANY (X,Y) IN THE DOMAIN OR ON THE BOUNDARY (SEE
C            DESCRIPTION BELOW).  THE NAME OF THIS FUNCTION MUST BE
C            DECLARED EXTERNAL IN THE CALLING PROGRAM.
C
C   BRHS     REAL FUNCTION OF K,X,Y (INPUT)
C            RETURNS THE RIGHT-HAND SIDE OF THE BOUNDARY CONDITION AT
C            THE POINT (X,Y) ON THE K-TH SIDE OF THE DOMAIN (SEE
C            DESCRIPTION BELOW).  THE NAME OF THIS FUNCTION MUST BE
C            DECLARED EXTERNAL IN THE CALLING PROGRAM.
C
C   AX       REAL SCALAR (INPUT) .LT. BX
C            THE VALUE OF X ALONG THE LEFT SIDE OF THE DOMAIN.
C
C   BX       REAL SCALAR (INPUT)
C            THE VALUE OF X ALONG THE RIGHT SIDE OF THE DOMAIN.
C
C   AY       REAL SCALAR (INPUT) .LT. BY
C            THE VALUE OF Y ALONG THE BOTTOM SIDE OF THE DOMAIN.
C
C   BY       REAL SCALAR (INPUT)
C            THE VALUE OF Y ALONG THE TOP SIDE OF THE DOMAIN.
C
C   NX       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN X.
C            (THE NUMBER OF VERTICAL PANELS IS THEN NX-1.)
C            NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   NY       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Y.
C            (THE NUMBER OF HORIZONTAL PANELS IS THEN NY-1.)
C
C   BCTY     INTEGER ARRAY OF SIZE 4 (INPUT)
C            INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE
C            DOMAIN AS FOLLOWS.
C
C               BCTY(1) = TYPE ON RIGHT SIDE  (X=BX)
C               BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY)
C               BCTY(3) = TYPE ON LEFT SIDE   (X=AX)
C               BCTY(4) = TYPE ON TOP SIDE    (Y=BY)
C
C            POSSIBLE VALUES ARE
C
C               1 == U PRESCRIBED
C               2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR
C                    DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4))
C               3 == PERIODIC
C
C   IORDER   INTEGER SCALAR (INPUT)
C            THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE
C            APPROXIMATION TO THE PROBLEM. POSSIBLE VALUES ARE
C
C              2 == SECOND ORDER ACCURATE COMPACT 9-POINT DIFFERENCES
C              4 == FOURTH ORDER ACCURATE COMPACT 9-POINT DIFFERENCES
C
C   U        REAL ARRAY OF SIZE LDXU BY NY+2 (OUTPUT)
C            THE SOLUTION OF THE PDE PROBLEM.
C            U(I,J) IS THE VALUE OF THE COMPUTED SOLUTION AT THE POINT
C            (X(I),Y(J)).  ROWS NX+1 AND NX+2 AND COLUMNS NY+1 AND
C            NY+2 ARE USED AS WORKING STORAGE.
C
C   LDXU     INTEGER SCALAR (INPUT) .GE. NX+2
C            THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   WORK     REAL ARRAY OF SIZE NWORK.
C            WORKING STORAGE REQUIRED BY HFFT2.
C
C   NWORK    INTEGER SCALAR (INPUT) .GE. (NX+1)*(NY+1)*(IORDER-2)/2
C            + 7*NX + 7*NY + NX/2 + 15.  THE LENGTH OF THE ARRAY WORK AS
C            DECLARED IN THE CALLING PROGRAM.  THIS MAY BE REDUCED BY
C            4*NY IF COEFU.LE.0.
C
C   INFO     INTEGER SCALAR (OUTPUT)
C            INDICATES STATUS OF COMPUTED SOLUTION.
C            POSSIBLE VALUES ARE
C
C               2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY
C                    CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE
C                    PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE
C                    RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED.
C                    THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT
C                    SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN
C                    ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN
C               1 == WARNING. COEFU.GT.0  A SOLUTION MAY NOT EXIST IF
C                    COEFU IS AN EIGENVALUE OF THE LAPLACIAN.  IF COEFU
C                    IS NEAR ONE OF THESE VALUES THEN THE COMPUTED
C                    SOLUTION MAY BE UNRELIABLE.
C               0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION.
C              -1 == ERROR. NX.LT.4
C              -2 == ERROR. NY.LT.4
C              -3 == ERROR. LDXU.LT.NX+2
C              -4 == ERROR. IORDER NOT 2 OR 4.
C              -5 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3.
C              -6 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON
C                           ONE SIDE OF DOMAIN BUT NOT THE OPPOSITE SIDE
C              -7 == ERROR. NWORK TOO SMALL.
C              -8 == ERROR. BX.LT.AX
C              -9 == ERROR. BY.LT.AY
C             -10 == ERROR. GRID SIZE IN X NOT SAME AS IN Y.
C
C
C   U S E R - D E F I N E D   F U N C T I O N S
C   -------------------------------------------
C
C   THE RIGHT HAND SIDE (FORCING FUNCTION) OF THE PARTIAL
C   DIFFERENTIAL EQUATION IS SPECIFIED BY THE FUNCTION PRHS.
C
C     REAL FUNCTION PRHS (X,Y)
C     REAL X,Y
C     PRHS = RIGHT SIDE OF THE PDE AT (X,Y)
C     RETURN
C     END
C
C   THE VALUE OF THE SOLUTION OR ITS FIRST DERIVATIVE ALONG THE
C   EDGES OF THE DOMAIN WHERE BCTY=1 OR 2 IS SUPPLIED VIA THE
C   FUNCTION BRHS.
C
C     REAL FUNCTION BRHS (K,X,Y)
C     INTEGER K
C     REAL X,Y
C     BRHS = RIGHT HAND SIDE OF KTH BOUNDARY CONDITION
C            (SEE BCTY) AT THE POINT (X,Y)
C     RETURN
C     END
C
C
C   E X T E R N A L   R E F E R E N C E S
C   -------------------------------------
C
C     HFFT2A,FDIS2,HDIS2,FD2N,
C     STORD2,FD2D,HD2N,REFL2,
C     MDALG2,EVDISC,TRISOL,
C     TRSALL,TRSOLG,TRSOLP,
C     SGPSL,FFTI,FFTB,FFTF          -- THIS PACKAGE
C
C     RFFTI,RFFTF,RFFTB,
C     SINTI,SINT,COSTI,COST,
C     SINQI,SINQF,SINQB,
C     COSQI,COSQF,COSQB             -- FFTPACK (SEE REF. 2)
C
C     R1MACH                        -- MACHINE CONSTANTS (SEE REF. 3)
C
C     PRHS,BRHS                     -- USER-SUPPLIED
C
C
C   P O R T A B I L I T Y
C   ---------------------
C
C   THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977).
C   ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE
C   FUNCTION R1MACH (SEE REF. 3).
C
C
C   R E F E R E N C E S
C   -------------------
C
C     1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD
C        FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS
C        II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS,
C        ORLANDO, FLA., 1984, 35-44.
C
C     2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE
C        PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS
C        ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3).
C        FFTPACK IS DESCRIBED IN
C
C          P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL
C          COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,
C          PP. 51-83.
C
C        FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE,
C        COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH,
C        BOX 3000, BOULDER, CO 80303, USA.
C
C     3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK
C        FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978),
C        PP. 177-188.
C
C     4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS,
C        HOLT, RINEHART AND WINSTON, NEW YORK, 1967.
C
C
C   A U T H O R  /  V E R S I O N
C   -----------------------------
C
C     RONALD F. BOISVERT
C     CENTER FOR APPLIED MATHEMATICS
C     NATIONAL BUREAU OF STANDARDS
C     GAITHERSBURG, MD 20899
C     USA
C
C     ORIGINAL DECEMBER 1987
C     REVISED  APRIL 1987
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, BCTY(4), IORDER, LDXU, NWORK, INFO
      REAL
     *     COEFU, AX, BX, AY, BY, U(LDXU,*), WORK(NWORK)
C
C     ... LOCAL VARIABLES
C
      INTEGER LOCGH, LOCBD1, LOCBD2, LOCBD3, LOCBD4, LOCWRK, NWORKA,
     *        NEEDED, LOC, NXM1, NYM1, NXP1, NYP1, NXP2, NYP2
      REAL
     *     R1MACH, EPSM, PRHS, BRHS, H, HX, HY, AXH, AYH, X, Y
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NXP1 = NX + 1
      NYP1 = NY + 1
      NXP2 = NX + 2
      NYP2 = NY + 2
C
      H = (BX-AX)/REAL(NXM1)
      EPSM = R1MACH(4)
C
      LOC GH  = 1
      LOC BD1 = LOC GH
      IF (IORDER .EQ. 4)  LOC BD1 = LOC GH  + NXP1*NYP1
      LOC BD2 = LOC BD1 + NY
      LOC BD3 = LOC BD2 + NX
      LOC BD4 = LOC BD3 + NY
      LOC WRK = LOC BD4 + NX
      NEEDED = LOC WRK + 5*NX + 5*NY + NX/2 + 14
      NWORKA = NWORK - LOCWRK + 1
C
C
C  ---------------------------
C  CHECK VALIDITY OF ARGUMENTS
C  ---------------------------
C
      INFO = 0
      IF (NX .LT. 4)  GO TO 901
      IF (NY .LT. 4)  GO TO 902
      IF (LDXU .LT. NX+2)  GO TO 903
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 904
      DO 10 K=1,4
         IF ((BCTY(K) .LT. 1) .OR. (BCTY(K) .GT. 3))  GO TO 905
   10 CONTINUE
      IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT  ) .NE. PRDC)) .OR.
     *    ((BCTY(LEFT  ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR.
     *    ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP   ) .NE. PRDC)) .OR.
     *    ((BCTY(TOP   ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC))    )
     *   GO TO 906
      IF (NWORK .LT. NEEDED)  GO TO 907
      IF (BX .LE. AX)   GO TO 908
      IF (BY .LE. AY)   GO TO 909
      HX = H
      HY = (BY-AY)/REAL(NYM1)
      IF (ABS(HX-HY) .GT. EPSM)  GO TO 910
C
C
C  ------------------
C  COMPUTE RHS OF PDE
C  ------------------
C
C     ... AT GRID POINTS
C
      DO 100 J=1,NY
         Y = AY + REAL(J-1)*H
         DO 100 I=1,NX
            X = AX + REAL(I-1)*H
            U(I,J) = PRHS(X,Y)
  100 CONTINUE
C
C     ... AT HALF GRID POINTS
C
      IF (IORDER .EQ. 4)  THEN
         AXH = AX + 0.50E0*H
         AYH = AY + 0.50E0*H
         DO 200 J=1,NYM1
            Y = AYH + REAL(J-1)*H
            K = LOC GH + J*NXP1
            DO 200 I=1,NXM1
               X = AXH + REAL(I-1)*H
               K = K + 1
               WORK(K) = PRHS(X,Y)
  200    CONTINUE
      ENDIF
C
C
C  ------------------
C  LOAD BOUNDARY DATA
C  ------------------
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .NE. PRDC)  THEN
         LOC = LOC BD1 - 1
         DO 310 J=1,NY
            Y = AY + REAL(J-1)*H
            LOC = LOC + 1
            WORK(LOC) = BRHS(RIGHT,BX,Y)
  310    CONTINUE
      ENDIF
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .NE. PRDC)  THEN
         LOC = LOC BD2 - 1
         DO 320 I=1,NX
            X = AX + REAL(I-1)*H
            LOC = LOC + 1
            WORK(LOC) = BRHS(BOTTOM,X,AY)
  320    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .NE. PRDC)  THEN
         LOC = LOC BD3 - 1
         DO 330 J=1,NY
            Y = AY + REAL(J-1)*H
            LOC = LOC + 1
            WORK(LOC) = BRHS(LEFT,AX,Y)
  330    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .NE. PRDC)  THEN
         LOC = LOC BD4 - 1
         DO 340 I=1,NX
            X = AX + REAL(I-1)*H
            LOC = LOC + 1
            WORK(LOC) = BRHS(TOP,X,BY)
  340    CONTINUE
      ENDIF
C
C
C  ----------------
C  CALL FAST SOLVER
C  ----------------
C
      CALL HFFT2A(COEFU,NX,NY,H,WORK(LOCGH),NXP1,BCTY,WORK(LOCBD1),
     *            WORK(LOCBD2),WORK(LOCBD3),WORK(LOCBD4),IORDER,
     *            U,LDXU,WORK(LOCWRK),NWORKA,INFO)
C
C
C  -----------
C  NORMAL EXIT
C  -----------
C
      WORK(1) = WORK(LOCWRK)
      GO TO 999
C
C
C  -----------
C  ERROR EXITS
C  -----------
C
  901 CONTINUE
      INFO = -1
      GO TO 999
C
  902 CONTINUE
      INFO = -2
      GO TO 999
C
  903 CONTINUE
      INFO = -3
      GO TO 999
C
  904 CONTINUE
      INFO = -4
      GO TO 999
C
  905 CONTINUE
      INFO = -5
      GO TO 999
C
  906 CONTINUE
      INFO = -6
      GO TO 999
C
  907 CONTINUE
      INFO = -7
      GO TO 999
C
  908 CONTINUE
      INFO = -8
      GO TO 999
C
  909 CONTINUE
      INFO = -9
      GO TO 999
C
  910 CONTINUE
      INFO = -10
      GO TO 999
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE HFFT2A (COEFU, NX, NY, H, GH, LDXGH, BCTY, BD1, BD2,
     *                   BD3, BD4, IORDER, U, LDXU, WORK, NWORK, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C       HFFT2   =  2 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT2A  =  2 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C       HFFT3   =  3 DIMENSIONS, PROBLEM DEFINED BY FUNCTIONS
C       HFFT3A  =  3 DIMENSIONS, PROBLEM DEFINED BY ARRAYS
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   P U R P O S E
C   -------------
C
C   HFFT2A SOLVES THE HELMHOLTZ EQUATION IN CARTESIAN COORDINATES
C   ON A TWO-DIMENSIONAL RECTANGULAR DOMAIN WITH ANY COMBINATION
C   OF DIRICHLET, NEUMANN, OR AND PERIODIC BOUNDARY CONDITIONS.
C
C
C   D E S C R I P T I O N
C   ---------------------
C
C   HFFT2A SOLVES THE EQUATION
C
C                   2       2
C                  D U  +  D U
C                  ---  +  ---  +  COEFU*U   =   G
C                    2       2
C                  DX      DY
C
C   ON THE RECTANGULAR DOMAIN (AX,BX)X(AY,BY)
C
C                         TOP  (SIDE 4)
C              Y=BY ----------------------------
C                   :                          :
C                   :                          :
C              LEFT :                          : RIGHT
C                   :                          :
C          (SIDE 3) :                          : (SIDE 1)
C                   :                          :
C                   :                          :
C              Y=AY ----------------------------
C                  X=AX   BOTTOM  (SIDE 2)   X=BX
C
C   WITH SOME COMBINATION OF DIRICHLET (SOLUTION PRESCRIBED), NEUMANN
C   (FIRST DERIVATIVE PRESCRIBED), OR PERIODIC BOUNDARY CONDITIONS.
C
C   THE OUTPUT OF THIS PROGRAM IS A TWO-DIMENSIONAL ARRAY GIVING
C   ESTIMATES OF THE SOLUTION AT A SET OF GRID POINTS (X(I),Y(J)), FOR
C   I=1,..,NX AND J=1,..,NY, WHERE
C
C                      X(I) = AX + (I-1)*H
C                      Y(J) = AY + (J-1)*H
C
C   AX IS THE X-COORDINATE OF THE LEFT EDGE OF THE RECTANGLE AND AY IS
C   THE Y-COORDINATE OF THE BOTTOM EDGE OF THE RECTANGLE.
C
C   WHEN COEFU=0 AND ONLY NEUMANN OR PERIODIC BOUNDARY CONDITIONS ARE
C   PRESCRIBED, THEN ANY CONSTANT MAY BE ADDED TO THE SOLUTION TO
C   OBTAIN ANOTHER SOLUTION TO THE PROBLEM. IN THIS CASE THE SOLUTION
C   OF MINIMUM INFINITY NORM IS RETURNED.
C
C   THE SOLUTION IS COMPUTED USING EITHER A SECOND OR FOURTH ORDER
C   ACCURATE FINITE DIFFERENCE APPROXIMATION OF THE CONTINUOUS EQUATION.
C   THE RESULTING SYSTEM OF LINEAR ALGEBRAIC EQUATIONS IS SOLVED USING
C   FAST FOURIER TRANSFORM TECHNIQUES. THE ALGORITHM RELIES UPON THE
C   FACT THAT NX-1 IS HIGHLY COMPOSITE (THE PRODUCT OF SMALL PRIMES).
C
C
C   P A R A M E T E R S
C   -------------------
C
C   COEFU    REAL SCALAR (INPUT)
C            THE COEFFICIENT OF U IN THE PARTIAL DIFFERENTIAL EQUATION.
C
C   NX       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN X.
C            (THE NUMBER OF VERTICAL PANELS IS THEN NX-1.)
C            NX SHOULD BE CHOSEN SO THAT NX-1 IS HIGHLY COMPOSITE
C            (THE PRODUCT OF SMALL PRIMES) TO INCREASE THE SPEED
C            OF THE FOURIER TRANSFORM ALGORITHM.
C
C   NY       INTEGER SCALAR (INPUT) .GE. 4
C            THE NUMBER OF GRID LINES IN Y.
C            (THE NUMBER OF HORIZONTAL PANELS IS THEN NY-1.)
C
C   H        REAL SCALAR (INPUT)
C            THE SPACE BETWEEN ADJACENT GRID LINES (IN BOTH X AND Y).
C
C   GH       REAL ARRAY OF SIZE LDXGH BY NY+1 (INPUT)
C            THE RIGHT HAND SIDE OF THE PDE AT HALF GRID POINTS.
C            G(I+1,J+1) IS THE VALUE OF THE RIGHT HAND SIDE AT THE
C            (I,J)TH HALF GRID POINT, I=1,..,NX-1, J=1,..,NY-1. THAT IS,
C
C                    GH(I+1,J+1) = G(XH(I),YH(J))
C                          XH(I) = AX + (I-0.5)*H
C                          YH(J) = AY + (J-0.5)*H
C
C            THE FIRST AND LAST ROWS AND COLUMNS OF GH ARE USED AS
C            WORKING STORAGE.  GH IS NOT USED WHEN IORDER=2.
C
C   LDXGH    INTEGER SCALAR (INPUT) .GE. NX+1
C            THE LEADING DIMENSION OF THE ARRAY GH EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   BCTY     INTEGER ARRAY OF SIZE 4 (INPUT)
C            INDICATES TYPE OF BOUNDARY CONDITION ON EACH SIDE OF THE
C            DOMAIN AS FOLLOWS.
C
C               BCTY(1) = TYPE ON RIGHT SIDE  (X=BX)
C               BCTY(2) = TYPE ON BOTTOM SIDE (Y=AY)
C               BCTY(3) = TYPE ON LEFT SIDE   (X=AX)
C               BCTY(4) = TYPE ON TOP SIDE    (Y=BY)
C
C            POSSIBLE VALUES ARE
C
C               1 == U PRESCRIBED
C               2 == DU/DX PRESCRIBED (FOR BCTY(1) AND BCTY(3)) OR
C                    DU/DY PRESCRIBED (FOR BCTY(2) AND BCTY(4))
C               3 == PERIODIC
C
C   BD1      REAL ARRAY OF SIZE NY (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE RIGHT SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(1)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DX
C                         3             NONE
C
C            BD1(J) GIVES THE VALUE AT THE POINT (BX,Y(J)).
C
C   BD2      REAL ARRAY OF SIZE NX (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE BOTTOM SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(2)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DY
C                         3             NONE
C
C            BD2(I) GIVES THE VALUE AT THE POINT (X(I),AY).
C
C   BD3      REAL ARRAY OF SIZE NY (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE LEFT SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(3)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DX
C                         3             NONE
C
C            BD3(J) GIVES THE VALUE AT THE POINT (AX,Y(J)).
C
C   BD4      REAL ARRAY OF SIZE NX (INPUT)
C            THE VALUES OF THE BOUNDARY CONDITION AT GRID POINTS ON
C            THE BOTTOM SIDE OF THE DOMAIN.  THE VALUE STORED DEPENDS
C            UPON THE TYPE OF BOUNDARY CONDITION AS FOLLOWS
C
C                      BCTY(4)       VALUE STORED
C                    ------------------------------
C                         1               U
C                         2             DU/DY
C                         3             NONE
C
C            BD4(I) GIVES THE VALUE AT THE POINT (X(I),BY).
C
C   IORDER   INTEGER SCALAR (INPUT)
C            THE ORDER OF ACCURACY OF THE FINITE DIFFERENCE
C            APPROXIMATION OF THE PARTIAL DIFFERENTIAL EQUATION.
C            POSSIBLE VALUES ARE
C
C              2 == 2ND ORDER ACCURATE 9-POINT COMPACT DIFFERENCES
C              4 == 4TH ORDER ACCURATE 9-POINT COMPACT DIFFERENCES
C
C   U        REAL ARRAY OF SIZE LDXU BY NY+2 (INPUT/OUTPUT)
C            ON INPUT, U(I,J) IS THE VALUE OF THE RIGHT HAND SIDE OF
C            THE PARTIAL DIFFERENTIAL EQUATION AT THE (I,J)TH GRID
C            POINT.  THAT IS,
C
C                U(I,J) = G(X(I),Y(J)),  I=1,..,NX, J=1,..,NY
C
C            ON OUTPUT, U(I,J) IS THE VALUE OF THE COMPUTED SOLUTION
C            AT (X(I),Y(J)).  ROWS NX+1 AND NX+2 AND COLUMNS NY+1 AND
C            NY+2 ARE USED FOR WORKING STORAGE.
C
C   LDXU     INTEGER SCALAR (INPUT) .GE. NX+2
C            THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS SPECIFIED
C            IN THE CALLING PROGRAM.
C
C   WORK     REAL ARRAY OF SIZE NWORK.
C            WORKING STORAGE REQUIRED BY HFFT2A.
C
C   NWORK    INTEGER SCALAR (INPUT) .GE. 5*NX + 5*NY + NX/2 + 15
C            THE LENGTH OF THE ARRAY WORK AS DECLARED IN THE CALLING
C            PROGRAM. THIS MAY BE REDUCED BY 4*NY IS COEFU.LE.0.
C
C   INFO     INTEGER SCALAR (OUTPUT)
C            INDICATES STATUS OF COMPUTED SOLUTION.
C            POSSIBLE VALUES ARE
C
C               2 == WARNING. NO SOLUTION EXISTS UNLESS A CONSISTENCY
C                    CONDITION IS SATISFIED (SEE REF. 4). THE DISCRETE
C                    PROBLEM IS ADJUSTED (BY ADDING A CONSTANT TO THE
C                    RIGHT SIDE) SO THAT THIS CONDITION IS SATISFIED.
C                    THIS CONSTANT IS RETURNED IN WORK(1). IF IT IS NOT
C                    SMALL THEN THE PROBLEM MAY NOT BE WELL-POSED. IN
C                    ADDITION, THE SOLUTION IS UNIQUE ONLY UP TO AN
C                    ADDITIVE CONSTANT.
C               1 == WARNING. COEFU.GT.0  A SOLUTION MAY NOT EXIST IF
C                    COEFU IS AN EIGENVALUE OF THE LAPLACIAN.  IF COEFU
C                    IS NEAR ONE OF THESE VALUES THEN THE COMPUTED
C                    SOLUTION MAY BE UNRELIABLE.
C               0 == SUCCESS. SUBPROGRAM RAN TO COMPLETION.
C              -1 == ERROR. NX.LT.4
C              -2 == ERROR. NY.LT.4
C              -3 == ERROR. LDXU.LT.NX+2
C              -4 == ERROR. IORDER NOT 2 OR 4.
C              -5 == ERROR. ELEMENT OF BCTY NOT 1, 2 OR 3.
C              -6 == ERROR. PERIODIC BOUNDARY CONDITIONS SPECIFIED ON
C                           ONE SIDE OF DOMAIN BUT NOT THE OPPOSITE SIDE
C              -7 == ERROR. NWORK TOO SMALL.
C              -8 == ERROR. LDXGH.LT.NX+1
C
C
C   E X T E R N A L   R E F E R E N C E S
C   -------------------------------------
C
C     FDIS2,HDIS2,FD2N,
C     STORD2,FD2D,HD2N,REFL2,
C     MDALG2,EVDISC,TRISOL,
C     TRSALL,TRSOLG,TRSOLP,
C     SGPSL,FFTI,FFTB,FFTF     -- THIS PACKAGE
C
C     RFFTI,RFFTF,RFFTB,
C     SINTI,SINT,COSTI,COST,
C     SINQI,SINQF,SINQB,
C     COSQI,COSQF,COSQB        -- FFTPACK (SEE REF. 2)
C
C     R1MACH                   -- MACHINE CONSTANTS (SEE REF. 3)
C
C
C   P O R T A B I L I T Y
C   ---------------------
C
C   THIS PACKAGE IS WRITTEN IN ANSI STANDARD FORTRAN (1977).
C   ALL MACHINE-DEPENDENT QUANTITIES ARE OBTAINED FROM THE
C   FUNCTION R1MACH (SEE REF. 3).
C
C
C   R E F E R E N C E S
C   -------------------
C
C     1) R. BOISVERT, A FOURTH ORDER ACCURATE FAST DIRECT METHOD
C        FOR THE HELMHOLTZ EQUATION, IN ELLIPTIC PROBLEM SOLVERS
C        II (G. BIRKHOFF AND A. SCHOENSTADT, EDS.), ACADEMIC PRESS,
C        ORLANDO, FLA., 1984, 35-44.
C
C     2) THE FFT PACKAGE USED IS A SLIGHTLY MODIFIED VERSION OF THE
C        PACKAGE FFTPACK WRITTEN BY PAUL SWARZTRAUBER. FFTPACK IS
C        ALSO USED BY THE SUBPROGRAM HW3CRT OF FISHPAK (VERSION 3).
C        FFTPACK IS DESCRIBED IN
C
C          P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL
C          COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,
C          PP. 51-83.
C
C        FOR FURTHER INFORMATION WRITE INFORMATION SERVICES OFFICE,
C        COMPUTING FACILITY, NATIONAL CENTER FOR ATMOSPHERIC RESEARCH,
C        BOX 3000, BOULDER, CO 80303, USA.
C
C     3) P. FOX, A. HALL, AND N. SCHRYER, ALGORITHM 528: FRAMEWORK
C        FOR A PORTABLE LIBRARY, ACM TRANS. MATH. SOFT. 4 (1978),
C        PP. 177-188.
C
C     4) S. G. MIKHLIN (ED.), LINEAR EQUATIONS OF MATHEMATICAL PHYSICS,
C        HOLT, RINEHART AND WINSTON, NEW YORK, 1967.
C
C
C   A U T H O R  /  V E R S I O N
C   -----------------------------
C
C     RONALD F. BOISVERT
C     CENTER FOR APPLIED MATHEMATICS
C     NATIONAL BUREAU OF STANDARDS
C     GAITHERSBURG, MD 20899
C     USA
C
C     ORIGINAL  DECEMBER 1985
C     REVISED   APRIL 1987
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, IORDER, LDXGH, LDXU, BCTY(4), NWORK, INFO
      REAL
     *     H, COEFU, GH(LDXGH,*), U(LDXU,*), WORK(NWORK),
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX)
C
C     ... LOCAL VARIABLES
C
      LOGICAL SNGULR, PRDX, PRDY
      INTEGER NXM1, NYM1, NM, NEEDED
      REAL
     *     EPSM, R1MACH, A, B, C, FX, FY, FACTOR, SCALE, PERTRB, UNORM
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      EPSM = R1MACH(4)
C
      NXM1 = NX - 1
      NYM1 = NY - 1
C
      SNGULR = (BCTY(RIGHT ) .NE. DRCH) .AND.
     *         (BCTY(BOTTOM) .NE. DRCH) .AND.
     *         (BCTY(LEFT  ) .NE. DRCH) .AND.
     *         (BCTY(TOP   ) .NE. DRCH) .AND.
     *         (ABS(COEFU) .LT. R1MACH(4))
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
      IL = 1
      IR = NX
      JL = 1
      JR = NY
      IF (BCTY(RIGHT ) .EQ. DRCH)  IR = NXM1
      IF (BCTY(BOTTOM) .EQ. DRCH)  JL = 2
      IF (BCTY(LEFT  ) .EQ. DRCH)  IL = 2
      IF (BCTY(TOP   ) .EQ. DRCH)  JR = NYM1
      IF (PRDX)  IR = NXM1
      IF (PRDY)  JR = NYM1
      NM = (IR-IL+1)*(JR-JL+1)
C
C
C  ---------------------------
C  CHECK VALIDITY OF ARGUMENTS
C  ---------------------------
C
      INFO = 0
      IF (NX .LT. 4)  GO TO 901
      IF (NY .LT. 4)  GO TO 902
      IF (LDXU .LT. NX+2)  GO TO 903
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 904
      DO 10 K=1,4
         IF ((BCTY(K) .LT. 1) .OR. (BCTY(K) .GT. 3))  GO TO 905
   10 CONTINUE
      IF (((BCTY(RIGHT ) .EQ. PRDC) .AND. (BCTY(LEFT  ) .NE. PRDC)) .OR.
     *    ((BCTY(LEFT  ) .EQ. PRDC) .AND. (BCTY(RIGHT ) .NE. PRDC)) .OR.
     *    ((BCTY(BOTTOM) .EQ. PRDC) .AND. (BCTY(TOP   ) .NE. PRDC)) .OR.
     *    ((BCTY(TOP   ) .EQ. PRDC) .AND. (BCTY(BOTTOM) .NE. PRDC))    )
     *   GO TO 906
      NEEDED = 5*NX + 5*NY + NX/2 + 15
      IF (NWORK .LT. NEEDED)  GO TO 907
      IF (LDXGH .LT. NX+1)  GO TO 908
C
      IF (COEFU .GT. 0.0E0)  INFO = 1
      IF (SNGULR)  INFO = 2
C
C
C  ----------
C  DISCRETIZE
C  ----------
C
      IF (IORDER .EQ. 4)  THEN
         CALL HDIS2(NX,NY,H,COEFU,GH,LDXGH-1,BCTY,BD1,BD2,BD3,BD4,
     *              A,B,C,U,LDXU-1,WORK)
      ELSE
         CALL FDIS2(NX,NY,H,COEFU,BCTY,BD1,BD2,BD3,BD4,
     *              A,B,C,U,LDXU)
      ENDIF
C
C  ---------------------------------------
C  ADJUST FOR CONSISTENCY IN SINGULAR CASE
C  ---------------------------------------
C
      PERTRB = 0.0E0
      IF (SNGULR) THEN
         SCALE = 0.0E0
         DO 100 J=JL,JR
            FY = 1.0E0
            IF (.NOT.PRDY.AND.(J.NE.1).AND.(J.NE.NY)) FY = 2.0E0
            DO 100 I=IL,IR
               FX = 1.0E0
               IF (.NOT.PRDX.AND.(I.NE.1).AND.(I.NE.NX)) FX = 2.0E0
               FACTOR = FX*FY
               PERTRB = PERTRB + FACTOR*U(I,J)
               SCALE = SCALE + FACTOR
  100    CONTINUE
         PERTRB = -PERTRB/SCALE
         DO 110 J=JL,JR
            DO 110 I=IL,IR
               U(I,J) = U(I,J) + PERTRB
  110    CONTINUE
      ENDIF
C
C
C  ------------------------------
C  MATRIX DECOMPOSITION USING FFT
C  ------------------------------
C
      CALL MDALG2(A,B,C,BCTY,U,LDXU,IL,IR,JL,JR,WORK)
C
C
C  -----------------------------------------
C  SELECT MIN NORM SOLUTION IN SINGULAR CASE
C  -----------------------------------------
C
      IF (SNGULR) THEN
         UNORM = 0.0E0
         DO 210 J=JL,JR
            DO 210 I=IL,IR
               UNORM = UNORM + U(I,J)
  210    CONTINUE
         UNORM = UNORM/REAL(NM)
         DO 220 J=JL,JR
            DO 220 I=IL,IR
               U(I,J) = U(I,J) - UNORM
  220    CONTINUE
      ENDIF
C
C
C  --------------------------------------
C  COPY IDENTICAL LINES IN PERIODIC CASES
C  --------------------------------------
C
      IF (PRDX) THEN
         DO 325 J=1,NY
            U(NX,J) = U(1,J)
  325    CONTINUE
      ENDIF
C
      IF (PRDY) THEN
         DO 375 I=1,NX
            U(I,NY) = U(I,1)
  375    CONTINUE
      ENDIF
C
C
C  -----------
C  NORMAL EXIT
C  -----------
C
      WORK(1) = PERTRB
      GO TO 999
C
C
C  -----------
C  ERROR EXITS
C  -----------
C
  901 CONTINUE
      INFO = -1
      GO TO 999
C
  902 CONTINUE
      INFO = -2
      GO TO 999
C
  903 CONTINUE
      INFO = -3
      GO TO 999
C
  904 CONTINUE
      INFO = -4
      GO TO 999
C
  905 CONTINUE
      INFO = -5
      GO TO 999
C
  906 CONTINUE
      INFO = -6
      GO TO 999
C
  907 CONTINUE
      INFO = -7
      GO TO 999
C
  908 CONTINUE
      INFO = -8
      GO TO 999
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE EVDISC (KBCL, KBCR, EIGEN, N)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   EVDISC COMPUTES THE EIGENVALUES OF THE FOLLOWING MATRIX
C
C                  :--                   --:
C                  :   0  R            T   :
C                  :   1  0  1             :
C                  :     1  0  1           :
C                  :       .  .  .         :
C                  :         .  .  .       :
C                  :           1  0  1     :
C                  :             1  0  1   :
C                  :   T            S  0   :
C                  :--                   --:
C
C   WHERE THE SCALARS R, S, AND T DEPEND UPON THE PARAMETERS KBCL
C   AND KBCR IN THE FOLLOWING WAY.
C
C           R = 1  (UNLESS KBCL=2 IN WHICH CASE R=2)
C           S = 1  (UNLESS KBCR=2 IN WHICH CASE S=2)
C           T = 0  (UNLESS KBCR=3 IN WHICH CASE T=1)
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KBCL, KBCR    INTEGER SCALARS (INPUT)
C                   INDICATE THE TYPE OF BOUNDARY CONDITIONS AT
C                   THE LEFT AND RIGHT ENDS OF AN INTERVAL.
C                   USES SAME CONVENTIONS AS BCTY IN HFFT2A.
C
C     EIGEN         REAL ARRAY OF SIZE N (OUTPUT)
C                   THE EIGENVALUES OF THE MATRIX SHOWN ABOVE.
C
C     N             INTEGER SCALAR (INPUT)
C                   THE ORDER OF THE MATRIX.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER KBCL, KBCR, N
      REAL
     *     EIGEN(N)
C
C     ... LOCAL VARIABLES
C
      REAL
     *     PI, FACTOR
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
      PI = 4.0E0*ATAN(1.0E0)
C
C  -----------
C  SELECT CASE
C  -----------
C
      GO TO (10,20,30), KBCL
   10 GO TO (100,200), KBCR
   20 GO TO (200,300), KBCR
   30 GO TO 400
C
C     CASE : DIRICHLET/DIRICHLET
C
  100 CONTINUE
      FACTOR = PI/REAL(N+1)
      DO 110 I=1,N
         EIGEN(I) = 2.0E0*COS(REAL(I)*FACTOR)
  110 CONTINUE
      GO TO 500
C
C     CASE : DIRICHLET/NEUMANN
C
  200 CONTINUE
      FACTOR = PI/REAL(2*N)
      DO 210 I=1,N
         EIGEN(I) = 2.0E0*COS(REAL(2*I-1)*FACTOR)
  210 CONTINUE
      GO TO 500
C
C     CASE : NEUMANN/NEUMANN
C
  300 CONTINUE
      FACTOR = PI/REAL(N-1)
      DO 310 I=1,N
         EIGEN(I) = 2.0E0*COS(REAL(I-1)*FACTOR)
  310 CONTINUE
      GO TO 500
C
C     CASE : PERIODIC
C
  400 CONTINUE
      FACTOR = 2.0E0*PI/REAL(N)
      DO 410 I=1,N
         K = I/2
         EIGEN(I) = 2.0E0*COS(REAL(K)*FACTOR)
  410 CONTINUE
      GO TO 500
C
C  ----
C  EXIT
C  ----
C
  500 CONTINUE
      RETURN
      END
      SUBROUTINE FDIS2 (NX, NY, H, COEFU, BCTY, BD1, BD2, BD3, BD4,
     *                  A, B, C, U, LDXU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FDIS2 COMPUTES A SECOND ORDER FINITE DIFFERENCE DISCRETIZATION
C   FOR A TWO-DIMENSIONAL RECTANGULAR DOMAIN
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     H, COEFU  REAL SCALARS (INPUT)
C               SEE HFFT2A.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE NY (INPUT)
C               SEE HFFT2A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE NX (INPUT)
C               SEE HFFT2A.
C
C     A, B, C   REAL SCALARS (OUTPUT)
C               GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL
C               (SCALED TO O(1))
C
C                        C  B  C
C                        B  A  B  U  =  RIGHT SIDE
C                        C  B  C
C
C     U         REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT)
C               ON INPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE PDE
C               EVALUATED AT THE (I,J)TH GRID POINT.
C               ON OUTPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE
C               DISCRETE PDE AT THE (I,J)TH GRID POINT.
C
C     LDXU      INTEGER SCALAR (INPUT)
C               SEE HFFT2A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY, LDXU
      REAL
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY),
     *     COEFU, H, A, B, C
C
C     ... LOCAL VARIABLES
C
      LOGICAL HAVED, HAVEN
      INTEGER I, J, NXM1, NYM1
      REAL
     *     BETA0, GAMMA0, DELTA0, DELTA1, H2, F
C
      COMMON /FD2COM/ GAMMA0, DELTA0, DELTA1
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
C
      HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR.
     *        (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP   ) .EQ. DRCH)
      HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR.
     *        (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP   ) .EQ. NEUM)
C
      H2 = H*H
      F = -H2*COEFU
      A = -(20.0E0 + 6.0E0*F)
      B =    4.0E0
      C =    1.0E0
      BETA0 = 6.0E0*H2
      GAMMA0 = -12.0E0*H
      DELTA0 = -10.0E0*H
      DELTA1 = -2.0E0*H
C
C
C  ---------------------------------
C  DISCRETIZE RIGHT HAND SIDE OF PDE
C  ---------------------------------
C
      ISTRT = 2
      ISTOP = NXM1
      IF (BCTY(LEFT  ) .NE. DRCH)  ISTRT = 1
      IF (BCTY(RIGH T) .EQ. NEUM)  ISTOP = NX
      JSTRT = 2
      JSTOP = NYM1
      IF (BCTY(BOTTOM) .NE. DRCH)  JSTRT = 1
      IF (BCTY(TOP   ) .EQ. NEUM)  JSTOP = NY
C
      DO 100 J=JSTRT,JSTOP
         DO 100 I=ISTRT,ISTOP
            U(I,J) =  BETA0*U(I,J)
  100 CONTINUE
C
C  ---------------------------------------
C  DISCRETIZE POINTS ON NEUMANN BOUNDARIES
C  ---------------------------------------
C
      IF (HAVEN)  CALL FD2N(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU)
C
C  ----------------------------------------------
C  ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES
C  ----------------------------------------------
C
      IF (HAVED) THEN
         CALL STORD2(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU)
         CALL FD2D(NX,NY,U,LDXU,BCTY,B,C,U)
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FD2D (NX, NY, UD, LDXU, BCTY, B, C, U)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FD2D ELIMINATES KNOWN TERMS FROM EQUATIONS CORRESPONDING TO POINTS
C   NEAR DIRICHLET BOUNDARIES OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     UD        REAL ARRAY OF SIZE LDXU BY NY (INPUT)
C               ENTRIES CORRESPONDING TO DIRICHLET POINTS CONTAIN
C               KNOWN VALUES OF THE SOLUTION.
C
C     LDXU      INTEGER SCALAR (INPUT)
C               THE LEADING DIMENSION OF THE ARRAYS UD AND U EXACTLY
C               AS DECLARED IN THE CALLING PROGRAM.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     B, C      REAL SCALARS (INPUT)
C               FINITE DIFFERENCE STENCIL COEFFICIENTS TO USE IN THE
C               ELIMINATION
C
C                             C B C
C                             B * B
C                             C B C
C
C     U         REAL ARRAY OF SIZE LDXU BY NY (INPUT/OUTPUT)
C               ON INPUT, ENTRIES CORRESPONDING TO POINTS WHERE THE
C               SOLUTION IS TO BE DETERMINED CONTAIN THE RIGHT HAND
C               SIDE OF A FINITE DIFFERENCE DISCRETIZATION.
C               ON EXIT, THESE ENTRIES ARE UPDATED SUCH THAT KNOWN
C               TERMS (DIRICHLET POINTS) ARE ELIMINATED FROM THE
C               LEFT HAND SIDE OF THE EQUATION.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY
      REAL
     *     UD(LDXU,NY), U(LDXU,NY), B, C
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY
      INTEGER I, J, NXM1, NXM2, NYM1, NYM2
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NXM2 = NX - 2
      NYM2 = NY - 2
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
C
C  -----------------------------------------------
C  ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES
C  -----------------------------------------------
C
      IL = 2
      IR = NXM1
      JL = 2
      JR = NYM1
      IF (BCTY(LEFT  ) .EQ. DRCH)  IL = 3
      IF (BCTY(RIGHT ) .EQ. DRCH)  IR = NXM2
      IF (BCTY(BOTTOM) .EQ. DRCH)  JL = 3
      IF (BCTY(TOP   ) .EQ. DRCH)  JR = NYM2
C
C     ... INTERIOR POINTS NEAR BOTTOM EDGE
C
      IF (BCTY(BOTTOM) .EQ. DRCH) THEN
         DO 505 I=IL,IR
            U(I,2) = U(I,2) - (C*UD(I-1,1)+B*UD(I,1)+C*UD(I+1,1))
  505    CONTINUE
      ENDIF
C
C     ... INTERIOR POINTS NEAR TOP EDGE
C
      IF (BCTY(TOP) .EQ. DRCH) THEN
         DO 515 I=IL,IR
            U(I,NYM1)= U(I,NYM1) -(C*UD(I-1,NY)+B*UD(I,NY)+C*UD(I+1,NY))
  515    CONTINUE
      ENDIF
C
C     ... INTERIOR POINTS NEAR LEFT EDGE
C
      IF (BCTY(LEFT) .EQ. DRCH) THEN
         DO 525 J=JL,JR
            U(2,J) = U(2,J) - (C*UD(1,J-1)+B*UD(1,J)+C*UD(1,J+1))
  525    CONTINUE
      ENDIF
C
C     ... INTERIOR POINTS NEAR RIGHT EDGE
C
      IF (BCTY(RIGHT) .EQ. DRCH) THEN
         DO 535 J=JL,JR
            U(NXM1,J)= U(NXM1,J) -(C*UD(NX,J-1)+B*UD(NX,J)+C*UD(NX,J+1))
  535    CONTINUE
      ENDIF
C
C     ... INTERIOR POINTS NEAR CORNERS
C
      IF ((BCTY(RIGHT) .EQ. DRCH) .AND. (BCTY(BOTTOM) .EQ. DRCH))
     *   U(NXM1,2) = U(NXM1,2) - B*(UD(NX,2) + UD(NXM1,1))
     *                         - C*(UD(NX,3) + UD(NX,1) + UD(NXM2,1))
C
      IF ((BCTY(BOTTOM) .EQ. DRCH) .AND. (BCTY(LEFT) .EQ. DRCH))
     *   U(2,2) = U(2,2) - B*(UD(1,2) + UD(2,1))
     *                   - C*(UD(1,3) + UD(1,1) + UD(3,1))
C
      IF ((BCTY(LEFT) .EQ. DRCH) .AND. (BCTY(TOP) .EQ. DRCH))
     *   U(2,NYM1) = U(2,NYM1) - B*(UD(1,NYM1) + UD(2,NY))
     *                         - C*(UD(1,NYM2) + UD(1,NY) + UD(3,NY))
C
      IF ((BCTY(TOP) .EQ. DRCH) .AND. (BCTY(RIGHT) .EQ. DRCH))
     *   U(NXM1,NYM1) = U(NXM1,NYM1) - B*(UD(NXM1,NY) + UD(NX,NYM1))
     *                         - C*(UD(NXM2,NY)+UD(NX,NY)+UD(NX,NYM2))
C
C     ... NEUMANN POINTS NEAR CORNERS ON BOTTOM EDGE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         IF (BCTY(LEFT) .EQ. DRCH)
     *      U(2,1) = U(2,1) - (B*UD(1,1) + 2.0E0*C*UD(1,2))
         IF (BCTY(RIGHT) .EQ. DRCH)
     *      U(NXM1,1) = U(NXM1,1) - (B*UD(NX,1) + 2.0E0*C*UD(NX,2))
      ENDIF
C
C     ... NEUMANN POINTS NEAR CORNERS ON TOP EDGE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         IF (BCTY(LEFT) .EQ. DRCH)
     *      U(2,NY) = U(2,NY) - (B*UD(1,NY) + 2.0E0*C*UD(1,NYM1))
         IF (BCTY(RIGHT) .EQ. DRCH)
     *      U(NXM1,NY)= U(NXM1,NY) - (B*UD(NX,NY) + 2.0E0*C*UD(NX,NYM1))
      ENDIF
C
C     ... NEUMANN POINTS NEAR CORNERS ON LEFT EDGE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         IF (BCTY(BOTTOM) .EQ. DRCH)
     *      U(1,2) = U(1,2) - (B*UD(1,1) + 2.0E0*C*UD(2,1))
         IF (BCTY(TOP) .EQ. DRCH)
     *      U(1,NYM1) = U(1,NYM1) - (B*UD(1,NY) + 2.0E0*C*UD(2,NY))
      ENDIF
C
C     ... NEUMANN POINTS NEAR CORNERS ON RIGHT EDGE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         IF (BCTY(BOTTOM) .EQ. DRCH)
     *      U(NX,2) = U(NX,2) - (B*UD(NX,1) + 2.0E0*C*UD(NXM1,1))
         IF (BCTY(TOP) .EQ. DRCH)
     *      U(NX,NYM1)= U(NX,NYM1) - (B*UD(NX,NY) + 2.0E0*C*UD(NXM1,NY))
      ENDIF
C
C     ... PERIODIC POINTS ON LEFT EDGE
C
      IF (PRDX) THEN
         IF (BCTY(BOTTOM) .EQ. DRCH)
     *      U(1,2) = U(1,2) - (C*UD(NXM1,1) + B*UD(1,1) + C*UD(2,1))
         IF (BCTY(TOP) .EQ. DRCH)
     *      U(1,NYM1)= U(1,NYM1) - (C*UD(NXM1,NY)+B*UD(1,NY)+C*UD(2,NY))
      ENDIF
C
C     ... PERIODIC POINTS ON BOTTOM EDGE
C
      IF (PRDY) THEN
         IF (BCTY(LEFT) .EQ. DRCH)
     *      U(2,1) = U(2,1) - (C*UD(1,NYM1) + B*UD(1,1) + C*UD(1,2))
         IF (BCTY(RIGHT) .EQ. DRCH)
     *      U(NXM1,1)= U(NXM1,1) - (C*UD(NX,NYM1)+B*UD(NX,1)+C*UD(NX,2))
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FD2N (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C  FD2N COMPUTES THE SECOND ORDER FINITE DIFFERENCE DISCRETIZATION
C  AT ALL BOUNDARY POINTS OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN
C  WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     BD1, BD3  INTEGER ARRAYS OF SIZE NY (INPUT)
C               SEE HFFT2A.
C
C     BD2, BD4  INTEGER ARRAYS OF SIZE NX (INPUT)
C               SEE HFFT2A.
C
C     U         REAL ARRAY OF SIZE LDXU BY NY (OUTPUT)
C               ON EXIT, ENTRIES OF U CORRESPONDING TO NEUMANN BOUNDARY
C               POINTS CONTAIN THE RIGHT HAND SIDE OF THE SECOND ORDER
C               FINITE DIFFERENCE DISCRETIZATION
C
C     LDXU      INTEGER SCALAR (INPUT)
C               SEE HFFT2A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY, LDXU
      REAL
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY)
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY
      INTEGER I, J, NXM1, NYM1
      REAL
     *     GAMMA0, DELTA0, DELTA1
C
      COMMON /FD2COM/ GAMMA0, DELTA0, DELTA1
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
C
C  -----------------------------
C  NEUMANN POINT DISCRETIZATIONS
C  -----------------------------
C
C     ... BOTTOM EDGE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         DO 305 I=2,NXM1
            U(I,1) = U(I,1) - GAMMA0*BD2(I)
  305    CONTINUE
      ENDIF
C
C     ... TOP EDGE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         DO 315 I=2,NXM1
            U(I,NY) = U(I,NY) + GAMMA0*BD4(I)
  315    CONTINUE
      ENDIF
C
C     ... LEFT EDGE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         DO 325 J=2,NYM1
            U(1,J) = U(1,J) - GAMMA0*BD3(J)
  325    CONTINUE
      ENDIF
C
C     ... RIGHT EDGE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         DO 335 J=2,NYM1
            U(NX,J) = U(NX,J) + GAMMA0*BD1(J)
  335    CONTINUE
      ENDIF
C
C     ... LOWER RIGHT CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *    U(NX,1) = U(NX,1)
     *              + DELTA0*BD1(1)
     *              + DELTA1*BD1(2)
     *              - DELTA0*BD2(NX)
     *              - DELTA1*BD2(NXM1)
C
C     ... LOWER LEFT CORNER
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM))
     *    U(1,1) = U(1,1)
     *             - DELTA0*BD2(1)
     *             - DELTA1*BD2(2)
     *             - DELTA0*BD3(1)
     *             - DELTA1*BD3(2)
C
C     ... UPPER LEFT CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM))
     *    U(1,NY) = U(1,NY)
     *              - DELTA0*BD3(NY)
     *              - DELTA1*BD3(NYM1)
     *              + DELTA0*BD4(1)
     *              + DELTA1*BD4(2)
C
C     ... UPPER RIGHT CORNER
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM))
     *    U(NX,NY) = U(NX,NY)
     *               + DELTA0*BD1(NY)
     *               + DELTA1*BD1(NYM1)
     *               + DELTA0*BD4(NX)
     *               + DELTA1*BD4(NXM1)
C
C
C  -----------------------------
C  PERIODIC POINT DISCRETIZATION
C  -----------------------------
C
C     ... LOWER LEFT CORNER (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(1,1) = U(1,1) - GAMMA0*BD2(1)
C
C     ... LOWER LEFT CORNER (NEUMANN/PERIODIC)
C
      IF (PRDY .AND. (BCTY(LEFT) .EQ. NEUM))
     *   U(1,1) = U(1,1) - GAMMA0*BD3(1)
C
C     ... UPPER LEFT CORNER (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM))
     *   U(1,NY) = U(1,NY) + GAMMA0*BD4(1)
C
C     ... LOWER RIGHT CORNER (NEUMANN/PERIODIC)
C
      IF (PRDY .AND. (BCTY(RIGHT) .EQ. NEUM))
     *   U(NX,1) = U(NX,1) + GAMMA0*BD1(1)
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FFTB (KBCL, KBCR, U, LDXU, IL, IR, JL, JR,  WSAVE)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FFTB PERFORMS M=JR-JL+1 REAL ONE-DIMENSIONAL INVERSE DISCRETE
C   FOURIER TRANSFORMS OF LENGTH N=IR-IL+1 (FOURIER SYNTHESIS).
C   THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KBCL, KBCR   INTEGER SCALARS (INPUT)
C                  GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND
C                  RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE
C                  THE SAME AS IN THE VECTOR BCTY OF HFFT2A.
C
C     U            REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT)
C                  ON INPUT, U CONTAINS THE SEQUENCES TO BE TRANSFORMED
C                  IN COLUMNS JL TO JR.  WITHIN EACH COLUMN THE
C                  SEQUENCES ARE STORED IN POSITIONS IL TO IR.
C                  ON OUTPUT THESE VALUES ARE REPLACED BY THEIR DISCRETE
C                  FOURIER TRANSFORMS.
C
C     LDXU         INTEGER SCALAR (INPUT)
C                  THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                  SPECIFIED IN THE CALLING PROGRAM.
C
C     IL, IR       INTEGER SCALARS (INPUT)
C     JL, JR       GIVES THE SUBSET OF THE ARRAY U WHICH CONTAINS THE
C                  SEQUENCES TO BE TRANSFORMED, I.E., POSITIONS I=
C                  IL,..,IR OF COLUMNS J=JL,..,JR.
C
C     WSAVE        REAL ARRAY OF SIZE 3*N + N/2 + 15 (INPUT)
C                  THE WORK ARRAY EXACTLY AS RETURNED FROM THE ROUTINE
C                  FFTI.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER KBCL, KBCR, IL, IR, JL, JR
      REAL
     *     U(LDXU,*), WSAVE(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER ICASE
      REAL
     *     SCALE
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
      N = IR - IL + 1
C
C  ---------------------------------------------
C  SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS
C  ---------------------------------------------
C
      ICASE = 2*(KBCL-1) + KBCR
      IF (KBCL .EQ. PRDC)  ICASE = 5
      GO TO (100,200,300,400,500), ICASE
C
C     CASE :  DIRICHLET/DIRICHLET
C
  100 CONTINUE
      SCALE = 0.50E0/REAL(N+1)
      DO 150 J=JL,JR
         CALL SINT(N,U(IL,J),WSAVE)
  150 CONTINUE
      GO TO 600
C
C     CASE :  DIRICHLET/NEUMANN
C
  200 CONTINUE
      SCALE = 0.250E0/REAL(N)
      DO 250 J=JL,JR
         CALL SINQB(N,U(IL,J),WSAVE)
  250 CONTINUE
      GO TO 600
C
C     CASE :  NEUMANN/DIRICHLET
C
  300 CONTINUE
      SCALE = 0.250E0/REAL(N)
      DO 350 J=JL,JR
         CALL COSQB(N,U(IL,J),WSAVE)
  350 CONTINUE
      GO TO 600
C
C     CASE :  NEUMANN/NEUMANN
C
  400 CONTINUE
      SCALE = 0.50E0/REAL(N-1)
      DO 450 J=JL,JR
         CALL COST(N,U(IL,J),WSAVE)
  450 CONTINUE
      GO TO 600
C
C     CASE :  PERIODIC
C
  500 CONTINUE
      SCALE = 1.0E0/REAL(N)
      DO 550 J=JL,JR
         CALL RFFTB(N,U(IL,J),WSAVE)
  550 CONTINUE
C
C  -----------------------------------
C  SCALE RESULT TO GET CORRECT INVERSE
C  -----------------------------------
C
  600 CONTINUE
      DO 650 J=JL,JR
         DO 650 I=IL,IR
            U(I,J) = SCALE*U(I,J)
  650 CONTINUE
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE FFTF (KBCL, KBCR, U, LDXU, IL, IR, JL, JR,  WSAVE)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FFTF PERFORMS M=JR-JL+1 REAL ONE-DIMENSIONAL DISCRETE FOURIER
C   TRANSFORMS OF LENGTH N=IR-IL+1 (FOURIER ANALYSIS).
C   THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KBCL, KBCR   INTEGER SCALARS (INPUT)
C                  GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND
C                  RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE
C                  THE SAME AS IN THE VECTOR BCTY OF HFFT2A.
C
C     U            REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT)
C                  ON INPUT, U CONTAINS THE SEQUENCES TO BE TRANSFORMED
C                  IN COLUMNS JL TO JR.  WITHIN EACH COLUMN THE
C                  SEQUENCES ARE STORED IN POSITIONS IL TO IR.
C                  ON OUTPUT THESE VALUES ARE REPLACED BY THEIR DISCRETE
C                  FOURIER TRANSFORMS.
C
C     LDXU         INTEGER SCALAR (INPUT)
C                  THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                  SPECIFIED IN THE CALLING PROGRAM.
C
C     IL, IR       INTEGER SCALARS (INPUT)
C     JL, JR       GIVES THE SUBSET OF THE ARRAY U WHICH CONTAINS THE
C                  SEQUENCES TO BE TRANSFORMED, I.E., POSITIONS I=
C                  IL,..,IR OF COLUMNS J=JL,..,JR.
C
C     WSAVE        REAL ARRAY OF SIZE 3*N + N/2 + 15 (INPUT)
C                  THE WORK ARRAY EXACTLY AS RETURNED FROM THE ROUTINE
C                  FFTI.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER KBCL, KBCR, IL, IR, JL, JR
      REAL
     *     U(LDXU,*), WSAVE(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER ICASE
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
      N = IR - IL + 1
C
C  ---------------------------------------------
C  SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS
C  ---------------------------------------------
C
      ICASE = 2*(KBCL-1) + KBCR
      IF (KBCL .EQ. PRDC)  ICASE = 5
      GO TO (100,200,300,400,500), ICASE
C
C     CASE :  DIRICHLET/DIRICHLET
C
  100 CONTINUE
      DO 150 J=JL,JR
         CALL SINT(N,U(IL,J),WSAVE)
  150 CONTINUE
      GO TO 600
C
C     CASE :  DIRICHLET/NEUMANN
C
  200 CONTINUE
      DO 250 J=JL,JR
         CALL SINQF(N,U(IL,J),WSAVE)
  250 CONTINUE
      GO TO 600
C
C     CASE :  NEUMANN/DIRICHLET
C
  300 CONTINUE
      DO 350 J=JL,JR
         CALL COSQF(N,U(IL,J),WSAVE)
  350 CONTINUE
      GO TO 600
C
C     CASE :  NEUMANN/NEUMANN
C
  400 CONTINUE
      DO 450 J=JL,JR
         CALL COST(N,U(IL,J),WSAVE)
  450 CONTINUE
      GO TO 600
C
C     CASE :  PERIODIC
C
  500 CONTINUE
      DO 550 J=JL,JR
         CALL RFFTF(N,U(IL,J),WSAVE)
  550 CONTINUE
C
C
C  ----
C  EXIT
C  ----
C
  600 CONTINUE
      RETURN
      END
      SUBROUTINE FFTI (KBCL, KBCR, N, WSAVE)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   FFTI INITIALIZES THE ONE-DIMENSIONAL FOURIER TRANSFORM SOFTWARE.
C   THE TYPE OF TRANSFORM SELECTED DEPENDS UPON THE BOUNDARY CONDITIONS.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KBCL, KBCR   INTEGER SCALARS (INPUT)
C                  GIVE THE TYPE OF BOUNDARY CONDITIONS AT THE LEFT AND
C                  RIGHT ENDPOINTS OF THE INTERVAL. POSSIBLE VALUES ARE
C                  THE SAME AS IN THE VECTOR BCTY OF HFFT2A.
C
C     N            INTEGER SCALAR (INPUT)
C                  THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.
C
C     WSAVE        REAL ARRAY OF SIZE 3*N + N/2 + 15 (OUTPUT)
C                  CONTAINS INFORMATION WHICH MUST BE PASSED TO THE
C                  SUBROUTINES FFTF AND FFTB WHEN ACTUALLY PERFORMING
C                  THE TRANSFORMS.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER KBCL, KBCR, N
      REAL
     *     WSAVE(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER ICASE
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------------------------------------
C  SELECT TRANSFORM BASED ON BOUNDARY CONDITIONS
C  ---------------------------------------------
C
      ICASE = 2*(KBCL-1) + KBCR
      IF (KBCL .EQ. PRDC)  ICASE = 5
      GO TO (110,120,130,140,150), ICASE
C
C     CASE :  DIRICHLET/DIRICHLET
C
  110 CONTINUE
      CALL SINTI(N,WSAVE)
      GO TO 200
C
C     CASE :  DIRICHLET/NEUMANN
C
  120 CONTINUE
      CALL SINQI(N,WSAVE)
      GO TO 200
C
C     CASE :  NEUMANN/DIRICHLET
C
  130 CONTINUE
      CALL COSQI(N,WSAVE)
      GO TO 200
C
C     CASE :  NEUMANN/NEUMANN
C
  140 CONTINUE
      CALL COSTI(N,WSAVE)
      GO TO 200
C
C     CASE :  PERIODIC
C
  150 CONTINUE
      CALL RFFTI(N,WSAVE)
      GO TO 200
C
C
C  ----
C  EXIT
C  ----
C
  200 CONTINUE
      RETURN
      END
      SUBROUTINE HDIS2 (NX, NY, H, COEFU, GH, LMXGH, BCTY,
     *                  BD1, BD2, BD3, BD4, A, B, C, U, LMXU, WORK)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   HDIS2 COMPUTES A FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION
C   FOR A TWO-DIMENSIONAL RECTANGULAR DOMAIN
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     H, COEFU  REAL SCALARS (INPUT)
C               SEE HFFT2A.
C
C     GH        REAL ARRAY OF SIZE LMXGH+1 BY NY+1 (INPUT)
C               SEE HFFT2A.
C
C     LMXGH     INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF FIRST DIMENSION OF ARRAY GH.  MUST BE
C               LDXGH-1 (LDXGH IS DEFINED IN HFFT2A).
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE NY (INPUT)
C               SEE HFFT2A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE NX (INPUT)
C               SEE HFFT2A.
C
C     A, B, C   REAL SCALARS (OUTPUT)
C               GIVES VALUES IN THE BASIC FINITE DIFFERENCE STENCIL
C               (SCALED TO O(1))
C
C                        C  B  C
C                        B  A  B  U  =  RIGHT SIDE
C                        C  B  C
C
C     U         REAL ARRAY OF SIZE LMXU+1 BY NY+2 (INPUT/OUTPUT)
C               ON INPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE PDE
C               EVALUATED AT THE (I,J)TH GRID POINT.
C               ON OUTPUT, U(I,J) IS THE RIGHT HAND SIDE OF THE
C               DISCRETE PDE AT THE (I,J)TH GRID POINT.
C
C     LMXU      INTEGER SCALAR (INPUT)
C               UPPER LIMIT OF FIRST DIMENSION OF ARRAY U.  MUST BE
C               LDXU-1 (LDXU IS DEFINED IN HFFT2A).
C
C     WORK      REAL ARRAY OF SIZE NX+1 BY 2
C               WORKING STORAGE FOR HDIS2.
C
C
C     ******************************************************************
C     *                                                                *
C     *   NOTE -- THE ARRAYS U AND GH ARE INDEXED DIFFERENTLY IN       *
C     *           THIS ROUTINE:  U(0:LMXU,0:*) AND GH(0:LMXGH,0:*)     *
C     *                                                                *
C     ******************************************************************
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY, LMXGH, LMXU
      REAL
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX),
     *     GH(0:LMXGH,0:*), U(0:LMXU,0:*), WORK(0:NX,0:1),
     *     COEFU, H, A, B, C
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY, HELMHZ, HAVED, HAVEN
      INTEGER I, J, JM1, NXM1, NYM1, C0, CM1
      REAL
     *     BETA0, BETA1, BETA2, DELTA0, DELTA1, DELTA2,
     *     DELTA3, GAMMA0, GAMMA1, H2, F, F2
C
      COMMON /HD2COM/ GAMMA0, GAMMA1, DELTA0, DELTA1, DELTA2, DELTA3
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      LDXU = LMXU + 1
      NXM1 = NX - 1
      NYM1 = NY - 1
C
      HELMHZ = COEFU .NE. 0.0E0
      HAVED = (BCTY(RIGHT) .EQ. DRCH) .OR. (BCTY(BOTTOM) .EQ. DRCH) .OR.
     *        (BCTY(LEFT ) .EQ. DRCH) .OR. (BCTY(TOP   ) .EQ. DRCH)
      HAVEN = (BCTY(RIGHT) .EQ. NEUM) .OR. (BCTY(BOTTOM) .EQ. NEUM) .OR.
     *        (BCTY(LEFT ) .EQ. NEUM) .OR. (BCTY(TOP   ) .EQ. NEUM)
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
      H2 = H*H
      F = -H2*COEFU
      F2 = F*F
      A = -(480.0E0 + 118.0E0*F + 5.0E0*F2)/24.0E0
      B =  (192.0E0 -   8.0E0*F +       F2)/48.0E0
      C =  ( 48.0E0 -   5.0E0*F)/48.0E0
      BETA0 = (48.0E0 + 5.0E0*F)/24.0E0
      BETA1 = -F/48.0E0
      BETA2 = 1.0E0
      GAMMA0 = -(12.0E0 + 13.0E0*F/12.0E0)
      GAMMA1 = -F/12.0E0
      DELTA2 = 2.0E0 + F/48.0E0
      DELTA3 = ((6.0E0 + F)/3.0E0 - 4.0E0*DELTA2)/18.0E0
      DELTA1 = 8.0E0*DELTA2 + 33.0E0*DELTA3 - (10.0E0 + F)*BETA2
      DELTA0 = -2.0E0*(BETA0 + 2.0E0*BETA1) - (DELTA2 + 4.0E0*DELTA3)
     *            - (4.0E0 + F*0.50E0)*BETA2
C
      BETA0 = H2*BETA0
      BETA1 = H2*BETA1
      BETA2 = H2*BETA2
      GAMMA0 = H*GAMMA0
      GAMMA1 = H*GAMMA1
      DELTA0 = H*DELTA0
      DELTA1 = H*DELTA1
      DELTA2 = H*DELTA2
      DELTA3 = H*DELTA3
C
C
C  -----------------------------
C  SHIFT VALUES OF G STORED IN U
C  -----------------------------
C
      DO 50 J=NY,1,-1
         DO 50 I=NX,1,-1
            U(I,J) = U(I-1,J-1)
   50 CONTINUE
C
C
C  -----------------------------------------
C  REFLECT FUNCTIONS G AND GH OUTSIDE DOMAIN
C  -----------------------------------------
C
      IF (HELMHZ)  CALL REFL2(1,NX,NY,PRDX,PRDY,U,LMXU)
      CALL REFL2(0,NXM1,NYM1,PRDX,PRDY,GH,LMXGH)
C
C
C  ----------------------------
C  DISCRETIZE RIGHT SIDE OF PDE
C  ----------------------------
C
      ISTRT = 2
      ISTOP = NXM1
      IF (BCTY(LEFT  ) .NE. DRCH)  ISTRT = 1
      IF (BCTY(RIGHT ) .EQ. NEUM)  ISTOP = NX
      JSTRT = 2
      JSTOP = NYM1
      IF (BCTY(BOTTOM) .NE. DRCH)  JSTRT = 1
      IF (BCTY(TOP   ) .EQ. NEUM)  JSTOP = NY
C
      IF (HELMHZ) THEN
C
C        CASE :  HELMHOLTZ EQUATION
C
         C0 = 0
         JM1 = JSTRT - 1
         DO 60 I=0,NX
            WORK(I,C0) = U(I,JM1)
   60    CONTINUE
         DO 100 J=JSTRT,JSTOP
            CM1 = C0
            C0  = 1 - CM1
            DO 80 I=0,NX
               WORK(I,C0) = U(I,J)
   80       CONTINUE
            DO 100 I=ISTRT,ISTOP
               U(I,J) =   BETA0*U(I,J)
     *                  + BETA1*( U(I+1,J) + U(I,J+1)
     *                          + WORK(I,CM1) + WORK(I-1,C0) )
     *                  + BETA2*( GH(I,J) + GH(I-1,J) +
     *                            GH(I-1,J-1) + GH(I,J-1) )
  100    CONTINUE
C
      ELSE
C
C        CASE :  POISSON EQUATION
C
         DO 200 J=JSTRT,JSTOP
            DO 200 I=ISTRT,ISTOP
               U(I,J) =  BETA0*U(I,J)
     *                 + BETA2*( GH(I,J) + GH(I-1,J) +
     *                           GH(I-1,J-1) + GH(I,J-1) )
  200    CONTINUE
C
      ENDIF
C
C
C  -------------------------
C  REMOVE SHIFT FROM ARRAY U
C  -------------------------
C
      DO 250 J=0,NYM1
         DO 250 I=0,NXM1
            U(I,J) = U(I+1,J+1)
  250 CONTINUE
C
C
C  ---------------------------------------
C  DISCRETIZE POINTS ON NEUMANN BOUNDARIES
C  ---------------------------------------
C
      IF (HAVEN)  CALL HD2N(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU)
C
C
C  -----------------------------------------------
C  ADJUST POINTS ADJACENT TO DIRICHLET BOUNDARIES
C  -----------------------------------------------
C
      IF (HAVED) THEN
         CALL STORD2(NX,NY,BCTY,BD1,BD2,BD3,BD4,U,LDXU)
         CALL FD2D(NX,NY,U,LDXU,BCTY,B,C,U)
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE HD2N (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C  HD2N COMPUTES THE FOURTH ORDER FINITE DIFFERENCE DISCRETIZATION
C  AT ALL BOUNDARY POINTS OF A TWO-DIMENSIONAL RECTANGULAR DOMAIN
C  WHERE NEUMANN BOUNDARY CONDITIONS HAVE BEEN SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     BD1, BD3  INTEGER ARRAYS OF SIZE NY (INPUT)
C               SEE HFFT2A.
C
C     BD2, BD4  INTEGER ARRAYS OF SIZE NX (INPUT)
C               SEE HFFT2A.
C
C     U         REAL ARRAY OF SIZE LDXU BY NY (OUTPUT)
C               ON EXIT, ENTRIES CORRESPONDING TO NEUMANN BOUNDARY
C               POINTS CONTAIN THE RIGHT HAND SIDE OF THE FINITE
C               DIFFERENCE DISCRETIZTION
C
C     LDXU      INTEGER SCALAR (INPUT)
C               SEE HFFT2A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), NX, NY, LDXU
      REAL
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX),
     *     U(LDXU,NY)
C
C     ... LOCAL VARIABLES
C
      LOGICAL PRDX, PRDY
      INTEGER I, J, NXM1, NYM1
      REAL
     *       DELTA0, DELTA1, DELTA2, DELTA3, GAMMA0, GAMMA1
C
      COMMON /HD2COM/ GAMMA0, GAMMA1, DELTA0, DELTA1, DELTA2, DELTA3
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXM1 = NX - 1
      NYM1 = NY - 1
      NXM2 = NX - 2
      NYM2 = NY - 2
      NXM3 = NX - 3
      NYM3 = NY - 3
      PRDX = BCTY(RIGHT ) .EQ. PRDC
      PRDY = BCTY(BOTTOM) .EQ. PRDC
C
C
C  ----------------------------
C  NEUMANN POINT DISCRETIZATION
C  ----------------------------
C
C     ... BOTTOM EDGE
C
      IF (BCTY(BOTTOM) .EQ. NEUM) THEN
         DO 305 I=2,NXM1
            U(I,1) =  U(I,1)
     *                - GAMMA0*BD2(I)
     *                - GAMMA1*(BD2(I-1) + BD2(I+1))
  305    CONTINUE
      ENDIF
C
C     ... TOP EDGE
C
      IF (BCTY(TOP) .EQ. NEUM) THEN
         DO 315 I=2,NXM1
            U(I,NY) =  U(I,NY)
     *                 + GAMMA0*BD4(I)
     *                 + GAMMA1*(BD4(I-1)+BD4(I+1))
  315    CONTINUE
      ENDIF
C
C     ... LEFT EDGE
C
      IF (BCTY(LEFT) .EQ. NEUM) THEN
         DO 325 J=2,NYM1
            U(1,J) =  U(1,J)
     *                - GAMMA0*BD3(J)
     *                - GAMMA1*(BD3(J-1) + BD3(J+1))
  325    CONTINUE
      ENDIF
C
C     ... RIGHT EDGE
C
      IF (BCTY(RIGHT) .EQ. NEUM) THEN
         DO 335 J=2,NYM1
            U(NX,J) =  U(NX,J)
     *                 + GAMMA0*BD1(J)
     *                 + GAMMA1*(BD1(J-1) + BD1(J+1))
  335    CONTINUE
      ENDIF
C
C     ... LOWER RIGHT CORNER
C
      IF ((BCTY(RIGHT) .EQ. NEUM) .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(NX,1) =   U(NX,1)
     *               + DELTA0*BD1(1)
     *               + DELTA1*BD1(2)
     *               + DELTA2*BD1(3)
     *               + DELTA3*BD1(4)
     *               - DELTA0*BD2(NX)
     *               - DELTA1*BD2(NXM1)
     *               - DELTA2*BD2(NXM2)
     *               - DELTA3*BD2(NXM3)
C
C     ... LOWER LEFT CORNER
C
      IF ((BCTY(BOTTOM) .EQ. NEUM) .AND. (BCTY(LEFT) .EQ. NEUM))
     *    U(1,1) =   U(1,1)
     *               - DELTA0*BD2(1)
     *               - DELTA1*BD2(2)
     *               - DELTA2*BD2(3)
     *               - DELTA3*BD2(4)
     *               - DELTA0*BD3(1)
     *               - DELTA1*BD3(2)
     *               - DELTA2*BD3(3)
     *               - DELTA3*BD3(4)
C
C     ... UPPER LEFT CORNER
C
      IF ((BCTY(LEFT) .EQ. NEUM) .AND. (BCTY(TOP) .EQ. NEUM))
     *   U(1,NY) =   U(1,NY)
     *               - DELTA0*BD3(NY)
     *               - DELTA1*BD3(NYM1)
     *               - DELTA2*BD3(NYM2)
     *               - DELTA3*BD3(NYM3)
     *               + DELTA0*BD4(1)
     *               + DELTA1*BD4(2)
     *               + DELTA2*BD4(3)
     *               + DELTA3*BD4(4)
C
C     ... UPPER RIGHT CORNER
C
      IF ((BCTY(TOP) .EQ. NEUM) .AND. (BCTY(RIGHT) .EQ. NEUM))
     *   U(NX,NY) =   U(NX,NY)
     *                + DELTA0*BD1(NY)
     *                + DELTA1*BD1(NYM1)
     *                + DELTA2*BD1(NYM2)
     *                + DELTA3*BD1(NYM3)
     *                + DELTA0*BD4(NX)
     *                + DELTA1*BD4(NXM1)
     *                + DELTA2*BD4(NXM2)
     *                + DELTA3*BD4(NXM3)
C
C
      IF (.NOT. (PRDX .OR. PRDY))  GO TO 999
C
C
C  -------------------------------------
C  NEUMANN/PERIODIC POINT DISCRETIZATION
C  -------------------------------------
C
C     ... LOWER LEFT CORNER (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(BOTTOM) .EQ. NEUM))
     *   U(1,1) =   U(1,1)
     *              - GAMMA0*BD2(1)
     *              - GAMMA1*(BD2(2) + BD2(NXM1))
C
C     ... LOWER LEFT CORNER (NEUMANN/PERIODIC)
C
      IF (PRDY .AND. (BCTY(LEFT) .EQ. NEUM))
     *   U(1,1) =   U(1,1)
     *              - GAMMA0*BD3(1)
     *              - GAMMA1*(BD3(2) + BD3(NYM1))
C
C     ... UPPER LEFT CORNER (PERIODIC/NEUMANN)
C
      IF (PRDX .AND. (BCTY(TOP) .EQ. NEUM))
     *   U(1,NY) =   U(1,NY)
     *               + GAMMA0*BD4(1)
     *               + GAMMA1*(BD4(2) + BD4(NXM1))
C
C     ... LOWER RIGHT CORNER (NEUMANN/PERIODIC)
C
      IF (PRDY .AND. (BCTY(RIGHT) .EQ. NEUM))
     *   U(NX,1) =   U(NX,1)
     *               + GAMMA0*BD1(1)
     *               + GAMMA1*(BD1(2) + BD1(NYM1))
C
C  ----
C  EXIT
C  ----
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE MDALG2 (A, B, C, BCTY, U, LDXU, IL, IR, JL, JR, WORK)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C
C    DECEMBER 1985  (REVISED APRIL 1987)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   MDALG2 IMPLEMENTS THE MATRIX DECOMPOSITION ALGORITHM (FOURIER
C   METHOD FOR A NINE-POINT DIFFERENCE OPERATOR ON A TWO-DIMENSIONAL
C   RECTANGULAR GRID.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     A, B, C      REAL SCALARS (INPUT)
C                  GIVE THE BASIC FINITE DIFFERENCE STENCIL THAT IS
C                  USED TO APPROXIMATE THE PDE.
C
C                         C  B  C
C                         B  A  B  U  = RIGHT HAND SIDE
C                         C  B  C
C
C     BCTY         INTEGER ARRAY OF SIZE 4 (INPUT)
C                  SEE HFFT2A.
C
C     U            REAL ARRAY OF SIZE LDXU BY JR (INPUT/OUTPUT)
C                  ON INPUT, U CONTAINS THE RIGHT HAND SIDE OF THE
C                  DISCRETE APPROXIMATION TO THE PDE FOR EACH POINT
C                  POINT AT WHICH THE SOLUTION IS TO BE DETERMINED,
C                  I.E., (I,J), I=IL,..,IR, J=JL,..,JR.
C                  ON OUTPUT THESE VALUES ARE REPLACED BY THE COMPUTED
C                  SOLUTION.
C
C     LDXU         INTEGER SCALAR (INPUT)
C                  THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                  SPECIFIED IN THE CALLING PROGRAM.
C
C     IL, IR,      INTEGER SCALARS (INPUT)
C     JL, JR       GIVES THE SUBSET OF GRID POINTS AT WHICH THE
C                  SOLUTION IS TO BE DETERMINED, I.E., THAT SET
C                  OF INDICES (I,J) WITH I=IL,..,IR AND J=JL,..,JR.
C
C     WORK         REAL ARRAY OF SIZE 5*N + 5*M + N/2 + 15 (WORKSPACE)
C                  HERE N=IR-IL+1 AND M=JR-JL+1. THE LENGTH OF THIS
C                  ARRAY MAY BE REDUCED BY M WHEN THE SOLUTION IS
C                  NOT PERIODIC IN Y.  IT MAY BE REDUCED BY 4*M IF
C                  THE COEFFICIENT OF U IN THE PDE IS .LE. 0.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), LDXU, IL, IR, JL, JR
      REAL
     *     A, B, C, U(LDXU,*), WORK(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER N, M, LOCEWK, LOCFWK, LOCTWK, TOTAL
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  --------------
C  INITIALIZATION
C  --------------
C
      N = IR - IL + 1
      M = JR - JL + 1
      LOC EWK = 1
      LOC FWK = LOC EWK + N
      LOC TWK = LOC FWK + 3*N + N/2 + 15
      TOTAL   = LOC TWK + N + 5*M - 1
C
      CALL FFTI(BCTY(LEFT),BCTY(RIGHT),N,WORK(LOCFWK))
C
C
C  ------------------
C  FORWARD TRANSFORMS
C  ------------------
C
      CALL FFTF(BCTY(LEFT),BCTY(RIGHT),U,LDXU,IL,IR,JL,JR,WORK(LOCFWK))
C
C
C  ------------------
C  TRIDIAGONAL SOLVES
C  ------------------
C
      CALL TRISOL(A,B,C,BCTY,U,LDXU,IL,IR,JL,JR,WORK(LOCEWK),
     *            WORK(LOCTWK))
C
C
C  -------------------
C  BACKWARD TRANSFORMS
C  -------------------
C
      CALL FFTB(BCTY(LEFT),BCTY(RIGHT),U,LDXU,IL,IR,JL,JR,WORK(LOCFWK))
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE REFL2 (KDIST, NX, NY, PRDX, PRDY, G, LMXG)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   REFL2 EXTENDS A TWO-DIMENSIONAL GRID FUNCTION SO THAT IT IS
C   DEFINED ONE GRID LINE OUTSIDE ITS ORGINAL DOMAIN.  THE EXTENTION
C   IS DONE BY REFLECTION THROUGH THE BOUNDARY EXCEPT WHERE
C   PERIODICITY IS SPECIFIED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     KDIST   INTEGER SCALAR (INPUT)
C             INDICATES HOW THE GRID FUNCTION IS DEFINED.
C             POSSIBLE VALUES ARE
C
C                1 == FUNCTION DEFINED AT CENTER OF GRID SQUARES
C                2 == FUNCTION DEFINED AT GRID POINTS
C
C     NX      INTEGER SCALAR (INPUT)
C             THE NUMBER OF GRID FUNCTION VALUES IN THE X DIRECTION.
C
C     NY      INTEGER SCALAR (INPUT)
C             THE NUMBER OF GRID FUNCTION VALUES IN THE Y DIRECTION.
C
C     PRDX    LOGICAL SCALAR (INPUT)
C             .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY
C             IN X.
C
C     PRDY    LOGICAL SCALAR (INPUT)
C             .TRUE. IF THE SOLUTION IS TO BE EXTENDED PERIODICALLY
C             IN Y.
C
C     G       REAL ARRAY OF SIZE LMXG+1 BY NY+1 (INPUT/OUTPUT)
C             ON INPUT, THE GRID FUNCTION OCCUPIES G(I,J), I=1,..,NX,
C             J=1,..,NY.
C             ON OUTPUT, THE FUNCTION HAS BEEN EXTENDED TO INCLUDE THE
C             POINTS G(0,J), G(NX+1,J), G(I,0), G(I,NY+1), I=0,..,NX+1,
C             J=0,..,NY+1.
C
C     LMXG    INTEGER SCALAR (INPUT)
C             THE UPPER LIMIT OF THE FIRST DIMENSION OF THE ARRAY G.
C             MUST BE SET TO LDXU-1, WHERE LDXU IS THE ACTUAL LENGTH OF
C             THE FIRST DIMENSION OF G AS DECLARED IN THE CALLING
C             PROGRAM.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      LOGICAL PRDX, PRDY
      INTEGER KDIST, NX, NY, LMXG
      REAL
     *     G(0:LMXG,0:*)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      NXP1 = NX + 1
      NYP1 = NY + 1
C
      I0 = 1 + KDIST
      J0 = 1 + KDIST
      I1 = NX - KDIST
      J1 = NY - KDIST
C
C
C  -----------
C  REFLECTIONS
C  -----------
C
C     ... IN Y DIRECTION
C
      DO 10 I=1,NX
         G(I,0) = G(I,J0)
         G(I,NYP1) = G(I,J1)
   10 CONTINUE
C
C     ... IN X DIRECTION
C
      DO 20 J=0,NYP1
         G(0,J) = G(I0,J)
         G(NXP1,J) = G(I1,J)
   20 CONTINUE
C
C
C  -------------------
C  PERIODIC EXTENSIONS
C  -------------------
C
C     ... IN X DIRECTION
C
      IF (PRDX) THEN
         DO 30 J=0,NYP1
            G(0,J) = G(NXP1,J)
   30     CONTINUE
      ENDIF
C
C     ... IN Y DIRECTION
C
      IF (PRDY) THEN
         DO 40 I=0,NXP1
            G(I,0) = G(I,NYP1)
   40    CONTINUE
      ENDIF
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE STORD2 (NX, NY, BCTY, BD1, BD2, BD3, BD4, U, LDXU)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   STORD2 STORES GIVEN DIRICHLET BOUNDARY DATA IN THE SOLUTION ARRAY U.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     NX, NY    INTEGER SCALARS (INPUT)
C               SEE HFFT2A.
C
C     BCTY      INTEGER ARRAY OF SIZE 4 (INPUT)
C               SEE HFFT2A.
C
C     BD1, BD3  REAL ARRAYS OF SIZE NY (INPUT)
C               SEE HFFT2A.
C
C     BD2, BD4  REAL ARRAYS OF SIZE NX (INPUT)
C               SEE HFFT2A.
C
C     U        REAL ARRAY OF SIZE LDXU BY NY (OUTPUT)
C              ON OUTPUT, ENTRIES CORRESPONDING TO DIRICHLET BOUNDARY
C              POINTS CONTAIN THE KNOWN VALUES OF THE SOLUTION.
C
C     LDXU     INTEGER SCALAR (INPUT)
C              SEE HFFT2A.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER NX, NY, BCTY(4), LDXU
      REAL
     *     BD1(NY), BD2(NX), BD3(NY), BD4(NX), U(LDXU,NY)
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ----------------------
C  HANDLE DIRICHLET SIDES
C  ----------------------
C
C     ... RIGHT SIDE
C
      IF (BCTY(RIGHT) .EQ. DRCH) THEN
         DO 210 J = 1,NY
            U(NX,J) = BD1(J)
  210    CONTINUE
      ENDIF
C
C     ... BOTTOM SIDE
C
      IF (BCTY(BOTTOM) .EQ. DRCH) THEN
         DO 220 I=1,NX
            U(I,1) = BD2(I)
  220    CONTINUE
      ENDIF
C
C     ... LEFT SIDE
C
      IF (BCTY(LEFT) .EQ. DRCH) THEN
         DO 230 J=1,NY
            U(1,J) = BD3(J)
  230    CONTINUE
      ENDIF
C
C     ... TOP SIDE
C
      IF (BCTY(TOP) .EQ. DRCH) THEN
         DO 240 I=1,NX
            U(I,NY) = BD4(I)
  240    CONTINUE
      ENDIF
C
C  ------------------------
C  HANDLE DIRICHLET CORNERS
C  ------------------------
C
      IF ((BCTY(TOP) .EQ. DRCH) .AND. (BCTY(RIGHT) .EQ. DRCH))
     *   U(NX,NY) = 0.50E0*( BD4(NX) + BD1(NY) )
      IF ((BCTY(RIGHT) .EQ. DRCH) .AND. (BCTY(BOTTOM) .EQ. DRCH))
     *   U(NX,1) = 0.50E0*( BD1(1) + BD2(NX) )
      IF ((BCTY(BOTTOM) .EQ. DRCH) .AND. (BCTY(LEFT) .EQ. DRCH))
     *   U(1,1) = 0.50E0*( BD2(1) + BD3(1) )
      IF ((BCTY(LEFT) .EQ. DRCH) .AND. (BCTY(TOP) .EQ. DRCH))
     *   U(1,NY) = 0.50E0*( BD3(NY) + BD4(1) )
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE TRISOL (A, B, C, BCTY, U, LDXU, IL, IR, JL, JR,
     *                   EIGEN, WORK)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    JOAN M. BAUMANN
C    NATIONAL BUREAU OF STANDARDS
C
C    DECEMBER 1985   (REVISED APRIL 1987)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   TRISOL SOLVES THE SET OF TRIDIAGONAL LINEAR SYSTEMS OF EQUATIONS
C   OBTAINED FROM THE MATRIX DECOMPOSITION ALGORITHM (FOURIER METHOD).
C
C   N TRIDIAGONAL SYSTEMS OF ORDER M ARE SOLVED, WHERE N=IR-IL+1
C   AND M=JR-JL+1.  EACH SYSTEM IS SYMMETRIC WITH CONSTANT DIAGONALS
C   (THE TOP LEFT AND BOTTOM RIGHT ELEMENTS MAY BE MULTIPLIED BY 1/2,
C   DEPENDING UPON THE BOUNDARY CONDITIONS).  THE MATRIX COEFFICIENTS
C   DEPEND UPON THE FINITE DIFFERENCE STENCIL COEFFICIENTS A, B, C, AND
C   THE BOUNDARY CONDITIONS GIVEN BY BCTY.  THE RIGHT HAND SIDES OF THE
C   SYSTEMS ARE STORED IN THE ROWS OF U.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     A, B, C     REAL SCALARS (INPUT)
C                 SEE MDALG2.
C
C     BCTY        INTEGER ARRAY OF SIZE 4 (INPUT)
C                 SEE HFFT2A.
C
C     U           REAL ARRAY OF SIZE LDXU BY M (INPUT/OUTPUT)
C                 ON INPUT THE RIGHT HAND SIDES OF THE LINEAR SYSTEMS
C                 TO BE SOLVED ARE STORED IN THE ROWS OF U, I.E., THE
C                 ITH RIGHT HAND SIDE IS IN U(I,J), J=JL,..,JR, FOR
C                 I=IL,..,IR.  ON OUTPUT THESE ARE REPLACED BY THE
C                 SOLUTIONS OF THE LINEAR SYSTEMS.
C
C     LDXU        INTEGER SCALAR (INPUT)
C                 THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                 SPECIFIED IN THE CALLING PROGRAM.
C
C     IL, IR,     INTEGER SCALARS (INPUT)
C     JL, JR      SPECIFY THE SUBARRAY OF U IN WHICH THE RIGHT HAND
C                 SIDES OF THE SYSTEMS ARE STORED.  SEE U ABOVE.
C
C     EIGEN       REAL ARRAY OF SIZE N (WORKSPACE)
C
C     WORK        REAL ARRAY OF SIZE 5*M + N. THIS LENGTH MAY BE REDUCED
C                 BY 4*M IF THE COEFFICIENT OF U IN THE PDE IS .LE. 0.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER BCTY(4), LDXU, IL, IR, JL, JR
      REAL
     *     A, B, C, U(LDXU,*), EIGEN(*), WORK(*)
C
C     ... LOCAL VARIABLES
C
      INTEGER N, M
      REAL
     *     MU, NU
C
C     ... LOCAL CONSTANTS
C
      INTEGER DRCH, NEUM, PRDC, LEFT, RIGHT, TOP, BOTTOM
      PARAMETER (DRCH=1, NEUM =2, PRDC=3,
     *           LEFT=3, RIGHT=1, TOP =4, BOTTOM=2)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      N = IR - IL + 1
      M = JR - JL + 1
C
      MU = 1.0E0
      NU = 1.0E0
      IF (BCTY(BOTTOM) .EQ. NEUM)  MU = 0.5E0
      IF (BCTY(TOP   ) .EQ. NEUM)  NU = 0.5E0
      CALL EVDISC(BCTY(LEFT),BCTY(RIGHT),EIGEN,N)
C
C
C  -------------------------
C  SOLVE TRIDIAGONAL SYSTEMS
C  -------------------------
C
C     ... CALCULATE THE CONSTANT DIAGONALS AND OFF-DIAGONALS OF THE
C         SYSTEMS TO BE SOLVED, STORING THEM IN THE ARRAYS EIGEN
C         AND WORK, RESPECTIVELY
C
      DO 100 K=1,N
         WORK(K)  = B + C*EIGEN(K)
         EIGEN(K) = A + B*EIGEN(K)
  100 CONTINUE
C
C     ... SOLVE SYSTEMS
C
      CALL TRSALL (EIGEN, WORK, U, LDXU, MU, NU, IL, IR, JL, JR,
     *             BCTY(BOTTOM).EQ.PRDC, WORK(N+1) )
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE TRSALL (DIAG, OFFDG, U, LDXU, MU, NU, IL, IR, JL, JR,
     *                   PRDC, WORK )
C
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    JOAN M. BAUMANN
C    NATIONAL BUREAU OF STANDARDS
C
C    DECEMBER 1985   (REVISED APRIL 1987)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   TRSALL SOLVES N TRIDIAGONAL SYSTEMS OF LINEAR EQUATIONS OF SIZE
C   M, WHERE N=IR=IL+1 AND M=JR-JL+1.  ALL OF THE SYSTEMS AU=G MUST
C   HAVE MATRICES A OF ONE OF THE FOLLOWING FORMS.
C
C                      :--                      --:
C                      :  MU*A  B                 :
C                      :     B  A  B              :
C                      :        B  A  B           :
C               A  =   :          .  .  .         :
C                      :            .  .  .       :
C                      :              B  A  B     :
C                      :                 B  A*NU  :
C                      :--                      --:
C
C   AND MU AND NU HAVING THE VALUES 0.5 OR 1.0, OR
C
C                      :--                      --:
C                      :     A  B           B     :
C                      :     B  A  B              :
C                      :        B  A  B           :
C               A  =   :          .  .  .         :
C                      :            .  .  .       :
C                      :              B  A  B     :
C                      :     B           B  A     :
C                      :--                      --:
C
C
C   ALL SYSTEMS MUST BE OF THE SAME FORM, ALTHOUGH THE SCALARS A AND B
C   MAY BE DIFFERENT FOR EACH SYSTEM.
C
C   ONE OF TWO ALGORITHMS IS USED DEPENDING UPON THE VALUES OF A AND B.
C   IF ABS(A) .GE. ABS(2*B) THEN AN EXTENSION OF AN ALGORITHM DUE TO EVA
C   IS USED; OTHERWISE GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING FOR
C   GENERAL TRIDIAGONAL MATRICES IS USED.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     DIAG        REAL ARRAY OF SIZE N (INPUT)
C                 CONSTANT DIAGONALS FOR THE SYSTEMS TO BE SOLVED.
C                 THE DIAGONAL ELEMENT A FOR THE I-TH SYSTEM IS STORED
C                 IN DIAG(K).
C
C     OFFDG       REAL ARRAY OF SIZE N (INPUT)
C                 CONSTANT OFF-DIAGONALS FOR THE SYSTEMS TO BE SOLVED.
C                 THE OFF-DIAGONAL ELEMENT A FOR THE I-TH SYSTEM IS
C                 STORED IN OFFDG(I).
C
C     U           REAL ARRAY OF SIZE LDXU BY M (INPUT/OUTPUT)
C                 ON INPUT THE RIGHT HAND SIDES OF THE LINEAR  SYSTEMS
C                 TO BE SOLVED ARE STORED IN THE ROWS OF U, I.E., THE
C                 ITH RIGHT HAND SIDE IS IN U(I,J), J=JL,..,JR, FOR
C                 I=IL,..,IR.
C                 ON OUTPUT THESE ROWS ARE REPLACED BY THE SOLUTIONS
C                 OF THE LINEAR SYSTEMS.
C
C     LDXU        INTEGER SCALAR (INPUT)
C                 THE LEADING DIMENSION OF THE ARRAY U EXACTLY AS
C                 SPECIFIED IN THE CALLING PROGRAM.
C
C     MU,NU       REAL  SCALARS (INPUT)
C                 MULTIPLICATIVE FACTORS FOR THE FIRST AND LAST
C                 DIAGONAL ELEMENTS, RESPECTIVELY, FOR EACH OF THE
C                 LINEAR SYSTEMS.  THESE ARE IGNORED IF PRDC=.TRUE.
C
C     IL, IR,     INTEGER SCALARS (INPUT)
C     JL, JR      SPECIFY THE SUBARRAY OF U IN WHICH THE RIGHT HAND
C                 SIDES OF THE SYSTEMS ARE STORED.  SEE U ABOVE.
C
C     PRDC        LOGICAL VARIABLE (INPUT)
C                 INDICATES THE FORM OF THE MATRICES.  IS .TRUE. FOR
C                 THE PERIODIC CASE (SECOND CASE ABOVE), AND .FALSE.
C                 OTHERWISE.
C
C     WORK        REAL WORK ARRAY OF SIZE 5*M. THIS CAN BE REDUCED TO
C                 M IF ABS(DIAG(K)) .GE. 2*ABS(OFFDG(K)) FOR ALL K.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER  LDXU, IL, IR, JL, JR
      REAL DIAG(*), OFFDG(*), U(LDXU,*), WORK(*), MU, NU
      LOGICAL PRDC
C
C     ... LOCAL VARIABLES
C
      INTEGER K, KX, IPOS, INFO
      REAL CORNER
C
C     ... LOCAL CONSTANTS
C
      INTEGER M, LOCC, LOCD, LOCE, LOCW
C
      M = JR - JL + 1
      LOCC =    1 + M
      LOCD = LOCC + M
      LOCE = LOCD + M
      LOCW = LOCE + M
C
C
C  -------------------------
C  SOLVE TRIDIAGONAL SYSTEMS
C  -------------------------
C
      K = 0
      DO 500 I=IL,IR
         K = K + 1
C
C        ... CONSTRUCT RIGHT HAND SIDE
C
         KX = 0
         DO 100 J=JL,JR
            KX = KX + 1
            WORK(KX) = U(I,J)
  100    CONTINUE
         WORK(1) = WORK(1)*MU
         WORK(M) = WORK(M)*NU
C
C        ... SOLVE
C
         IF (ABS(DIAG(K)) .GE. 2.0*ABS(OFFDG(K))) THEN
C
C           ... CASE OF COEFU .LE. 0   --   USE EVANS ALGORITHM
C
            IF (PRDC) THEN
               CALL TRSOLP(DIAG(K), OFFDG(K), WORK, M, INFO)
            ELSE
               CALL TRSOLG (DIAG(K), OFFDG(K), MU, NU, WORK, M, INFO)
            ENDIF
         ELSE
C
C           ... CASE OF COEFU .GT. 0  --   USE GAUSS WITH PIVOTING
C
            DO 200 IPOS=0,M-1
               WORK(LOCC+IPOS) = OFFDG(K)
               WORK(LOCE+IPOS) = OFFDG(K)
               WORK(LOCD+IPOS) = DIAG(K)
  200       CONTINUE
            WORK(LOCD) = MU*WORK(LOCD)
            WORK(LOCD+M-1) = NU*WORK(LOCD+M-1)
            CORNER = 0.0E0
            IF (PRDC)  CORNER = OFFDG(K)
            CALL SGPSL(M, WORK(LOCC), WORK(LOCD), WORK(LOCE),CORNER,
     +                 CORNER, WORK, WORK(LOCW), INFO)
         ENDIF
C
C        ... REPLACE ROW
C
         KX = 0
         DO 300 J=JL,JR
            KX = KX + 1
            U(I,J) = WORK(KX)
  300    CONTINUE
  500 CONTINUE
C
C
C  ----
C  EXIT
C  ----
C
      RETURN
      END
      SUBROUTINE TRSOLG (A, B, MU, NU, G, NG, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    JOAN M. BAUMANN
C    NATIONAL BUREAU OF STANDARDS
C    DECEMBER 1985
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   TRSOLG SOLVES THE TRIDIAGONAL SYSTEM AX = G, WHERE
C
C                       :--                      --:
C                       :  MU*A  B                 :
C                       :     B  A  B              :
C                       :        B  A  B           :
C                A  =   :          .  .  .         :
C                       :            .  .  .       :
C                       :              B  A  B     :
C                       :                 B  A*NU  :
C                       :--                      --:
C
C   WHERE ABS(A).GE.2*ABS(B)) AND MU AND NU HAVE ONE OF THE VALUES
C   0.5 OR 1.0.
C
C
C   ALGORITHM
C
C   THE ALGORITHM USED IS N EXTENSION OF AN INTERLOCKING FACTORIZATION
C   METHOD DUE TO EVANS.
C
C   REFERENCE:  D. J. EVANS, AN ALGORITHM FOR THE SOLUTION OF CERTAIN
C   TRIDIAGONAL SYSTEMS OF LINEAR EQUATIONS, THE COMPUTER JOURNAL,
C   VOL. 15, PP. 356-359.
C
C
C   DEGENERATE CASES
C
C   WHEN MU=NU=0.5 AND ABS(A).EQ.2*ABS(B) THE MATRIX A IS SINGULAR.
C   IN THESE CASES A CERTAIN CONSISTENCY CONDITION MUST BE SATISFIED;
C   IF IT IS, THERE ARE AN INFINITE NUMBER OF SOLUTIONS, EACH DIFFERING
C   BY AN ADDITIVE CONSTANT.  THE CONSISTENCY CONDITIONS ARE
C
C        CASE -A=2B :  SUM(I=1,..,NG) G(I) = 0
C        CASE  A=2B :  SUM(I ODD) G(I) + SUM(I EVEN) G(I) = 0
C
C   WE ASSUME THESE CONDITIONS HOLD AND SELECT THE UNIQUE SOLUTION WITH
C   G(NG) = 0.0.
C
C
C   P A R A M E T E R S
C   -------------------
C
C     A           REAL SCALAR (INPUT)
C                 CONSTANT DIAGONAL FOR THE SYSTEM TO BE SOLVED.
C
C     B           REAL SCALAR (INPUT)  ABS(A) .GE. 2*ABS(B)
C                 CONSTANT OFF-DIAGONAL FOR THE SYSTEM TO BE SOLVED.
C
C     MU,NU       REAL  SCALARS (INPUT)  .EQ. 0.5 OR 1.0
C                 MULTIPLICATIVE FACTORS FOR FIRST AND LAST DIAGONAL
C                 ELEMENTS, RESPECTIVELY.
C
C     G           REAL ARRAY OF SIZE M (INPUT/OUTPUT)
C                 ON INPUT, CONTAINS THE RIGHT HAND SIDE OF THE LINEAR
C                 SYSTEM.  ON OUTPUT THIS IS REPLACED BY THE SOLUTIONONS
C                 VECTOR.
C
C     NG          INTEGER SCALAR (INPUT)  .GE. 2
C                 THE NUMBER OF ROWS IN THE SYSTEMS TO BE SOLVED.
C
C     INFO        INTEGER SCALAR (OUTPUT)
C                 INDICATES STATUS OF COMPUTED SOLUTION.
C                 POSSIBLE VALUES ARE
C
C                    0 == SUBROUTINE RAN TO COMPLETION (SUCCESS)
C                    1 == ERROR. ABS(A).LT.2*ABS(B)
C                    2 == ERROR. N.LT.2
C                    3 == ERROR. MU OR NU .NE. 0.5 OR 1.0
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      REAL A, B, MU, NU, G(NG)
      INTEGER NG, INFO
C
C     ... LOCAL VARIABLES
C
      REAL AA
      INTEGER KASE, N
C
C     ... LOCAL CONSTANTS
C
      REAL ALPHA, ALPHA2, BETA, BETA2, GAMMA2, DELTA,
     *     EPS, XN, CON1, CON2, ZERO, ONE, TWO, FOUR, HALF, EPMACH
C
      SAVE  ZERO,  ONE,   TWO,   FOUR,  HALF
      DATA  ZERO,  ONE,   TWO,   FOUR,  HALF
     *    / 0.0E0, 1.0E0, 2.0E0, 4.0E0, 0.50E0 /
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      N = NG
      EPMACH = R1MACH(4)
      EPS = 50.0E0*EPMACH
      IF (ABS(MU - HALF) .LT. EPS)  MU = HALF
      IF (ABS(MU - ONE ) .LT. EPS)  MU = ONE
      IF (ABS(NU - HALF) .LT. EPS)  NU = HALF
      IF (ABS(NU - ONE ) .LT. EPS)  NU = ONE
C
C     ...  CHECK FOR ILLEGAL INPUT PARAMETERS
C
      INFO = 0
      IF (((MU .NE. HALF) .AND. (MU .NE. ONE)) .OR.
     *    ((NU .NE. HALF) .AND. (NU .NE. ONE))      )  INFO = 3
      IF (N .LT. 2)  INFO = 2
      IF ((ABS(A) - TWO*ABS(B)) .LT. ZERO)  INFO = 1
      IF (INFO .NE. 0)  GO TO 999
C
C
C  -----------------------
C  CHECK FOR B=0, CASE = 6
C  -----------------------
C
      IF (ABS(B/A) .LT. EPMACH)  GO TO 600
C
C
C  ---------------------------
C  PREPROCESSING FOR CASES 1-5
C  ---------------------------
C
      ALPHA = -TWO*B/(A + SQRT(MAX(ZERO,A*A - FOUR*B*B)))
      IF (ABS(ALPHA) .GT. ONE)  ALPHA = ONE/ALPHA
      ALPHA2 = ALPHA*ALPHA
      BETA2  = MU*(ONE + ALPHA2) - ALPHA2
      BETA   = SQRT(BETA2)
      GAMMA2 = NU*(ONE + ALPHA2) - ONE
C
C     ... RESCALE SYSTEM TO TRIDIAGONAL(-ALPHA,1+ALPHA**2,-ALPHA)
C
      CON1   = (ONE + ALPHA2)/A
      DO 10 I=1,N
         G(I) = CON1*G(I)
 10   CONTINUE
C
C
C  --------------
C  DETERMINE CASE
C  --------------
C
C     KASE = 1  ==  ABS(ALPHA) < 1.0
C     KASE = 2  ==  ABS(ALPHA) = 1.0,  MU = 1.0,  NU = 1.0
C     KASE = 3  ==  ABS(ALPHA) = 1.0,  MU =  .5,  NU =  .5
C     KASE = 4  ==  ABS(ALPHA) = 1.0,  MU =  .5,  NU = 1.0
C     KASE = 5  ==  ABS(ALPHA) = 1.0,  MU = 1.0,  NU =  .5
C
      IF ((-ONE + EPS .LE. ALPHA) .AND. (ALPHA .LE. ONE - EPS)) THEN
            KASE = 1
         ELSE IF ((MU .EQ. ONE) .AND. (NU .EQ. ONE)) THEN
            KASE = 2
         ELSE IF ((MU .EQ. HALF) .AND. (NU .EQ. HALF)) THEN
            KASE = 3
         ELSE IF ((MU .EQ. HALF) .AND. (NU .EQ. ONE)) THEN
            KASE = 4
         ELSE IF ((MU .EQ. ONE) .AND. (NU .EQ. HALF)) THEN
            KASE = 5
         ELSE
            INFO = 3
            GO TO 999
      ENDIF
      GO TO (100, 200, 300, 400, 500), KASE
C
C
C  ------
C  CASE 1
C  ------
C
C     ... PREPROCESSING
C
 100  CONTINUE
      CON2 = (ONE - ALPHA2 - BETA2)/BETA2
      AA = ALPHA
      XN = G(N)
      DO 110 J=1,N-2
         XN = XN + AA*G(N-J)
         AA = AA*ALPHA
 110  CONTINUE
      XN = XN + AA*(ONE - ALPHA2)/BETA2*G(1)
      DO 120 J=2,N
         AA = AA*ALPHA
         XN = XN + CON2*AA*G(J)
 120  CONTINUE
      DELTA = ONE - ALPHA2 + GAMMA2 + GAMMA2*CON2*AA
      XN = XN/DELTA
      GOTO 220
C
C
C  ------
C  CASE 2
C  ------
C
C     ... PREPROCESSING
C
  200 CONTINUE
      XN = ZERO
      IF (MOD(N-1,2) .EQ. 1) THEN
         AA = ALPHA
      ELSE
         AA = ONE
      ENDIF
      DO 210 K=1,N-1
         XN = XN + G(K)*REAL(K)*AA
         AA = AA*ALPHA
  210 CONTINUE
      XN = (XN + G(N)*REAL(N))/REAL(N+1)
C
C     ... BACK SUBSTITUTION (CASES 1 AND 2)
C
 220  CONTINUE
      G(N) = G(N) - GAMMA2*XN
      DO 230 I=N-1,2,-1
         G(I) = G(I) + ALPHA*G(I+1)
 230  CONTINUE
      G(1) = (G(1) + ALPHA*G(2))/BETA
C
C     ... FORWARD ELIMINATION (CASES 1 AND 2)
C
      G(1) = G(1)/BETA
      DO 240 I=2,N-1
         G(I) = G(I) + ALPHA*G(I-1)
 240   CONTINUE
      G(N)=XN
      GO TO 999
C
C
C  --------------------------
C  CASE 3 : CONVERT TO CASE 4
C  --------------------------
C
 300  CONTINUE
      G(N) = ZERO
      N = N-1
C
C  ------
C  CASE 4
C  ------
C
C     ... FORWARD ELIMINATION
C
 400  CONTINUE
      G(1) = -ALPHA*G(1)
      DO 410 I=2,N
         G(I) = -ALPHA*(G(I) - G(I-1))
 410  CONTINUE
C
C     ... BACK SUBSTITUTION
C
      G(N) = -ALPHA*G(N)
      DO 420 I=N-1,1,-1
         G(I) = -ALPHA*(G(I) - G(I+1))
 420  CONTINUE
      GO TO 999
C
C
C  ------
C  CASE 5
C  ------
C
C     ... BACK SUBSTITUTION
C
 500  CONTINUE
      DO 510 I=N-1,1,-1
         G(I) = G(I) + ALPHA*G(I+1)
 510  CONTINUE
C
C     ... FORWARD ELMINATION
C
      DO 520 I=2,N
         G(I) = G(I) + ALPHA*G(I-1)
 520  CONTINUE
      GO TO 999
C
C
C  ------------------------
C  CASE 6 : DIAGONAL SYSTEM
C  ------------------------
C
 600  CONTINUE
      DO 610 I=1,N
         G(I) = G(I)/A
 610  CONTINUE
      G(1) = G(1)/MU
      G(N) = G(N)/NU
      GO TO 999
C
C
C  ----
C  EXIT
C  ----
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE TRSOLP (A, B, G, NG, INFO)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    JOAN M. BAUMANN
C    NATIONAL BUREAU OF STANDARDS
C
C    DECEMBER 1985   (REVISED APRIL 1987)
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C
C   TRSOLP SOLVES THE TRIDIAGONAL LINEAR SYSTEM AX = G, WHERE
C
C                        :--                  --:
C                        :   A  B           B   :
C                        :   B  A  B            :
C                        :      B  A  B         :
C                 A  =   :        .  .  .       :
C                        :          .  .  .     :
C                        :            B  A  B   :
C                        :   B           B  A   :
C                        :--                  --:
C
C   WHERE ABS(A).GE.ABS(2*B).
C
C
C   ALGORITHM
C
C    THE ALGORITHM USED IS AN INTERLOCKING FACTORIZATION METHOD DUE TO
C    EVANS.
C
C   REFERENCE: D. J. EVANS, FAST ADI METHODS FOR THE SOLUTION OF LINEAR
C   PARABOLIC PARTIAL DIFFERENTIAL EQUATIONS INVOLVING 2 SPACE
C   DIMENSIONS, BIT, VOL. 17, P.486-491.
C
C
C   DEGENERATE CASES
C
C   WHEN -A=2B OR WHEN A=2B AND NG IS EVEN THE MATRIX A IS SINGULAR.
C   IN THESE CASES THERE ARE NO SOLUTIONS UNLESS G SATISFIES A CERTAIN
C   CONSISTENCY CONDITION.  WHEN IT DOES, THERE ARE AN INFINITE NUMBER
C   OF SOLUTIONS, EACH DIFFERENING BY AN ADDITVE CONSTANT.  THE
C   CONSISTENCY CONDITIONS ARE
C
C     CASE -A=2B          :  SUM(I=1,..,NG) G(I) = 0
C     CASE  A=2B, NG EVEN :  SUM(I ODD) G(I) - SUM(I EVEN) G(I) = 0
C
C   WE ASSUME THESE CONDITIONS HOLD AND SELECT THE UNIQUE SOLUTION WITH
C   G(NG) = 0.0.
C
C
C   -------------------
C   P A R A M E T E R S
C   -------------------
C
C     A           REAL SCALAR (INPUT)
C                 CONSTANT DIAGONAL FOR THE SYSTEM TO BE SOLVED
C
C     B           REAL SCALAR (INPUT)
C                 CONSTANT OFF-DIAGONAL FOR THE SYSTEM TO BE SOLVED
C
C     G           REAL ARRAY OF SIZE M (INPUT/OUTPUT)
C                 ON INPUT THE RIGHT HAND SIDES OF THE LINEAR
C                 SYSTEMS TO BE SOLVED ARE STORED IN THE ROWS
C                 OF G, I.E., THE ITH RIGHT HAND SIDE IS IN G(I).
C                 ON OUTPUT THESE ARE REPLACED BY THE SOLUTIONS
C                 OF THE LINEAR SYSTEMS.
C
C     NG          INTEGER SCALAR (INPUT)
C                 THE NUMBER OF ROWS IN THE SYSTEMS TO BE SOLVED.
C
C     INFO        INTEGER SCALAR (OUTPUT)
C                 INDICATES STATUS OF COMPUTED SOLUTION.
C                 POSSIBLE VALUES ARE
C
C                    0 == SUBROUTINE RAN TO COMPLETION (SUCCESS)
C                    1 == ERROR. ABS(A).LT.2*ABS(B)
C                    2 == ERROR. N.LT.3
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      REAL A, B, G(NG)
      INTEGER NG, INFO
C
C     ... LOCAL VARIABLES
C
      REAL AA
      INTEGER N
C
C     ... LOCAL CONSTANTS
C
      REAL ALPHA, EPS, FACTOR, ZERO, ONE, TWO, FOUR, EPMACH
C
      SAVE  ZERO,  ONE,   TWO,   FOUR
      DATA  ZERO,  ONE,   TWO,   FOUR
     *    / 0.0E0, 1.0E0, 2.0E0, 4.0E0 /
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      N = NG
      EPMACH = R1MACH(4)
      EPS = 50.0E0*EPMACH
C
C     ...  CHECK FOR ILLEGAL INPUT PARAMETERS
C
      INFO = 0
C      IF ((ABS(A) - 2.0E0*ABS(B)) .LT. ZERO)  INFO = 1
      IF (N .LT. 3)  INFO = 2
      IF (INFO .NE. 0)  GO TO 999
C
C
C  ------------------
C  CHECK FOR B=0 CASE
C  ------------------
C
      IF (ABS(B/A) .LT. EPMACH)  GO TO 200
C
C
C  --------------------------------------------------------
C  RESCALE PROBLEM TO TRIDIAGONAL(-ALPHA,1+ALPHA**2,-ALPHA)
C  --------------------------------------------------------
C
      ALPHA = -TWO*B/(A + SQRT(MAX(ZERO,A*A - FOUR*B*B)))
      IF (ABS(ALPHA) .GT. ONE) ALPHA = ONE/ALPHA
      FACTOR = (ONE + ALPHA*ALPHA)/A
      DO 10 I = 1,N
         G(I) = FACTOR*G(I)
   10 CONTINUE
C
C
C  -----------------------
C  CHECK FOR SINGULAR CASE
C  -----------------------
C
      IF (((ABS(ONE + ALPHA) .LE. EPS) .AND. (MOD(N,2) .EQ. 0)) .OR.
     *    (ABS(ONE - ALPHA) .LE. EPS))  GO TO 300
C
C
C  -------------
C  STANDARD CASE
C  -------------
C
C     ... PREPROCESSING
C
      AA = ALPHA
      DO 20 I = N,2,-1
         G(1) = G(1) + AA*G(I)
         AA = AA*ALPHA
   20 CONTINUE
      G(1) = G(1)/(ONE - AA)
C
C    ... FORWARD ELIMINATION
C
      DO 40 I = 2,N
         G(I) = G(I) + ALPHA*G(I-1)
   40 CONTINUE
C
C     ... DETERMINE INTERLOCKING ELEMENT XN
C
      AA = ALPHA
      DO 45 I = 1,N-1
         G(N) = G(N) + AA*G(I)
         AA = AA*ALPHA
   45 CONTINUE
      G(N) = G(N)/(ONE - AA)
C
C     ... BACK SUBSTITUTION
C
      DO 50 I = N-1,1,-1
         G(I) = G(I) + ALPHA*G(I+1)
   50 CONTINUE
      GO TO 999
C
C
C  ---------------------
C  SPECIAL CASE :  B = 0
C  ---------------------
C
  200 CONTINUE
      DO 210 I=1,N
         G(I) = G(I)/A
  210 CONTINUE
      GO TO 999
C
C
C  --------------------------------
C  SPECIAL CASE :  SINGULAR PROBLEM
C  --------------------------------
C
  300 CONTINUE
      G(N) = ZERO
      CALL TRSOLG (ONE + ALPHA*ALPHA, -ALPHA, ONE, ONE, G, N-1, INFO)
      GO TO 999
C
C
C  ----
C  EXIT
C  ----
C
  999 CONTINUE
      RETURN
      END
      SUBROUTINE SGPSL (N,C,D,E,C0,E0,B,W,INFO)
C
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
C
C    ---------------      4TH ORDER ACCURATE FAST DIRECT SOLUTION
C    PACKAGE :  HFFT      OF THE HELMHOLTZ EQUATION ON RECTANGULAR
C    ---------------      DOMAINS IN TWO AND THREE DIMENSIONS
C
C    INTERNAL MODULE
C
C    RONALD F. BOISVERT
C    NATIONAL BUREAU OF STANDARDS
C
C    APRIL 1987
C
C *-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*
*
C
C  SGPSL SOLVES A LINEAR SYSTEM OF EQUATIONS DEFINED BY A GENERAL
C  TRIDIAGONAL MATRIX WITH ADDITIONAL NONZEROS IN THE (1,N) AND (N,1)
C  POSITIONS USING GAUSS ELIMINATION WITH PARTIAL PIVOTING.
C
C
C  P A R A M E T E R S
C  -------------------
C
C  ON ENTRY
C
C     N       INTEGER (N.GE.3)
C             IS THE ORDER OF THE TRIDIAGONAL MATRIX.
C
C     C       REAL(N)
C             IS THE SUBDIAGONAL OF THE TRIDIAGONAL MATRIX.
C             C(2) THROUGH C(N) SHOULD CONTAIN THE SUBDIAGONAL.
C             ON OUTPUT, C IS DESTROYED.
C
C     D       REAL(N)
C             IS THE DIAGONAL OF THE TRIDIAGONAL MATRIX.
C             ON OUTPUT, D IS DESTROYED.
C
C     E       REAL(N)
C             IS THE SUPERDIAGONAL OF THE TRIDIAGONAL MATRIX.
C             E(1) THROUGH E(N-1) SHOULD CONTAIN THE SUPERDIAGONAL.
C             ON OUTPUT, E IS DESTROYED.
C
C     C0      REAL
C             THE NONZERO ELEMENT A(1,N).
C
C     E0      REAL
C             THE NONZERO ELEMENT A(N,1).
C
C     B       REAL(N)
C             IS THE RIGHT HAND SIDE VECTOR.
C
C     W       REAL(N)
C             WORKSPACE.
C
C  ON RETURN
C
C     B       IS THE SOLUTION VECTOR.
C
C     INFO    INTEGER
C             = -1 IF N .LT. 3
C             = 0  NORMAL VALUE.
C             = K  IF THE K-TH ELEMENT OF THE DIAGONAL BECOMES
C                  EXACTLY ZERO.  THE SUBROUTINE RETURNS WHEN
C                  THIS IS DETECTED.
C
C  THIS IS A MODIFICATION OF THE LINPACK ROUTINE SGTSL.
C
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... PARAMETERS
C
      INTEGER N, INFO
      REAL C(N), D(N), E(N), B(N), W(N)
C
C     ... LOCAL VARIABLES
C
      LOGICAL LASROW
      INTEGER K, KBIG, KP1, KP2, NM1, NM2, NM3
      REAL T, RK, RKP1, RKP2, A(3,3)
C
C
C  ---------------
C  INITIALIZATIONS
C  ---------------
C
      INFO = -1
      IF (N .LE. 3)  GO TO 100
C
      NM1 = N - 1
      NM2 = N - 2
      NM3 = N - 3
C
      ZERO = 0.0E0
      LASROW = E0 .NE. ZERO
      RKP1 = E0
      RKP2 = ZERO
      W(1) = C0
      DO 10 I=2,NM2
         W(I) = ZERO
   10 CONTINUE
      W(NM1) = E(NM1)
      W(N) = D(N)
C
      C(1) = D(1)
      D(1) = E(1)
      E(1) = ZERO
      E(N) = ZERO
C
C  -------------------
C  FORWARD ELIMINATION
C  -------------------
C
      DO 30 K = 1, NM3
         INFO = K
         KP1 = K + 1
         KP2 = K + 2
         RK = RKP1
         RKP1 = RKP2
         RKP2 = ZERO
         IF (K .EQ. NM3)  RKP2 = C(N)
C
C        ... FIND THE LARGEST OF THE TWO ROWS
C
         IF (ABS(C(KP1)) .GT. ABS(C(K))) THEN
C
C           ... INTERCHANGE ROW
C
            T = C(KP1)
            C(KP1) = C(K)
            C(K) = T
            T = D(KP1)
            D(KP1) = D(K)
            D(K) = T
            T = E(KP1)
            E(KP1) = E(K)
            E(K) = T
            T = W(KP1)
            W(KP1) = W(K)
            W(K) = T
            T = B(KP1)
            B(KP1) = B(K)
            B(K) = T
         ENDIF
C
C        ... CHECK FOR SINGULARITY
C
         IF (C(K) .EQ. ZERO) GO TO 100
C
C        ... ELIMINATE IN ROW K+1
C
         T = -C(KP1)/C(K)
         C(KP1) = D(KP1) + T*D(K)
         D(KP1) = E(KP1) + T*E(K)
         E(KP1) = ZERO
         W(KP1) = W(KP1) + T*W(K)
         B(KP1) = B(KP1) + T*B(K)
C
C        ... ELIMINATE IN LAST ROW
C
         IF (LASROW) THEN
            T = -RK/C(K)
            RKP1 = RKP1 + T*D(K)
            RKP2 = RKP2 + T*E(K)
            W(N) = W(N) + T*W(K)
            B(N) = B(N) + T*B(K)
         ENDIF
   30 CONTINUE
C
C     ... DO LAST 3 BY 3 BLOCK
C
      A(1,1) = C(NM2)
      A(1,2) = D(NM2)
      A(1,3) = W(NM2)
      A(2,1) = C(NM1)
      A(2,2) = D(NM1)
      A(2,3) = W(NM1)
      A(3,1) = RKP1
      A(3,2) = RKP2
      A(3,3) = W(N)
C
C     === STEP N-2 ===
C
      INFO = NM2
      KBIG = 1
      IF (ABS(A(2,1)) .GT. ABS(A(1,1)))    KBIG = 2
      IF (ABS(A(3,1)) .GT. ABS(A(KBIG,1))) KBIG = 3
      IF (KBIG .NE. 1) THEN
C
C        ... PIVOT
C
         T = A(KBIG,1)
         A(KBIG,1) = A(1,1)
         A(1,1) = T
         T = A(KBIG,2)
         A(KBIG,2) = A(1,2)
         A(1,2) = T
         T = A(KBIG,3)
         A(KBIG,3) = A(1,3)
         A(1,3) = T
         K = NM3 + KBIG
         T = B(K)
         B(K) = B(NM2)
         B(NM2) = T
      ENDIF
      IF (A(1,1) .EQ. ZERO)  GO TO 100
C
C     ... ELIMINATE
C
      T = -A(2,1)/A(1,1)
      A(2,2) = A(2,2) + T*A(1,2)
      A(2,3) = A(2,3) + T*A(1,3)
      B(NM1) = B(NM1) + T*B(NM2)
      T = -A(3,1)/A(1,1)
      A(3,2) = A(3,2) + T*A(1,2)
      A(3,3) = A(3,3) + T*A(1,3)
      B(N) = B(N) + T*B(NM2)
C
C     === STEP N-1 ===
C
      INFO = NM1
      IF (ABS(A(3,2)) .GT. ABS(A(2,2))) THEN
C
C        ... PIVOT
C
         T = A(3,2)
         A(3,2) = A(2,2)
         A(2,2) = T
         T = A(3,3)
         A(3,3) = A(2,3)
         A(2,3) = T
         T = B(N)
         B(N) = B(NM1)
         B(NM1) = T
      ENDIF
      IF (A(2,2) .EQ. ZERO)  GO TO 100
C
C     ... ELIMINATE
C
      T = -A(3,2)/A(2,2)
      A(3,3) = A(3,3) + T*A(2,3)
      B(N) = B(N) + T*B(NM1)
C
C     === STEP N ===
C
      INFO = N
      IF (A(3,3) .EQ. ZERO)  GO TO 100
C
C  ----------
C  BACK SOLVE
C  ----------
C
      B(N) = B(N)/A(3,3)
      B(NM1) = (B(NM1) - A(2,3)*B(N))/A(2,2)
      B(NM2) = (B(NM2) - A(1,2)*B(NM1) - A(1,3)*B(N))/A(1,1)
      DO 60 K = NM3, 1, -1
         B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2) - W(K)*B(N))/C(K)
   60 CONTINUE
      INFO = 0
C
C  ----
C  EXIT
C  ----
C
  100 CONTINUE
      RETURN
      END
*
      SUBROUTINE COSQB(N,X,WSAVE)
C***BEGIN PROLOGUE  COSQB
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  UNNORMALIZED INVERSE OF COSQF.
C***DESCRIPTION
C
C  SUBROUTINE COSQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C  WAVE DATA. THAT IS, COSQB COMPUTES A SEQUENCE FROM ITS
C  REPRESENTATION IN TERMS OF A COSINE SERIES WITH ODD WAVE NUMBERS.
C  THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C  COSQB IS THE UNNORMALIZED INVERSE OF COSQF SINCE A CALL OF COSQB
C  FOLLOWED BY A CALL OF COSQF WILL MULTIPLY THE INPUT SEQUENCE X
C  BY 4*N.
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQB MUST BE
C  INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE).
C
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY THAT MUST BE DIMENSIONED AT LEAST 3*N+15
C          IN THE PROGRAM THAT CALLS COSQB.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C               X(I)= THE SUM FROM K=1 TO K=N OF
C
C                 4*X(K)*COS((2*K-1)*(I-1)*PI/(2*N))
C
C               A CALL OF COSQB FOLLOWED BY A CALL OF
C               COSQF WILL MULTIPLY THE SEQUENCE X BY 4*N.
C               THEREFORE COSQF IS THE UNNORMALIZED INVERSE
C               OF COSQB.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C          BE DESTROYED BETWEEN CALLS OF COSQB OR COSQF.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COSQB1
C***END PROLOGUE  COSQB
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COSQB
      TSQRT2 = 2.*SQRT(2.)
      IF (N-2) 101,102,103
  101 X(1) = 4.*X(1)
      RETURN
  102 X1 = 4.*(X(1)+X(2))
      X(2) = TSQRT2*(X(1)-X(2))
      X(1) = X1
      RETURN
  103 CALL COSQB1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COSQF(N,X,WSAVE)
C***BEGIN PROLOGUE  COSQF
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS.
C***DESCRIPTION
C
C  SUBROUTINE COSQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C  WAVE DATA. THAT IS, COSQF COMPUTES THE COEFFICIENTS IN A COSINE
C  SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS.  THE TRANSFORM
C  IS DEFINED BELOW AT OUTPUT PARAMETER X
C
C  COSQF IS THE UNNORMALIZED INVERSE OF COSQB SINCE A CALL OF COSQF
C  FOLLOWED BY A CALL OF COSQB WILL MULTIPLY THE INPUT SEQUENCE X
C  BY 4*N.
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COSQF MUST BE
C  INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE).
C
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15
C          IN THE PROGRAM THAT CALLS COSQF.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE COSQI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C               X(I) = X(1) PLUS THE SUM FROM K=2 TO K=N OF
C
C                  2*X(K)*COS((2*I-1)*(K-1)*PI/(2*N))
C
C               A CALL OF COSQF FOLLOWED BY A CALL OF
C               COSQB WILL MULTIPLY THE SEQUENCE X BY 4*N.
C               THEREFORE COSQB IS THE UNNORMALIZED INVERSE
C               OF COSQF.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C          BE DESTROYED BETWEEN CALLS OF COSQF OR COSQB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COSQF1
C***END PROLOGUE  COSQF
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COSQF
      SQRT2 = SQRT(2.)
      IF (N-2) 102,101,103
  101 TSQX = SQRT2*X(2)
      X(2) = X(1)-TSQX
      X(1) = X(1)+TSQX
  102 RETURN
  103 CALL COSQF1 (N,X,WSAVE,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COSQI(N,WSAVE)
C***BEGIN PROLOGUE  COSQI
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  INITIALIZE FOR COSQF AND COSQB.
C***DESCRIPTION
C
C  SUBROUTINE COSQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C  BOTH COSQF AND COSQB.  THE PRIME FACTORIZATION OF N TOGETHER WITH
C  A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C  STORED IN WSAVE.
C
C  INPUT PARAMETER
C
C  N       THE LENGTH OF THE ARRAY TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  OUTPUT PARAMETER
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15.
C          THE SAME WORK ARRAY CAN BE USED FOR BOTH COSQF AND COSQB
C          AS LONG AS N REMAINS UNCHANGED.  DIFFERENT WSAVE ARRAYS
C          ARE REQUIRED FOR DIFFERENT VALUES OF N.  THE CONTENTS OF
C          WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF COSQF OR COSQB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTI
C***END PROLOGUE  COSQI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COSQI
      PIH = 2.*ATAN(1.)
      DT = PIH/REAL(N)
      FK = 0.
      DO 101 K=1,N
         FK = FK+1.
         WSAVE(K) = COS(FK*DT)
  101 CONTINUE
      CALL RFFTI (N,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COSTI(N,WSAVE)
C***BEGIN PROLOGUE  COSTI
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  INITIALIZE FOR COST.
C***DESCRIPTION
C
C  SUBROUTINE COSTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C  SUBROUTINE COST.  THE PRIME FACTORIZATION OF N TOGETHER WITH
C  A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C  STORED IN WSAVE.
C
C  INPUT PARAMETER
C
C  N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF SMALL PRIMES.
C
C  OUTPUT PARAMETER
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15.
C          DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES
C          OF N.  THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN
C          CALLS OF COST.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTI
C***END PROLOGUE  COSTI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COSTI
      PI = 4.*ATAN(1.)
      IF (N .LE. 3) RETURN
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      DT = PI/REAL(NM1)
      FK = 0.
      DO 101 K=2,NS2
         KC = NP1-K
         FK = FK+1.
         WSAVE(K) = 2.*SIN(FK*DT)
         WSAVE(KC) = 2.*COS(FK*DT)
  101 CONTINUE
      CALL RFFTI (NM1,WSAVE(N+1))
      RETURN
      END
      SUBROUTINE COST(N,X,WSAVE)
C***BEGIN PROLOGUE  COST
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  COSINE TRANSFORM OF A REAL, EVEN SEQUENCE.
C***DESCRIPTION
C
C  SUBROUTINE COST COMPUTES THE DISCRETE FOURIER COSINE TRANSFORM
C  OF AN EVEN SEQUENCE X(I).  THE TRANSFORM IS DEFINED BELOW AT OUTPUT
C  PARAMETER X.
C
C  COST IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF COST
C  FOLLOWED BY ANOTHER CALL OF COST WILL MULTIPLY THE INPUT SEQUENCE
C  X BY 2*(N-1).  THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE COST MUST BE
C  INITIALIZED BY CALLING SUBROUTINE COSTI(N,WSAVE).
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE SEQUENCE X.  N MUST BE GREATER THAN 1.
C          THE METHOD IS MOST EFFICIENT WHEN N-1 IS A PRODUCT OF
C          SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15
C          IN THE PROGRAM THAT CALLS COST.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE COSTI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C             X(I) = X(1)+(-1)**(I-1)*X(N)
C
C               + THE SUM FROM K=2 TO K=N-1
C
C                   X(K)*COS((K-1)*(I-1)*PI/(N-1))
C
C               A CALL OF COST FOLLOWED BY ANOTHER CALL OF
C               COST WILL MULTIPLY THE SEQUENCE X BY 2*(N-1).
C               HENCE COST IS THE UNNORMALIZED INVERSE
C               OF ITSELF.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C          DESTROYED BETWEEN CALLS OF COST.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTF
C***END PROLOGUE  COST
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  COST
      NM1 = N-1
      NP1 = N+1
      NS2 = N/2
      IF (N-2) 106,101,102
  101 X1H = X(1)+X(2)
      X(2) = X(1)-X(2)
      X(1) = X1H
      RETURN
  102 IF (N .GT. 3) GO TO 103
      X1P3 = X(1)+X(3)
      TX2 = X(2)+X(2)
      X(2) = X(1)-X(3)
      X(1) = X1P3+TX2
      X(3) = X1P3-TX2
      RETURN
  103 C1 = X(1)-X(N)
      X(1) = X(1)+X(N)
      DO 104 K=2,NS2
         KC = NP1-K
         T1 = X(K)+X(KC)
         T2 = X(K)-X(KC)
         C1 = C1+WSAVE(KC)*T2
         T2 = WSAVE(K)*T2
         X(K) = T1-T2
         X(KC) = T1+T2
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) X(NS2+1) = X(NS2+1)+X(NS2+1)
      CALL RFFTF (NM1,X,WSAVE(N+1))
      XIM2 = X(2)
      X(2) = C1
      DO 105 I=4,N,2
         XI = X(I)
         X(I) = X(I-2)-X(I-1)
         X(I-1) = XIM2
         XIM2 = XI
  105 CONTINUE
      IF (MODN .NE. 0) X(N) = XIM2
  106 RETURN
      END
      SUBROUTINE RFFTB(N,R,WSAVE)
C***BEGIN PROLOGUE  RFFTB
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A1
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY.
C***DESCRIPTION
C
C  SUBROUTINE RFFTB COMPUTES THE REAL PERODIC SEQUENCE FROM ITS
C  FOURIER COEFFICIENTS (FOURIER SYNTHESIS).  THE TRANSFORM IS DEFINED
C  BELOW AT OUTPUT PARAMETER R.
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C          N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED.
C
C  R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C          TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15
C          IN THE PROGRAM THAT CALLS RFFTB.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C          THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.
C
C
C  OUTPUT PARAMETERS
C
C  R       FOR N EVEN AND FOR I = 1,...,N
C
C               R(I) = R(1)+(-1)**(I-1)*R(N)
C
C                    PLUS THE SUM FROM K=2 TO K=N/2 OF
C
C                     2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                    -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C          FOR N ODD AND FOR I = 1,...,N
C
C               R(I) = R(1) PLUS THE SUM FROM K=2 TO K=(N+1)/2 OF
C
C                    2.*R(2*K-2)*COS((K-1)*(I-1)*2*PI/N)
C
C                   -2.*R(2*K-1)*SIN((K-1)*(I-1)*2*PI/N)
C
C   *****  NOTE:
C               THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C               FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C               SEQUENCE BY N.
C
C  WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C          CALLS OF RFFTB OR RFFTF.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTB1
C***END PROLOGUE  RFFTB
      DIMENSION       R(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTB
      IF (N .EQ. 1) RETURN
      CALL RFFTB1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTF(N,R,WSAVE)
C***BEGIN PROLOGUE  RFFTF
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A1
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  FORWARD TRANSFORM OF A REAL, PERIODIC SEQUENCE.
C***DESCRIPTION
C
C  SUBROUTINE RFFTF COMPUTES THE FOURIER COEFFICIENTS OF A REAL
C  PERODIC SEQUENCE (FOURIER ANALYSIS).  THE TRANSFORM IS DEFINED
C  BELOW AT OUTPUT PARAMETER R.
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY R TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C          N MAY CHANGE SO LONG AS DIFFERENT WORK ARRAYS ARE PROVIDED
C
C  R       A REAL ARRAY OF LENGTH N WHICH CONTAINS THE SEQUENCE
C          TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15
C          IN THE PROGRAM THAT CALLS RFFTF.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE RFFTI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C          THE SAME WSAVE ARRAY CAN BE USED BY RFFTF AND RFFTB.
C
C
C  OUTPUT PARAMETERS
C
C  R       R(1) = THE SUM FROM I=1 TO I=N OF R(I)
C
C          IF N IS EVEN SET L = N/2; IF N IS ODD SET L = (N+1)/2
C
C            THEN FOR K = 2,...,L
C
C               R(2*K-2) = THE SUM FROM I = 1 TO I = N OF
C
C                    R(I)*COS((K-1)*(I-1)*2*PI/N)
C
C               R(2*K-1) = THE SUM FROM I = 1 TO I = N OF
C
C                   -R(I)*SIN((K-1)*(I-1)*2*PI/N)
C
C          IF N IS EVEN
C
C               R(N) = THE SUM FROM I = 1 TO I = N OF
C
C                    (-1)**(I-1)*R(I)
C
C   *****  NOTE:
C               THIS TRANSFORM IS UNNORMALIZED SINCE A CALL OF RFFTF
C               FOLLOWED BY A CALL OF RFFTB WILL MULTIPLY THE INPUT
C               SEQUENCE BY N.
C
C  WSAVE   CONTAINS RESULTS WHICH MUST NOT BE DESTROYED BETWEEN
C          CALLS OF RFFTF OR RFFTB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTF1
C***END PROLOGUE  RFFTF
      DIMENSION       R(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTF
      IF (N .EQ. 1) RETURN
      CALL RFFTF1 (N,R,WSAVE,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE RFFTI(N,WSAVE)
C***BEGIN PROLOGUE  RFFTI
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A1
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  INITIALIZE FOR RFFTF AND RFFTB.
C***DESCRIPTION
C
C  SUBROUTINE RFFTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C  BOTH RFFTF AND RFFTB.  THE PRIME FACTORIZATION OF N TOGETHER WITH
C  A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C  STORED IN WSAVE.
C
C  INPUT PARAMETER
C
C  N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.
C
C  OUTPUT PARAMETER
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 2*N+15.
C          THE SAME WORK ARRAY CAN BE USED FOR BOTH RFFTF AND RFFTB
C          AS LONG AS N REMAINS UNCHANGED.  DIFFERENT WSAVE ARRAYS
C          ARE REQUIRED FOR DIFFERENT VALUES OF N.  THE CONTENTS OF
C          WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF RFFTF OR RFFTB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTI1
C***END PROLOGUE  RFFTI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  RFFTI
      IF (N .EQ. 1) RETURN
      CALL RFFTI1 (N,WSAVE(N+1),WSAVE(2*N+1))
      RETURN
      END
      SUBROUTINE SINQB(N,X,WSAVE)
C***BEGIN PROLOGUE  SINQB
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  UNNORMALIZED INVERSE OF SINQF.
C***DESCRIPTION
C
C  SUBROUTINE SINQB COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C  WAVE DATA.  THAT IS, SINQB COMPUTES A SEQUENCE FROM ITS
C  REPRESENTATION IN TERMS OF A SINE SERIES WITH ODD WAVE NUMBERS.
C  THE TRANSFORM IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C  SINQF IS THE UNNORMALIZED INVERSE OF SINQB SINCE A CALL OF SINQB
C  FOLLOWED BY A CALL OF SINQF WILL MULTIPLY THE INPUT SEQUENCE X
C  BY 4*N.
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQB MUST BE
C  INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE).
C
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15
C          IN THE PROGRAM THAT CALLS SINQB.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C               X(I)= THE SUM FROM K=1 TO K=N OF
C
C                 4*X(K)*SIN((2K-1)*I*PI/(2*N))
C
C               A CALL OF SINQB FOLLOWED BY A CALL OF
C               SINQF WILL MULTIPLY THE SEQUENCE X BY 4*N.
C               THEREFORE SINQF IS THE UNNORMALIZED INVERSE
C               OF SINQB.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C          BE DESTROYED BETWEEN CALLS OF SINQB OR SINQF.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COSQB
C***END PROLOGUE  SINQB
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINQB
      IF (N .GT. 1) GO TO 101
      X(1) = 4.*X(1)
      RETURN
  101 NS2 = N/2
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      CALL COSQB (N,X,WSAVE)
      DO 103 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  103 CONTINUE
      RETURN
      END
      SUBROUTINE SINQF(N,X,WSAVE)
C***BEGIN PROLOGUE  SINQF
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS.
C***DESCRIPTION
C
C  SUBROUTINE SINQF COMPUTES THE FAST FOURIER TRANSFORM OF QUARTER
C  WAVE DATA.  THAT IS, SINQF COMPUTES THE COEFFICIENTS IN A SINE
C  SERIES REPRESENTATION WITH ONLY ODD WAVE NUMBERS.  THE TRANSFORM
C  IS DEFINED BELOW AT OUTPUT PARAMETER X.
C
C  SINQB IS THE UNNORMALIZED INVERSE OF SINQF SINCE A CALL OF SINQF
C  FOLLOWED BY A CALL OF SINQB WILL MULTIPLY THE INPUT SEQUENCE X
C  BY 4*N.
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINQF MUST BE
C  INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE).
C
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE ARRAY X TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15
C          IN THE PROGRAM THAT CALLS SINQF.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE SINQI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C               X(I) = (-1)**(I-1)*X(N)
C
C                  + THE SUM FROM K=1 TO K=N-1 OF
C
C                  2*X(K)*SIN((2*I-1)*K*PI/(2*N))
C
C               A CALL OF SINQF FOLLOWED BY A CALL OF
C               SINQB WILL MULTIPLY THE SEQUENCE X BY 4*N.
C               THEREFORE SINQB IS THE UNNORMALIZED INVERSE
C               OF SINQF.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT
C          BE DESTROYED BETWEEN CALLS OF SINQF OR SINQB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COSQF
C***END PROLOGUE  SINQF
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINQF
      IF (N .EQ. 1) RETURN
      NS2 = N/2
      DO 101 K=1,NS2
         KC = N-K
         XHOLD = X(K)
         X(K) = X(KC+1)
         X(KC+1) = XHOLD
  101 CONTINUE
      CALL COSQF (N,X,WSAVE)
      DO 102 K=2,N,2
         X(K) = -X(K)
  102 CONTINUE
      RETURN
      END
      SUBROUTINE SINQI(N,WSAVE)
C***BEGIN PROLOGUE  SINQI
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  INITIALIZE FOR SINQF AND SINQB.
C***DESCRIPTION
C
C  SUBROUTINE SINQI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C  BOTH SINQF AND SINQB.  THE PRIME FACTORIZATION OF N TOGETHER WITH
C  A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C  STORED IN WSAVE.
C
C  INPUT PARAMETER
C
C  N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N IS A PRODUCT OF SMALL PRIMES.
C
C  OUTPUT PARAMETER
C
C  WSAVE   A WORK ARRAY WHICH MUST BE DIMENSIONED AT LEAST 3*N+15.
C          THE SAME WORK ARRAY CAN BE USED FOR BOTH SINQF AND SINQB
C          AS LONG AS N REMAINS UNCHANGED.  DIFFERENT WSAVE ARRAYS
C          ARE REQUIRED FOR DIFFERENT VALUES OF N.  THE CONTENTS OF
C          WSAVE MUST NOT BE CHANGED BETWEEN CALLS OF SINQF OR SINQB.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  COSQI
C***END PROLOGUE  SINQI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINQI
      CALL COSQI (N,WSAVE)
      RETURN
      END
      SUBROUTINE SINTI(N,WSAVE)
C***BEGIN PROLOGUE  SINTI
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  INITIALIZE FOR SINT.
C***DESCRIPTION
C
C  SUBROUTINE SINTI INITIALIZES THE ARRAY WSAVE WHICH IS USED IN
C  SUBROUTINE SINT.  THE PRIME FACTORIZATION OF N TOGETHER WITH
C  A TABULATION OF THE TRIGONOMETRIC FUNCTIONS ARE COMPUTED AND
C  STORED IN WSAVE.
C
C  INPUT PARAMETER
C
C  N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N+1 IS A PRODUCT OF SMALL PRIMES.
C
C  OUTPUT PARAMETER
C
C  WSAVE   A WORK ARRAY WITH AT LEAST INT(3.5*N+16) LOCATIONS.
C          DIFFERENT WSAVE ARRAYS ARE REQUIRED FOR DIFFERENT VALUES
C          OF N.  THE CONTENTS OF WSAVE MUST NOT BE CHANGED BETWEEN
C          CALLS OF SINT.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTI
C***END PROLOGUE  SINTI
      DIMENSION       WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINTI
      PI = 4.*ATAN(1.)
      IF (N .LE. 1) RETURN
      NP1 = N+1
      NS2 = N/2
      DT = PI/REAL(NP1)
      KS = N+2
      KF = KS+NS2-1
      FK = 0.
      DO 101 K=KS,KF
         FK = FK+1.
         WSAVE(K) = 2.*SIN(FK*DT)
  101 CONTINUE
      CALL RFFTI (NP1,WSAVE(KF+1))
      RETURN
      END
      SUBROUTINE SINT(N,X,WSAVE)
C***BEGIN PROLOGUE  SINT
C***DATE WRITTEN   790601   (YYMMDD)
C***REVISION DATE  860115   (YYMMDD)
C***CATEGORY NO.  J1A3
C***KEYWORDS  FOURIER TRANSFORM
C***AUTHOR  SWARZTRAUBER, P. N., (NCAR)
C***PURPOSE  SINE TRANSFORM OF A REAL, ODD SEQUENCE.
C***DESCRIPTION
C
C  SUBROUTINE SINT COMPUTES THE DISCRETE FOURIER SINE TRANSFORM
C  OF AN ODD SEQUENCE X(I).  THE TRANSFORM IS DEFINED BELOW AT
C  OUTPUT PARAMETER X.
C
C  SINT IS THE UNNORMALIZED INVERSE OF ITSELF SINCE A CALL OF SINT
C  FOLLOWED BY ANOTHER CALL OF SINT WILL MULTIPLY THE INPUT SEQUENCE
C  X BY 2*(N+1).
C
C  THE ARRAY WSAVE WHICH IS USED BY SUBROUTINE SINT MUST BE
C  INITIALIZED BY CALLING SUBROUTINE SINTI(N,WSAVE).
C
C  INPUT PARAMETERS
C
C  N       THE LENGTH OF THE SEQUENCE TO BE TRANSFORMED.  THE METHOD
C          IS MOST EFFICIENT WHEN N+1 IS THE PRODUCT OF SMALL PRIMES.
C
C  X       AN ARRAY WHICH CONTAINS THE SEQUENCE TO BE TRANSFORMED
C
C
C  WSAVE   A WORK ARRAY WITH DIMENSION AT LEAST INT(3.5*N+16)
C          IN THE PROGRAM THAT CALLS SINT.  THE WSAVE ARRAY MUST BE
C          INITIALIZED BY CALLING SUBROUTINE SINTI(N,WSAVE), AND A
C          DIFFERENT WSAVE ARRAY MUST BE USED FOR EACH DIFFERENT
C          VALUE OF N.  THIS INITIALIZATION DOES NOT HAVE TO BE
C          REPEATED SO LONG AS N REMAINS UNCHANGED.  THUS SUBSEQUENT
C          TRANSFORMS CAN BE OBTAINED FASTER THAN THE FIRST.
C
C  OUTPUT PARAMETERS
C
C  X       FOR I=1,...,N
C
C               X(I)= THE SUM FROM K=1 TO K=N
C
C                    2*X(K)*SIN(K*I*PI/(N+1))
C
C               A CALL OF SINT FOLLOWED BY ANOTHER CALL OF
C               SINT WILL MULTIPLY THE SEQUENCE X BY 2*(N+1).
C               HENCE SINT IS THE UNNORMALIZED INVERSE
C               OF ITSELF.
C
C  WSAVE   CONTAINS INITIALIZATION CALCULATIONS WHICH MUST NOT BE
C          DESTROYED BETWEEN CALLS OF SINT.
C
C  *********************************************************************
C  *                                                                   *
C  *   SUBPROGRAM REVISION HISTORY                                     *
C  *                                                                   *
C  *   06/01/79  -  ORIGINAL VERSION BY PAUL SWARZTRAUBER.             *
C  *                DISTRIBUTED BY NCAR (REF. 1).                      *
C  *   04/01/83  -  SLATEC COMMON MATH LIBRARY SUBCOMMITTEE.           *
C  *                MODIFIED TO USE SLATEC LIBRARY SOURCE FILE FORMAT. *
C  *                DISTRIBUTED IN THE SLATEC LIBRARY (REF. 2).        *
C  *   01/15/86  -  RON BOISVERT, NATIONAL BUREAU OF STANDARDS.        *
C  *                MODIFIED TO CONVERT TO PORTABLE FORTRAN 77.        *
C  *                                                                   *
C  *   THE CHANGES INTRODUCED IN THE MOST RECENT MODIFICATION ARE      *
C  *                                                                   *
C  *   (A) DUMMY ARRAY SIZE DECLARATIONS (1) CHANGED TO (*)            *
C  *   (B) REFERENCES TO INTRINSIC FUNCTION FLOAT CHANGED TO REAL      *
C  *   (C) MATHEMATICAL CONSTANTS PREVIOUSLY CODED IN DATA STATE-      *
C  *       MENTS NOW COMPUTED AT RUNTIME USING FORTRAN INTRINSIC       *
C  *       FUNCTIONS.  THE AFFECTED VARIABLES ARE                      *
C  *                                                                   *
C  *          PI      SQRT2   SQRT3   TAUR    TR11    TR12             *
C  *          PIH     TSQRT2          TAUI    TI11    TI12             *
C  *          TPI     HSQT2                                            *
C  *                                                                   *
C  *   REFERENCES                                                      *
C  *                                                                   *
C  *   1. P.N. SWARZTRAUBER, VECTORIZING THE FFTS, IN PARALLEL         *
C  *      COMPUTATIONS (G. RODRIGUE, ED.), ACADEMIC PRESS, 1982,       *
C  *      PP. 51-83.                                                   *
C  *   2. B.L. BUZBEE, THE SLATEC COMMON MATH LIBRARY, IN SOURCES      *
C  *      AND DEVELOPMENT OF MATHEMATICAL SOFTWARE (W. COWELL, ED.),   *
C  *      PRENTICE-HALL, 1984, PP. 302-318.                            *
C  *                                                                   *
C  *********************************************************************
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  RFFTF
C***END PROLOGUE  SINT
      DIMENSION       X(*)       ,WSAVE(*)
C***FIRST EXECUTABLE STATEMENT  SINT
      SQRT3 = SQRT(3.)
      IF (N-2) 101,102,103
  101 X(1) = X(1)+X(1)
      RETURN
  102 XH = SQRT3*(X(1)+X(2))
      X(2) = SQRT3*(X(1)-X(2))
      X(1) = XH
      RETURN
  103 NP1 = N+1
      NS2 = N/2
      WSAVE(1) = 0.
      KW = NP1
      DO 104 K=1,NS2
1        KW = KW+1
         KC = NP1-K
         T1 = X(K)-X(KC)
         T2 = WSAVE(KW)*(X(K)+X(KC))
         WSAVE(K+1) = T1+T2
         WSAVE(KC+1) = T2-T1
  104 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .NE. 0) WSAVE(NS2+2) = 4.*X(NS2+1)
      NF = NP1+NS2+1
      CALL RFFTF (NP1,WSAVE,WSAVE(NF))
      X(1) = .5*WSAVE(1)
      DO 105 I=3,N,2
         X(I-1) = -WSAVE(I)
         X(I) = X(I-2)+WSAVE(I-1)
  105 CONTINUE
      IF (MODN .NE. 0) RETURN
      X(N) = -WSAVE(N+1)
      RETURN
      END
      SUBROUTINE COSQB1(N,X,W,XH)
C***BEGIN PROLOGUE  COSQB1
C***REFER TO  COSQB
C***ROUTINES CALLED  RFFTB
C***END PROLOGUE  COSQB1
      DIMENSION       X(*)       ,W(*)       ,XH(*)
C***FIRST EXECUTABLE STATEMENT  COSQB1
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 I=3,N,2
         XIM1 = X(I-1)+X(I)
         X(I) = X(I)-X(I-1)
         X(I-1) = XIM1
  101 CONTINUE
      X(1) = X(1)+X(1)
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) X(N) = X(N)+X(N)
      CALL RFFTB (N,X,XH)
      DO 102 K=2,NS2
         KC = NP2-K
         XH(K) = W(K-1)*X(KC)+W(KC-1)*X(K)
         XH(KC) = W(K-1)*X(K)-W(KC-1)*X(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*(X(NS2+1)+X(NS2+1))
      DO 103 K=2,NS2
         KC = NP2-K
         X(K) = XH(K)+XH(KC)
         X(KC) = XH(K)-XH(KC)
  103 CONTINUE
      X(1) = X(1)+X(1)
      RETURN
      END
      SUBROUTINE COSQF1(N,X,W,XH)
C***BEGIN PROLOGUE  COSQF1
C***REFER TO  COSQF
C***ROUTINES CALLED  RFFTF
C***END PROLOGUE  COSQF1
      DIMENSION       X(*)       ,W(*)       ,XH(*)
C***FIRST EXECUTABLE STATEMENT  COSQF1
      NS2 = (N+1)/2
      NP2 = N+2
      DO 101 K=2,NS2
         KC = NP2-K
         XH(K) = X(K)+X(KC)
         XH(KC) = X(K)-X(KC)
  101 CONTINUE
      MODN = MOD(N,2)
      IF (MODN .EQ. 0) XH(NS2+1) = X(NS2+1)+X(NS2+1)
      DO 102 K=2,NS2
         KC = NP2-K
         X(K) = W(K-1)*XH(KC)+W(KC-1)*XH(K)
         X(KC) = W(K-1)*XH(K)-W(KC-1)*XH(KC)
  102 CONTINUE
      IF (MODN .EQ. 0) X(NS2+1) = W(NS2)*XH(NS2+1)
      CALL RFFTF (N,X,XH)
      DO 103 I=3,N,2
         XIM1 = X(I-1)-X(I)
         X(I) = X(I-1)+X(I)
         X(I-1) = XIM1
  103 CONTINUE
      RETURN
      END
      SUBROUTINE RADBG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C***BEGIN PROLOGUE  RADBG
C***REFER TO  RFFTB
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADBG
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
C***FIRST EXECUTABLE STATEMENT  RADBG
      TPI = 8.*ATAN(1.)
      ARG = TPI/REAL(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IPP2 = IP+2
      IPPH = (IP+1)/2
      IF (IDO .LT. L1) GO TO 103
      DO 102 K=1,L1
         DO 101 I=1,IDO
            CH(I,K,1) = CC(I,1,K)
  101    CONTINUE
  102 CONTINUE
      GO TO 106
  103 DO 105 I=1,IDO
         DO 104 K=1,L1
            CH(I,K,1) = CC(I,1,K)
  104    CONTINUE
  105 CONTINUE
  106 DO 108 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 107 K=1,L1
            CH(1,K,J) = CC(IDO,J2-2,K)+CC(IDO,J2-2,K)
            CH(1,K,JC) = CC(1,J2-1,K)+CC(1,J2-1,K)
  107    CONTINUE
  108 CONTINUE
      IF (IDO .EQ. 1) GO TO 116
      IF (NBD .LT. L1) GO TO 112
      DO 111 J=2,IPPH
         JC = IPP2-J
         DO 110 K=1,L1
CDIR$ IVDEP
            DO 109 I=3,IDO,2
               IC = IDP2-I
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      GO TO 116
  112 DO 115 J=2,IPPH
         JC = IPP2-J
CDIR$ IVDEP
         DO 114 I=3,IDO,2
            IC = IDP2-I
            DO 113 K=1,L1
               CH(I-1,K,J) = CC(I-1,2*J-1,K)+CC(IC-1,2*J-2,K)
               CH(I-1,K,JC) = CC(I-1,2*J-1,K)-CC(IC-1,2*J-2,K)
               CH(I,K,J) = CC(I,2*J-1,K)-CC(IC,2*J-2,K)
               CH(I,K,JC) = CC(I,2*J-1,K)+CC(IC,2*J-2,K)
  113       CONTINUE
  114    CONTINUE
  115 CONTINUE
  116 AR1 = 1.
      AI1 = 0.
      DO 120 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 117 IK=1,IDL1
            C2(IK,L) = CH2(IK,1)+AR1*CH2(IK,2)
            C2(IK,LC) = AI1*CH2(IK,IP)
  117    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 119 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 118 IK=1,IDL1
               C2(IK,L) = C2(IK,L)+AR2*CH2(IK,J)
               C2(IK,LC) = C2(IK,LC)+AI2*CH2(IK,JC)
  118       CONTINUE
  119    CONTINUE
  120 CONTINUE
      DO 122 J=2,IPPH
         DO 121 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+CH2(IK,J)
  121    CONTINUE
  122 CONTINUE
      DO 124 J=2,IPPH
         JC = IPP2-J
         DO 123 K=1,L1
            CH(1,K,J) = C1(1,K,J)-C1(1,K,JC)
            CH(1,K,JC) = C1(1,K,J)+C1(1,K,JC)
  123    CONTINUE
  124 CONTINUE
      IF (IDO .EQ. 1) GO TO 132
      IF (NBD .LT. L1) GO TO 128
      DO 127 J=2,IPPH
         JC = IPP2-J
         DO 126 K=1,L1
CDIR$ IVDEP
            DO 125 I=3,IDO,2
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      GO TO 132
  128 DO 131 J=2,IPPH
         JC = IPP2-J
         DO 130 I=3,IDO,2
            DO 129 K=1,L1
               CH(I-1,K,J) = C1(I-1,K,J)-C1(I,K,JC)
               CH(I-1,K,JC) = C1(I-1,K,J)+C1(I,K,JC)
               CH(I,K,J) = C1(I,K,J)+C1(I-1,K,JC)
               CH(I,K,JC) = C1(I,K,J)-C1(I-1,K,JC)
  129       CONTINUE
  130    CONTINUE
  131 CONTINUE
  132 CONTINUE
      IF (IDO .EQ. 1) RETURN
      DO 133 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  133 CONTINUE
      DO 135 J=2,IP
         DO 134 K=1,L1
            C1(1,K,J) = CH(1,K,J)
  134    CONTINUE
  135 CONTINUE
      IF (NBD .GT. L1) GO TO 139
      IS = -IDO
      DO 138 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 137 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 136 K=1,L1
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  136       CONTINUE
  137    CONTINUE
  138 CONTINUE
      GO TO 143
  139 IS = -IDO
      DO 142 J=2,IP
         IS = IS+IDO
         DO 141 K=1,L1
            IDIJ = IS
CDIR$ IVDEP
            DO 140 I=3,IDO,2
               IDIJ = IDIJ+2
               C1(I-1,K,J) = WA(IDIJ-1)*CH(I-1,K,J)-WA(IDIJ)*CH(I,K,J)
               C1(I,K,J) = WA(IDIJ-1)*CH(I,K,J)+WA(IDIJ)*CH(I-1,K,J)
  140       CONTINUE
  141    CONTINUE
  142 CONTINUE
  143 RETURN
      END
      SUBROUTINE RADB2(IDO,L1,CC,CH,WA1)
C***BEGIN PROLOGUE  RADB2
C***REFER TO  RFFTB
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADB2
      DIMENSION       CC(IDO,2,L1)           ,CH(IDO,L1,2)           ,
     1                WA1(*)
C***FIRST EXECUTABLE STATEMENT  RADB2
      DO 101 K=1,L1
         CH(1,K,1) = CC(1,1,K)+CC(IDO,2,K)
         CH(1,K,2) = CC(1,1,K)-CC(IDO,2,K)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            CH(I-1,K,1) = CC(I-1,1,K)+CC(IC-1,2,K)
            TR2 = CC(I-1,1,K)-CC(IC-1,2,K)
            CH(I,K,1) = CC(I,1,K)-CC(IC,2,K)
            TI2 = CC(I,1,K)+CC(IC,2,K)
            CH(I-1,K,2) = WA1(I-2)*TR2-WA1(I-1)*TI2
            CH(I,K,2) = WA1(I-2)*TI2+WA1(I-1)*TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(IDO,K,1) = CC(IDO,1,K)+CC(IDO,1,K)
         CH(IDO,K,2) = -(CC(1,2,K)+CC(1,2,K))
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADB3(IDO,L1,CC,CH,WA1,WA2)
C***BEGIN PROLOGUE  RADB3
C***REFER TO  RFFTB
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADB3
      DIMENSION       CC(IDO,3,L1)           ,CH(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
C***FIRST EXECUTABLE STATEMENT  RADB3
      TAUR = -.5
      TAUI = .5*SQRT(3.)
      DO 101 K=1,L1
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         CR2 = CC(1,1,K)+TAUR*TR2
         CH(1,K,1) = CC(1,1,K)+TR2
         CI3 = TAUI*(CC(1,3,K)+CC(1,3,K))
         CH(1,K,2) = CR2-CI3
         CH(1,K,3) = CR2+CI3
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            CR2 = CC(I-1,1,K)+TAUR*TR2
            CH(I-1,K,1) = CC(I-1,1,K)+TR2
            TI2 = CC(I,3,K)-CC(IC,2,K)
            CI2 = CC(I,1,K)+TAUR*TI2
            CH(I,K,1) = CC(I,1,K)+TI2
            CR3 = TAUI*(CC(I-1,3,K)-CC(IC-1,2,K))
            CI3 = TAUI*(CC(I,3,K)+CC(IC,2,K))
            DR2 = CR2-CI3
            DR3 = CR2+CI3
            DI2 = CI2+CR3
            DI3 = CI2-CR3
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADB4(IDO,L1,CC,CH,WA1,WA2,WA3)
C***BEGIN PROLOGUE  RADB4
C***REFER TO  RFFTB
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADB4
      DIMENSION       CC(IDO,4,L1)           ,CH(IDO,L1,4)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
C***FIRST EXECUTABLE STATEMENT  RADB4
      SQRT2 = SQRT(2.)
      DO 101 K=1,L1
         TR1 = CC(1,1,K)-CC(IDO,4,K)
         TR2 = CC(1,1,K)+CC(IDO,4,K)
         TR3 = CC(IDO,2,K)+CC(IDO,2,K)
         TR4 = CC(1,3,K)+CC(1,3,K)
         CH(1,K,1) = TR2+TR3
         CH(1,K,2) = TR1-TR4
         CH(1,K,3) = TR2-TR3
         CH(1,K,4) = TR1+TR4
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            TI1 = CC(I,1,K)+CC(IC,4,K)
            TI2 = CC(I,1,K)-CC(IC,4,K)
            TI3 = CC(I,3,K)-CC(IC,2,K)
            TR4 = CC(I,3,K)+CC(IC,2,K)
            TR1 = CC(I-1,1,K)-CC(IC-1,4,K)
            TR2 = CC(I-1,1,K)+CC(IC-1,4,K)
            TI4 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR3 = CC(I-1,3,K)+CC(IC-1,2,K)
            CH(I-1,K,1) = TR2+TR3
            CR3 = TR2-TR3
            CH(I,K,1) = TI2+TI3
            CI3 = TI2-TI3
            CR2 = TR1-TR4
            CR4 = TR1+TR4
            CI2 = TI1+TI4
            CI4 = TI1-TI4
            CH(I-1,K,2) = WA1(I-2)*CR2-WA1(I-1)*CI2
            CH(I,K,2) = WA1(I-2)*CI2+WA1(I-1)*CR2
            CH(I-1,K,3) = WA2(I-2)*CR3-WA2(I-1)*CI3
            CH(I,K,3) = WA2(I-2)*CI3+WA2(I-1)*CR3
            CH(I-1,K,4) = WA3(I-2)*CR4-WA3(I-1)*CI4
            CH(I,K,4) = WA3(I-2)*CI4+WA3(I-1)*CR4
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = CC(1,2,K)+CC(1,4,K)
         TI2 = CC(1,4,K)-CC(1,2,K)
         TR1 = CC(IDO,1,K)-CC(IDO,3,K)
         TR2 = CC(IDO,1,K)+CC(IDO,3,K)
         CH(IDO,K,1) = TR2+TR2
         CH(IDO,K,2) = SQRT2*(TR1-TI1)
         CH(IDO,K,3) = TI2+TI2
         CH(IDO,K,4) = -SQRT2*(TR1+TI1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADB5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C***BEGIN PROLOGUE  RADB5
C***REFER TO  RFFTB
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADB5
      DIMENSION       CC(IDO,5,L1)           ,CH(IDO,L1,5)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
C***FIRST EXECUTABLE STATEMENT  RADB5
      PI = 4.*ATAN(1.)
      TR11 = SIN(.1*PI)
      TI11 = SIN(.4*PI)
      TR12 = -SIN(.3*PI)
      TI12 = SIN(.2*PI)
      DO 101 K=1,L1
         TI5 = CC(1,3,K)+CC(1,3,K)
         TI4 = CC(1,5,K)+CC(1,5,K)
         TR2 = CC(IDO,2,K)+CC(IDO,2,K)
         TR3 = CC(IDO,4,K)+CC(IDO,4,K)
         CH(1,K,1) = CC(1,1,K)+TR2+TR3
         CR2 = CC(1,1,K)+TR11*TR2+TR12*TR3
         CR3 = CC(1,1,K)+TR12*TR2+TR11*TR3
         CI5 = TI11*TI5+TI12*TI4
         CI4 = TI12*TI5-TI11*TI4
         CH(1,K,2) = CR2-CI5
         CH(1,K,3) = CR3-CI4
         CH(1,K,4) = CR3+CI4
         CH(1,K,5) = CR2+CI5
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            TI5 = CC(I,3,K)+CC(IC,2,K)
            TI2 = CC(I,3,K)-CC(IC,2,K)
            TI4 = CC(I,5,K)+CC(IC,4,K)
            TI3 = CC(I,5,K)-CC(IC,4,K)
            TR5 = CC(I-1,3,K)-CC(IC-1,2,K)
            TR2 = CC(I-1,3,K)+CC(IC-1,2,K)
            TR4 = CC(I-1,5,K)-CC(IC-1,4,K)
            TR3 = CC(I-1,5,K)+CC(IC-1,4,K)
            CH(I-1,K,1) = CC(I-1,1,K)+TR2+TR3
            CH(I,K,1) = CC(I,1,K)+TI2+TI3
            CR2 = CC(I-1,1,K)+TR11*TR2+TR12*TR3
            CI2 = CC(I,1,K)+TR11*TI2+TR12*TI3
            CR3 = CC(I-1,1,K)+TR12*TR2+TR11*TR3
            CI3 = CC(I,1,K)+TR12*TI2+TR11*TI3
            CR5 = TI11*TR5+TI12*TR4
            CI5 = TI11*TI5+TI12*TI4
            CR4 = TI12*TR5-TI11*TR4
            CI4 = TI12*TI5-TI11*TI4
            DR3 = CR3-CI4
            DR4 = CR3+CI4
            DI3 = CI3+CR4
            DI4 = CI3-CR4
            DR5 = CR2+CI5
            DR2 = CR2-CI5
            DI5 = CI2-CR5
            DI2 = CI2+CR5
            CH(I-1,K,2) = WA1(I-2)*DR2-WA1(I-1)*DI2
            CH(I,K,2) = WA1(I-2)*DI2+WA1(I-1)*DR2
            CH(I-1,K,3) = WA2(I-2)*DR3-WA2(I-1)*DI3
            CH(I,K,3) = WA2(I-2)*DI3+WA2(I-1)*DR3
            CH(I-1,K,4) = WA3(I-2)*DR4-WA3(I-1)*DI4
            CH(I,K,4) = WA3(I-2)*DI4+WA3(I-1)*DR4
            CH(I-1,K,5) = WA4(I-2)*DR5-WA4(I-1)*DI5
            CH(I,K,5) = WA4(I-2)*DI5+WA4(I-1)*DR5
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADFG(IDO,IP,L1,IDL1,CC,C1,C2,CH,CH2,WA)
C***BEGIN PROLOGUE  RADFG
C***REFER TO  RFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADFG
      DIMENSION       CH(IDO,L1,IP)          ,CC(IDO,IP,L1)          ,
     1                C1(IDO,L1,IP)          ,C2(IDL1,IP),
     2                CH2(IDL1,IP)           ,WA(*)
C***FIRST EXECUTABLE STATEMENT  RADFG
      TPI = 8.*ATAN(1.)
      ARG = TPI/REAL(IP)
      DCP = COS(ARG)
      DSP = SIN(ARG)
      IPPH = (IP+1)/2
      IPP2 = IP+2
      IDP2 = IDO+2
      NBD = (IDO-1)/2
      IF (IDO .EQ. 1) GO TO 119
      DO 101 IK=1,IDL1
         CH2(IK,1) = C2(IK,1)
  101 CONTINUE
      DO 103 J=2,IP
         DO 102 K=1,L1
            CH(1,K,J) = C1(1,K,J)
  102    CONTINUE
  103 CONTINUE
      IF (NBD .GT. L1) GO TO 107
      IS = -IDO
      DO 106 J=2,IP
         IS = IS+IDO
         IDIJ = IS
         DO 105 I=3,IDO,2
            IDIJ = IDIJ+2
            DO 104 K=1,L1
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  104       CONTINUE
  105    CONTINUE
  106 CONTINUE
      GO TO 111
  107 IS = -IDO
      DO 110 J=2,IP
         IS = IS+IDO
         DO 109 K=1,L1
            IDIJ = IS
CDIR$ IVDEP
            DO 108 I=3,IDO,2
               IDIJ = IDIJ+2
               CH(I-1,K,J) = WA(IDIJ-1)*C1(I-1,K,J)+WA(IDIJ)*C1(I,K,J)
               CH(I,K,J) = WA(IDIJ-1)*C1(I,K,J)-WA(IDIJ)*C1(I-1,K,J)
  108       CONTINUE
  109    CONTINUE
  110 CONTINUE
  111 IF (NBD .LT. L1) GO TO 115
      DO 114 J=2,IPPH
         JC = IPP2-J
         DO 113 K=1,L1
CDIR$ IVDEP
            DO 112 I=3,IDO,2
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  112       CONTINUE
  113    CONTINUE
  114 CONTINUE
      GO TO 121
  115 DO 118 J=2,IPPH
         JC = IPP2-J
         DO 117 I=3,IDO,2
            DO 116 K=1,L1
               C1(I-1,K,J) = CH(I-1,K,J)+CH(I-1,K,JC)
               C1(I-1,K,JC) = CH(I,K,J)-CH(I,K,JC)
               C1(I,K,J) = CH(I,K,J)+CH(I,K,JC)
               C1(I,K,JC) = CH(I-1,K,JC)-CH(I-1,K,J)
  116       CONTINUE
  117    CONTINUE
  118 CONTINUE
      GO TO 121
  119 DO 120 IK=1,IDL1
         C2(IK,1) = CH2(IK,1)
  120 CONTINUE
  121 DO 123 J=2,IPPH
         JC = IPP2-J
         DO 122 K=1,L1
            C1(1,K,J) = CH(1,K,J)+CH(1,K,JC)
            C1(1,K,JC) = CH(1,K,JC)-CH(1,K,J)
  122    CONTINUE
  123 CONTINUE
C
      AR1 = 1.
      AI1 = 0.
      DO 127 L=2,IPPH
         LC = IPP2-L
         AR1H = DCP*AR1-DSP*AI1
         AI1 = DCP*AI1+DSP*AR1
         AR1 = AR1H
         DO 124 IK=1,IDL1
            CH2(IK,L) = C2(IK,1)+AR1*C2(IK,2)
            CH2(IK,LC) = AI1*C2(IK,IP)
  124    CONTINUE
         DC2 = AR1
         DS2 = AI1
         AR2 = AR1
         AI2 = AI1
         DO 126 J=3,IPPH
            JC = IPP2-J
            AR2H = DC2*AR2-DS2*AI2
            AI2 = DC2*AI2+DS2*AR2
            AR2 = AR2H
            DO 125 IK=1,IDL1
               CH2(IK,L) = CH2(IK,L)+AR2*C2(IK,J)
               CH2(IK,LC) = CH2(IK,LC)+AI2*C2(IK,JC)
  125       CONTINUE
  126    CONTINUE
  127 CONTINUE
      DO 129 J=2,IPPH
         DO 128 IK=1,IDL1
            CH2(IK,1) = CH2(IK,1)+C2(IK,J)
  128    CONTINUE
  129 CONTINUE
C
      IF (IDO .LT. L1) GO TO 132
      DO 131 K=1,L1
         DO 130 I=1,IDO
            CC(I,1,K) = CH(I,K,1)
  130    CONTINUE
  131 CONTINUE
      GO TO 135
  132 DO 134 I=1,IDO
         DO 133 K=1,L1
            CC(I,1,K) = CH(I,K,1)
  133    CONTINUE
  134 CONTINUE
  135 DO 137 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 136 K=1,L1
            CC(IDO,J2-2,K) = CH(1,K,J)
            CC(1,J2-1,K) = CH(1,K,JC)
  136    CONTINUE
  137 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IF (NBD .LT. L1) GO TO 141
      DO 140 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 139 K=1,L1
CDIR$ IVDEP
            DO 138 I=3,IDO,2
               IC = IDP2-I
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  138       CONTINUE
  139    CONTINUE
  140 CONTINUE
      RETURN
  141 DO 144 J=2,IPPH
         JC = IPP2-J
         J2 = J+J
         DO 143 I=3,IDO,2
            IC = IDP2-I
            DO 142 K=1,L1
               CC(I-1,J2-1,K) = CH(I-1,K,J)+CH(I-1,K,JC)
               CC(IC-1,J2-2,K) = CH(I-1,K,J)-CH(I-1,K,JC)
               CC(I,J2-1,K) = CH(I,K,J)+CH(I,K,JC)
               CC(IC,J2-2,K) = CH(I,K,JC)-CH(I,K,J)
  142       CONTINUE
  143    CONTINUE
  144 CONTINUE
      RETURN
      END
      SUBROUTINE RADF2(IDO,L1,CC,CH,WA1)
C***BEGIN PROLOGUE  RADF2
C***REFER TO  RFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADF2
      DIMENSION       CH(IDO,2,L1)           ,CC(IDO,L1,2)           ,
     1                WA1(*)
C***FIRST EXECUTABLE STATEMENT  RADF2
      DO 101 K=1,L1
         CH(1,1,K) = CC(1,K,1)+CC(1,K,2)
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 108
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  103    CONTINUE
  104 CONTINUE
      GO TO 111
  108 DO 110 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 109 K=1,L1
            TR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            TI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CH(I,1,K) = CC(I,K,1)+TI2
            CH(IC,2,K) = TI2-CC(I,K,1)
            CH(I-1,1,K) = CC(I-1,K,1)+TR2
            CH(IC-1,2,K) = CC(I-1,K,1)-TR2
  109    CONTINUE
  110 CONTINUE
  111 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         CH(1,2,K) = -CC(IDO,K,2)
         CH(IDO,1,K) = CC(IDO,K,1)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF3(IDO,L1,CC,CH,WA1,WA2)
C***BEGIN PROLOGUE  RADF3
C***REFER TO  RFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADF3
      DIMENSION       CH(IDO,3,L1)           ,CC(IDO,L1,3)           ,
     1                WA1(*)     ,WA2(*)
C***FIRST EXECUTABLE STATEMENT  RADF3
      TAUR = -.5
      TAUI = .5*SQRT(3.)
      DO 101 K=1,L1
         CR2 = CC(1,K,2)+CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2
         CH(1,3,K) = TAUI*(CC(1,K,3)-CC(1,K,2))
         CH(IDO,2,K) = CC(1,K,1)+TAUR*CR2
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR2 = DR2+DR3
            CI2 = DI2+DI3
            CH(I-1,1,K) = CC(I-1,K,1)+CR2
            CH(I,1,K) = CC(I,K,1)+CI2
            TR2 = CC(I-1,K,1)+TAUR*CR2
            TI2 = CC(I,K,1)+TAUR*CI2
            TR3 = TAUI*(DI2-DI3)
            TI3 = TAUI*(DR3-DR2)
            CH(I-1,3,K) = TR2+TR3
            CH(IC-1,2,K) = TR2-TR3
            CH(I,3,K) = TI2+TI3
            CH(IC,2,K) = TI3-TI2
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RADF4(IDO,L1,CC,CH,WA1,WA2,WA3)
C***BEGIN PROLOGUE  RADF4
C***REFER TO  RFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADF4
      DIMENSION       CC(IDO,L1,4)           ,CH(IDO,4,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)
C***FIRST EXECUTABLE STATEMENT  RADF4
      HSQT2 = .5*SQRT(2.)
      DO 101 K=1,L1
         TR1 = CC(1,K,2)+CC(1,K,4)
         TR2 = CC(1,K,1)+CC(1,K,3)
         CH(1,1,K) = TR1+TR2
         CH(IDO,4,K) = TR2-TR1
         CH(IDO,2,K) = CC(1,K,1)-CC(1,K,3)
         CH(1,3,K) = CC(1,K,4)-CC(1,K,2)
  101 CONTINUE
      IF (IDO-2) 107,105,102
  102 IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 111
      DO 104 K=1,L1
CDIR$ IVDEP
         DO 103 I=3,IDO,2
            IC = IDP2-I
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  103    CONTINUE
  104 CONTINUE
      GO TO 110
  111 DO 109 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 108 K=1,L1
            CR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            CI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            CR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            CI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            CR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            CI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            TR1 = CR2+CR4
            TR4 = CR4-CR2
            TI1 = CI2+CI4
            TI4 = CI2-CI4
            TI2 = CC(I,K,1)+CI3
            TI3 = CC(I,K,1)-CI3
            TR2 = CC(I-1,K,1)+CR3
            TR3 = CC(I-1,K,1)-CR3
            CH(I-1,1,K) = TR1+TR2
            CH(IC-1,4,K) = TR2-TR1
            CH(I,1,K) = TI1+TI2
            CH(IC,4,K) = TI1-TI2
            CH(I-1,3,K) = TI4+TR3
            CH(IC-1,2,K) = TR3-TI4
            CH(I,3,K) = TR4+TI3
            CH(IC,2,K) = TR4-TI3
  108    CONTINUE
  109 CONTINUE
  110 IF (MOD(IDO,2) .EQ. 1) RETURN
  105 DO 106 K=1,L1
         TI1 = -HSQT2*(CC(IDO,K,2)+CC(IDO,K,4))
         TR1 = HSQT2*(CC(IDO,K,2)-CC(IDO,K,4))
         CH(IDO,1,K) = TR1+CC(IDO,K,1)
         CH(IDO,3,K) = CC(IDO,K,1)-TR1
         CH(1,2,K) = TI1-CC(IDO,K,3)
         CH(1,4,K) = TI1+CC(IDO,K,3)
  106 CONTINUE
  107 RETURN
      END
      SUBROUTINE RADF5(IDO,L1,CC,CH,WA1,WA2,WA3,WA4)
C***BEGIN PROLOGUE  RADF5
C***REFER TO  RFFTF
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RADF5
      DIMENSION       CC(IDO,L1,5)           ,CH(IDO,5,L1)           ,
     1                WA1(*)     ,WA2(*)     ,WA3(*)     ,WA4(*)
C***FIRST EXECUTABLE STATEMENT  RADF5
      PI = 4.*ATAN(1.)
      TR11 = SIN(.1*PI)
      TI11 = SIN(.4*PI)
      TR12 = -SIN(.3*PI)
      TI12 = SIN(.2*PI)
      DO 101 K=1,L1
         CR2 = CC(1,K,5)+CC(1,K,2)
         CI5 = CC(1,K,5)-CC(1,K,2)
         CR3 = CC(1,K,4)+CC(1,K,3)
         CI4 = CC(1,K,4)-CC(1,K,3)
         CH(1,1,K) = CC(1,K,1)+CR2+CR3
         CH(IDO,2,K) = CC(1,K,1)+TR11*CR2+TR12*CR3
         CH(1,3,K) = TI11*CI5+TI12*CI4
         CH(IDO,4,K) = CC(1,K,1)+TR12*CR2+TR11*CR3
         CH(1,5,K) = TI12*CI5-TI11*CI4
  101 CONTINUE
      IF (IDO .EQ. 1) RETURN
      IDP2 = IDO+2
      IF((IDO-1)/2.LT.L1) GO TO 104
      DO 103 K=1,L1
CDIR$ IVDEP
         DO 102 I=3,IDO,2
            IC = IDP2-I
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  102    CONTINUE
  103 CONTINUE
      RETURN
  104 DO 106 I=3,IDO,2
         IC = IDP2-I
CDIR$ IVDEP
         DO 105 K=1,L1
            DR2 = WA1(I-2)*CC(I-1,K,2)+WA1(I-1)*CC(I,K,2)
            DI2 = WA1(I-2)*CC(I,K,2)-WA1(I-1)*CC(I-1,K,2)
            DR3 = WA2(I-2)*CC(I-1,K,3)+WA2(I-1)*CC(I,K,3)
            DI3 = WA2(I-2)*CC(I,K,3)-WA2(I-1)*CC(I-1,K,3)
            DR4 = WA3(I-2)*CC(I-1,K,4)+WA3(I-1)*CC(I,K,4)
            DI4 = WA3(I-2)*CC(I,K,4)-WA3(I-1)*CC(I-1,K,4)
            DR5 = WA4(I-2)*CC(I-1,K,5)+WA4(I-1)*CC(I,K,5)
            DI5 = WA4(I-2)*CC(I,K,5)-WA4(I-1)*CC(I-1,K,5)
            CR2 = DR2+DR5
            CI5 = DR5-DR2
            CR5 = DI2-DI5
            CI2 = DI2+DI5
            CR3 = DR3+DR4
            CI4 = DR4-DR3
            CR4 = DI3-DI4
            CI3 = DI3+DI4
            CH(I-1,1,K) = CC(I-1,K,1)+CR2+CR3
            CH(I,1,K) = CC(I,K,1)+CI2+CI3
            TR2 = CC(I-1,K,1)+TR11*CR2+TR12*CR3
            TI2 = CC(I,K,1)+TR11*CI2+TR12*CI3
            TR3 = CC(I-1,K,1)+TR12*CR2+TR11*CR3
            TI3 = CC(I,K,1)+TR12*CI2+TR11*CI3
            TR5 = TI11*CR5+TI12*CR4
            TI5 = TI11*CI5+TI12*CI4
            TR4 = TI12*CR5-TI11*CR4
            TI4 = TI12*CI5-TI11*CI4
            CH(I-1,3,K) = TR2+TR5
            CH(IC-1,2,K) = TR2-TR5
            CH(I,3,K) = TI2+TI5
            CH(IC,2,K) = TI5-TI2
            CH(I-1,5,K) = TR3+TR4
            CH(IC-1,4,K) = TR3-TR4
            CH(I,5,K) = TI3+TI4
            CH(IC,4,K) = TI4-TI3
  105    CONTINUE
  106 CONTINUE
      RETURN
      END
      SUBROUTINE RFFTB1(N,C,CH,WA,IFAC)
C***BEGIN PROLOGUE  RFFTB1
C***REFER TO  RFFTB
C***ROUTINES CALLED  RADB2,RADB3,RADB4,RADB5,RADBG
C***END PROLOGUE  RFFTB1
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTB1
      NF = IFAC(2)
      NA = 0
      L1 = 1
      IW = 1
      DO 116 K1=1,NF
         IP = IFAC(K1+2)
         L2 = IP*L1
         IDO = N/L2
         IDL1 = IDO*L1
         IF (IP .NE. 4) GO TO 103
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADB4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 102
  101    CALL RADB4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
  102    NA = 1-NA
         GO TO 115
  103    IF (IP .NE. 2) GO TO 106
         IF (NA .NE. 0) GO TO 104
         CALL RADB2 (IDO,L1,C,CH,WA(IW))
         GO TO 105
  104    CALL RADB2 (IDO,L1,CH,C,WA(IW))
  105    NA = 1-NA
         GO TO 115
  106    IF (IP .NE. 3) GO TO 109
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADB3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 108
  107    CALL RADB3 (IDO,L1,CH,C,WA(IW),WA(IX2))
  108    NA = 1-NA
         GO TO 115
  109    IF (IP .NE. 5) GO TO 112
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 110
         CALL RADB5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 111
  110    CALL RADB5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
  111    NA = 1-NA
         GO TO 115
  112    IF (NA .NE. 0) GO TO 113
         CALL RADBG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         GO TO 114
  113    CALL RADBG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
  114    IF (IDO .EQ. 1) NA = 1-NA
  115    L1 = L2
         IW = IW+(IP-1)*IDO
  116 CONTINUE
      IF (NA .EQ. 0) RETURN
      DO 117 I=1,N
         C(I) = CH(I)
  117 CONTINUE
      RETURN
      END
      SUBROUTINE RFFTF1(N,C,CH,WA,IFAC)
C***BEGIN PROLOGUE  RFFTF1
C***REFER TO  RFFTF
C***ROUTINES CALLED  RADF2,RADF3,RADF4,RADF5,RADFG
C***END PROLOGUE  RFFTF1
      DIMENSION       CH(*)      ,C(*)       ,WA(*)      ,IFAC(*)
C***FIRST EXECUTABLE STATEMENT  RFFTF1
      NF = IFAC(2)
      NA = 1
      L2 = N
      IW = N
      DO 111 K1=1,NF
         KH = NF-K1
         IP = IFAC(KH+3)
         L1 = L2/IP
         IDO = N/L2
         IDL1 = IDO*L1
         IW = IW-(IP-1)*IDO
         NA = 1-NA
         IF (IP .NE. 4) GO TO 102
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IF (NA .NE. 0) GO TO 101
         CALL RADF4 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  101    CALL RADF4 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3))
         GO TO 110
  102    IF (IP .NE. 2) GO TO 104
         IF (NA .NE. 0) GO TO 103
         CALL RADF2 (IDO,L1,C,CH,WA(IW))
         GO TO 110
  103    CALL RADF2 (IDO,L1,CH,C,WA(IW))
         GO TO 110
  104    IF (IP .NE. 3) GO TO 106
         IX2 = IW+IDO
         IF (NA .NE. 0) GO TO 105
         CALL RADF3 (IDO,L1,C,CH,WA(IW),WA(IX2))
         GO TO 110
  105    CALL RADF3 (IDO,L1,CH,C,WA(IW),WA(IX2))
         GO TO 110
  106    IF (IP .NE. 5) GO TO 108
         IX2 = IW+IDO
         IX3 = IX2+IDO
         IX4 = IX3+IDO
         IF (NA .NE. 0) GO TO 107
         CALL RADF5 (IDO,L1,C,CH,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  107    CALL RADF5 (IDO,L1,CH,C,WA(IW),WA(IX2),WA(IX3),WA(IX4))
         GO TO 110
  108    IF (IDO .EQ. 1) NA = 1-NA
         IF (NA .NE. 0) GO TO 109
         CALL RADFG (IDO,IP,L1,IDL1,C,C,C,CH,CH,WA(IW))
         NA = 1
         GO TO 110
  109    CALL RADFG (IDO,IP,L1,IDL1,CH,CH,CH,C,C,WA(IW))
         NA = 0
  110    L2 = L1
  111 CONTINUE
      IF (NA .EQ. 1) RETURN
      DO 112 I=1,N
         C(I) = CH(I)
  112 CONTINUE
      RETURN
      END
      SUBROUTINE RFFTI1(N,WA,IFAC)
C***BEGIN PROLOGUE  RFFTI1
C***REFER TO  RFFTI
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  RFFTI1
      DIMENSION       WA(*)      ,IFAC(*)    ,NTRYH(4)
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C***FIRST EXECUTABLE STATEMENT  RFFTI1
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      TPI = 8.*ATAN(1.)
      ARGH = TPI/REAL(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = IFAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = REAL(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
               WA(I-1) = COS(ARG)
               WA(I) = SIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END
      REAL FUNCTION R1MACH(I)
C***BEGIN PROLOGUE  R1MACH
C***DATE WRITTEN   790101   (YYMMDD)
C***REVISION DATE  831014   (YYMMDD)
C***CATEGORY NO.  R1
C***KEYWORDS  MACHINE CONSTANTS
C***AUTHOR  FOX, P. A., (BELL LABS)
C           HALL, A. D., (BELL LABS)
C           SCHRYER, N. L., (BELL LABS)
C***PURPOSE  RETURNS SINGLE PRECISION MACHINE DEPENDENT CONSTANTS
C***DESCRIPTION
C
C     R1MACH CAN BE USED TO OBTAIN MACHINE-DEPENDENT PARAMETERS
C     FOR THE LOCAL MACHINE ENVIRONMENT.  IT IS A FUNCTION
C     SUBROUTINE WITH ONE (INPUT) ARGUMENT, AND CAN BE CALLED
C     AS FOLLOWS, FOR EXAMPLE
C
C          A = R1MACH(I)
C
C     WHERE I=1,...,5.  THE (OUTPUT) VALUE OF A ABOVE IS
C     DETERMINED BY THE (INPUT) VALUE OF I.  THE RESULTS FOR
C     VARIOUS VALUES OF I ARE DISCUSSED BELOW.
C
C  SINGLE-PRECISION MACHINE CONSTANTS
C  R1MACH(1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
C  R1MACH(2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
C  R1MACH(3) = B**(-T), THE SMALLEST RELATIVE SPACING.
C  R1MACH(4) = B**(1-T), THE LARGEST RELATIVE SPACING.
C  R1MACH(5) = LOG10(B)
C***REFERENCES  FOX, P.A., HALL, A.D., SCHRYER, N.L, *FRAMEWORK FOR
C                 A PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHE-
C                 MATICAL SOFTWARE, VOL. 4, NO. 2, JUNE 1978,
C                 PP. 177-188.
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  R1MACH
C
      INTEGER SMALL(2)
      INTEGER LARGE(2)
      INTEGER RIGHT(2)
      INTEGER DIVER(2)
      INTEGER LOG10(2)
C
      REAL RMACH(5)
C
      EQUIVALENCE (RMACH(1),SMALL(1))
      EQUIVALENCE (RMACH(2),LARGE(1))
      EQUIVALENCE (RMACH(3),RIGHT(1))
      EQUIVALENCE (RMACH(4),DIVER(1))
      EQUIVALENCE (RMACH(5),LOG10(1))
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
C
C     DATA RMACH(1) / Z400800000 /
C     DATA RMACH(2) / Z5FFFFFFFF /
C     DATA RMACH(3) / Z4E9800000 /
C     DATA RMACH(4) / Z4EA800000 /
C     DATA RMACH(5) / Z500E730E8 /
C
C     MACHINE CONSTANTS FOR THE BURROUGHS 5700/6700/7700 SYSTEMS.
C
C     DATA RMACH(1) / O1771000000000000 /
C     DATA RMACH(2) / O0777777777777777 /
C     DATA RMACH(3) / O1311000000000000 /
C     DATA RMACH(4) / O1301000000000000 /
C     DATA RMACH(5) / O1157163034761675 /
C
C
C     MACHINE CONSTANTS FOR THE CDC CYBER 170 SERIES (FTN5).
C
      DATA RMACH(1) / O"00014000000000000000" /
      DATA RMACH(2) / O"37767777777777777777" /
      DATA RMACH(3) / O"16404000000000000000" /
      DATA RMACH(4) / O"16414000000000000000" /
      DATA RMACH(5) / O"17164642023241175720" /
C
C     MACHINE CONSTANTS FOR THE CDC CYBER 200 SERIES
C
C     DATA RMACH(1) / X'9000400000000000' /
C     DATA RMACH(2) / X'6FFF7FFFFFFFFFFF' /
C     DATA RMACH(3) / X'FFA3400000000000' /
C     DATA RMACH(4) / X'FFA4400000000000' /
C     DATA RMACH(5) / X'FFD04D104D427DE8' /
C
C     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES.
C
C     DATA RMACH(1) / 00564000000000000000B /
C     DATA RMACH(2) / 37767777777777777776B /
C     DATA RMACH(3) / 16414000000000000000B /
C     DATA RMACH(4) / 16424000000000000000B /
C     DATA RMACH(5) / 17164642023241175720B /
C
C     MACHINE CONSTANTS FOR THE CRAY 1
C
C     DATA RMACH(1) / 200034000000000000000B /
C     DATA RMACH(2) / 577767777777777777776B /
C     DATA RMACH(3) / 377224000000000000000B /
C     DATA RMACH(4) / 377234000000000000000B /
C     DATA RMACH(5) / 377774642023241175720B /
C
C     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
C
C     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
C     STATIC RMACH(5)
C
C     DATA SMALL/20K,0/,LARGE/77777K,177777K/
C     DATA RIGHT/35420K,0/,DIVER/36020K,0/
C     DATA LOG10/40423K,42023K/
C
C     MACHINE CONSTANTS FOR THE HARRIS 220
C
C     DATA SMALL(1),SMALL(2) / '20000000, '00000201 /
C     DATA LARGE(1),LARGE(2) / '37777777, '00000177 /
C     DATA RIGHT(1),RIGHT(2) / '20000000, '00000352 /
C     DATA DIVER(1),DIVER(2) / '20000000, '00000353 /
C     DATA LOG10(1),LOG10(2) / '23210115, '00000377 /
C
C     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES.
C
C     DATA RMACH(1) / O402400000000 /
C     DATA RMACH(2) / O376777777777 /
C     DATA RMACH(3) / O714400000000 /
C     DATA RMACH(4) / O716400000000 /
C     DATA RMACH(5) / O776464202324 /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C
C     3 WORD DOUBLE PRECISION WITH FTN4
C
C     DATA SMALL(1), SMALL(2) / 40000B,       1 /
C     DATA LARGE(1), LARGE(2) / 77777B, 177776B /
C     DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C     DATA DIVER(1), DIVER(2) / 40000B,    327B /
C     DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     MACHINE CONSTANTS FOR THE HP 2100
C     4 WORD DOUBLE PRECISION WITH FTN4
C
C     DATA SMALL(1), SMALL(2) / 40000B,       1 /
C     DATA LARGE91), LARGE(2) / 77777B, 177776B /
C     DATA RIGHT(1), RIGHT(2) / 40000B,    325B /
C     DATA DIVER(1), DIVER(2) / 40000B,    327B /
C     DATA LOG10(1), LOG10(2) / 46420B,  46777B /
C
C     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
C     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86  AND
C     THE PERKIN ELMER (INTERDATA) 7/32.
C
C     DATA RMACH(1) / Z00100000 /
C     DATA RMACH(2) / Z7FFFFFFF /
C     DATA RMACH(3) / Z3B100000 /
C     DATA RMACH(4) / Z3C100000 /
C     DATA RMACH(5) / Z41134413 /
C
C     MACHINE CONSTANTS FOR THE PDP-10 (KA OR KI PROCESSOR).
C
C     DATA RMACH(1) / "000400000000 /
C     DATA RMACH(2) / "377777777777 /
C     DATA RMACH(3) / "146400000000 /
C     DATA RMACH(4) / "147400000000 /
C     DATA RMACH(5) / "177464202324 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1) /    8388608 /
C     DATA LARGE(1) / 2147483647 /
C     DATA RIGHT(1) /  880803840 /
C     DATA DIVER(1) /  889192448 /
C     DATA LOG10(1) / 1067065499 /
C
C     DATA RMACH(1) / O00040000000 /
C     DATA RMACH(2) / O17777777777 /
C     DATA RMACH(3) / O06440000000 /
C     DATA RMACH(4) / O06500000000 /
C     DATA RMACH(5) / O07746420233 /
C
C     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
C     16-BIT INTEGERS  (EXPRESSED IN INTEGER AND OCTAL).
C
C     DATA SMALL(1),SMALL(2) /   128,     0 /
C     DATA LARGE(1),LARGE(2) / 32767,    -1 /
C     DATA RIGHT(1),RIGHT(2) / 13440,     0 /
C     DATA DIVER(1),DIVER(2) / 13568,     0 /
C     DATA LOG10(1),LOG10(2) / 16282,  8347 /
C
C     DATA SMALL(1),SMALL(2) / O000200, O000000 /
C     DATA LARGE(1),LARGE(2) / O077777, O177777 /
C     DATA RIGHT(1),RIGHT(2) / O032200, O000000 /
C     DATA DIVER(1),DIVER(2) / O032400, O000000 /
C     DATA LOG10(1),LOG10(2) / O037632, O020233 /
C
C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
C
C     DATA RMACH(1) / O000400000000 /
C     DATA RMACH(2) / O377777777777 /
C     DATA RMACH(3) / O146400000000 /
C     DATA RMACH(4) / O147400000000 /
C     DATA RMACH(5) / O177464202324 /
C
C     MACHINE CONSTANTS FOR THE VAX 11/780
C    (EXPRESSED IN INTEGER AND HEXADECIMAL)
C  ***THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS***
C  *** THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS***
C
C     DATA SMALL(1) /       128 /
C     DATA LARGE(1) /    -32769 /
C     DATA RIGHT(1) /     13440 /
C     DATA DIVER(1) /     13568 /
C     DATA LOG10(1) / 547045274 /
C
C     DATA SMALL(1) / Z00000080 /
C     DATA LARGE(1) / ZFFFF7FFF /
C     DATA RIGHT(1) / Z00003480 /
C     DATA DIVER(1) / Z00003500 /
C     DATA LOG10(1) / Z209B3F9A /
C
C     MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
C
C     DATA SMALL(1),SMALL(2) /     0,    256/
C     DATA LARGE(1),LARGE(2) /    -1,   -129/
C     DATA RIGHT(1),RIGHT(2) /     0,  26880/
C     DATA DIVER(1),DIVER(2) /     0,  27136/
C     DATA LOG10(1),LOG10(2) /  8347,  32538/
C
C
C***FIRST EXECUTABLE STATEMENT  R1MACH
C
      R1MACH = RMACH(I)
      RETURN
C
      END
C
C  EXAMPLE OF HFFT3 USAGE
C
C-----------------------------------------------------------------------
C
C  PROBLEM   UXX + UYY + UZZ - PI**2*U = G(X,Y)
C
C            U = 1                    ON X=0
C            UX= Z*EXP(Z)+COS(2*PI*Y) ON X=1
C            UZ= X                    ON Z=0
C            U = EXP(X)+X*COS(2*PI*Y) ON Z=1
C
C            U(X,0,Z) = U(X,1,Z)
C
C            G = (X**2+Z**2-PI**2)*EXP(X*Z) - 5*PI**2*X*COS(2*PI*Y)
C
C  SOLUTION  U = EXP(X*Z) + X*COS(2*PI*Y)
C
C-----------------------------------------------------------------------
C
C  ------------
C  DECLARATIONS
C  ------------
C
C     ... CONSTANTS
C
      PARAMETER (NMAX=29)
      PARAMETER (NWORK = 3+NMAX*(7+NMAX*(11+NMAX)))
      PARAMETER (LDXU = NMAX+2)
C
C     ... GLOBAL VARIABLES
C
      COMMON /GLOBAL/ TWOPI, PISQR
      EXTERNAL PRHS, BRHS
C
C     ... LOCAL VARIABLES
C
      INTEGER BCTY(6)
      REAL U(LDXU,LDXU,LDXU), WORK(NWORK)
C
C---------------------------------------------------------------------
C
      PI = 4.0*ATAN(1.0)
      TWOPI = 2.0*PI
      PISQR = PI*PI
C
C  -------------
C  SETUP PROBLEM
C  -------------
C
      AX = 0.0
      BX = 1.0
      AY = 0.0
      BY = 1.0
      AZ = 0.0
      BZ = 1.0
      COEFU = -PISQR
      BCTY(1) = 2
      BCTY(2) = 3
      BCTY(3) = 1
      BCTY(4) = 3
      BCTY(5) = 1
      BCTY(6) = 2
      IORDER = 4
C
C  --------------------------
C  SOLVE ON SEQUENCE OF GRIDS
C  --------------------------
C
      PRINT 2000
      DO 500 N=5,29,4
         NX = N
         NY = N
         NZ = N
C
C        ... SOLVE PDE
C
         CALL HFFT3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,
     *              BCTY,IORDER,U,LDXU,LDXU,WORK,NWORK,INFO)
         IF (INFO .LT. 0)  GO TO 900
C
C        ... EVALUATE ERROR
C
         H = (BX-AX)/REAL(NX-1)
         ERRMAX = 0.0E0
         DO 100 K=1,NZ
            Z = AZ + REAL(K-1)*H
            DO 100 J=1,NY
               Y = AY + REAL(J-1)*H
               DO 100 I=1,NX
                  X = AX + REAL(I-1)*H
                  TRUSOL = TRUE(X,Y,Z)
                  ERROR = ABS(TRUSOL-U(I,J,K))
                  ERRMAX = MAX(ERROR,ERRMAX)
  100    CONTINUE
         PRINT 2001,N,ERRMAX
  500 CONTINUE
      STOP
C
C     ... ERROR EXIT
C
  900 CONTINUE
      PRINT 2002,INFO
      STOP
C
 2000 FORMAT(/'   GRID    MAX-ERROR' / '  -------------------' /)
 2001 FORMAT(4X,I2,4X,1PE10.3)
 2002 FORMAT(/'   HFFT3 RETURNED INFO = ',I2)
C
      END
      FUNCTION PRHS (X,Y,Z)
C
C     ... RIGHT HAND SIDE OF PDE (USER-SUPPLIED)
C
      COMMON /GLOBAL/ TWOPI, PISQR
      PRHS = (X*X+Z*Z-PISQR)*EXP(X*Z) - 5.0*PISQR*X*COS(TWOPI*Y)
      RETURN
      END
      FUNCTION BRHS(K,X,Y,Z)
C
C     ... RIGHT HAND SIDE OF BOUNDARY CONDITIONS (USER-SUPPLIED)
C
      COMMON /GLOBAL/ TWOPI, PISQR
      GO TO (1,2,3,4,5,6),K
      GO TO 999
C
    1 CONTINUE
      BRHS = Z*EXP(Z) + COS(TWOPI*Y)
      GO TO 999
C
    2 CONTINUE
      GO TO 999
C
    3 CONTINUE
      BRHS = 1.0
      GO TO 999
C
    4 CONTINUE
      GO TO 999
C
    5 CONTINUE
      BRHS = EXP(X) + X*COS(TWOPI*Y)
      GO TO 999
C
    6 CONTINUE
      BRHS = X
      GO TO 999
C
  999 CONTINUE
      RETURN
      END
      FUNCTION TRUE (X,Y,Z)
      COMMON /GLOBAL/ TWOPI, PISQR
      TRUE = EXP(X*Z) + X*COS(TWOPI*Y)
      RETURN
      END
C     PROGRAM TESTH3 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT)
C
C                       ----------------------
C                       TEST DRIVER FOR HFFT3
C                       ----------------------
C
C   SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS.
C   USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-11).
C
C   NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN
C           THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN.
C           ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON
C           A NEW COMPUTER.
C
C   THE PROBLEMS ARE
C
C     1.  SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION.
C         (PROBLEM A3 OF REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, BY=1, AZ=0, BZ=1
C
C         U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z)
C
C     2.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS; SOLUTION SAME AS IN PROBLEM 1.
C         (PROBLEM B3 OF REFERENCE)
C
C         COEFU = -5
C         U GIVEN ON BY=1, BZ=1
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=0
C         UZ GIVEN ON AZ=0
C
C         U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z)
C
C     3.  POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT
C         ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION
C         HAS DISCONTINUOUS 3RD DERIVATIVES.
C
C         COEFU = 0
C         U GIVEN ON AX=0, AY=0, AZ=0
C         UX GIVEN ON BX=1
C         UY GIVEN ON BY=1
C         UZ GIVEN ON BZ=1
C
C         U = P(X)*P(Y)*P(Z)
C
C         P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85.  BETWEEN THESE
C         IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE
C         TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES.
C
C     4.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = -100
C         U GIVEN ON BX=1, BY=1, BZ=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C         UZ GIVEN ON AZ=0
C
C         U = (P(X;10)+P(Y;20)+P(Z;5))/3
C
C         P(X;A) = COSH(A*X)/COSH(A)
C
C     5.  DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS
C         SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0, Z=0.
C         (PROBLEM F3 OF THE REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, AY=1, AZ=0, BZ=1
C
C         U = (X**1.5-X)*(Y**1.5-Y)*(Z**1.5-Z)
C
C     6.  SMOOTH, PERIODIC HELMHOLTZ PROBLEM.
C         (PROBLEM C3 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI, AZ=0, BZ=PI
C
C         U = COS(4Y) + SIN(4(X-Y)) + COS(4Z)
C
C     7.  SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AZ=-1, BZ=1
C         UY GIVEN ON AY=-1, BY=1
C
C         U = T(Y)*(A(X) + T(Y)*B(X))/2 + S(Z)*(A(X) + S(Z)*B(X))/2
C
C         T(Y) = 1-Y**2,  S(Z) = 1-Z,  A(X) = R*C(X) + EXP(SQRT(Q*X)),
C         B(X) = (7-P)*R/16/C(X),  P = 14+SQRT(133),  Q = 14-SQRT(133),
C         R = (7-Q)/R/SQRT(133),  C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X))
C
C     8.  POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0, Z=0.
C         (PROBLEM E2 OF THE REFERNCE)
C
C         COEFU = 0
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (X*Y)**2.5
C
C     9.  SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC
C         BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6.
C         (PROBLEM D2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI
C         U GIVEN ON AY=0, AZ=0
C         UY GIVEN ON BY=PI
C         UZ GIVEN ON BZ=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C    10.  HELMHOLTZ EQUATION WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION IS CUBIC MONOMIAL; ALL METHODS SHOULD BE EXACT.
C
C         COEFU = -5
C         U GIVEN ON AY=0
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON BY=1
C         UZ GIVEN ON AZ=0, BZ=1
C
C         U = X*Y*Z
C
C    11.  HOMOGENEOUS NEUMANNT PROBLEM; INCLUDED TO COLLECT TIMING
C         DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM.
C
C         COEFU = 0
C         UX=0 ON AX=0, BX=1
C         UY=0 ON AY=0, BY=1
C         UZ=0 ON AZ=0, AZ=1
C
C
C-----------------------------------------------------------------------
C
C
C     ... CONSTANTS
C
C         NMAX = MAX GRID SIZE FOR THIS PROGRAM
C         NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID
C         LDXU,LDYU,LDZU = REQUIRED DIMENSIONS FOR U
C         LUIN = INPUT UNIT FOR READS
C         LUOUT = OUTPUT UNIT FOR WRITES
C
      PARAMETER (NMAX=29)
      PARAMETER (NWORK = 33 + NMAX*(21 + NMAX*(12 + NMAX)))
      PARAMETER (LDXU=NMAX+2, LDYU=NMAX+2, LDZU=NMAX+2)
      PARAMETER (LUIN=5, LUOUT=6)
C
C     ... VARIABLES
C
      INTEGER BCTY(6)
      REAL
     *     COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,LDZU),
     *     WORK(NWORK), H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE
C
      EXTERNAL PRHS, BRHS
C
C
C-----------------------------------------------------------------------
C
C
C  SELECT ORDER OF ACCURACY
C
    5 CONTINUE
      WRITE(LUOUT,*) 'ENTER ORDER OF ACCURACY (2 OR 4) '
      READ(LUIN,*) IORDER
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 5
C
C  SELECT PROBLEM
C
   10 CONTINUE
      WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-11, 0 TO STOP) '
      READ(LUIN,*) KPROB
      IF (KPROB .EQ. 0)  STOP
      IF ((KPROB .LT. 0) .OR. (KPROB .GT. 11))  GO TO 10
C
C  SOLVE ON SEQUENCE OF GRIDS
C
      WRITE(LUOUT,2000) KPROB,IORDER
      EOLD = 0.0E0
      NRUNS = (NMAX-1)/4
      NX = 1
      DO 500 K=1,NRUNS
C
C        ... SETUP PROBLEM
C
         NX = NX + 4
         CALL SETUP(KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
         IF (NY .GT. NMAX)  GO TO 10
         IF (NZ .GT. NMAX)  GO TO 10
C
C        ... SOLVE PROBLEM
C
         CALL TIMER(T0)
         CALL HFFT3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTY,
     *              IORDER,U,LDXU,LDYU,WORK,NWORK,INFO)
         CALL TIMER(T1)
         CPTIME = T1 - T0
C
         IF (INFO .LT. 0) THEN
            WRITE(6,2002) INFO
            GO TO 10
         ENDIF
C
C        ... COMPUTE ERROR
C
         H = (BX-AX)/REAL(NX-1)
         CALL GETERR(AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,RELERR,
     *               TRUMAX)
C
C        ... COMPUTE CONVERGENCE RATE
C
         IF (RELERR .LT. EOLD) THEN
            RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD))
         ELSE
            RATE = 0.0E0
         ENDIF
C
C        ... PRINT SUMMARY
C
         WRITE(LUOUT,2001) NX,NY,NZ,H,INFO,ABSERR,RELERR,TRUMAX,RATE,
     *                     CPTIME
         HOLD = H
         EOLD = RELERR
  500 CONTINUE
      GO TO 10
C
 2000 FORMAT(///'  PROBLEM ',I2,7X,'MODULE HFFT3',7X,'IORDER = ',I1
     *       //'   NX  NY  NZ',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR',
     *       6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,39('--') /)
 2001 FORMAT(2X,I3,1X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,
     *       2X,0P,F4.1,1X,F6.2)
 2002 FORMAT(/' HFFT3 RETURNS INFO = ',I3 /)
C
      END
      SUBROUTINE GETERR (AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,
     *                   RELERR,TRUMAX)
C
C  ----------------------------------------------------------
C  COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID
C  ----------------------------------------------------------
C
      REAL AX,AY,AZ,H,U(LDXU,LDYU,*),ABSERR,RELERR,TRUMAX
      REAL X,Y,Z,TRUSOL,DIFF
C
      ABSERR = 0.0E0
      TRUMAX = 0.0E0
      DO 100 K=1,NZ
         Z = AZ + REAL(K-1)*H
         DO 100 J=1,NY
            Y = AY + H*REAL(J-1)
            DO 100 I=1,NX
               X = AX + H*REAL(I-1)
               TRUSOL = TRUE(X,Y,Z)
               ABSERR = MAX(ABS(TRUSOL-U(I,J,K)),ABSERR)
               TRUMAX = MAX(ABS(TRUSOL),TRUMAX)
  100 CONTINUE
C
      IF (TRUMAX .GT. 0.0E0) THEN
         RELERR = ABSERR/TRUMAX
      ELSE
         RELERR = ABSERR
      ENDIF
      RETURN
      END
      SUBROUTINE SETUP (KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
C
C  -----------------------------------------------------------
C  SETUP PROBLEM KPROB (NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
C  -----------------------------------------------------------
C
      INTEGER KPROB,NX,NY,NZ,BCTY(6)
      REAL
     *     COEFU,AX,BX,AY,BY,AZ,BZ
C
      COMMON /SELECT/ IPROB
C
      IPROB = KPROB
C
C  DEFAULT VALUES
C
      NY = NX
      NZ = NX
      AX = 0.0E0
      BX = 1.0E0
      AY = 0.0E0
      BY = 1.0E0
      AZ = 0.0E0
      BZ = 1.0E0
      COEFU = 0.0E0
      BCTY(1) = 1
      BCTY(2) = 1
      BCTY(3) = 1
      BCTY(4) = 1
      BCTY(6) = 1
      BCTY(5) = 1
C
C  SELECT OPTIONS FOR EACH CASE
C
      GO TO (100,200,300,400,500,600,700,800,900,1000,1100), IPROB
      GO TO 9999
C
  100 CONTINUE
      GO TO 9999
C
  200 CONTINUE
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(6) = 2
      COEFU = -5.0E0
      GO TO 9999
C
  300 CONTINUE
      BCTY(1) = 2
      BCTY(4) = 2
      BCTY(5) = 2
      GO TO 9999
C
  400 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(6) = 2
      COEFU = -100.0E0
      GO TO 9999
C
  500 CONTINUE
      GO TO 9999
C
  600 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      BZ = BX
      COEFU = -20.0E0
      DO 605 I=1,6
         BCTY(I) = 3
  605 CONTINUE
      GO TO 9999
C
  700 CONTINUE
      NY = 2*NX - 1
      NZ = NY
      AY = -1.0E0
      AZ = -1.0E0
      BCTY(2) = 2
      BCTY(4) = 2
      GO TO 9999
C
  800 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  900 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      BZ = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(2) = 1
      BCTY(3) = 3
      BCTY(4) = 2
      BCTY(6) = 1
      BCTY(5) = 2
      GO TO 9999
C
 1000 CONTINUE
      BCTY(1) = 2
      BCTY(3) = 2
      BCTY(4) = 2
      BCTY(6) = 2
      BCTY(5) = 2
      COEFU = -5.0E0
      GO TO 9999
C
 1100 CONTINUE
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(4) = 2
      BCTY(6) = 2
      BCTY(5) = 2
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION PRHS(X,Y,Z)
C
C  ----------------------------------------
C  RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION
C  ----------------------------------------
C
      REAL X,Y,Z
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB
C
         PRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      XMX2 = X*(1.0E0 - X)
      YMY2 = Y*(1.0E0 - Y)
      ZMZ2 = Z*(1.0E0 - Z)
      PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 +
     *                     XMX2*Y*(Y+3.0E0)*ZMZ2 +
     *                     XMX2*YMY2*Z*(Z+3.0E0)   )
      GO TO 9999
C
  200 CONTINUE
      XMX2 = X*(1.0E0 - X)
      YMY2 = Y*(1.0E0 - Y)
      ZMZ2 = Z*(1.0E0 - Z)
      PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 +
     *                     XMX2*Y*(Y+3.0E0)*ZMZ2 +
     *                     XMX2*YMY2*Z*(Z+3.0E0)   )
      PRHS = PRHS - 5.0E0*TRUE(X,Y,Z)
      GO TO 9999
C
  300 CONTINUE
      PRHS = D2P(X)*P(Y)*P(Z) + P(X)*D2P(Y)*P(Z) + P(X)*P(Y)*D2P(Z)
      GO TO 9999
C
  400 CONTINUE
      PRHS = 100.0E0*Q(Y,20.0E0) - 25.0E0*Q(Z,5.0E0)
      GO TO 9999
C
  500 CONTINUE
      C = -0.18750E0
      A = 0.750E0
      AM2 = A - 2.0E0
      IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0) .AND. (Z .NE. 0.0E0)) THEN
         PRHS = C*( X**AM2*(Y**A-Y)*(Z**A-Z)
     *            + Y**AM2*(X**A-X)*(Z**A-Z)
     *            + Z**AM2*(X**A-X)*(Y**A-Y) )
      ELSE
         PRHS = 0.0E0
      ENDIF
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      B2 = B*B
      PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y))
     *       -       (B2+20.0E0)*(COS(B*Y)+COS(B*Z))
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      Z1 = 1.0E0 - Z
      DEK1X = RK1*RK1*EK1X
      DEK2X = RK2*RK2*EK2X
      DEDIFF = DEK1X-DEK2X
      DDF1 = A*DEDIFF + DEK2X
      DDF2 = B*DEDIFF
      UXX = 0.50E0*( Y21*(DDF1+Y21*DDF2) + Z1*(DDF1+Z1*DDF2) )
      UYY = -(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2)
      UZZ = F2
      PRHS = UXX + UYY + UZZ
      GO TO 9999
C
  800 CONTINUE
      PRHS= 3.750E0*(SQRT(X*(Y*Z)**5)+SQRT(Y*(X*Z)**5)+SQRT(Z*(X*Y)**5))
      GO TO 9999
C
 1000 CONTINUE
      PRHS = -5.0E0*X*Y*Z
      GO TO 9999
C
 1100 CONTINUE
      PRHS = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION BRHS (K,X,Y,Z)
C
C  --------------------------------------
C  RIGHT-HAND SIDE OF BOUNDARY CONDITIONS
C  --------------------------------------
C
      REAL X,Y,Z
C
      COMMON / SELECT / IPROB
C
      GO TO (100,200,300,400,100,100,700,800,900,1000,1100), IPROB
C
  100 CONTINUE
      BRHS = TRUE(X,Y,Z)
      GO TO 9999
C
  200 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN
         BRHS = (1.0-X-X**2)*Y*(1.0-Y)*Z*(1.0-Z)*EXP(X+Y+Z)
      ELSE IF (K .EQ. 2) THEN
              BRHS = (1.0-Y-Y**2)*X*(1.0-X)*Z*(1.0-Z)*EXP(X+Y+Z)
           ELSE IF (K .EQ. 6) THEN
                   BRHS = (1.0-Z-Z**2)*X*(1.0-X)*Y*(1.0-Y)*EXP(X+Y+Z)
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  300 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 4) .OR. (K .EQ. 5)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  400 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 3) .OR. (K .EQ. 6)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  700 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 4)) THEN
         S133 = SQRT(133.0E0)
         RK1 = SQRT(14.0E0+S133)
         RK2 = SQRT(14.0E0-S133)
         A = (-7.0E0+S133)/(2.0E0*S133)
         EK1X = EXP(RK1*X)
         EK2X = EXP(RK2*X)
         EDIFF = EK1X-EK2X
         F1 = A*EDIFF + EK2X
         BRHS = -Y*F1
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  800 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 3)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  900 CONTINUE
      B = 4.0E0
      IF ((K .EQ. 2) .OR. (K .EQ. 6)) THEN
         BRHS = TRUE(X,Y,Z)
      ELSE IF (K .EQ. 4) THEN
         BRHS = -B*( SIN(B*Y) + COS(B*(X-Y)) )
      ELSE
         BRHS = -B*SIN(B*Z)
      ENDIF
      GO TO 9999
C
 1000 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN
         BRHS = Y*Z
      ELSE IF (K .EQ. 4) THEN
         BRHS = X*Z
      ELSE IF ((K .EQ. 5) .OR. (K .EQ. 6)) THEN
         BRHS = X*Y
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
 1100 CONTINUE
      BRHS = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION TRUE(X,Y,Z)
C
C  -------------
C  TRUE SOLUTION
C  -------------
C
      REAL X,Y,Z
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB
C
         TRUE = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z)
      GO TO 9999
C
  200 CONTINUE
      TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z)
      GO TO 9999
C
  300 CONTINUE
      TRUE = P(X)*P(Y)*P(Z)
      GO TO 9999
C
  400 CONTINUE
      TRUE = ( Q(X,10.0E0) + Q(Y,20.0E0) + Q(Z,5.0E0) )/3.0E0
      GO TO 9999
C
  500 CONTINUE
      A = 0.750E0
      TRUE = (X**A-X)*(Y**A-Y)*(Z**A-Z)
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      TRUE = COS(B*Y) + SIN(B*(X-Y)) + COS(B*Z)
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      Z1 = 1.0E0 - Z
      TRUE = 0.50E0*( Y21*(F1 + Y21*F2) + Z1*(F1 + Z1*F2) )
      GO TO 9999
C
  800 CONTINUE
      TRUE = SQRT((X*Y*Z)**5)
      GO TO 9999
C
 1000 CONTINUE
      TRUE = X*Y*Z
      GO TO 9999
C
 1100 CONTINUE
      TRUE = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 20
      DZ = Z2 - Z1
      P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ
     *              + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3
      RETURN
   10 CONTINUE
      P = 1.0E0
      RETURN
   20 CONTINUE
      P = 0.0E0
      RETURN
      END
      REAL FUNCTION D2P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 10
      DZ = Z2 - Z1
      C3 = -1.0E0/DZ**3
      C4 = 3.0E0/DZ**4
      C5 = -6.0E0/DZ**5
      ZMZ1 = Z - Z1
      ZMZ2 = Z - Z2
      ZMZ12 = ZMZ1*ZMZ1
      ZMZ22 = ZMZ2*ZMZ2
      D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22
     *               + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1
      RETURN
   10 CONTINUE
      D2P = 0.0E0
      RETURN
      END
      REAL FUNCTION Q (Z,A)
      Q = COSH(A*Z)/COSH(A)
      RETURN
      END
      SUBROUTINE TIMER (T)
C
C  ------------------------------------------------
C  RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC)
C  ------------------------------------------------
C
      REAL T
      T = SECOND()
      RETURN
      END
C     PROGRAM TEST2 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT)
C
C                      ---------------------
C                      TEST DRIVER FOR HFFT2
C                      ---------------------
C
C   SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS.
C   USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-10).
C
C   NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN
C           THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN.
C           ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON
C           A NEW COMPUTER.
C
C   THE PROBLEMS ARE
C
C     1.  SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION.
C         (PROBLEM A2 OF REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, BY=1
C
C         U = 3XY(1-X)(1-Y) EXP(X+Y)
C
C     2.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS; SOLUTION SAME AS IN PROBLEM 1.
C         (PROBLEM B2 OF REFERENCE)
C
C         COEFU = -5
C         U GIVEN ON BY=1
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=0
C
C         U = 3XY(1-X)(1-Y) EXP(X+Y)
C
C     3.  POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT
C         ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION
C         HAS DISCONTINUOUS 3RD DERIVATIVES.
C
C         COEFU = 0
C         U GIVEN ON AX=0, AY=0
C         UX GIVEN ON BX=1
C         UY GIVEN ON BY=1
C
C         U = P(X)*P(Y)
C
C         P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85.  BETWEEN THESE
C         IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE
C         TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES.
C
C     4.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = -100
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (P(X;10)+P(Y;20)/2
C
C         P(X;A) = COSH(A*X)/COSH(A)
C
C     5.  DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS
C         SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0.
C         (PROBLEM F2 OF THE REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, AY=1
C
C         U = (X**1.5-X)*(Y**1.5-Y)
C
C     6.  SMOOTH, PERIODIC HELMHOLTZ PROBLEM.
C         (PROBLEM C2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C     7.  SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=-1, BY=1
C
C         U = T(Y)*( A(X) + T(Y)*B(X) )
C
C         T(Y) = 1-Y**2,  A(X) = R*C(X) + EXP(SQRT(Q*X)),
C         B(X) = (7-P)*R/16/C(X),  P = 14+SQRT(133),  Q = 14-SQRT(133),
C         R = (7-Q)/R/SQRT(133),  C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X))
C
C     8.  POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0.
C         (PROBLEM E2 OF THE REFERNCE)
C
C         COEFU = 0
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (X*Y)**2.5
C
C     9.  SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC
C         BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6.
C         (PROBLEM D2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI
C         U GIVEN ON AY=0
C         UY GIVEN ON BY=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C    10.  HOMOGENEOUS DIRICHLET PROBLEM; INCLUDED TO COLLECT TIMING
C         DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM.
C
C         COEFU = 0
C         U=0 ON AX=0, BX=1, AY=0, BY=1
C
C
C-----------------------------------------------------------------------
C
C
C     ... CONSTANTS
C
C         NMAX = MAX GRID SIZE FOR THIS PROGRAM
C         NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID
C         LDXU,LDYU = REQUIRED DIMENSIONS FOR U
C         LUIN = INPUT UNIT FOR READS
C         LUOUT = OUTPUT UNIT FOR WRITES
C
      PARAMETER (NRUNS=7,NMAX=2**NRUNS+1)
      PARAMETER (NWORK= (NMAX+1)**2 + 14*NMAX + NMAX/2 + 15)
      PARAMETER (LDXU=NMAX+2,LDYU=NMAX+2)
      PARAMETER (LUIN=5, LUOUT=6)
C
C     ... VARIABLES
C
      INTEGER BCTY(4)
      REAL
     *     COEFU, AX, BX, AY, BY, U(LDXU,LDYU), WORK(NWORK),
     *     H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE
C
      EXTERNAL PRHS, BRHS
C
C
C-----------------------------------------------------------------------
C
C
C  SELECT ORDER OF ACCURACY
C
    5 CONTINUE
      WRITE(LUOUT,*) ' ENTER ORDER OF ACCURACY (2 OR 4) '
      READ(LUIN,*) IORDER
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 5
C
C  SELECT PROBLEM
C
   10 CONTINUE
      WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-10, 0 TO STOP) '
      READ(LUIN,*) KPROB
      IF (KPROB .EQ. 0)  STOP
      IF ((KPROB .LT. 0) .OR. (KPROB .GT. 10))  GO TO 10
C
C  SOLVE ON SEQUENCE OF GRIDS
C
      WRITE(LUOUT,2000) KPROB,IORDER
      EOLD = 0.0E0
      DO 500 K=2,NRUNS
C
C        ... SETUP PROBLEM KPROB
C
         NX = 2**K + 1
         CALL SETUP(KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY)
         IF (NY .GT. NMAX)  GO TO 10
C
C        ... SOLVE PROBLEM
C
         CALL TIMER(T0)
         CALL HFFT2(COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER,
     *              U,LDXU,WORK,NWORK,INFO)
         CALL TIMER(T1)
         CPTIME = T1 - T0
C
         IF (INFO .LT. 0) THEN
            WRITE(LUOUT,2002) INFO
            GO TO 10
         ENDIF
C
C        ... COMPUTE ERROR
C
         H = (BX-AX)/REAL(NX-1)
         CALL GETERR(AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX)
C
C        ... COMPUTE CONVERGENCE RATE
C
         IF (RELERR .LT. EOLD) THEN
            RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD))
         ELSE
            RATE = 0.0E0
         ENDIF
C
C        ... PRINT SUMMARY
C
         WRITE(LUOUT,2001) NX,NY,H,INFO,ABSERR,RELERR,TRUMAX,RATE,CPTIME
         HOLD = H
         EOLD = RELERR
  500 CONTINUE
      GO TO 10
C
 2000 FORMAT(///'  PROBLEM ',I2,7X,'MODULE HFFT2',7X,'IORDER = ',I1
     *        //'   NX  NY',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR',
     *          6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,37('--') /)
 2001 FORMAT(2X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,2X,0P,F4.1,1X,F6.2)
 2002 FORMAT(/'  HFFT2 RETURNS INFO = ',I3)
C
      END
      SUBROUTINE GETERR (AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX)
C
C  ----------------------------------------------------------
C  COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID
C  ----------------------------------------------------------
C
      REAL AX,AY,H,U(LDXU,*),ABSERR,RELERR,TRUMAX
      REAL X,Y,TRUSOL,DIFF
C
      ABSERR = 0.0E0
      TRUMAX = 0.0E0
      DO 100 J=1,NY
         Y = AY + H*REAL(J-1)
         DO 100 I=1,NX
            X = AX + H*REAL(I-1)
            TRUSOL = TRUE(X,Y)
            ABSERR = MAX(ABS(TRUSOL-U(I,J)),ABSERR)
            TRUMAX = MAX(ABS(TRUSOL),TRUMAX)
  100 CONTINUE
C
      IF (TRUMAX .NE. 0.0E0) THEN
         RELERR = ABSERR/TRUMAX
      ELSE
         RELERR = ABSERR
      ENDIF
      RETURN
      END
      SUBROUTINE SETUP (KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY)
C
C  ---------------------------------------------------------
C  SETUP PROBLEM KPROB (NX, NY, COEFU, AX, BX, AY, BY, BCTY)
C  ---------------------------------------------------------
C
      INTEGER KPROB,NX,NY,BCTY(4)
      REAL
     *     COEFU,AX,BX,AY,BY
C
      COMMON /SELECT/ IPROB
C
      IPROB = KPROB
C
C  DEFAULT VALUES
C
      NY = NX
      AX = 0.0E0
      BX = 1.0E0
      AY = 0.0E0
      BY = 1.0E0
      COEFU = 0.0E0
      BCTY(1) = 1
      BCTY(2) = 1
      BCTY(3) = 1
      BCTY(4) = 1
C
C  SELECT OPTIONS FOR EACH CASE
C
      GO TO (100,200,300,400,500,600,700,800,900), IPROB
      GO TO 9999
C
  100 CONTINUE
      GO TO 9999
C
  200 CONTINUE
      COEFU = -5.0E0
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  300 CONTINUE
      BCTY(1) = 2
      BCTY(4) = 2
      GO TO 9999
C
  400 CONTINUE
      COEFU = -100.0E0
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  500 CONTINUE
      GO TO 9999
C
  600 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(2) = 3
      BCTY(3) = 3
      BCTY(4) = 3
      GO TO 9999
C
  700 CONTINUE
      NY = 2*NX - 1
      AY = -1.0E0
      BCTY(2) = 2
      BCTY(4) = 2
      GO TO 9999
C
  800 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  900 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(4) = 2
      BCTY(3) = 3
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION PRHS(X,Y)
C
C  ----------------------------------------
C  RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION
C  ----------------------------------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600), IPROB
C
         PRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      PRHS = 6.0E0*X*Y*EXP(X+Y)*(X*Y+X+Y-3.)
      GO TO 9999
C
  200 CONTINUE
      PRHS = X*Y*EXP(X+Y)*(6.0E0*(X*Y+X+Y-3.0E0)
     *               - 15.0E0*(1.0E0-X)*(1.0E0-Y))
      GO TO 9999
C
  300 CONTINUE
      PRHS = D2P(X)*P(Y) + P(X)*D2P(Y)
      GO TO 9999
C
  400 CONTINUE
      PRHS = 150.0E0*COSH(20.0E0*Y)/COSH(20.0E0)
      GO TO 9999
C
  500 CONTINUE
      C = -0.18750E0
      A = 0.750E0
      AM2 = A - 2.0E0
      IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0)) THEN
         PRHS = C*(X**AM2*(Y**A-Y) + Y**AM2*(X**A-X))
      ELSE
         PRHS = 0.0E0
      ENDIF
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      B2 = B*B
      PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y))
     *       -       (B2+20.0E0)*COS(B*Y)
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      DEK1X = RK1*RK1*EK1X
      DEK2X = RK2*RK2*EK2X
      DEDIFF = DEK1X-DEK2X
      DDF1 = A*DEDIFF + DEK2X
      DDF2 = B*DEDIFF
      UXX = Y21*(DDF1 + Y21*DDF2)
      UYY = -2.0E0*(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2)
      PRHS = UXX + UYY
      GO TO 9999
C
  800 CONTINUE
      PRHS = 3.750E0*(SQRT(X*Y**5) + SQRT(Y*X**5))
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION BRHS (K,X,Y)
C
C  --------------------------------------
C  RIGHT-HAND SIDE OF BOUNDARY CONDITIONS
C  --------------------------------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,900), IPROB
C
         BRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      BRHS = 0.0E0
      GO TO 9999
C
  200 CONTINUE
      GO TO (210,220,210,240), K
  210    BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*X)*Y*(1.0E0-Y)
         GO TO 9999
  220    BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*Y)*X*(1.0E0-X)
         GO TO 9999
  240    BRHS = 0.0E0
         GO TO 9999
C
  300 CONTINUE
      GO TO (310,320,320,310), K
  310    BRHS = 0.0E0
         GO TO 9999
  320    BRHS = TRUE(X,Y)
         GO TO 9999
C
  400 CONTINUE
      GO TO (420,410,410,420), K
  410    BRHS = 0.0E0
         GO TO 9999
  420    BRHS = TRUE(X,Y)
         GO TO 9999
C
  500 CONTINUE
      BRHS = TRUE(X,Y)
      GO TO 9999
C
  600 CONTINUE
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      GO TO (710,720,710,720), K
  710    BRHS = Y21*(F1 + Y21*F2)
         GO TO 9999
  720    BRHS = -2.0E0*Y*(F1 + 2.0E0*Y21*F2)
         GO TO 9999
C
  800 CONTINUE
      GO TO (810,820,820,810), K
  810    BRHS = SQRT((X*Y)**5)
         GO TO 9999
  820    BRHS = 0.0E0
         GO TO 9999
C
  900 CONTINUE
      IF (K .EQ. 2) THEN
         BRHS = TRUE(X,Y)
      ELSE
         BRHS = -4.0E0*COS(4.0E0*X)
      ENDIF
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION TRUE(X,Y)
C
C  -------------
C  TRUE SOLUTION
C  -------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,100,300,400,500,600,700,800,600), IPROB
C
         TRUE = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      TRUE = 3.0E0*EXP(X+Y)*X*Y*(1.0E0-X)*(1.0E0-Y)
      GO TO 9999
C
  300 CONTINUE
      TRUE = P(X)*P(Y)
      GO TO 9999
C
  400 CONTINUE
      TRUE = (COSH(10.E0*X)/COSH(10.0E0)+COSH(20.0E0*Y)/COSH(20.0E0))
     *                              /2.0E0
      GO TO 9999
C
  500 CONTINUE
      A = 0.750E0
      TRUE = (X**A-X)*(Y**A-Y)
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      TRUE = COS(B*Y) + SIN(B*(X-Y))
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      TRUE = Y21*(F1 + Y21*F2)
      GO TO 9999
C
  800 CONTINUE
      TRUE = SQRT((X*Y)**5)
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 20
      DZ = Z2 - Z1
      P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ
     *              + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3
      RETURN
   10 CONTINUE
      P = 1.0E0
      RETURN
   20 CONTINUE
      P = 0.0E0
      RETURN
      END
      REAL FUNCTION D2P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 10
      DZ = Z2 - Z1
      C3 = -1.0E0/DZ**3
      C4 = 3.0E0/DZ**4
      C5 = -6.0E0/DZ**5
      ZMZ1 = Z - Z1
      ZMZ2 = Z - Z2
      ZMZ12 = ZMZ1*ZMZ1
      ZMZ22 = ZMZ2*ZMZ2
      D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22
     *               + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1
      RETURN
   10 CONTINUE
      D2P = 0.0E0
      RETURN
      END
      SUBROUTINE TIMER (T)
C
C  ------------------------------------------------
C  RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC)
C  ------------------------------------------------
C
      REAL T
      T = SECOND()
      RETURN
      END
C     PROGRAM TESTF3 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT)
C
C                 ----------------------
C                 TEST DRIVER FOR HW3CRT
C                 ----------------------
C
C   SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS.
C   USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-11).
C
C   NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN
C           THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN.
C           ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON
C           A NEW COMPUTER.
C
C   THE PROBLEMS ARE
C
C     1.  SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION.
C         (PROBLEM A3 OF REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, BY=1, AZ=0, BZ=1
C
C         U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z)
C
C     2.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS; SOLUTION SAME AS IN PROBLEM 1.
C         (PROBLEM B3 OF REFERENCE)
C
C         COEFU = -5
C         U GIVEN ON BY=1, BZ=1
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=0
C         UZ GIVEN ON AZ=0
C
C         U = XYZ(1-X)(1-Y)(1-Z) EXP(X+Y+Z)
C
C     3.  POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT
C         ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION
C         HAS DISCONTINUOUS 3RD DERIVATIVES.
C
C         COEFU = 0
C         U GIVEN ON AX=0, AY=0, AZ=0
C         UX GIVEN ON BX=1
C         UY GIVEN ON BY=1
C         UZ GIVEN ON BZ=1
C
C         U = P(X)*P(Y)*P(Z)
C
C         P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85.  BETWEEN THESE
C         IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE
C         TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES.
C
C     4.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = -100
C         U GIVEN ON BX=1, BY=1, BZ=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C         UZ GIVEN ON AZ=0
C
C         U = (P(X;10)+P(Y;20)+P(Z;5))/3
C
C         P(X;A) = COSH(A*X)/COSH(A)
C
C     5.  DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS
C         SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0, Z=0.
C         (PROBLEM F3 OF THE REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, AY=1, AZ=0, BZ=1
C
C         U = (X**1.5-X)*(Y**1.5-Y)*(Z**1.5-Z)
C
C     6.  SMOOTH, PERIODIC HELMHOLTZ PROBLEM.
C         (PROBLEM C3 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI, AZ=0, BZ=PI
C
C         U = COS(4Y) + SIN(4(X-Y)) + COS(4Z)
C
C     7.  SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AZ=-1, BZ=1
C         UY GIVEN ON AY=-1, BY=1
C
C         U = T(Y)*(A(X) + T(Y)*B(X))/2 + S(Z)*(A(X) + S(Z)*B(X))/2
C
C         T(Y) = 1-Y**2,  S(Z) = 1-Z,  A(X) = R*C(X) + EXP(SQRT(Q*X)),
C         B(X) = (7-P)*R/16/C(X),  P = 14+SQRT(133),  Q = 14-SQRT(133),
C         R = (7-Q)/R/SQRT(133),  C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X))
C
C     8.  POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0, Z=0.
C         (PROBLEM E2 OF THE REFERNCE)
C
C         COEFU = 0
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (X*Y)**2.5
C
C     9.  SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC
C         BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6.
C         (PROBLEM D2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI
C         U GIVEN ON AY=0, AZ=0
C         UY GIVEN ON BY=PI
C         UZ GIVEN ON BZ=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C    10.  HELMHOLTZ EQUATION WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION IS CUBIC MONOMIAL; ALL METHODS SHOULD BE EXACT.
C
C         COEFU = -5
C         U GIVEN ON AY=0
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON BY=1
C         UZ GIVEN ON AZ=0, BZ=1
C
C         U = X*Y*Z
C
C    11.  HOMOGENEOUS NEUMANNT PROBLEM; INCLUDED TO COLLECT TIMING
C         DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM.
C
C         COEFU = 0
C         UX=0 ON AX=0, BX=1
C         UY=0 ON AY=0, BY=1
C         UZ=0 ON AZ=0, AZ=1
C
C
C-----------------------------------------------------------------------
C
C
C     ... CONSTANTS
C
C         NMAX = MAX GRID SIZE FOR THIS PROGRAM
C         NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID
C         LDXU = REQUIRED DIMENSION FOR U
C         LUIN = INPUT UNIT FOR READS
C         LUOUT = OUTPUT UNIT FOR WRITES
C
      PARAMETER (NMAX=29)
      PARAMETER (NWORK= 2*NMAX**3 + 6*NMAX**2 + 7*NMAX + NMAX/2 + 15)
      PARAMETER (LDXU=NMAX, LDYU=NMAX, LDZU=NMAX)
      PARAMETER (LUIN=5, LUOUT=6)
C
C     ... VARIABLES
C
      INTEGER BCTY(6)
      REAL
     *     COEFU, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,LDZU),
     *     WORK(NWORK), H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE
C
      EXTERNAL PRHS, BRHS
C
C
C-----------------------------------------------------------------------
C
C
C  SELECT PROBLEM
C
   10 CONTINUE
      WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-11, 0 TO STOP) '
      READ(LUIN,*) KPROB
      IF (KPROB .EQ. 0)  STOP
      IF ((KPROB .LT. 0) .OR. (KPROB .GT. 11))  GO TO 10
C
C  SOLVE ON SEQUENCE OF GRIDS
C
      WRITE(LUOUT,2000) KPROB
      EOLD = 0.0E0
      NRUNS = 6
      NX = 5
      DO 500 K=1,NRUNS
C
C        ... SETUP PROBLEM
C
         NX = NX + 4
         CALL SETUP(KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
         IF (NY .GT. NMAX)  GO TO 10
         IF (NZ .GT. NMAX)  GO TO 10
C
C        ... SOLVE PROBLEM
C
         CALL TIMER(T0)
         CALL FISH3(COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,BCTY,
     *              U,LDXU,LDYU,WORK,NWORK,INFO)
         CALL TIMER(T1)
         CPTIME = T1 - T0
C
         IF (INFO .NE. 0) THEN
            WRITE(LUOUT,2002) INFO
            GO TO 10
         ENDIF
C
C        ... COMPUTE ERROR
C
         H = (BX-AX)/REAL(NX-1)
         CALL GETERR(AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,RELERR,
     *               TRUMAX)
C
C        ... COMPUTE CONVERGENCE RATE
C
         IF (RELERR .LT. EOLD) THEN
            RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD))
         ELSE
            RATE = 0.0E0
         ENDIF
C
C        ... PRINT SUMMARY
C
         WRITE(LUOUT,2001) NX,NY,NZ,H,INFO,ABSERR,RELERR,TRUMAX,RATE,
     *                     CPTIME
         HOLD = H
         EOLD = RELERR
  500 CONTINUE
      GO TO 10
C
 2000 FORMAT(///'  PROBLEM ',I2,7X,'MODULE HW3CRT'
     *       //'   NX  NY  NZ',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR',
     *       6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,39('--') /)
 2001 FORMAT(2X,I3,1X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,
     *       2X,0P,F4.1,1X,F6.2)
 2002 FORMAT(/'  HW3CRT RETURNS INFO = ',I3/)
C
      END
      SUBROUTINE FISH3 (COEFU,PRHS,BRHS,AX,BX,AY,BY,AZ,BZ,NX,NY,NZ,
     *                  BCTY,U,LDXU,LDYU,WORK,NWORK,INFO)
C
C-----------------------------------------------------------------------
C
C   DRIVER FOR FISHPAK SUBPROGRAM HW3CRT
C
C-----------------------------------------------------------------------
C
      INTEGER NX, NY, NZ, BCTY(6), LDXU, LDYU, NWORK, INFO
      REAL
     *     COEFU, PRHS, BRHS, AX, BX, AY, BY, AZ, BZ, U(LDXU,LDYU,*),
     *     WORK(NWORK)
      REAL
     *     H, X(100), Y(100), Z(100), PERTRB
C
C--------------------------------------------------------------------
C
      L = NX-1
      M = NY-1
      N = NZ-1
      H = (BX-AX)/REAL(L)
C
      KBCA = BCTY(3)
      KBCB = BCTY(1)
      KBCC = BCTY(2)
      KBCD = BCTY(4)
      KBCE = BCTY(6)
      KBCF = BCTY(5)
      IF ((KBCA .EQ. 3) .AND. (KBCB .EQ. 3)) LBDCND = 0
      IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 1)) LBDCND = 1
      IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 2)) LBDCND = 2
      IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 2)) LBDCND = 3
      IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 1)) LBDCND = 4
      IF ((KBCC .EQ. 3) .AND. (KBCD .EQ. 3)) MBDCND = 0
      IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 1)) MBDCND = 1
      IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 2)) MBDCND = 2
      IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 2)) MBDCND = 3
      IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 1)) MBDCND = 4
      IF ((KBCE .EQ. 3) .AND. (KBCF .EQ. 3)) NBDCND = 0
      IF ((KBCE .EQ. 1) .AND. (KBCF .EQ. 1)) NBDCND = 1
      IF ((KBCE .EQ. 1) .AND. (KBCF .EQ. 2)) NBDCND = 2
      IF ((KBCE .EQ. 2) .AND. (KBCF .EQ. 2)) NBDCND = 3
      IF ((KBCE .EQ. 2) .AND. (KBCF .EQ. 1)) NBDCND = 4
C
C  COMPUTE GRID POINTS
C
      DO 10 I=1,NX
         X(I) = AX + REAL(I-1)*H
   10 CONTINUE
      DO 20 J=1,NY
         Y(J) = AY + REAL(J-1)*H
   20 CONTINUE
      DO 30 K=1,NZ
         Z(K) = AZ + REAL(K-1)*H
   30 CONTINUE
      X(NX) = BX
      Y(NY) = BY
      Z(NZ) = BZ
C
C  LOAD RHS OF HELMHOLTZ EQUATION
C
      DO 50 K=1,NZ
         DO 50 J=1,NY
            DO 50 I=1,NX
               U(I,J,K) = PRHS(X(I),Y(J),Z(K))
   50 CONTINUE
C
C  LOAD DIRICHLET BOUNDARY VALUES
C
      IF (KBCA .EQ. 1) THEN
         DO 110 K=1,NZ
            DO 110 J=1,NY
               U(1,J,K) = BRHS(3,X(1),Y(J),Z(K))
  110    CONTINUE
      ENDIF
C
      IF (KBCB .EQ. 1) THEN
         DO 120 K=1,NZ
            DO 120 J=1,NY
               U(NX,J,K) = BRHS(1,X(NX),Y(J),Z(K))
  120    CONTINUE
      ENDIF
C
      IF (KBCC .EQ. 1) THEN
         DO 130 K=1,NZ
            DO 130 I=1,NX
               U(I,1,K) = BRHS(2,X(I),Y(1),Z(K))
  130    CONTINUE
      ENDIF
C
      IF (KBCD .EQ. 1) THEN
         DO 140 K=1,NZ
            DO 140 I=1,NX
               U(I,NY,K) = BRHS(4,X(I),Y(NY),Z(K))
  140    CONTINUE
      ENDIF
C
      IF (KBCE .EQ. 1) THEN
         DO 150 J=1,NY
            DO 150 I=1,NX
               U(I,J,1) = BRHS(6,X(I),Y(J),Z(1))
  150    CONTINUE
      ENDIF
C
      IF (KBCF .EQ. 1) THEN
         DO 160 J=1,NY
            DO 160 I=1,NX
               U(I,J,NZ) = BRHS(5,X(I),Y(J),Z(NZ))
  160    CONTINUE
      ENDIF
C
C  PARTITION WORK ARRAY
C
      LOC BDA = 1
      LOC BDB = LOC BDA + LDYU*NZ
      LOC BDC = LOC BDB + LDYU*NZ
      LOC BDD = LOC BDC + LDXU*NZ
      LOC BDE = LOC BDD + LDXU*NZ
      LOC BDF = LOC BDE + LDXU*NY
      LOC WRK = LOC BDF + LDXU*NY
C
C  LOAD NEUMANN BOUNDARY VALUES
C
      IF (KBCA .EQ. 2) THEN
         DO 210 K=1,NZ
            LOC = LOC BDA + (K-1)*LDYU - 1
            DO 210 J=1,NY
               LOC = LOC + 1
               WORK(LOC) = BRHS(3,X(1),Y(J),Z(K))
  210    CONTINUE
      ENDIF
C
      IF (KBCB .EQ. 2) THEN
         DO 220 K=1,NZ
            LOC = LOC BDB + (K-1)*LDYU - 1
            DO 220 J=1,NY
               LOC = LOC + 1
               WORK(LOC) = BRHS(1,X(NX),Y(J),Z(K))
  220    CONTINUE
      ENDIF
C
      IF (KBCC .EQ. 2) THEN
         DO 230 K=1,NZ
            LOC = LOC BDC + (K-1)*LDXU - 1
            DO 230 I=1,NX
               LOC = LOC + 1
               WORK(LOC) = BRHS(2,X(I),Y(1),Z(K))
  230    CONTINUE
      ENDIF
C
      IF (KBCD .EQ. 2) THEN
         DO 240 K=1,NZ
            LOC = LOC BDD + (K-1)*LDXU - 1
            DO 240 I=1,NX
               LOC = LOC + 1
               WORK(LOC) = BRHS(4,X(I),Y(NY),Z(K))
  240    CONTINUE
      ENDIF
C
      IF (KBCE .EQ. 2) THEN
         DO 250 J=1,NY
            LOC = LOC BDE + (J-1)*LDXU - 1
            DO 250 I=1,NX
               LOC = LOC + 1
               WORK(LOC) = BRHS(6,X(I),Y(J),Z(1))
  250    CONTINUE
      ENDIF
C
      IF (KBCF .EQ. 2) THEN
         DO 260 J=1,NY
            LOC = LOC BDF + (J-1)*LDXU - 1
            DO 260 I=1,NX
               LOC = LOC + 1
               WORK(LOC) = BRHS(5,X(I),Y(J),Z(NZ))
  260    CONTINUE
      ENDIF
C
C
      CALL HW3CRT(AX,BX,L,LBDCND,WORK(LOCBDA),WORK(LOCBDB),
     *            AY,BY,M,MBDCND,WORK(LOCBDC),WORK(LOCBDD),
     *            AZ,BZ,N,NBDCND,WORK(LOCBDE),WORK(LOCBDF),
     *            COEFU,LDXU,LDYU,U,PERTRB,INFO,WORK(LOCWRK))
C
      RETURN
      END
      SUBROUTINE GETERR (AX,AY,AZ,H,NX,NY,NZ,U,LDXU,LDYU,ABSERR,
     *                   RELERR,TRUMAX)
C
C  ----------------------------------------------------------
C  COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID
C  ----------------------------------------------------------
C
      REAL AX,AY,AZ,H,U(LDXU,LDYU,*),ABSERR,RELERR,TRUMAX
      REAL X,Y,Z,TRUSOL,DIFF
C
      ABSERR = 0.0E0
      TRUMAX = 0.0E0
      DO 100 K=1,NZ
         Z = AZ + REAL(K-1)*H
         DO 100 J=1,NY
            Y = AY + H*REAL(J-1)
            DO 100 I=1,NX
               X = AX + H*REAL(I-1)
               TRUSOL = TRUE(X,Y,Z)
               ABSERR = MAX(ABS(TRUSOL-U(I,J,K)),ABSERR)
               TRUMAX = MAX(ABS(TRUSOL),TRUMAX)
  100 CONTINUE
C
      IF (TRUMAX .GT. 0.0E0) THEN
         RELERR = ABSERR/TRUMAX
      ELSE
         RELERR = ABSERR
      ENDIF
      RETURN
      END
      SUBROUTINE SETUP (KPROB,NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
C
C  -----------------------------------------------------------
C  SETUP PROBLEM KPROB (NX,NY,NZ,COEFU,AX,BX,AY,BY,AZ,BZ,BCTY)
C  -----------------------------------------------------------
C
      INTEGER KPROB,NX,NY,NZ,BCTY(6)
      REAL
     *     COEFU,AX,BX,AY,BY,AZ,BZ
C
      COMMON /SELECT/ IPROB
C
      IPROB = KPROB
C
C  DEFAULT VALUES
C
      NY = NX
      NZ = NX
      AX = 0.0E0
      BX = 1.0E0
      AY = 0.0E0
      BY = 1.0E0
      AZ = 0.0E0
      BZ = 1.0E0
      COEFU = 0.0E0
      BCTY(1) = 1
      BCTY(2) = 1
      BCTY(3) = 1
      BCTY(4) = 1
      BCTY(6) = 1
      BCTY(5) = 1
C
C  SELECT OPTIONS FOR EACH CASE
C
      GO TO (100,200,300,400,500,600,700,800,900,1000,1100), IPROB
      GO TO 9999
C
  100 CONTINUE
      GO TO 9999
C
  200 CONTINUE
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(6) = 2
      COEFU = -5.0E0
      GO TO 9999
C
  300 CONTINUE
      BCTY(1) = 2
      BCTY(4) = 2
      BCTY(5) = 2
      GO TO 9999
C
  400 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(6) = 2
      COEFU = -100.0E0
      GO TO 9999
C
  500 CONTINUE
      GO TO 9999
C
  600 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      BZ = BX
      COEFU = -20.0E0
      DO 605 I=1,6
         BCTY(I) = 3
  605 CONTINUE
      GO TO 9999
C
  700 CONTINUE
      NY = 2*NX - 1
      NZ = NY
      AY = -1.0E0
      AZ = -1.0E0
      BCTY(2) = 2
      BCTY(4) = 2
      GO TO 9999
C
  800 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  900 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      BZ = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(2) = 1
      BCTY(3) = 3
      BCTY(4) = 2
      BCTY(6) = 1
      BCTY(5) = 2
      GO TO 9999
C
 1000 CONTINUE
      BCTY(1) = 2
      BCTY(3) = 2
      BCTY(4) = 2
      BCTY(6) = 2
      BCTY(5) = 2
      COEFU = -5.0E0
      GO TO 9999
C
 1100 CONTINUE
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      BCTY(4) = 2
      BCTY(6) = 2
      BCTY(5) = 2
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION PRHS(X,Y,Z)
C
C  ----------------------------------------
C  RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION
C  ----------------------------------------
C
      REAL X,Y,Z
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB
C
         PRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      XMX2 = X*(1.0E0 - X)
      YMY2 = Y*(1.0E0 - Y)
      ZMZ2 = Z*(1.0E0 - Z)
      PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 +
     *                     XMX2*Y*(Y+3.0E0)*ZMZ2 +
     *                     XMX2*YMY2*Z*(Z+3.0E0)   )
      GO TO 9999
C
  200 CONTINUE
      XMX2 = X*(1.0E0 - X)
      YMY2 = Y*(1.0E0 - Y)
      ZMZ2 = Z*(1.0E0 - Z)
      PRHS = -EXP(X+Y+Z)*( X*(X+3.0E0)*YMY2*ZMZ2 +
     *                     XMX2*Y*(Y+3.0E0)*ZMZ2 +
     *                     XMX2*YMY2*Z*(Z+3.0E0)   )
      PRHS = PRHS - 5.0E0*TRUE(X,Y,Z)
      GO TO 9999
C
  300 CONTINUE
      PRHS = D2P(X)*P(Y)*P(Z) + P(X)*D2P(Y)*P(Z) + P(X)*P(Y)*D2P(Z)
      GO TO 9999
C
  400 CONTINUE
      PRHS = 100.0E0*Q(Y,20.0E0) - 25.0E0*Q(Z,5.0E0)
      GO TO 9999
C
  500 CONTINUE
      C = -0.18750E0
      A = 0.750E0
      AM2 = A - 2.0E0
      IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0) .AND. (Z .NE. 0.0E0)) THEN
         PRHS = C*( X**AM2*(Y**A-Y)*(Z**A-Z)
     *            + Y**AM2*(X**A-X)*(Z**A-Z)
     *            + Z**AM2*(X**A-X)*(Y**A-Y) )
      ELSE
         PRHS = 0.0E0
      ENDIF
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      B2 = B*B
      PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y))
     *       -       (B2+20.0E0)*(COS(B*Y)+COS(B*Z))
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      Z1 = 1.0E0 - Z
      DEK1X = RK1*RK1*EK1X
      DEK2X = RK2*RK2*EK2X
      DEDIFF = DEK1X-DEK2X
      DDF1 = A*DEDIFF + DEK2X
      DDF2 = B*DEDIFF
      UXX = 0.50E0*( Y21*(DDF1+Y21*DDF2) + Z1*(DDF1+Z1*DDF2) )
      UYY = -(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2)
      UZZ = F2
      PRHS = UXX + UYY + UZZ
      GO TO 9999
C
  800 CONTINUE
      PRHS= 3.750E0*(SQRT(X*(Y*Z)**5)+SQRT(Y*(X*Z)**5)+SQRT(Z*(X*Y)**5))
      GO TO 9999
C
 1000 CONTINUE
      PRHS = -5.0E0*X*Y*Z
      GO TO 9999
C
 1100 CONTINUE
      PRHS = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION BRHS (K,X,Y,Z)
C
C  --------------------------------------
C  RIGHT-HAND SIDE OF BOUNDARY CONDITIONS
C  --------------------------------------
C
      REAL X,Y,Z
C
      COMMON / SELECT / IPROB
C
      GO TO (100,200,300,400,100,100,700,800,900,1000,1100), IPROB
C
  100 CONTINUE
      BRHS = TRUE(X,Y,Z)
      GO TO 9999
C
  200 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN
         BRHS = (1.0-X-X**2)*Y*(1.0-Y)*Z*(1.0-Z)*EXP(X+Y+Z)
      ELSE IF (K .EQ. 2) THEN
              BRHS = (1.0-Y-Y**2)*X*(1.0-X)*Z*(1.0-Z)*EXP(X+Y+Z)
           ELSE IF (K .EQ. 6) THEN
                   BRHS = (1.0-Z-Z**2)*X*(1.0-X)*Y*(1.0-Y)*EXP(X+Y+Z)
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  300 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 4) .OR. (K .EQ. 5)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  400 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 3) .OR. (K .EQ. 6)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  700 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 4)) THEN
         S133 = SQRT(133.0E0)
         RK1 = SQRT(14.0E0+S133)
         RK2 = SQRT(14.0E0-S133)
         A = (-7.0E0+S133)/(2.0E0*S133)
         EK1X = EXP(RK1*X)
         EK2X = EXP(RK2*X)
         EDIFF = EK1X-EK2X
         F1 = A*EDIFF + EK2X
         BRHS = -Y*F1
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  800 CONTINUE
      IF ((K .EQ. 2) .OR. (K .EQ. 3)) THEN
         BRHS = 0.0E0
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
  900 CONTINUE
      B = 4.0E0
      IF ((K .EQ. 2) .OR. (K .EQ. 6)) THEN
         BRHS = TRUE(X,Y,Z)
      ELSE IF (K .EQ. 4) THEN
         BRHS = -B*( SIN(B*Y) + COS(B*(X-Y)) )
      ELSE
         BRHS = -B*SIN(B*Z)
      ENDIF
      GO TO 9999
C
 1000 CONTINUE
      IF ((K .EQ. 1) .OR. (K .EQ. 3)) THEN
         BRHS = Y*Z
      ELSE IF (K .EQ. 4) THEN
         BRHS = X*Z
      ELSE IF ((K .EQ. 5) .OR. (K .EQ. 6)) THEN
         BRHS = X*Y
      ELSE
         BRHS = TRUE(X,Y,Z)
      ENDIF
      GO TO 9999
C
 1100 CONTINUE
      BRHS = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION TRUE(X,Y,Z)
C
C  -------------
C  TRUE SOLUTION
C  -------------
C
      REAL X,Y,Z
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600,1000,1100), IPROB
C
         TRUE = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z)
      GO TO 9999
C
  200 CONTINUE
      TRUE = EXP(X+Y+Z)*X*Y*Z*(1.0E0-X)*(1.0E0-Y)*(1.0E0-Z)
      GO TO 9999
C
  300 CONTINUE
      TRUE = P(X)*P(Y)*P(Z)
      GO TO 9999
C
  400 CONTINUE
      TRUE = ( Q(X,10.0E0) + Q(Y,20.0E0) + Q(Z,5.0E0) )/3.0E0
      GO TO 9999
C
  500 CONTINUE
      A = 0.750E0
      TRUE = (X**A-X)*(Y**A-Y)*(Z**A-Z)
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      TRUE = COS(B*Y) + SIN(B*(X-Y)) + COS(B*Z)
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      Z1 = 1.0E0 - Z
      TRUE = 0.50E0*( Y21*(F1 + Y21*F2) + Z1*(F1 + Z1*F2) )
      GO TO 9999
C
  800 CONTINUE
      TRUE = SQRT((X*Y*Z)**5)
      GO TO 9999
C
 1000 CONTINUE
      TRUE = X*Y*Z
      GO TO 9999
C
 1100 CONTINUE
      TRUE = 0.0E0
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 20
      DZ = Z2 - Z1
      P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ
     *              + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3
      RETURN
   10 CONTINUE
      P = 1.0E0
      RETURN
   20 CONTINUE
      P = 0.0E0
      RETURN
      END
      REAL FUNCTION D2P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 10
      DZ = Z2 - Z1
      C3 = -1.0E0/DZ**3
      C4 = 3.0E0/DZ**4
      C5 = -6.0E0/DZ**5
      ZMZ1 = Z - Z1
      ZMZ2 = Z - Z2
      ZMZ12 = ZMZ1*ZMZ1
      ZMZ22 = ZMZ2*ZMZ2
      D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22
     *               + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1
      RETURN
   10 CONTINUE
      D2P = 0.0E0
      RETURN
      END
      REAL FUNCTION Q (Z,A)
      Q = COSH(A*Z)/COSH(A)
      RETURN
      END
      SUBROUTINE TIMER (T)
C
C  ------------------------------------------------
C  RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC)
C  ------------------------------------------------
C
      REAL T
      T = SECOND()
      RETURN
      END
C FISHPAK12  FROM PORTLIB                                  03/12/81
      SUBROUTINE HW3CRT (XS,XF,L,LBDCND,BDXS,BDXF,YS,YF,M,MBDCND,BDYS,
     1                   BDYF,ZS,ZF,N,NBDCND,BDZS,BDZF,ELMBDA,LDIMF,
     2                   MDIMF,F,PERTRB,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C          SUBROUTINE HW3CRT SOLVES THE STANDARD SEVEN-POINT FINITE
C     DIFFERENCE APPROXIMATION TO THE HELMHOLTZ EQUATION IN CARTESIAN
C     COORDINATES:
C
C         (D/DX)(DU/DX) + (D/DY)(DU/DY) + (D/DZ)(DU/DZ)
C
C                    + LAMBDA*U = F(X,Y,Z) .
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C
C            * * * * * *   ON INPUT    * * * * * *
C
C     XS,XF
C        THE RANGE OF X, I.E. XS .LE. X .LE. XF .
C        XS MUST BE LESS THAN XF.
C
C     L
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (XS,XF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE L+1 GRID POINTS IN THE
C        X-DIRECTION GIVEN BY X(I) = XS+(I-1)DX FOR I=1,2,...,L+1,
C        WHERE DX = (XF-XS)/L IS THE PANEL WIDTH.  L MUST BE AT
C        LEAST 5 .
C
C     LBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT X = XS AND X = XF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN X, I.E.
C             U(L+I,J,K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT X = XS AND X = XF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT X = XS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO X IS SPECIFIED AT X = XF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C             SPECIFIED AT X = XS AND X = XF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO X IS
C             SPECIFIED AT X = XS AND THE SOLUTION IS SPECIFIED AT X=XF.
C
C     BDXS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XS.
C        WHEN LBDCND = 3 OR 4,
C
C             BDXS(J,K) = (D/DX)U(XS,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        WHEN LBDCND HAS ANY OTHER VALUE, BDXS IS A DUMMY VARIABLE.
C        BDXS MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C     BDXF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO X AT X = XF.
C        WHEN LBDCND = 2 OR 3,
C
C             BDXF(J,K) = (D/DX)U(XF,Y(J),Z(K)), J=1,2,...,M+1,
C                                                K=1,2,...,N+1.
C
C        WHEN LBDCND HAS ANY OTHER VALUE, BDXF IS A DUMMY VARIABLE.
C        BDXF MUST BE DIMENSIONED AT LEAST (M+1)*(N+1).
C
C     YS,YF
C        THE RANGE OF Y, I.E. YS .LE. Y .LE. YF.
C        YS MUST BE LESS THAN YF.
C
C     M
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (YS,YF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE M+1 GRID POINTS IN THE
C        Y-DIRECTION GIVEN BY Y(J) = YS+(J-1)DY FOR J=1,2,...,M+1,
C        WHERE DY = (YF-YS)/M IS THE PANEL WIDTH.  M MUST BE AT
C        LEAST 5 .
C
C     MBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Y = YS AND Y = YF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN Y, I.E.
C             U(I,M+J,K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT Y = YS AND Y = YF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT Y = YS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO Y IS SPECIFIED AT Y = YF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C             SPECIFIED AT Y = YS AND Y = YF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y IS
C             SPECIFIED AT Y = YS AND THE SOLUTION IS SPECIFIED AT Y=YF.
C
C     BDYS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YS.
C        WHEN MBDCND = 3 OR 4,
C
C             BDYS(I,K) = (D/DY)U(X(I),YS,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        WHEN MBDCND HAS ANY OTHER VALUE, BDYS IS A DUMMY VARIABLE.
C        BDYS MUST BE DIMENSIONED AT LEAST (L+1)*(N+1).
C
C     BDYF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Y AT Y = YF.
C        WHEN MBDCND = 2 OR 3,
C
C             BDYF(I,K) = (D/DY)U(X(I),YF,Z(K)), I=1,2,...,L+1,
C                                                K=1,2,...,N+1.
C
C        WHEN MBDCND HAS ANY OTHER VALUE, BDYF IS A DUMMY VARIABLE.
C        BDYF MUST BE DIMENSIONED AT LEAST (L+1)*(N+1).
C
C     ZS,ZF
C        THE RANGE OF Z, I.E. ZS .LE. Z .LE. ZF.
C        ZS MUST BE LESS THAN ZF.
C
C     N
C        THE NUMBER OF PANELS INTO WHICH THE INTERVAL (ZS,ZF) IS
C        SUBDIVIDED.  HENCE, THERE WILL BE N+1 GRID POINTS IN THE
C        Z-DIRECTION GIVEN BY Z(K) = ZS+(K-1)DZ FOR K=1,2,...,N+1,
C        WHERE DZ = (ZF-ZS)/N IS THE PANEL WIDTH.  N MUST BE AT LEAST 5.
C
C     NBDCND
C        INDICATES THE TYPE OF BOUNDARY CONDITIONS AT Z = ZS AND Z = ZF.
C
C        = 0  IF THE SOLUTION IS PERIODIC IN Z, I.E.
C             U(I,J,N+K) = U(I,J,K).
C        = 1  IF THE SOLUTION IS SPECIFIED AT Z = ZS AND Z = ZF.
C        = 2  IF THE SOLUTION IS SPECIFIED AT Z = ZS AND THE DERIVATIVE
C             OF THE SOLUTION WITH RESPECT TO Z IS SPECIFIED AT Z = ZF.
C        = 3  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS
C             SPECIFIED AT Z = ZS AND Z = ZF.
C        = 4  IF THE DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z IS
C             SPECIFIED AT Z = ZS AND THE SOLUTION IS SPECIFIED AT Z=ZF.
C
C     BDZS
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZS.
C        WHEN NBDCND = 3 OR 4,
C
C             BDZS(I,J) = (D/DZ)U(X(I),Y(J),ZS), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        WHEN NBDCND HAS ANY OTHER VALUE, BDZS IS A DUMMY VARIABLE.
C        BDZS MUST BE DIMENSIONED AT LEAST (L+1)*(M+1).
C
C     BDZF
C        A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        DERIVATIVE OF THE SOLUTION WITH RESPECT TO Z AT Z = ZF.
C        WHEN NBDCND = 2 OR 3,
C
C             BDZF(I,J) = (D/DZ)U(X(I),Y(J),ZF), I=1,2,...,L+1,
C                                                J=1,2,...,M+1.
C
C        WHEN NBDCND HAS ANY OTHER VALUE, BDZF IS A DUMMY VARIABLE.
C        BDZF MUST BE DIMENSIONED AT LEAST (L+1)*(M+1).
C
C     ELMBDA
C        THE CONSTANT LAMBDA IN THE HELMHOLTZ EQUATION. IF
C        LAMBDA .GT. 0, A SOLUTION MAY NOT EXIST.  HOWEVER, HW3CRT WILL
C        ATTEMPT TO FIND A SOLUTION.
C
C     F
C        A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE
C        RIGHT SIDE OF THE HELMHOLTZ EQUATION AND BOUNDARY VALUES (IF
C        ANY).  FOR I=2,3,...,L, J=2,3,...,M, AND K=2,3,...,N
C
C                   F(I,J,K) = F(X(I),Y(J),Z(K)).
C
C        ON THE BOUNDARIES F IS DEFINED BY
C
C        LBDCND      F(1,J,K)         F(L+1,J,K)
C        ------   ---------------   ---------------
C
C          0      F(XS,Y(J),Z(K))   F(XS,Y(J),Z(K))
C          1      U(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C          2      U(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   J=1,2,...,M+1
C          3      F(XS,Y(J),Z(K))   F(XF,Y(J),Z(K))   K=1,2,...,N+1
C          4      F(XS,Y(J),Z(K))   U(XF,Y(J),Z(K))
C
C        MBDCND      F(I,1,K)         F(I,M+1,K)
C        ------   ---------------   ---------------
C
C          0      F(X(I),YS,Z(K))   F(X(I),YS,Z(K))
C          1      U(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C          2      U(X(I),YS,Z(K))   F(X(I),YF,Z(K))   I=1,2,...,L+1
C          3      F(X(I),YS,Z(K))   F(X(I),YF,Z(K))   K=1,2,...,N+1
C          4      F(X(I),YS,Z(K))   U(X(I),YF,Z(K))
C
C        NBDCND      F(I,J,1)         F(I,J,N+1)
C        ------   ---------------   ---------------
C
C          0      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZS)
C          1      U(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C          2      U(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   I=1,2,...,L+1
C          3      F(X(I),Y(J),ZS)   F(X(I),Y(J),ZF)   J=1,2,...,M+1
C          4      F(X(I),Y(J),ZS)   U(X(I),Y(J),ZF)
C
C        F MUST BE DIMENSIONED AT LEAST (L+1)*(M+1)*(N+1).
C
C        NOTE:
C
C        IF THE TABLE CALLS FOR BOTH THE SOLUTION U AND THE RIGHT SIDE F
C        ON A BOUNDARY, THEN THE SOLUTION MUST BE SPECIFIED.
C
C     LDIMF
C        THE ROW (OR FIRST) DIMENSION OF THE ARRAYS F,BDYS,BDYF,BDZS,
C        AND BDZF AS IT APPEARS IN THE PROGRAM CALLING HW3CRT. THIS
C        PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION OF THESE
C        ARRAYS.  LDIMF MUST BE AT LEAST L+1.
C
C     MDIMF
C        THE COLUMN (OR SECOND) DIMENSION OF THE ARRAY F AND THE ROW (OR
C        FIRST) DIMENSION OF THE ARRAYS BDXS AND BDXF AS IT APPEARS IN
C        THE PROGRAM CALLING HW3CRT.  THIS PARAMETER IS USED TO SPECIFY
C        THE VARIABLE DIMENSION OF THESE ARRAYS.
C        MDIMF MUST BE AT LEAST M+1.
C
C     W
C        A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C        WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST 30 + L + M + 5*N
C        + MAX(L,M,N) + 7*(INT((L+1)/2) + INT((M+1)/2))
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C     F
C        CONTAINS THE SOLUTION U(I,J,K) OF THE FINITE DIFFERENCE
C        APPROXIMATION FOR THE GRID POINT (X(I),Y(J),Z(K)) FOR
C        I=1,2,...,L+1, J=1,2,...,M+1, AND K=1,2,...,N+1.
C
C     PERTRB
C        IF A COMBINATION OF PERIODIC OR DERIVATIVE BOUNDARY CONDITIONS
C        IS SPECIFIED FOR A POISSON EQUATION (LAMBDA = 0), A SOLUTION
C        MAY NOT EXIST.  PERTRB IS A CONSTANT, CALCULATED AND SUBTRACTED
C        FROM F, WHICH ENSURES THAT A SOLUTION EXISTS.  PWSCRT THEN
C        COMPUTES THIS SOLUTION, WHICH IS A LEAST SQUARES SOLUTION TO
C        THE ORIGINAL APPROXIMATION.  THIS SOLUTION IS NOT UNIQUE AND IS
C        UNNORMALIZED.  THE VALUE OF PERTRB SHOULD BE SMALL COMPARED TO
C        THE RIGHT SIDE F.  OTHERWISE, A SOLUTION IS OBTAINED TO AN
C        ESSENTIALLY DIFFERENT PROBLEM.  THIS COMPARISON SHOULD ALWAYS
C        BE MADE TO INSURE THAT A MEANINGFUL SOLUTION HAS BEEN OBTAINED.
C
C     IERROR
C        AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.  EXCEPT
C        FOR NUMBERS 0 AND 12, A SOLUTION IS NOT ATTEMPTED.
C
C        =  0  NO ERROR
C        =  1  XS .GE. XF
C        =  2  L .LT. 5
C        =  3  LBDCND .LT. 0 .OR. LBDCND .GT. 4
C        =  4  YS .GE. YF
C        =  5  M .LT. 5
C        =  6  MBDCND .LT. 0 .OR. MBDCND .GT. 4
C        =  7  ZS .GE. ZF
C        =  8  N .LT. 5
C        =  9  NBDCND .LT. 0 .OR. NBDCND .GT. 4
C        = 10  LDIMF .LT. L+1
C        = 11  MDIMF .LT. M+1
C        = 12  LAMBDA .GT. 0
C
C        SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY INCORRECT
C        CALL TO HW3CRT, THE USER SHOULD TEST IERROR AFTER THE CALL.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   BDXS(MDIMF,N+1),BDXF(MDIMF,N+1),BDYS(LDIMF,N+1),
C     ARGUMENTS      BDYF(LDIMF,N+1),BDZS(LDIMF,M+1),BDZF(LDIMF,M+1),
C                    F(LDIMF,MDIMF,N+1),W(SEE ARGUMENT LIST)
C
C     LATEST         DECEMBER 1, 1978
C     REVISION
C
C     SUBPROGRAMS    HW3CRT,POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,
C     REQUIRED       RFFTB,RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,
C                    COSQF1,COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,
C                    CFFTI1,CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,
C                    CFFTF,CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,
C                    PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977
C
C     ALGORITHM      THIS SUBROUTINE DEFINES THE FINITE DIFFERENCE
C                    EQUATIONS, INCORPORATES BOUNDARY DATA, AND
C                    ADJUSTS THE RIGHT SIDE OF SINGULAR SYSTEMS AND
C                    THEN CALLS POIS3D TO SOLVE THE SYSTEM.
C
C     SPACE          7862(DECIMAL) = 17300(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE HW3CRT IS ROUGHLY PROPORTIONAL
C                    TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON
C                    INPUT PARAMETERS LBDCND AND MBDCND.  SOME TYPICAL
C                    VALUES ARE LISTED IN THE TABLE BELOW.
C                       THE SOLUTION PROCESS EMPLOYED RESULTS IN A LOSS
C                    OF NO MORE THAN THREE SIGNIFICANT DIGITS FOR L,M AN
C                    N AS LARGE AS 32.  MORE DETAILED INFORMATION ABOUT
C                    ACCURACY CAN BE FOUND IN THE DOCUMENTATION FOR
C                    SUBROUTINE POIS3D WHICH IS THE ROUTINE THAT ACTUALL
C                    SOLVES THE FINITE DIFFERENCE EQUATIONS.
C
C
C                       L(=M=N)     LBDCND(=MBDCND=NBDCND)      T(MSECS)
C                       -------     ----------------------      --------
C
C                         16                  0                    300
C                         16                  1                    302
C                         16                  3                    348
C                         32                  0                   1925
C                         32                  1                   1929
C                         32                  3                   2109
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      NONE
C
C     REQUIRED         COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE        NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       BDXS(MDIMF,1)          ,BDXF(MDIMF,1)          ,
     1                BDYS(LDIMF,1)          ,BDYF(LDIMF,1)          ,
     2                BDZS(LDIMF,1)          ,BDZF(LDIMF,1)          ,
     3                F(LDIMF,MDIMF,1)       ,W(1)
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (XF .LE. XS) IERROR = 1
      IF (L .LT. 5) IERROR = 2
      IF (LBDCND.LT.0 .OR. LBDCND.GT.4) IERROR = 3
      IF (YF .LE. YS) IERROR = 4
      IF (M .LT. 5) IERROR = 5
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) IERROR = 6
      IF (ZF .LE. ZS) IERROR = 7
      IF (N .LT. 5) IERROR = 8
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) IERROR = 9
      IF (LDIMF .LT. L+1) IERROR = 10
      IF (MDIMF .LT. M+1) IERROR = 11
      IF (IERROR .NE. 0) GO TO 188
      DY = (YF-YS)/FLOAT(M)
      TWBYDY = 2./DY
      C2 = 1./(DY**2)
      MSTART = 1
      MSTOP = M
      MP1 = M+1
      MP = MBDCND+1
      GO TO (104,101,101,102,102),MP
  101 MSTART = 2
  102 GO TO (104,104,103,103,104),MP
  103 MSTOP = MP1
  104 MUNK = MSTOP-MSTART+1
      DZ = (ZF-ZS)/FLOAT(N)
      TWBYDZ = 2./DZ
      NP = NBDCND+1
      C3 = 1./(DZ**2)
      NP1 = N+1
      NSTART = 1
      NSTOP = N
      GO TO (108,105,105,106,106),NP
  105 NSTART = 2
  106 GO TO (108,108,107,107,108),NP
  107 NSTOP = NP1
  108 NUNK = NSTOP-NSTART+1
      LP1 = L+1
      DX = (XF-XS)/FLOAT(L)
      C1 = 1./(DX**2)
      TWBYDX = 2./DX
      LP = LBDCND+1
      LSTART = 1
      LSTOP = L
C
C     ENTER BOUNDARY DATA FOR X-BOUNDARIES.
C
      GO TO (122,109,109,112,112),LP
  109 LSTART = 2
      DO 111 J=MSTART,MSTOP
         DO 110 K=NSTART,NSTOP
            F(2,J,K) = F(2,J,K)-C1*F(1,J,K)
  110    CONTINUE
  111 CONTINUE
      GO TO 115
  112 DO 114 J=MSTART,MSTOP
         DO 113 K=NSTART,NSTOP
            F(1,J,K) = F(1,J,K)+TWBYDX*BDXS(J,K)
  113    CONTINUE
  114 CONTINUE
  115 GO TO (122,116,119,119,116),LP
  116 DO 118 J=MSTART,MSTOP
         DO 117 K=NSTART,NSTOP
            F(L,J,K) = F(L,J,K)-C1*F(LP1,J,K)
  117    CONTINUE
  118 CONTINUE
      GO TO 122
  119 LSTOP = LP1
      DO 121 J=MSTART,MSTOP
         DO 120 K=NSTART,NSTOP
            F(LP1,J,K) = F(LP1,J,K)-TWBYDX*BDXF(J,K)
  120    CONTINUE
  121 CONTINUE
  122 LUNK = LSTOP-LSTART+1
C
C     ENTER BOUNDARY DATA FOR Y-BOUNDARIES.
C
      GO TO (136,123,123,126,126),MP
  123 DO 125 I=LSTART,LSTOP
         DO 124 K=NSTART,NSTOP
            F(I,2,K) = F(I,2,K)-C2*F(I,1,K)
  124    CONTINUE
  125 CONTINUE
      GO TO 129
  126 DO 128 I=LSTART,LSTOP
         DO 127 K=NSTART,NSTOP
            F(I,1,K) = F(I,1,K)+TWBYDY*BDYS(I,K)
  127    CONTINUE
  128 CONTINUE
  129 GO TO (136,130,133,133,130),MP
  130 DO 132 I=LSTART,LSTOP
         DO 131 K=NSTART,NSTOP
            F(I,M,K) = F(I,M,K)-C2*F(I,MP1,K)
  131    CONTINUE
  132 CONTINUE
      GO TO 136
  133 DO 135 I=LSTART,LSTOP
         DO 134 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,MP1,K)-TWBYDY*BDYF(I,K)
  134    CONTINUE
  135 CONTINUE
  136 CONTINUE
C
C     ENTER BOUNDARY DATA FOR Z-BOUNDARIES.
C
      GO TO (150,137,137,140,140),NP
  137 DO 139 I=LSTART,LSTOP
         DO 138 J=MSTART,MSTOP
            F(I,J,2) = F(I,J,2)-C3*F(I,J,1)
  138    CONTINUE
  139 CONTINUE
      GO TO 143
  140 DO 142 I=LSTART,LSTOP
         DO 141 J=MSTART,MSTOP
            F(I,J,1) = F(I,J,1)+TWBYDZ*BDZS(I,J)
  141    CONTINUE
  142 CONTINUE
  143 GO TO (150,144,147,147,144),NP
  144 DO 146 I=LSTART,LSTOP
         DO 145 J=MSTART,MSTOP
            F(I,J,N) = F(I,J,N)-C3*F(I,J,NP1)
  145    CONTINUE
  146 CONTINUE
      GO TO 150
  147 DO 149 I=LSTART,LSTOP
         DO 148 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,NP1)-TWBYDZ*BDZF(I,J)
  148    CONTINUE
  149 CONTINUE
C
C     DEFINE A,B,C COEFFICIENTS IN W-ARRAY.
C
  150 CONTINUE
      IWB = NUNK+1
      IWC = IWB+NUNK
      IWW = IWC+NUNK
      DO 151 K=1,NUNK
         I = IWC+K-1
         W(K) = C3
         W(I) = C3
         I = IWB+K-1
         W(I) = -2.*C3+ELMBDA
  151 CONTINUE
      GO TO (155,155,153,152,152),NP
  152 W(IWC) = 2.*C3
  153 GO TO (155,155,154,154,155),NP
  154 W(IWB-1) = 2.*C3
  155 CONTINUE
      PERTRB = 0.
C
C     FOR SINGULAR PROBLEMS ADJUST DATA TO INSURE A SOLUTION WILL EXIST.
C
      GO TO (156,172,172,156,172),LP
  156 GO TO (157,172,172,157,172),MP
  157 GO TO (158,172,172,158,172),NP
  158 IF (ELMBDA) 172,160,159
  159 IERROR = 12
      GO TO 172
  160 CONTINUE
      MSTPM1 = MSTOP-1
      LSTPM1 = LSTOP-1
      NSTPM1 = NSTOP-1
      XLP = (2+LP)/3
      YLP = (2+MP)/3
      ZLP = (2+NP)/3
      S1 = 0.
      DO 164 K=2,NSTPM1
         DO 162 J=2,MSTPM1
            DO 161 I=2,LSTPM1
               S1 = S1+F(I,J,K)
  161       CONTINUE
            S1 = S1+(F(1,J,K)+F(LSTOP,J,K))/XLP
  162    CONTINUE
         S2 = 0.
         DO 163 I=2,LSTPM1
            S2 = S2+F(I,1,K)+F(I,MSTOP,K)
  163    CONTINUE
         S2 = (S2+(F(1,1,K)+F(1,MSTOP,K)+F(LSTOP,1,K)+F(LSTOP,MSTOP,K))/
     1                                                          XLP)/YLP
         S1 = S1+S2
  164 CONTINUE
      S = (F(1,1,1)+F(LSTOP,1,1)+F(1,1,NSTOP)+F(LSTOP,1,NSTOP)+
     1    F(1,MSTOP,1)+F(LSTOP,MSTOP,1)+F(1,MSTOP,NSTOP)+
     2                                   F(LSTOP,MSTOP,NSTOP))/(XLP*YLP)
      DO 166 J=2,MSTPM1
         DO 165 I=2,LSTPM1
            S = S+F(I,J,1)+F(I,J,NSTOP)
  165    CONTINUE
  166 CONTINUE
      S2 = 0.
      DO 167 I=2,LSTPM1
         S2 = S2+F(I,1,1)+F(I,1,NSTOP)+F(I,MSTOP,1)+F(I,MSTOP,NSTOP)
  167 CONTINUE
      S = S2/YLP+S
      S2 = 0.
      DO 168 J=2,MSTPM1
         S2 = S2+F(1,J,1)+F(1,J,NSTOP)+F(LSTOP,J,1)+F(LSTOP,J,NSTOP)
  168 CONTINUE
      S = S2/XLP+S
      PERTRB = (S/ZLP+S1)/((FLOAT(LUNK+1)-XLP)*(FLOAT(MUNK+1)-YLP)*
     1                                              (FLOAT(NUNK+1)-ZLP))
      DO 171 I=1,LUNK
         DO 170 J=1,MUNK
            DO 169 K=1,NUNK
               F(I,J,K) = F(I,J,K)-PERTRB
  169       CONTINUE
  170    CONTINUE
  171 CONTINUE
  172 CONTINUE
      NPEROD = 0
      IF (NBDCND .EQ. 0) GO TO 173
      NPEROD = 1
      W(1) = 0.
      W(IWW-1) = 0.
  173 CONTINUE
      CALL POIS3D (LBDCND,LUNK,C1,MBDCND,MUNK,C2,NPEROD,NUNK,W,W(IWB),
     1             W(IWC),LDIMF,MDIMF,F(LSTART,MSTART,NSTART),IR,W(IWW))
C
C     FILL IN SIDES FOR PERIODIC BOUNDARY CONDITIONS.
C
      IF (LP .NE. 1) GO TO 180
      IF (MP .NE. 1) GO TO 175
      DO 174 K=NSTART,NSTOP
         F(1,MP1,K) = F(1,1,K)
  174 CONTINUE
      MSTOP = MP1
  175 IF (NP .NE. 1) GO TO 177
      DO 176 J=MSTART,MSTOP
         F(1,J,NP1) = F(1,J,1)
  176 CONTINUE
      NSTOP = NP1
  177 DO 179 J=MSTART,MSTOP
         DO 178 K=NSTART,NSTOP
            F(LP1,J,K) = F(1,J,K)
  178    CONTINUE
  179 CONTINUE
  180 CONTINUE
      IF (MP .NE. 1) GO TO 185
      IF (NP .NE. 1) GO TO 182
      DO 181 I=LSTART,LSTOP
         F(I,1,NP1) = F(I,1,1)
  181 CONTINUE
      NSTOP = NP1
  182 DO 184 I=LSTART,LSTOP
         DO 183 K=NSTART,NSTOP
            F(I,MP1,K) = F(I,1,K)
  183    CONTINUE
  184 CONTINUE
  185 CONTINUE
      IF (NP .NE. 1) GO TO 188
      DO 187 I=LSTART,LSTOP
         DO 186 J=MSTART,MSTOP
            F(I,J,NP1) = F(I,J,1)
  186    CONTINUE
  187 CONTINUE
  188 CONTINUE
      RETURN
      END
C FISHPAK18  FROM PORTLIB                                  03/12/81
      SUBROUTINE POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,
     1                   MDIMF,F,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C     SUBROUTINE POIS3D SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C       C1*(X(I-1,J,K)-2.*X(I,J,K)+X(I+1,J,K))
C     + C2*(X(I,J-1,K)-2.*X(I,J,K)+X(I,J+1,K))
C     + A(K)*X(I,J,K-1)+B(K)*X(I,J,K)+C(K)*X(I,J,K+1) = F(I,J,K)
C
C     FOR  I=1,2,...,L , J=1,2,...,M , AND K=1,2,...,N .
C
C     THE INDICES K-1 AND K+1 ARE EVALUATED MODULO N, I.E.
C     X(I,J,0) = X(I,J,N) AND X(I,J,N+1) = X(I,J,1). THE UNKNOWNS
C     X(0,J,K), X(L+1,J,K), X(I,0,K), AND X(I,M+1,K) ARE ASSUMED TO TAKE
C     ON CERTAIN PRESCRIBED VALUES DESCRIBED BELOW.
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C    * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C
C            * * * * * *   ON INPUT    * * * * * *
C
C     LPEROD   INDICATES THE VALUES THAT X(0,J,K) AND X(L+1,J,K) ARE
C              ASSUMED TO HAVE.
C
C              = 0  IF X(0,J,K) = X(L,J,K) AND X(L+1,J,K) = X(1,J,K).
C              = 1  IF X(0,J,K) = X(L+1,J,K) = 0.
C              = 2  IF X(0,J,K) = 0  AND X(L+1,J,K) = X(L-1,J,K).
C              = 3  IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = X(L-1,J,K).
C              = 4  IF X(0,J,K) = X(2,J,K) AND X(L+1,J,K) = 0.
C
C     L        THE NUMBER OF UNKNOWNS IN THE I-DIRECTION. L MUST BE AT
C              LEAST 3.
C
C     C1       THE REAL CONSTANT THAT APPEARS IN THE ABOVE EQUATION.
C
C     MPEROD   INDICATES THE VALUES THAT X(I,0,K) AND X(I,M+1,K) ARE
C              ASSUMED TO HAVE.
C
C              = 0  IF X(I,0,K) = X(I,M,K) AND X(I,M+1,K) = X(I,1,K).
C              = 1  IF X(I,0,K) = X(I,M+1,K) = 0.
C              = 2  IF X(I,0,K) = 0 AND X(I,M+1,K) = X(I,M-1,K).
C              = 3  IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = X(I,M-1,K).
C              = 4  IF X(I,0,K) = X(I,2,K) AND X(I,M+1,K) = 0.
C
C     M        THE NUMBER OF UNKNOWNS IN THE J-DIRECTION. M MUST BE AT
C              LEAST 3.
C
C     C2       THE REAL CONSTANT WHICH APPEARS IN THE ABOVE EQUATION.
C
C     NPEROD   = 0  IF A(1) AND C(N) ARE NOT ZERO.
C              = 1  IF A(1) = C(N) = 0.
C
C     N        THE NUMBER OF UNKNOWNS IN THE K-DIRECTION. N MUST BE AT
C              LEAST 3.
C
C
C     A,B,C    ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT SPECIFY THE
C              COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE.
C
C              IF NPEROD = 0 THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE
C              INDEX K, BUT MUST BE CONSTANT.  SPECIFICALLY,THE
C              SUBROUTINE CHECKS THE FOLLOWING CONDITION
C
C                          A(K) = C(1)
C                          C(K) = C(1)
C                          B(K) = B(1)
C
C                  FOR K=1,2,...,N.
C
C     LDIMF    THE ROW (OR FIRST) DIMENSION OF THE THREE-DIMENSIONAL
C              ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D.
C              THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION
C              OF F.  LDIMF MUST BE AT LEAST L.
C
C     MDIMF    THE COLUMN (OR SECOND) DIMENSION OF THE THREE-DIMENSIONAL
C              ARRAY F AS IT APPEARS IN THE PROGRAM CALLING POIS3D.
C              THIS PARAMETER IS USED TO SPECIFY THE VARIABLE DIMENSION
C              OF F.  MDIMF MUST BE AT LEAST M.
C
C     F        A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF
C              THE RIGHT SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN
C              ABOVE.  F MUST BE DIMENSIONED AT LEAST L X M X N.
C
C     W        A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE
C              USER FOR WORK SPACE.  THE LENGTH OF W MUST BE AT LEAST
C              30 + L + M + 2*N + MAX(L,M,N) +
C              7*(INT((L+1)/2) + INT((M+1)/2)).
C
C
C            * * * * * *   ON OUTPUT   * * * * * *
C
C     F        CONTAINS THE SOLUTION X.
C
C     IERROR   AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS.
C              EXCEPT FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C              = 0  NO ERROR
C              = 1  IF LPEROD .LT. 0 OR .GT. 4
C              = 2  IF L .LT. 3
C              = 3  IF MPEROD .LT. 0 OR .GT. 4
C              = 4  IF M .LT. 3
C              = 5  IF NPEROD .LT. 0 OR .GT. 1
C              = 6  IF N .LT. 3
C              = 7  IF LDIMF .LT. L
C              = 8  IF MDIMF .LT. M
C              = 9  IF A(K) .NE. C(1) OR C(K) .NE. C(1) OR B(I) .NE.B(1)
C                      FOR SOME K=1,2,...,N.
C              = 10 IF NPEROD = 1 AND A(1) .NE. 0 OR C(N) .NE. 0
C
C              SINCE THIS IS THE ONLY MEANS OF INDICATING A POSSIBLY
C              INCORRECT CALL TO POIS3D, THE USER SHOULD TEST IERROR
C              AFTER THE CALL.
C
C
C    * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   A(N),B(N),C(N),F(LDIMF,MDIMF,N),
C     ARGUMENTS      W(SEE ARGUMENT LIST)
C
C     LATEST         DECEMBER 1, 1978
C     REVISION
C
C     SUBPROGRAMS    POIS3D,POS3D1,TRID,RFFTI,RFFTF,RFFTF1,RFFTB,
C     REQUIRED       RFFTB1,COSTI,COST,SINTI,SINT,COSQI,COSQF,COSQF1
C                    COSQB,COSQB1,SINQI,SINQF,SINQB,CFFTI,CFFTI1,
C                    CFFTB,CFFTB1,PASSB2,PASSB3,PASSB4,PASSB,CFFTF,
C                    CFFTF1,PASSF1,PASSF2,PASSF3,PASSF4,PASSF,PIMACH,
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         VALUE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        WRITTEN BY ROLAND SWEET AT NCAR IN JULY,1977
C
C     ALGORITHM      THIS SUBROUTINE SOLVES THREE-DIMENSIONAL BLOCK
C                    TRIDIAGONAL LINEAR SYSTEMS ARISING FROM FINITE
C                    DIFFERENCE APPROXIMATIONS TO THREE-DIMENSIONAL
C                    POISSON EQUATIONS USING THE FOURIER TRANSFORM
C                    PACKAGE SCLRFFTPAK WRITTEN BY PAUL SWARZTRAUBER.
C
C     SPACE          6561(DECIMAL) = 14641(OCTAL) LOCATIONS ON THE
C     REQUIRED       NCAR CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE POIS3D IS ROUGHLY PROPORTIONAL
C                    TO L*M*N*(LOG2(L)+LOG2(M)+5), BUT ALSO DEPENDS ON
C                    INPUT PARAMETERS LPEROD AND MPEROD.  SOME TYPICAL
C                    VALUES ARE LISTED IN THE TABLE BELOW WHEN NPEROD=0.
C                       TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                    UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE
C                    A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE
C                    "PURPOSE" WITH
C
C                       A(K) = C(K) = -0.5*B(K) = 1,       K=1,2,...,N
C
C                    AND, WHEN NPEROD = 1
C
C                       A(1) = C(N) = 0
C                       A(N) = C(1) = 2.
C
C                    THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS-
C                    TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS
C                    COMPUTED.  USING THIS ARRAY Y SUBROUTINE POIS WAS
C                    CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z.  THEN
C                    THE RELATIVE ERROR, DEFINED AS
C
C                    E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K)))
C
C                    WHERE THE TWO MAXIMA ARE TAKEN OVER I=1,2,...,L,
C                    J=1,2,...,M AND K=1,2,...,N, WAS COMPUTED.  THE
C                    VALUE OF E IS GIVEN IN THE TABLE BELOW FOR SOME
C                    TYPICAL VALUES OF L,M AND N.
C
C
C                       L(=M=N)   LPEROD    MPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         16        0         0         272     1.E-13
C                         15        1         1         287     4.E-13
C                         17        3         3         338     2.E-13
C                         32        0         0        1755     2.E-13
C                         31        1         1        1894     2.E-12
C                         33        3         3        2042     7.E-13
C
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUTE FORTRAN.
C                    THE MACHINE DEPENDENT CONSTANT PI IS DEFINED IN
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS,SIN,ATAN
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      NONE
C
C    * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,
     1                F(LDIMF,MDIMF,1)       ,W(1)       ,SAVE(6)
      LP = LPEROD+1
      MP = MPEROD+1
      NP = NPEROD+1
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
      IF (L .LT. 3) IERROR = 2
      IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
      IF (M .LT. 3) IERROR = 4
      IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
      IF (N .LT. 3) IERROR = 6
      IF (LDIMF .LT. L) IERROR = 7
      IF (MDIMF .LT. M) IERROR = 8
      IF (NP .NE. 1) GO TO 103
      DO 101 K=1,N
         IF (A(K) .NE. C(1)) GO TO 102
         IF (C(K) .NE. C(1)) GO TO 102
         IF (B(K) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 9
  103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
  104 IF (IERROR .NE. 0) GO TO 122
      IWYRT = L+1
      IWT = IWYRT+M
      IWD = IWT+MAX0(L,M,N)+1
      IWBB = IWD+N
      IWX = IWBB+N
      IWY = IWX+7*((L+1)/2)+15
      GO TO (105,114),NP
C
C     REORDER UNKNOWNS WHEN NPEROD = 0.
C
  105 NH = (N+1)/2
      NHM1 = NH-1
      NODD = 1
      IF (2*NH .EQ. N) NODD = 2
      DO 111 I=1,L
         DO 110 J=1,M
            DO 106 K=1,NHM1
               NHPK = NH+K
               NHMK = NH-K
               W(K) = F(I,J,NHMK)-F(I,J,NHPK)
               W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
  106       CONTINUE
            W(NH) = 2.*F(I,J,NH)
            GO TO (108,107),NODD
  107       W(N) = 2.*F(I,J,N)
  108       DO 109 K=1,N
               F(I,J,K) = W(K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      SAVE(1) = C(NHM1)
      SAVE(2) = A(NH)
      SAVE(3) = C(NH)
      SAVE(4) = B(NHM1)
      SAVE(5) = B(N)
      SAVE(6) = A(N)
      C(NHM1) = 0.
      A(NH) = 0.
      C(NH) = 2.*C(NH)
      GO TO (112,113),NODD
  112 B(NHM1) = B(NHM1)-A(NH-1)
      B(N) = B(N)+A(N)
      GO TO 114
  113 A(N) = C(NH)
  114 CONTINUE
      CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
     1             W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
      GO TO (115,122),NP
  115 DO 121 I=1,L
         DO 120 J=1,M
            DO 116 K=1,NHM1
               NHMK = NH-K
               NHPK = NH+K
               W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
               W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
  116       CONTINUE
            W(NH) = .5*F(I,J,NH)
            GO TO (118,117),NODD
  117       W(N) = .5*F(I,J,N)
  118       DO 119 K=1,N
               F(I,J,K) = W(K)
  119       CONTINUE
  120    CONTINUE
  121 CONTINUE
      C(NHM1) = SAVE(1)
      A(NH) = SAVE(2)
      C(NH) = SAVE(3)
      B(NHM1) = SAVE(4)
      B(N) = SAVE(5)
      A(N) = SAVE(6)
  122 CONTINUE
      RETURN
      END
      SUBROUTINE POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,XRT,YRT,T,D,
     1                   WX,WY,C1,C2,BB)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,
     1                F(LDIMF,MDIMF,1)       ,XRT(1)     ,YRT(1)     ,
     2                T(1)       ,D(1)       ,WX(1)      ,WY(1)      ,
     3                BB(1)
      PI = PIMACH(DUM)
      LR = L
      MR = M
      NR = N
C
C     GENERATE TRANSFORM ROOTS
C
      LRDEL = ((LP-1)*(LP-3)*(LP-5))/3
      SCALX = LR+LRDEL
      DX = PI/(2.*SCALX)
      GO TO (108,103,101,102,101),LP
  101 DI = 0.5
      SCALX = 2.*SCALX
      GO TO 104
  102 DI = 1.0
      GO TO 104
  103 DI = 0.0
  104 DO 105 I=1,LR
         XRT(I) = -4.*C1*(SIN((FLOAT(I)-DI)*DX))**2
  105 CONTINUE
      SCALX = 2.*SCALX
      GO TO (112,106,110,107,111),LP
  106 CALL SINTI (LR,WX)
      GO TO 112
  107 CALL COSTI (LR,WX)
      GO TO 112
  108 XRT(1) = 0.
      XRT(LR) = -4.*C1
      DO 109 I=3,LR,2
         XRT(I-1) = -4.*C1*(SIN(FLOAT((I-1))*DX))**2
         XRT(I) = XRT(I-1)
  109 CONTINUE
      CALL RFFTI (LR,WX)
      GO TO 112
  110 CALL SINQI (LR,WX)
      GO TO 112
  111 CALL COSQI (LR,WX)
  112 CONTINUE
      MRDEL = ((MP-1)*(MP-3)*(MP-5))/3
      SCALY = MR+MRDEL
      DY = PI/(2.*SCALY)
      GO TO (120,115,113,114,113),MP
  113 DJ = 0.5
      SCALY = 2.*SCALY
      GO TO 116
  114 DJ = 1.0
      GO TO 116
  115 DJ = 0.0
  116 DO 117 J=1,MR
         YRT(J) = -4.*C2*(SIN((FLOAT(J)-DJ)*DY))**2
  117 CONTINUE
      SCALY = 2.*SCALY
      GO TO (124,118,122,119,123),MP
  118 CALL SINTI (MR,WY)
      GO TO 124
  119 CALL COSTI (MR,WY)
      GO TO 124
  120 YRT(1) = 0.
      YRT(MR) = -4.*C2
      DO 121 J=3,MR,2
         YRT(J-1) = -4.*C2*(SIN(FLOAT((J-1))*DY))**2
         YRT(J) = YRT(J-1)
  121 CONTINUE
      CALL RFFTI (MR,WY)
      GO TO 124
  122 CALL SINQI (MR,WY)
      GO TO 124
  123 CALL COSQI (MR,WY)
  124 CONTINUE
      IFWRD = 1
      IS = 1
  125 CONTINUE
C
C     TRANSFORM X
C
      DO 141 J=1,MR
         DO 140 K=1,NR
            DO 126 I=1,LR
               T(I) = F(I,J,K)
  126       CONTINUE
            GO TO (127,130,131,134,135),LP
  127       GO TO (128,129),IFWRD
  128       CALL RFFTF (LR,T,WX)
            GO TO 138
  129       CALL RFFTB (LR,T,WX)
            GO TO 138
  130       CALL SINT (LR,T,WX)
            GO TO 138
  131       GO TO (132,133),IFWRD
  132       CALL SINQF (LR,T,WX)
            GO TO 138
  133       CALL SINQB (LR,T,WX)
            GO TO 138
  134       CALL COST (LR,T,WX)
            GO TO 138
  135       GO TO (136,137),IFWRD
  136       CALL COSQF (LR,T,WX)
            GO TO 138
  137       CALL COSQB (LR,T,WX)
  138       CONTINUE
            DO 139 I=1,LR
               F(I,J,K) = T(I)
  139       CONTINUE
  140    CONTINUE
  141 CONTINUE
      GO TO (142,164),IFWRD
C
C     TRANSFORM Y
C
  142 CONTINUE
      DO 158 I=1,LR
         DO 157 K=1,NR
            DO 143 J=1,MR
               T(J) = F(I,J,K)
  143       CONTINUE
            GO TO (144,147,148,151,152),MP
  144       GO TO (145,146),IFWRD
  145       CALL RFFTF (MR,T,WY)
            GO TO 155
  146       CALL RFFTB (MR,T,WY)
            GO TO 155
  147       CALL SINT (MR,T,WY)
            GO TO 155
  148       GO TO (149,150),IFWRD
  149       CALL SINQF (MR,T,WY)
            GO TO 155
  150       CALL SINQB (MR,T,WY)
            GO TO 155
  151       CALL COST (MR,T,WY)
            GO TO 155
  152       GO TO (153,154),IFWRD
  153       CALL COSQF (MR,T,WY)
            GO TO 155
  154       CALL COSQB (MR,T,WY)
  155       CONTINUE
            DO 156 J=1,MR
               F(I,J,K) = T(J)
  156       CONTINUE
  157    CONTINUE
  158 CONTINUE
      GO TO (159,125),IFWRD
  159 CONTINUE
C
C     SOLVE TRIDIAGONAL SYSTEMS IN Z
C
      DO 163 I=1,LR
         DO 162 J=1,MR
            DO 160 K=1,NR
               BB(K) = B(K)+XRT(I)+YRT(J)
               T(K) = F(I,J,K)
  160       CONTINUE
            CALL TRID (NR,A,BB,C,T,D)
            DO 161 K=1,NR
               F(I,J,K) = T(K)
  161       CONTINUE
  162    CONTINUE
  163 CONTINUE
      IFWRD = 2
      IS = -1
      GO TO 142
  164 CONTINUE
      DO 167 I=1,LR
         DO 166 J=1,MR
            DO 165 K=1,NR
               F(I,J,K) = F(I,J,K)/(SCALX*SCALY)
  165       CONTINUE
  166    CONTINUE
  167 CONTINUE
      RETURN
      END
      FUNCTION PIMACH (DUM)
C
C     THIS SUBPROGRAM SUPPLIES THE VALUE OF THE CONSTANT PI CORRECT TO
C     MACHINE PRECISION WHERE
C
C     PI=3.1415926535897932384626433832795028841971693993751058209749446
C
      PIMACH = 3.14159265358979
      RETURN
      END
      SUBROUTINE TRID(MR,A,B,C,Y,D)
C***BEGIN PROLOGUE  TRID
C***REFER TO  POIS3D
C***ROUTINES CALLED  (NONE)
C***END PROLOGUE  TRID
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                D(1)
C***FIRST EXECUTABLE STATEMENT  TRID
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
      END
C     PROGRAM TESTF2 (INPUT,OUTPUT,TAPE5=INPUT,TAPE6=OUTPUT)
C
C                 ---------------------
C                 TEST DRIVER FOR SEPX4
C                 ---------------------
C
C   SOLVE SAMPLE PROBLEMS ON A SEQUENCE OF GRIDS AND PRINT STATISTICS.
C   USER SELECTS ORDER OF ACCURACY (2 OR 4) AND PROBLEM NUMBER (1-10).
C
C   NOTE -- THIS PROGRAM CALLS THE SUBROUTINE TIMER (INCLUDED) TO OBTAIN
C           THE ELAPSED CPU TIME IN SECONDS SINCE THE START OF THE RUN.
C           ROUTINE MUST BE REPLACED WHEN IMPLEMENTING THIS PROGRAM ON
C           A NEW COMPUTER.
C
C   THE PROBLEMS ARE
C
C     1.  SMOOTH HOMOGENEOUS DIRICHLET PROBLEM FOR THE POISSON EQUATION.
C         (PROBLEM A2 OF REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, BY=1
C
C         U = 3XY(1-X)(1-Y) EXP(X+Y)
C
C     2.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS; SOLUTION SAME AS IN PROBLEM 1.
C         (PROBLEM B2 OF REFERENCE)
C
C         COEFU = -5
C         U GIVEN ON BY=1
C         UX GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=0
C
C         U = 3XY(1-X)(1-Y) EXP(X+Y)
C
C     3.  POISSON EQUATION; SOLUTION IS A WAVE FRONT ALONG A RIGHT
C         ANGLE JOINING TWO REGIONS WHERE IT IS A CONSTANT; SOLUTION
C         HAS DISCONTINUOUS 3RD DERIVATIVES.
C
C         COEFU = 0
C         U GIVEN ON AX=0, AY=0
C         UX GIVEN ON BX=1
C         UY GIVEN ON BY=1
C
C         U = P(X)*P(Y)
C
C         P(X) IS 1 FOR X.LT.0.15 AND 0 FOR X.GT.0.85.  BETWEEN THESE
C         IT IS DEFINED AS THE QUINTIC POLYNOMIAL WHICH JOINS THESE
C         TWO FLAT REGIONS AND GIVES P TWO CONTINUOUS DERIVATIVES.
C
C     4.  SMOOTH HELMHOLTZ PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = -100
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (P(X;10)+P(Y;20)/2
C
C         P(X;A) = COSH(A*X)/COSH(A)
C
C     5.  DIRICHLET PROBLEM FOR POISSON EQUATION; SOLUTION HAS
C         SINGULAR SECOND DERIVATIVES ALONG X=0, Y=0.
C         (PROBLEM F2 OF THE REFERENCE)
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1, AY=0, AY=1
C
C         U = (X**1.5-X)*(Y**1.5-Y)
C
C     6.  SMOOTH, PERIODIC HELMHOLTZ PROBLEM.
C         (PROBLEM C2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI, AY=0, BY=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C     7.  SMOOTH POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY
C         CONDITIONS.
C
C         COEFU = 0
C         U GIVEN ON AX=0, BX=1
C         UY GIVEN ON AY=-1, BY=1
C
C         U = T(Y)*( A(X) + T(Y)*B(X) )
C
C         T(Y) = 1-Y**2,  A(X) = R*C(X) + EXP(SQRT(Q*X)),
C         B(X) = (7-P)*R/16/C(X),  P = 14+SQRT(133),  Q = 14-SQRT(133),
C         R = (7-Q)/R/SQRT(133),  C(X) = EXP(SQRT(P*X))-EXP(SQRT(Q*X))
C
C     8.  POISSON PROBLEM WITH SOME DERIVATIVE BOUNDARY CONDITIONS;
C         SOLUTION HAS SINGULAR THIRD DERIVATIVES ALONG X=0, Y=0.
C         (PROBLEM E2 OF THE REFERNCE)
C
C         COEFU = 0
C         U GIVEN ON BX=1, BY=1
C         UX GIVEN ON AX=0
C         UY GIVEN ON AY=0
C
C         U = (X*Y)**2.5
C
C     9.  SMOOTH HELMHOLTZ PROBLEM WITH DIRICHLET, NEUMANN AND PERIODIC
C         BOUNDARY CONDITIONS; SAME SOLUTION AS PROBLEM 6.
C         (PROBLEM D2 OF THE REFERENCE)
C
C         COEFU = -20
C         U PERIODIC ON AX=0, BX=PI
C         U GIVEN ON AY=0
C         UY GIVEN ON BY=PI
C
C         U = COS(4Y) + SIN(4(X-Y))
C
C    10.  HOMOGENEOUS DIRICHLET PROBLEM; INCLUDED TO COLLECT TIMING
C         DATA WHEN COST OF FUNCTION EVALUATIONS IS MINIMUM.
C
C         COEFU = 0
C         U=0 ON AX=0, BX=1, AY=0, BY=1
C
C
C-----------------------------------------------------------------------
C
C
C     ... CONSTANTS
C
C         NMAX = MAX GRID SIZE FOR THIS PROGRAM
C         NWORK = WORKSPACE REQUIRED FOR NMAX BY NMAX GRID
C         LDXU,LDYU = REQUIRED DIMENSIONS FOR U
C         LUIN = INPUT UNIT FOR READS
C         LUOUT = OUTPUT UNIT FOR WRITES
C
      PARAMETER (NRUNS=7, NMAX=2**NRUNS+1)
      PARAMETER (LDXU=NMAX, LDYU=NMAX)
      PARAMETER (NWORK = 2*NMAX**2 + 10*NMAX + NMAX/2 + 17)
      PARAMETER (LUIN=5, LUOUT=6)
C
      INTEGER BCTY(4)
      REAL
     *     COEFU, AX, BX, AY, BY, U(LDXU,LDYU), WORK(NWORK),
     *     H, ABSERR, RELERR, TRUMAX, HOLD, EOLD, RATE
C
      EXTERNAL PRHS, BRHS
C
C
C-----------------------------------------------------------------------
C
C
C  SELECT ORDER OF ACCURACY
C
    5 CONTINUE
      WRITE(LUOUT,*) ' ENTER ORDER OF ACCURACY (2 OR 4) '
      READ(LUIN,*) IORDER
      IF ((IORDER .NE. 2) .AND. (IORDER .NE. 4))  GO TO 5
C
C  SELECT PROBLEM
C
   10 CONTINUE
      WRITE(LUOUT,*) ' ENTER PROBLEM NUMBER (1-10, 0 TO STOP) '
      READ(LUIN,*) KPROB
      IF (KPROB .EQ. 0)  STOP
      IF ((KPROB .LT. 0) .OR. (KPROB .GT. 10))  GO TO 10
C
C  SOLVE ON SEQUENCE OF GRIDS
C
      WRITE(LUOUT,2000) KPROB,IORDER
      EOLD = 0.0E0
      DO 500 K=3,NRUNS
C
C        ... SETUP PROBLEM
C
         NX = 2**K + 1
         CALL SETUP(KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY)
         IF (NY .GT. NMAX)  GO TO 10
C
C        ... SOLVE PROBLEM
C
         CALL TIMER(T0)
         CALL FISH2(COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER,
     *              U,LDXU,WORK,NWORK,INFO)
         CALL TIMER(T1)
         CPTIME = T1 - T0
C
         IF (INFO .NE. 0) THEN
            WRITE(LUOUT,2002) INFO
            GO TO 10
         ENDIF
C
C        ... COMPUTE ERROR
C
         H = (BX-AX)/REAL(NX-1)
         CALL GETERR(AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX)
C
C        ... COMPUTE CONVERGENCE RATE
C
         IF (RELERR .LT. EOLD) THEN
            RATE = ABS(ALOG(RELERR/EOLD)/ALOG(H/HOLD))
         ELSE
            RATE = 0.0E0
         ENDIF
C
C        ... PRINT SUMMARY
C
         WRITE(LUOUT,2001) NX,NY,H,INFO,ABSERR,RELERR,TRUMAX,RATE,
     *                     CPTIME
         HOLD = H
         EOLD = RELERR
  500 CONTINUE
      GO TO 10
C
 2000 FORMAT(///'  PROBLEM ',I2,7X,'MODULE FISH2',7X,'IORDER = ',I1
     *       //'   NX  NY',7X,'H',5X,'INFO',3X,'ABSERR',6X,'RELERR',
     *       6X,'TRUMAX',4X,'RATE',3X,'SECS' / 2X,37('--') /)
 2001 FORMAT(2X,I3,1X,I3,2X,1P,E11.4,1X,I2,3E12.4,2X,0P,F4.1,1X,F6.2)
 2002 FORMAT(/'  SEPX4 RETURNS INFO = ',I3/)
C
      END
      SUBROUTINE FISH2 (COEFU,PRHS,BRHS,AX,BX,AY,BY,NX,NY,BCTY,IORDER,
     *                  U,LDXU,WORK,NWORK,INFO)
C
C-----------------------------------------------------------------------
C
C   DRIVER FOR FISHPAK SUBPROGRAM SEPX4
C
C-----------------------------------------------------------------------
C
      INTEGER NX, NY, BCTY(4), IORDER, LDXU, INFO
      REAL
     *     COEFU, PRHS, BRHS, AX, BX, AY, BY, U(LDXU,*), WORK(NWORK)
      REAL
     *      CU, ALPHA, BETA, H, X, Y, PERTRB
C
      COMMON / COEF / CU
      EXTERNAL COFX
C
C-----------------------------------------------------------------------
C
      CU = COEFU
      M = NX-1
      N = NY-1
      ALPHA = 0.0E0
      BETA = 0.0E0
      H = (BX-AX)/REAL(M)
C
      KBCA = BCTY(3)
      KBCB = BCTY(1)
      KBCC = BCTY(2)
      KBCD = BCTY(4)
      IF ((KBCA .EQ. 3) .AND. (KBCB .EQ. 3)) MBDCND = 0
      IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 1)) MBDCND = 1
      IF ((KBCA .EQ. 1) .AND. (KBCB .EQ. 2)) MBDCND = 2
      IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 2)) MBDCND = 3
      IF ((KBCA .EQ. 2) .AND. (KBCB .EQ. 1)) MBDCND = 4
      IF ((KBCC .EQ. 3) .AND. (KBCD .EQ. 3)) NBDCND = 0
      IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 1)) NBDCND = 1
      IF ((KBCC .EQ. 1) .AND. (KBCD .EQ. 2)) NBDCND = 2
      IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 2)) NBDCND = 3
      IF ((KBCC .EQ. 2) .AND. (KBCD .EQ. 1)) NBDCND = 4
C
      LOC BDA = 1
      LOC BDB = LOC BDA + NY
      LOC BDC = LOC BDB + NY
      LOC BDD = LOC BDC + NX
      LOC GRH = LOC BDD + NX
      LOC WRK = LOC GRH + LDXU*NY
C
      IF (KBCA .EQ. 2) THEN
         K = LOC BDA - 1
         DO 10 J=1,NY
            Y = AY + H*REAL(J-1)
            K = K + 1
            WORK(K) = BRHS(3,AX,Y)
   10    CONTINUE
      ENDIF
C
      IF (KBCB .EQ. 2) THEN
         K = LOC BDB - 1
         DO 20 J=1,NY
            Y = AY + H*REAL(J-1)
            K = K + 1
            WORK(K) = BRHS(1,BX,Y)
   20    CONTINUE
      ENDIF
C
      IF (KBCC .EQ. 2) THEN
         K = LOC BDC - 1
         DO 30 I=1,NX
            X = AX + H*REAL(I-1)
            K = K + 1
            WORK(K) = BRHS(2,X,AY)
   30    CONTINUE
      ENDIF
C
      IF (KBCD .EQ. 2) THEN
         K = LOC BDD - 1
         DO 40 I=1,NX
            X = AX + H*REAL(I-1)
            K = K + 1
            WORK(K) = BRHS(4,X,BY)
   40    CONTINUE
      ENDIF
C
      IF (KBCA .EQ. 1) THEN
         DO 50 J=1,NY
            Y = AY + H*REAL(J-1)
            U(1,J) = BRHS(3,AX,Y)
   50    CONTINUE
      ENDIF
C
      IF (KBCB .EQ. 1) THEN
         DO 60 J=1,NY
            Y = AY + H*REAL(J-1)
            U(NX,J) = BRHS(1,BX,Y)
   60    CONTINUE
      ENDIF
C
      IF (KBCC .EQ. 1) THEN
         DO 70 I=1,NX
            X = AX + H*REAL(I-1)
            U(I,1) = BRHS(2,X,AY)
   70    CONTINUE
      ENDIF
C
      IF (KBCD .EQ. 1) THEN
         DO 80 I=1,NX
            X = AX + H*REAL(I-1)
            U(I,NY) = BRHS(4,X,BY)
   80    CONTINUE
      ENDIF
C
      DO 90 J=1,NY
         K = LOC GRH + (J-1)*LDXU - 1
         Y = AY + H*REAL(J-1)
         DO 90 I=1,NX
            X = AX + H*REAL(I-1)
            K = K + 1
            WORK(K) = PRHS(X,Y)
   90 CONTINUE
C
      WORK(LOCWRK) = REAL(NWORK - LOCWRK + 1)
C
      CALL SEPX4(IORDER,AX,BX,M,MBDCND,WORK(LOCBDA),ALPHA,WORK(LOCBDB),
     *           BETA,AY,BY,N,NBDCND,WORK(LOCBDC),WORK(LOCBDD),COFX,
     *           WORK(LOCGRH),U,LDXU,WORK(LOCWRK),PERTRB,INFO)
C
      RETURN
      END
      SUBROUTINE COFX (X,CUXX,CUX,CU)
      REAL
     *     X, CUXX, CUX, CU, COEFU
      COMMON / COEF / COEFU
      CUXX = 1.0E0
      CUX  = 0.0E0
      CU   = COEFU
      RETURN
      END
      SUBROUTINE GETERR (AX,AY,H,NX,NY,U,LDXU,ABSERR,RELERR,TRUMAX)
C
C  ----------------------------------------------------------
C  COMPUTE MAX(ABSOLUTE ERROR) AND MAX(TRUE SOLUTION) ON GRID
C  ----------------------------------------------------------
C
      REAL AX,AY,H,U(LDXU,*),ABSERR,RELERR,TRUMAX
      REAL X,Y,TRUSOL,DIFF
C
      ABSERR = 0.0E0
      TRUMAX = 0.0E0
      DO 100 J=1,NY
         Y = AY + H*REAL(J-1)
         DO 100 I=1,NX
            X = AX + H*REAL(I-1)
            TRUSOL = TRUE(X,Y)
            ABSERR = MAX(ABS(TRUSOL-U(I,J)),ABSERR)
            TRUMAX = MAX(ABS(TRUSOL),TRUMAX)
  100 CONTINUE
C
      IF (TRUMAX .NE. 0.0E0) THEN
         RELERR = ABSERR/TRUMAX
      ELSE
         RELERR = ABSERR
      ENDIF
      RETURN
      END
      SUBROUTINE SETUP (KPROB,NX,NY,COEFU,AX,BX,AY,BY,BCTY)
C
C  ---------------------------------------------------------
C  SETUP PROBLEM KPROB (NX, NY, COEFU, AX, BX, AY, BY, BCTY)
C  ---------------------------------------------------------
C
      INTEGER KPROB,NX,NY,BCTY(4)
      REAL
     *     COEFU,AX,BX,AY,BY
C
      COMMON /SELECT/ IPROB
C
      IPROB = KPROB
C
C  DEFAULT VALUES
C
      NY = NX
      AX = 0.0E0
      BX = 1.0E0
      AY = 0.0E0
      BY = 1.0E0
      COEFU = 0.0E0
      BCTY(1) = 1
      BCTY(2) = 1
      BCTY(3) = 1
      BCTY(4) = 1
C
C  SELECT OPTIONS FOR EACH CASE
C
      GO TO (100,200,300,400,500,600,700,800,900), IPROB
      GO TO 9999
C
  100 CONTINUE
      GO TO 9999
C
  200 CONTINUE
      COEFU = -5.0E0
      BCTY(1) = 2
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  300 CONTINUE
      BCTY(1) = 2
      BCTY(4) = 2
      GO TO 9999
C
  400 CONTINUE
      COEFU = -100.0E0
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  500 CONTINUE
      GO TO 9999
C
  600 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(2) = 3
      BCTY(3) = 3
      BCTY(4) = 3
      GO TO 9999
C
  700 CONTINUE
      NY = 2*NX - 1
      AY = -1.0E0
      BCTY(2) = 2
      BCTY(4) = 2
      GO TO 9999
C
  800 CONTINUE
      BCTY(2) = 2
      BCTY(3) = 2
      GO TO 9999
C
  900 CONTINUE
      BX = 4.0E0*ATAN(1.0E0)
      BY = BX
      COEFU = -20.0E0
      BCTY(1) = 3
      BCTY(4) = 2
      BCTY(3) = 3
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION PRHS(X,Y)
C
C  ----------------------------------------
C  RIGHT-HAND SIDE OF DIFFERENTIAL EQUATION
C  ----------------------------------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,600), IPROB
C
         PRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      PRHS = 6.0E0*X*Y*EXP(X+Y)*(X*Y+X+Y-3.)
      GO TO 9999
C
  200 CONTINUE
      PRHS = X*Y*EXP(X+Y)*(6.0E0*(X*Y+X+Y-3.0E0)
     *               - 15.0E0*(1.0E0-X)*(1.0E0-Y))
      GO TO 9999
C
  300 CONTINUE
      PRHS = D2P(X)*P(Y) + P(X)*D2P(Y)
      GO TO 9999
C
  400 CONTINUE
      PRHS = 150.0E0*COSH(20.0E0*Y)/COSH(20.0E0)
      GO TO 9999
C
  500 CONTINUE
      C = -0.18750E0
      A = 0.750E0
      AM2 = A - 2.0E0
      IF ((X .NE. 0.0E0) .AND. (Y .NE. 0.0E0)) THEN
         PRHS = C*(X**AM2*(Y**A-Y) + Y**AM2*(X**A-X))
      ELSE
         PRHS = 0.0E0
      ENDIF
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      B2 = B*B
      PRHS = - 2.0E0*(B2+10.0E0)*SIN(B*(X-Y))
     *       -       (B2+20.0E0)*COS(B*Y)
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      DEK1X = RK1*RK1*EK1X
      DEK2X = RK2*RK2*EK2X
      DEDIFF = DEK1X-DEK2X
      DDF1 = A*DEDIFF + DEK2X
      DDF2 = B*DEDIFF
      UXX = Y21*(DDF1 + Y21*DDF2)
      UYY = -2.0E0*(F1 + 2.0E0*(1.0E0-3.0E0*Y*Y)*F2)
      PRHS = UXX + UYY
      GO TO 9999
C
  800 CONTINUE
      PRHS = 3.750E0*(SQRT(X*Y**5) + SQRT(Y*X**5))
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION BRHS (K,X,Y)
C
C  --------------------------------------
C  RIGHT-HAND SIDE OF BOUNDARY CONDITIONS
C  --------------------------------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,200,300,400,500,600,700,800,900), IPROB
C
         BRHS = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      BRHS = 0.0E0
      GO TO 9999
C
  200 CONTINUE
      GO TO (210,220,210,240), K
  210    BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*X)*Y*(1.0E0-Y)
         GO TO 9999
  220    BRHS = 3.0E0*EXP(X+Y)*(1.0E0-2.0E0*Y)*X*(1.0E0-X)
         GO TO 9999
  240    BRHS = 0.0E0
         GO TO 9999
C
  300 CONTINUE
      GO TO (310,320,320,310), K
  310    BRHS = 0.0E0
         GO TO 9999
  320    BRHS = TRUE(X,Y)
         GO TO 9999
C
  400 CONTINUE
      GO TO (420,410,410,420), K
  410    BRHS = 0.0E0
         GO TO 9999
  420    BRHS = TRUE(X,Y)
         GO TO 9999
C
  500 CONTINUE
      BRHS = TRUE(X,Y)
      GO TO 9999
C
  600 CONTINUE
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      GO TO (710,720,710,720), K
  710    BRHS = Y21*(F1 + Y21*F2)
         GO TO 9999
  720    BRHS = -2.0E0*Y*(F1 + 2.0E0*Y21*F2)
         GO TO 9999
C
  800 CONTINUE
      GO TO (810,820,820,810), K
  810    BRHS = SQRT((X*Y)**5)
         GO TO 9999
  820    BRHS = 0.0E0
         GO TO 9999
C
  900 CONTINUE
      IF (K .EQ. 2) THEN
         BRHS = TRUE(X,Y)
      ELSE
         BRHS = -4.0E0*COS(4.0E0*X)
      ENDIF
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION TRUE(X,Y)
C
C  -------------
C  TRUE SOLUTION
C  -------------
C
      REAL X,Y
C
      COMMON /SELECT/ IPROB
C
      GO TO (100,100,300,400,500,600,700,800,600), IPROB
C
         TRUE = 0.0E0
         GO TO 9999
C
  100 CONTINUE
      TRUE = 3.0E0*EXP(X+Y)*X*Y*(1.0E0-X)*(1.0E0-Y)
      GO TO 9999
C
  300 CONTINUE
      TRUE = P(X)*P(Y)
      GO TO 9999
C
  400 CONTINUE
      TRUE = (COSH(10.E0*X)/COSH(10.0E0)+COSH(20.0E0*Y)/COSH(20.0E0))
     *                              /2.0E0
      GO TO 9999
C
  500 CONTINUE
      A = 0.750E0
      TRUE = (X**A-X)*(Y**A-Y)
      GO TO 9999
C
  600 CONTINUE
      B = 4.0E0
      TRUE = COS(B*Y) + SIN(B*(X-Y))
      GO TO 9999
C
  700 CONTINUE
      S133 = SQRT(133.0E0)
      RK1 = SQRT(14.0E0+S133)
      RK2 = SQRT(14.0E0-S133)
      A = (-7.0E0+S133)/(2.0E0*S133)
      B = (-7.0E0-S133)*A/16.0E0
      EK1X = EXP(RK1*X)
      EK2X = EXP(RK2*X)
      EDIFF = EK1X-EK2X
      F1 = A*EDIFF + EK2X
      F2 = B*EDIFF
      Y21 = 1.0E0 - Y*Y
      TRUE = Y21*(F1 + Y21*F2)
      GO TO 9999
C
  800 CONTINUE
      TRUE = SQRT((X*Y)**5)
      GO TO 9999
C
 9999 CONTINUE
      RETURN
      END
      REAL FUNCTION P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 20
      DZ = Z2 - Z1
      P = 1.0E0 - (Z-Z1)**3*(1.0E0 - 3.0E0*(Z-Z2)/DZ
     *              + 6.0E0*(Z-Z2)**2/DZ**2)/DZ**3
      RETURN
   10 CONTINUE
      P = 1.0E0
      RETURN
   20 CONTINUE
      P = 0.0E0
      RETURN
      END
      REAL FUNCTION D2P (Z)
      Z1 = 0.150E0
      Z2 = 0.850E0
      IF (Z .LE. Z1)  GO TO 10
      IF (Z .GE. Z2)  GO TO 10
      DZ = Z2 - Z1
      C3 = -1.0E0/DZ**3
      C4 = 3.0E0/DZ**4
      C5 = -6.0E0/DZ**5
      ZMZ1 = Z - Z1
      ZMZ2 = Z - Z2
      ZMZ12 = ZMZ1*ZMZ1
      ZMZ22 = ZMZ2*ZMZ2
      D2P = 6.0E0*(C3*ZMZ1 + C4*ZMZ1*ZMZ2 + C4*ZMZ12 + C5*ZMZ1*ZMZ22
     *               + 2.0E0*C5*ZMZ12*ZMZ2) + 2.0E0*C5*ZMZ12*ZMZ1
      RETURN
   10 CONTINUE
      D2P = 0.0E0
      RETURN
      END
      SUBROUTINE TIMER (T)
C
C  ------------------------------------------------
C  RETURNS ELAPSED CP TIME SINCE START OF JOB (SEC)
C  ------------------------------------------------
C
      REAL T
      T = SECOND()
      RETURN
      END
C FISHPAK13  FROM PORTLIB                                  03/12/81
      SUBROUTINE SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1NBDCND,BDC,BDD,COFX,GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C
C DIMENSION OF           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C ARGUMENTS              USOL(IDMN,N+1), GRHS(IDMN,N+1),
C                        W (SEE ARGUMENT LIST)
C
C LATEST REVISION        OCTOBER 1980
C
C
C PURPOSE                SEPX4 SOLVES FOR EITHER THE SECOND-ORDER
C                        FINITE DIFFERENCE APPROXIMATION OR A
C                        A FOURTH-ORDER APPROXIMATION  TO THE
C                        SOLUTION OF A SEPARABLE ELLIPTIC EQUATION
C                             AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y)
C
C                        ON A RECTANGLE (X GREATER THAN OR EQUAL TO A
C                        AND LESS THAN OR EQUAL TO B; Y GREATER THAN
C                        OR EQUAL TO C AND LESS THAN OR EQUAL TO D).
C                        ANY COMBINATION OF PERIODIC OR MIXED BOUNDARY
C                        CONDITIONS IS ALLOWED.
C                        IF BOUNDARY CONDITIONS IN THE X DIRECTION
C                        ARE PERIODIC (SEE MBDCND=0 BELOW) THEN THE
C                        COEFFICIENTS MUST SATISFY
C                        AF(X)=C1,BF(X)=0,CF(X)=C2 FOR ALL X.
C                        HERE C1,C2 ARE CONSTANTS, C1.GT.0.
C
C                        THE POSSIBLE BOUNDARY CONDITIONS ARE
C                        IN THE X-DIRECTION:
C                         (0) PERIODIC, U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                         (1) U(A,Y), U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (2) U(A,Y), DU(B,Y)/DX+BETA*U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C                         (3) DU(A,Y)/DX+ALPHA*U(A,Y),DU(B,Y)/DX+
C                             BETA*U(B,Y) ARE SPECIFIED FOR ALL Y
C                         (4) DU(A,Y)/DX+ALPHA*U(A,Y),U(B,Y) ARE
C                             SPECIFIED FOR ALL Y
C
C                        IN THE Y-DIRECTION:
C                         (0) PERIODIC, U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                         (1) U(X,C),U(X,D) ARE SPECIFIED FOR ALL X
C                         (2) U(X,C),DU(X,D)/DY ARE SPECIFIED FOR ALL X
C                         (3) DU(X,C)/DY,DU(X,D)/DY ARE SPECIFIED FOR
C                            ALL X
C                        (4) DU(X,C)/DY,U(X,D) ARE SPECIFIED FOR ALL X
C
C USAGE                  CALL SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,
C                                  BETA,C,D,N,NBDCND,BDC,BDD,COFX,
C                                  GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C ARGUMENTS
C
C
C                        IORDER
C                          = 2 IF A SECOND-ORDER APPROXIMATION IS SOUGHT
C                          = 4 IF A FOURTH-ORDER APPROXIMATION IS SOUGHT
C
C                        A,B
C                          THE RANGE OF THE X-INDEPENDENT VARIABLE;
C                          I.E., X IS GREATER THAN OR EQUAL TO A AND
C                          LESS THAN OR EQUAL TO B.  A MUST BE LESS THAN
C                          B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          [A,B] IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          M+1 GRID POINTS IN THE X-DIRECTION GIVEN BY
C                          XI=A+(I-1)*DLX FOR I=1,2,...,M+1 WHERE
C                          DLX=(B-A)/M IS THE PANEL WIDTH.  M MUST BE
C                          LESS THAN IDMN AND GREATER THAN 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION AT
C                          X=A AND X=B
C                          = 0 IF THE SOLUTION IS PERIODIC IN X; I.E.,
C                              U(X+B-A,Y)=U(X,Y) FOR ALL Y,X
C                          = 1 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              X=B; I.E., U(A,Y) AND U(B,Y) ARE
C                              SPECIFIED FOR ALL Y
C                          = 2 IF THE SOLUTION IS SPECIFIED AT X=A AND
C                              THE BOUNDARY CONDITION IS MIXED AT X=B;
C                              I.E., U(A,Y) AND DU(B,Y)/DX+BETA*U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C                          = 3 IF THE BOUNDARY CONDITIONS AT X=A AND X=B
C                              ARE MIXED; I.E., DU(A,Y)/DX+ALPHA*U(A,Y)
C                              AND DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 4 IF THE BOUNDARY CONDITION AT X=A IS MIXED
C                              AND THE SOLUTION IS SPECIFIED AT X=B;
C                              I.E., DU(A,Y)/DX+ALPHA*U(A,Y) AND U(B,Y)
C                              ARE SPECIFIED FOR ALL Y
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(A,Y)/DX+
C                          ALPHA*U(A,Y) AT X=A, WHEN MBDCND=3 OR 4.
C                               BDA(J) = DU(A,YJ)/DX+ALPHA*U(A,YJ);
C                               J=1,2,...,N+1
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDA IS A
C                          DUMMY PARAMETER.
C
C ON INPUT               ALPHA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=A (SEE
C                          ARGUMENT BDA).  IF MBDCND " 3,4 THEN ALPHA IS
C                          A DUMMY PARAMETER.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF DU(B,Y)/DX+
C                          BETA*U(B,Y) AT X=B.  WHEN MBDCND=2 OR 3
C                               BDB(J) = DU(B,YJ)/DX+BETA*U(B,YJ);
C                               J=1,2,...,N+1
C                          WHEN MBDCND HAS ANY OTHER VALUE, BDB IS A
C                          DUMMY PARAMETER.
C
C                        BETA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=B (SEE
C                          ARGUMENT BDB).  IF MBDCND"2,3 THEN BETA IS A
C                          DUMMY PARAMETER.
C
C                        C,D
C                          THE RANGE OF THE Y-INDEPENDENT VARIABLE;
C                          I.E., Y IS GREATER THAN OR EQUAL TO C AND
C                          LESS THAN OR EQUAL TO D.  C MUST BE LESS THAN
C                          D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE INTERVAL
C                          [C,D] IS SUBDIVIDED.  HENCE, THERE WILL BE
C                          N+1 GRID POINTS IN THE Y-DIRECTION GIVEN BY
C                          YJ=C+(J-1)*DLY FOR J=1,2,...,N+1 WHERE
C                          DLY=(D-C)/N IS THE PANEL WIDTH.  IN ADDITION,
C                          N MUST BE GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPES OF BOUNDARY CONDITIONS AT
C                          Y=C AND Y=D
C                          = 0 IF THE SOLUTION IS PERIODIC IN Y; I.E.,
C                              U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                          = 1 IF THE SOLUTION IS SPECIFIED AT Y=C AND
C                              Y = D, I.E., U(X,C) AND U(X,D) ARE
C                              SPECIFIED FOR ALL X
C                          = 2 IF THE SOLUTION IS SPECIFIED AT Y=C AND
C                              THE BOUNDARY CONDITION IS MIXED AT Y=D;
C                              I.E., DU(X,C)/DY AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 3 IF THE BOUNDARY CONDITIONS ARE MIXED AT
C                              Y=CAND Y=D I.E., DU(X,D)/DY
C                              AND DU(X,D)/DY ARE SPECIFIED
C                              FOR ALL X
C                          = 4 IF THE BOUNDARY CONDITION IS MIXED AT Y=C
C                              AND THE SOLUTION IS SPECIFIED AT Y=D;
C                              I.E. DU(X,C)/DY+GAMA*U(X,C) AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C
C                        BDC
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIES THE VALUE DU(X,C)/DY
C                          AT Y=C.  WHEN NBDCND=3 OR 4
C                            BDC(I) = DU(XI,C)/DY
C                             I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS A
C                          DUMMY PARAMETER.
C
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                           SPECIFIED THE VALUE OF DU(X,D)/DY
C                           AT Y=D.  WHEN NBDCND=2 OR 3
C                             BDD(I)=DU(XI,D)/DY
C                            I=1,2,...,M+1.
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS A
C                          DUMMY PARAMETER.
C
C
C                        COFX
C                          A USER-SUPPLIED SUBPROGRAM WITH
C                          PARAMETERS X, AFUN, BFUN, CFUN WHICH
C                          RETURNS THE VALUES OF THE X-DEPENDENT
C                          COEFFICIENTS AF(X), BF(X), CF(X) IN
C                          THE ELLIPTIC EQUATION AT X.
C                        IF BOUNDARY CONDITIONS IN THE X DIRECTION
C                        ARE PERIODIC THEN THE COEFFICIENTS
C                        MUST SATISFY AF(X)=C1,BF(X)=0,CF(X)=C2 FOR
C                        ALL X.  HERE C1.GT.0 AND C2 ARE CONSTANTS.
C
C                        NOTE THAT COFX MUST BE DECLARED EXTERNAL
C                        IN THE CALLING ROUTINE.
C
C                        GRHS
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT-HAND SIDE OF THE ELLIPTIC
C                          EQUATION; I.E., GRHS(I,J)=G(XI,YI), FOR
C                          I=2,...,M; J=2,...,N.  AT THE BOUNDARIES,
C                          GRHS IS DEFINED BY
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          WHERE * MEANS THESE QUANTITES ARE NOT USED.
C                          GRHS SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        USOL
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE SOLUTION ALONG THE BOUNDARIES.
C                          AT THE BOUNDARIES, USOL IS DEFINED BY
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          WHERE * MEANS THE QUANTITES ARE NOT USED IN
C                          THE SOLUTION.
C
C                          IF IORDER=2, THE USER MAY EQUIVALENCE GRHS
C                          AND USOL TO SAVE SPACE.  NOTE THAT IN THIS
C                          CASE THE TABLES SPECIFYING THE BOUNDARIES OF
C                          THE GRHS AND USOL ARRAYS DETERMINE THE
C                          BOUNDARIES UNIQUELY EXCEPT AT THE CORNERS.
C                          IF THE TABLES CALL FOR BOTH G(X,Y) AND
C                          U(X,Y) AT A CORNER THEN THE SOLUTION MUST BE
C                          CHOSEN.  FOR EXAMPLE, IF MBDCND=2 AND
C                          NBDCND=4, THEN U(A,C), U(A,D), U(B,D) MUST BE
C                          CHOSEN AT THE CORNERS IN ADDITION TO G(B,C).
C
C                          IF IORDER=4, THEN THE TWO ARRAYS, USOL AND
C                          GRHS, MUST BE DISTINCT.
C
C                          USOL SHOULD BE DIMENSIONED IDMN BY AT LEAST
C                          N+1 IN THE CALLING ROUTINE.
C
C                        IDMN
C                          THE ROW (OR FIRST) DIMENSION OF THE ARRAYS
C                          GRHS AND USOL AS IT APPEARS IN THE PROGRAM
C                          CALLING SEPX4.  THIS PARAMETER IS USED TO
C                          SPECIFY THE VARIABLE DIMENSION OF GRHS AND
C                          USOL.  IDMN MUST BE AT LEAST 7 AND GREATER
C                          THAN OR EQUAL TO M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED
C                        BY THE USER FOR WORK SPACE.
C                        10*N+(16+INT(LOG2(N)))*(M+1)+23 WILL SUFFICE
C                        AS A LENGTH FOR W.  THE ACTUAL LENGTH OF
C                        W IN THE CALLING ROUTINE MUST BE SET IN W(1)
C                        (SEE IERROR=11).
C ON OUTPUT              USOL
C                          CONTAINS THE APPROXIMATE SOLUTION TO THE
C                          ELLIPTIC EQUATION.  USOL(I,J) IS THE
C                          APPROXIMATION TO U(XI,YJ) FOR I=1,2...,M+1
C                          AND J=1,2,...,N+1.  THE APPROXIMATION HAS
C                          ERROR O(DLX**2+DLY**2) IF CALLED WITH
C                          IORDER=2 AND O(DLX**4+DLY**4) IF CALLED WITH
C                          IORDER=4.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT BE
C                          DESTROYED IF SEPX4 IS CALLED AGAIN WITH
C                          INTL=1.  IN ADDITION W(1) CONTAINS THE EXACT
C                          MINIMAL LENGTH (IN FLOATING POINT) REQUIRED
C                          FOR THE WORK SPACE (SEE IERROR=11).
C
C                        PERTRB
C                        IF A COMBINATION OF PERIODIC OR DERIVATIVE
C                        BOUNDARY CONDITIONS (I.E., ALPHA=BETA=0 IF
C                        MBDCND=3) IS SPECIFIED AND IF CF(X)=0 FOR ALL X
C                        THEN A SOLUTION TO THE DISCRETIZED MATRIX
C                        EQUATION MAY NOT EXIST (REFLECTING THE NON-
C                        UNIQUENESS OF SOLUTIONS TO THE PDE).  PERTRB
C                        IS A CONSTANT CALCULATED AND SUBTRACTED FROM
C                        THE RIGHT HAND SIDE OF THE MATRIX EQUATION
C                        INSURING THE EXISTENCE OF A SOLUTION.
C                        SEPX4 COMPUTES THIS SOLUTION WHICH IS A
C                        WEIGHTED MINIMAL LEAST SQUARES SOLUTION TO
C                        THE ORIGINAL PROBLEM.  IF SINGULARITY IS
C                        NOT DETECTED PERTRB=0.0 IS RETURNED BY
C                        SEPX4.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS OR FAILURE TO FIND A SOLUTION
C                          = 0 NO ERROR
C                          = 1 IF A GREATER THAN B OR C GREATER THAN D
C                          = 2 IF MBDCND LESS THAN 0 OR MBDCND GREATER
C                              THAN 4
C                          = 3 IF NBDCND LESS THAN 0 OR NBDCND GREATER
C                              THAN 4
C                          = 4 IF ATTEMPT TO FIND A SOLUTION FAILS.
C                              (THE LINEAR SYSTEM GENERATED IS NOT
C                              DIAGONALLY DOMINANT.)
C                          = 5 IF IDMN IS TOO SMALL (SEE DISCUSSION OF
C                              IDMN)
C                          = 6 IF M IS TOO SMALL OR TOO LARGE (SEE
C                              DISCUSSION OF M)
C                          = 7 IF N IS TOO SMALL (SEE DISCUSSION OF N)
C                          = 8 IF IORDER IS NOT 2 OR 4
C                          = 9 IF INTL IS NOT 0 OR 1
C                          = 10 IF AFUN IS LESS THAN OR EQUAL TO ZERO
C                          FOR SOME INTERIOR MESH POINT XI
C                               SOME INTERIOR MESH POINT (XI,YJ)
C                          = 11 IF THE WORK SPACE LENGTH INPUT IN W(1)
C                               IS LESS THAN THE EXACT MINIMAL WORK
C                               SPACE LENGTH REQUIRED OUTPUT IN W(1).
C                        = 12 IF MBDCND=0 AND AF(X)=CF(X)=CONSTANT
C                             OR BF(X)=0 FOR ALL X IS NOT TRUE.
C
C
C SPECIAL CONDITIONS     NONE
C
C COMMON BLOCKS          SPL4
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       NONE
C FILES
C
C SPECIALIST             JOHN C. ADAMS, NCAR, BOULDER, COLORADO  80307
C
C LANGUAGE               FORTRAN
C
C
C  ENTRY POINTS          SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4,
C                        DEFE4,DX4,DY4
C
C HISTORY                SEPX4 WAS DEVELOPED BY MODIFYING THE ULIB
C                        ROUTINE SEPELI DURING OCTOBER 1978.
C                        IT SHOULD BE USED INSTEAD OF SEPELI WHENEVER
C                        POSSIBLE.  THE INCREASE IN SPEED IS AT LEAST
C                        A FACTOR OF THREE.
C
C ALGORITHM              SEPX4 AUTOMATICALLY DISCRETIZES THE SEPARABLE
C                        ELLIPTIC EQUATION WHICH IS THEN SOLVED BY A
C                        GENERALIZED CYCLIC REDUCTION ALGORITHM IN THE
C                        SUBROUTINE POIS.  THE FOURTH ORDER SOLUTION
C                        IS OBTAINED USING THE TECHNIQUE OF
C                        DEFFERRED CORRECTIONS REFERENCED BELOW.
C
C
C REFERENCES             KELLER, H.B., NUMERICAL METHODS FOR TWO-POINT
C                          BOUNDARY-VALUE PROBLEMS, BLAISDEL (1968),
C                          WALTHAM, MASS.
C
C                        SWARZTRAUBER, P., AND R. SWEET (1975):
C                          EFFICIENT FORTRAN SUBPROGRAMS FOR THE
C                          SOLUTION OF ELLIPTIC PARTIAL DIFFERENTIAL
C                          EQUATIONS.  NCAR TECHNICAL NOTE
C                          NCAR-TN/IA-109, PP. 135-137.
C
C
C
C
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       BDA(1)     ,BDB(1)     ,BDC(1)     ,BDD(1)     ,
     1                W(1)
      EXTERNAL COFX
C
C     CHECK INPUT PARAMETERS
C
      CALL CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      K = M+1
      L = N+1
C     ESTIMATE LOG BASE 2 OF N
      LOG2N=INT(ALOG(FLOAT(N+1))/ALOG(2.0)+0.5)
      LENGTH=4*(N+1)+(10+LOG2N)*(M+1)
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = FLOAT(LOUTPT)
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END
      SUBROUTINE SPELI4(IORDER,A,B,M,MBDCND,
     1BDA,ALPHA,BDB,BETA,C,D,N,NBDCND,BDC,BDD,COFX,AN,BN,
     2                   CN,DN,UN,ZN,AM,BM,CM,DM,UM,ZM,GRHS,USOL,IDMN,
     3                   W,PERTRB,IERROR)
C
C     SPELI4 SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI
C     AND COMPUTES A SECOND ORDER SOLUTION IN USOL.  A RETURN JUMP TO
C     SEPX4 OCCURRS IF IORDER=2.  IF IORDER=4 A FOURTH ORDER
C     SOLUTION IS GENERATED IN USOL.
C
      DIMENSION       BDA(1)     ,BDB(1)     ,BDC(1)     ,BDD(1)     ,
     1                W(1)
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       AN(1)      ,BN(1)      ,CN(1)      ,DN(1)      ,
     1                UN(1)      ,ZN(1)
      DIMENSION       AM(1)      ,BM(1)      ,CM(1)      ,DM(1)      ,
     1                UM(1)      ,ZM(1)
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      LOGICAL         SINGLR
      EXTERNAL COFX
C
C
C     SET PARAMETERS INTERNALLY
C
      KSWX = MBDCND+1
      KSWY = NBDCND+1
      K = M+1
      L = N+1
      AIT = A
      BIT = B
      CIT = C
      DIT = D
      DLY=(DIT-CIT)/FLOAT(N)
C
C     SET RIGHT HAND SIDE VALUES FROM GRHS IN USOL ON THE INTERIOR
C     AND NON-SPECIFIED BOUNDARIES.
C
      DO  20 I=2,M
         DO  10 J=2,N
      USOL(I,J)=DLY**2*GRHS(I,J)
   10    CONTINUE
   20 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) GO TO  40
      DO  30 J=2,N
      USOL(1,J)=DLY**2*GRHS(1,J)
   30 CONTINUE
   40 CONTINUE
      IF (KSWX.EQ.2 .OR. KSWX.EQ.5) GO TO  60
      DO  50 J=2,N
      USOL(K,J)=DLY**2*GRHS(K,J)
   50 CONTINUE
   60 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) GO TO  80
      DO  70 I=2,M
      USOL(I,1)=DLY**2*GRHS(I,1)
   70 CONTINUE
   80 CONTINUE
      IF (KSWY.EQ.2 .OR. KSWY.EQ.5) GO TO 100
      DO  90 I=2,M
      USOL(I,L)=DLY**2*GRHS(I,L)
   90 CONTINUE
  100 CONTINUE
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1USOL(1,1)=DLY**2*GRHS(1,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.3)
     1USOL(K,1)=DLY**2*GRHS(K,1)
      IF (KSWX.NE.2 .AND. KSWX.NE.3 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1USOL(1,L)=DLY**2*GRHS(1,L)
      IF (KSWX.NE.2 .AND. KSWX.NE.5 .AND. KSWY.NE.2 .AND. KSWY.NE.5)
     1USOL(K,L)=DLY**2*GRHS(K,L)
      I1 = 1
C
C     SET SWITCHES FOR PERIODIC OR NON-PERIODIC BOUNDARIES
C
      MP=1
      IF(KSWX.EQ.1) MP=0
      NP=NBDCND
C
C     SET DLX,DLY AND SIZE OF BLOCK TRI-DIAGONAL SYSTEM GENERATED
C     IN NINT,MINT
C
      DLX = (BIT-AIT)/FLOAT(M)
      MIT = K-1
      IF (KSWX .EQ. 2) MIT = K-2
      IF (KSWX .EQ. 4) MIT = K
      DLY = (DIT-CIT)/FLOAT(N)
      NIT = L-1
      IF (KSWY .EQ. 2) NIT = L-2
      IF (KSWY .EQ. 4) NIT = L
      TDLX3 = 2.0*DLX**3
      DLX4 = DLX**4
      TDLY3 = 2.0*DLY**3
      DLY4 = DLY**4
C
C     SET SUBSCRIPT LIMITS FOR PORTION OF ARRAY TO INPUT TO BLKTRI
C
      IS = 1
      JS = 1
      IF (KSWX.EQ.2 .OR. KSWX.EQ.3) IS = 2
      IF (KSWY.EQ.2 .OR. KSWY.EQ.3) JS = 2
      NS = NIT+JS-1
      MS = MIT+IS-1
C
C     SET X - DIRECTION
C
      DO 110 I=1,MIT
         XI = AIT+FLOAT(IS+I-2)*DLX
         CALL COFX (XI,AI,BI,CI)
         AXI = (AI/DLX-0.5*BI)/DLX
         BXI = -2.*AI/DLX**2+CI
         CXI = (AI/DLX+0.5*BI)/DLX
      AM(I)=DLY**2*AXI
      BM(I)=DLY**2*BXI
      CM(I)=DLY**2*CXI
  110 CONTINUE
C
C     SET Y DIRECTION
C
      DO 120 J=1,NIT
      DYJ=1.0
      EYJ=-2.0
      FYJ=1.0
         AN(J) = DYJ
         BN(J) = EYJ
         CN(J) = FYJ
  120 CONTINUE
C
C     ADJUST EDGES IN X DIRECTION UNLESS PERIODIC
C
      AX1 = AM(1)
      CXM = CM(MIT)
      GO TO (170,130,150,160,140),KSWX
C
C     DIRICHLET-DIRICHLET IN X DIRECTION
C
  130 AM(1) = 0.0
      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED-DIRICHLET IN X DIRECTION
C
  140 AM(1) = 0.0
      BM(1) = BM(1)+2.*ALPHA*DLX*AX1
      CM(1) = CM(1)+AX1
      CM(MIT) = 0.0
      GO TO 170
C
C     DIRICHLET-MIXED IN X DIRECTION
C
  150 AM(1) = 0.0
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*BETA*DLX*CXM
      CM(MIT) = 0.0
      GO TO 170
C
C     MIXED - MIXED IN X DIRECTION
C
  160 CONTINUE
      AM(1) = 0.0
      BM(1) = BM(1)+2.*DLX*ALPHA*AX1
      CM(1) = CM(1)+AX1
      AM(MIT) = AM(MIT)+CXM
      BM(MIT) = BM(MIT)-2.*DLX*BETA*CXM
      CM(MIT) = 0.0
  170 CONTINUE
C
C     ADJUST IN Y DIRECTION UNLESS PERIODIC
C
      DY1 = AN(1)
      FYN = CN(NIT)
      GAMA=0.0
      XNU=0.0
      GO TO (220,180,200,210,190),KSWY
C
C     DIRICHLET-DIRICHLET IN Y DIRECTION
C
  180 CONTINUE
      AN(1) = 0.0
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED-DIRICHLET IN Y DIRECTION
C
  190 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      CN(NIT) = 0.0
      GO TO 220
C
C     DIRICHLET-MIXED IN Y DIRECTION
C
  200 AN(1) = 0.0
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.*DLY*XNU*FYN
      CN(NIT) = 0.0
      GO TO 220
C
C     MIXED - MIXED DIRECTION IN Y DIRECTION
C
  210 CONTINUE
      AN(1) = 0.0
      BN(1) = BN(1)+2.*DLY*GAMA*DY1
      CN(1) = CN(1)+DY1
      AN(NIT) = AN(NIT)+FYN
      BN(NIT) = BN(NIT)-2.0*DLY*XNU*FYN
      CN(NIT) = 0.0
  220 IF (KSWX .EQ. 1) GO TO 270
C
C     ADJUST USOL ALONG X EDGE
C
      DO 260 J=JS,NS
         IF (KSWX.NE.2 .AND. KSWX.NE.3) GO TO 230
         USOL(IS,J) = USOL(IS,J)-AX1*USOL(1,J)
         GO TO 240
  230    USOL(IS,J) = USOL(IS,J)+2.0*DLX*AX1*BDA(J)
  240    IF (KSWX.NE.2 .AND. KSWX.NE.5) GO TO 250
         USOL(MS,J) = USOL(MS,J)-CXM*USOL(K,J)
         GO TO 260
  250    USOL(MS,J) = USOL(MS,J)-2.0*DLX*CXM*BDB(J)
  260 CONTINUE
  270 IF (KSWY .EQ. 1) GO TO 320
C
C     ADJUST USOL ALONG Y EDGE
C
      DO 310 I=IS,MS
         IF (KSWY.NE.2 .AND. KSWY.NE.3) GO TO 280
         USOL(I,JS) = USOL(I,JS)-DY1*USOL(I,1)
         GO TO 290
  280    USOL(I,JS) = USOL(I,JS)+2.0*DLY*DY1*BDC(I)
  290    IF (KSWY.NE.2 .AND. KSWY.NE.5) GO TO 300
         USOL(I,NS) = USOL(I,NS)-FYN*USOL(I,L)
         GO TO 310
  300    USOL(I,NS) = USOL(I,NS)-2.0*DLY*FYN*BDD(I)
  310 CONTINUE
  320 CONTINUE
C
C     SAVE ADJUSTED EDGES IN GRHS IF IORDER=4
C
      IF (IORDER .NE. 4) GO TO 350
      DO 330 J=JS,NS
         GRHS(IS,J) = USOL(IS,J)
         GRHS(MS,J) = USOL(MS,J)
  330 CONTINUE
      DO 340 I=IS,MS
         GRHS(I,JS) = USOL(I,JS)
         GRHS(I,NS) = USOL(I,NS)
  340 CONTINUE
  350 CONTINUE
      IORD = IORDER
      PERTRB = 0.0
C
C     CHECK IF OPERATOR IS SINGULAR
C
      CALL CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR)
C
C     COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE
C     IF SINGULAR
C
      IF (SINGLR) CALL TRIS4 (MIT,AM,BM,CM,DM,UM,ZM)
      IF (SINGLR) CALL TRIS4 (NIT,AN,BN,CN,DN,UN,ZN)
C
C     ADJUST RIGHT HAND SIDE IF NECESSARY
C
  360 CONTINUE
      IF (SINGLR) CALL ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB)
C
C     COMPUTE SOLUTION
C
C     SAVE ADJUSTED RIGHT HAND SIDE IN GRHS
      DO 444 J=JS,NS
      DO 444 I=IS,MS
      GRHS(I,J)=USOL(I,J)
  444 CONTINUE
      CALL GENBUN(NP,NIT,MP,MIT,AM,BM,CM,IDMN,USOL(IS,JS),IEROR,W)
C     CHECK IF ERROR DETECTED IN POIS
C     THIS CAN ONLY CORRESPOND TO IERROR=12
      IF(IEROR.EQ.0) GO TO 224
C     SET ERROR FLAG IF IMPROPER COEFFICIENTS INPUT TO POIS
      IERROR=12
      RETURN
  224 CONTINUE
      IF (IERROR .NE. 0) RETURN
C
C     SET PERIODIC BOUNDARIES IF NECESSARY
C
      IF (KSWX .NE. 1) GO TO 380
      DO 370 J=1,L
         USOL(K,J) = USOL(1,J)
  370 CONTINUE
  380 IF (KSWY .NE. 1) GO TO 400
      DO 390 I=1,K
         USOL(I,L) = USOL(I,1)
  390 CONTINUE
  400 CONTINUE
C
C     MINIMIZE SOLUTION WITH RESPECT TO WEIGHTED LEAST SQUARES
C     NORM IF OPERATOR IS SINGULAR
C
      IF (SINGLR) CALL MINSO4 (USOL,IDMN,ZN,ZM,PRTRB)
C
C     RETURN IF DEFE4RED CORRECTIONS AND A FOURTH ORDER SOLUTION ARE
C     NOT FLAGGED
C
      IF (IORD .EQ. 2) RETURN
      IORD = 2
C
C     COMPUTE NEW RIGHT HAND SIDE FOR FOURTH ORDER SOLUTION
C
      CALL DEFE4(COFX,IDMN,USOL,GRHS)
      GO TO 360
      END
      SUBROUTINE CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERR
     1OR)
      EXTERNAL COFX
C
C     THIS PROGRAM CHECKS THE INPUT PARAMETERS FOR ERRORS
C
C
C
C     CHECK DEFINITION OF SOLUTION REGION
C
      IERROR = 1
      IF (A.GE.B .OR. C.GE.D) RETURN
C
C     CHECK BOUNDARY SWITCHES
C
      IERROR = 2
      IF (MBDCND.LT.0 .OR. MBDCND.GT.4) RETURN
      IERROR = 3
      IF (NBDCND.LT.0 .OR. NBDCND.GT.4) RETURN
C
C     CHECK FIRST DIMENSION IN CALLING ROUTINE
C
      IERROR = 5
      IF (IDMN .LT. 7) RETURN
C
C     CHECK M
C
      IERROR = 6
      IF (M.GT.(IDMN-1) .OR. M.LT.6) RETURN
C
C     CHECK N
C
      IERROR = 7
      IF (N .LT. 5) RETURN
C
C     CHECK IORDER
C
      IERROR = 8
      IF (IORDER.NE.2 .AND. IORDER.NE.4) RETURN
C
C     CHECK INTL
C
C
C     CHECK THAT EQUATION IS ELLIPTIC
C
      DLX = (B-A)/FLOAT(M)
      DO  30 I=2,M
         XI = A+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
      IF (AI.GT.0.0) GO TO 10
      IERROR=10
      RETURN
   10 CONTINUE
   30 CONTINUE
C
C     NO ERROR FOUND
C
      IERROR = 0
      RETURN
      END
      SUBROUTINE TRIS4 (N,A,B,C,D,U,Z)
C
C     THIS SUBROUTINE SOLVES FOR A NON-ZERO EIGENVECTOR CORRESPONDING
C     TO THE ZERO EIGENVALUE OF THE TRANSPOSE OF THE RANK
C     DEFICIENT ONE MATRIX WITH SUBDIAGONAL A, DIAGONAL B, AND
C     SUPERDIAGONAL C , WITH A(1) IN THE (1,N) POSITION, WITH
C     C(N) IN THE (N,1) POSITION, AND ALL OTHER ELEMENTS ZERO.
C
      DIMENSION       A(N)       ,B(N)       ,C(N)       ,D(N)       ,
     1                U(N)       ,Z(N)
      BN = B(N)
      D(1) = A(2)/B(1)
      V = A(1)
      U(1) = C(N)/B(1)
      NM2 = N-2
      DO  10 J=2,NM2
         DEN = B(J)-C(J-1)*D(J-1)
         D(J) = A(J+1)/DEN
         U(J) = -C(J-1)*U(J-1)/DEN
         BN = BN-V*U(J-1)
         V = -V*D(J-1)
   10 CONTINUE
      DEN = B(N-1)-C(N-2)*D(N-2)
      D(N-1) = (A(N)-C(N-2)*U(N-2))/DEN
      AN = C(N-1)-V*D(N-2)
      BN = BN-V*U(N-2)
      DEN = BN-AN*D(N-1)
C
C     SET LAST COMPONENT EQUAL TO ONE
C
      Z(N) = 1.0
      Z(N-1) = -D(N-1)
      NM1 = N-1
      DO  20 J=2,NM1
         K = N-J
         Z(K) = -D(K)*Z(K+1)-U(K)*Z(N)
   20 CONTINUE
      RETURN
      END
      SUBROUTINE ORTHO4 (USOL,IDMN,ZN,ZM,PERTRB)
C
C     THIS SUBROUTINE ORTHO4ONALIZES THE ARRAY USOL WITH RESPECT TO
C     THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       USOL(IDMN,1)           ,ZN(1)      ,ZM(1)
      ISTR = IS
      IFNL = MS
      JSTR = JS
      JFNL = NS
C
C     COMPUTE WEIGHTED INNER PRODUCTS
C
      UTE = 0.0
      ETE = 0.0
      DO  20 I=IS,MS
         II = I-IS+1
         DO  10 J=JS,NS
            JJ = J-JS+1
            ETE = ETE+ZM(II)*ZN(JJ)
            UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ)
   10    CONTINUE
   20 CONTINUE
C
C     SET PERTURBATION PARAMETER
C
      PERTRB = UTE/ETE
C
C     SUBTRACT OFF CONSTANT PERTRB
C
      DO  40 I=ISTR,IFNL
         DO  30 J=JSTR,JFNL
            USOL(I,J) = USOL(I,J)-PERTRB
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
      SUBROUTINE DEFE4(COFX,IDMN,USOL,GRHS)
C
C     THIS SUBROUTINE FIRST APPROXIMATES THE TRUN1ATION ERROR GIVEN BY
C     TRUN1(X,Y)=DLX**2*TX+DLY**2*TY WHERE
C     TX=AFUN(X)*UXXXX/12.0+BFUN(X)*UXXX/6.0 ON THE INTERIOR AND
C     AT THE BOUNDARIES IF PERIODIC(HERE UXXX,UXXXX ARE THE THIRD
C     AND FOURTH PARTIAL DERIVATIVES OF U WITH RESPECT TO X).
C     TX IS OF THE FORM AFUN(X)/3.0*(UXXXX/4.0+UXXX/DLX)
C     AT X=A OR X=B IF THE BOUNDARY CONDITION THERE IS MIXED.
C     TX=0.0 ALONG SPECIFIED BOUNDARIES.  TY HAS SYMMETRIC FORM
C     IN Y WITH X,AFUN(X),BFUN(X) REPLACED BY Y,DFUN(Y),EFUN(Y).
C     THE SECOND ORDER SOLUTION IN USOL IS USED TO APPROXIMATE
C     (VIA SECOND ORDER FINITE DIFFERENCING) THE TRUN1ATION ERROR
C     AND THE RESULT IS ADDED TO THE RIGHT HAND SIDE IN GRHS
C     AND THEN TRANSFERRED TO USOL TO BE USED AS A NEW RIGHT
C     HAND SIDE WHEN CALLING BLKTRI FOR A FOURTH ORDER SOLUTION.
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      EXTERNAL COFX
C
C
C     COMPUTE TRUN1ATION ERROR APPROXIMATION OVER THE ENTIRE MESH
C
         DO  30 I=IS,MS
            XI = AIT+FLOAT(I-1)*DLX
            CALL COFX (XI,AI,BI,CI)
         DO 30 J=JS,NS
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT (XI,YJ)
C
            CALL DX4(USOL,IDMN,I,J,UXXX,UXXXX)
            CALL DY4(USOL,IDMN,I,J,UYYY,UYYYY)
            TX = AI*UXXXX/12.0+BI*UXXX/6.0
             TY=UYYYY/12.0
C
C     RESET FORM OF TRUN1ATION IF AT BOUNDARY WHICH IS NON-PERIODIC
C
            IF (KSWX.EQ.1 .OR. (I.GT.1 .AND. I.LT.K)) GO TO  10
            TX = AI/3.0*(UXXXX/4.0+UXXX/DLX)
   10       IF (KSWY.EQ.1 .OR. (J.GT.1 .AND. J.LT.L)) GO TO  20
            TY = (UYYYY/4.0+UYYY/DLY)/3.0
   20 GRHS(I,J)=GRHS(I,J)+DLY**2*(DLX**2*TX+DLY**2*TY)
   30    CONTINUE
C
C     RESET THE RIGHT HAND SIDE IN USOL
C
      DO  60 I=IS,MS
         DO  50 J=JS,NS
            USOL(I,J) = GRHS(I,J)
   50    CONTINUE
   60 CONTINUE
      RETURN
      END
      SUBROUTINE MINSO4 (USOL,IDMN,ZN,ZM,PERTB)
C
C     THIS SUBROUTINE ORTHO4ONALIZES THE ARRAY USOL WITH RESPECT TO
C     THE CONSTANT ARRAY IN A WEIGHTED LEAST SQUARES NORM
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       USOL(IDMN,1)           ,ZN(1)      ,ZM(1)
C
C     ENTRY AT MINSO4 OCCURRS WHEN THE FINAL SOLUTION IS
C     TO BE MINIMIZED WITH RESPECT TO THE WEIGHTED
C     LEAST SQUARES NORM
C
      ISTR = 1
      IFNL = K
      JSTR = 1
      JFNL = L
C
C     COMPUTE WEIGHTED INNER PRODUCTS
C
      UTE = 0.0
      ETE = 0.0
      DO  20 I=IS,MS
         II = I-IS+1
         DO  10 J=JS,NS
            JJ = J-JS+1
            ETE = ETE+ZM(II)*ZN(JJ)
            UTE = UTE+USOL(I,J)*ZM(II)*ZN(JJ)
   10    CONTINUE
   20 CONTINUE
C
C     SET PERTURBATION PARAMETER
C
      PERTRB = UTE/ETE
C
C     SUBTRACT OFF CONSTANT PERTRB
C
      DO  40 I=ISTR,IFNL
         DO  30 J=JSTR,JFNL
            USOL(I,J) = USOL(I,J)-PERTRB
   30    CONTINUE
   40 CONTINUE
      RETURN
      END
C FISHPAK15  FROM PORTLIB                                  03/12/81
      SUBROUTINE GENBUN (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W)
C
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                        F I S H P A K                          *
C     *                                                               *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                  (VERSION 3.1 , OCTOBER 1980)                  *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C     * * * * * * * * *  PURPOSE    * * * * * * * * * * * * * * * * * *
C
C
C     SUBROUTINE GENBUN SOLVES THE LINEAR SYSTEM OF EQUATIONS
C
C          A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C
C          + X(I,J-1) - 2.*X(I,J) + X(I,J+1) = Y(I,J)
C
C               FOR I = 1,2,...,M  AND  J = 1,2,...,N.
C
C     THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M, I.E.,
C     X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND X(I,0) MAY BE EQUAL TO
C     0, X(I,2), OR X(I,N) AND X(I,N+1) MAY BE EQUAL TO 0, X(I,N-1), OR
C     X(I,1) DEPENDING ON AN INPUT PARAMETER.
C
C
C     * * * * * * * *    PARAMETER DESCRIPTION     * * * * * * * * * *
C
C             * * * * * *   ON INPUT    * * * * * *
C
C     NPEROD
C       INDICATES THE VALUES THAT X(I,0) AND X(I,N+1) ARE ASSUMED TO
C       HAVE.
C
C       = 0  IF X(I,0) = X(I,N) AND X(I,N+1) = X(I,1).
C       = 1  IF X(I,0) = X(I,N+1) = 0  .
C       = 2  IF X(I,0) = 0 AND X(I,N+1) = X(I,N-1).
C       = 3  IF X(I,0) = X(I,2) AND X(I,N+1) = X(I,N-1).
C       = 4  IF X(I,0) = X(I,2) AND X(I,N+1) = 0.
C
C     N
C       THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.  N MUST BE GREATER
C       THAN 2.
C
C     MPEROD
C       = 0 IF A(1) AND C(M) ARE NOT ZERO
C       = 1 IF A(1) = C(M) = 0
C
C     M
C       THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.  M MUST BE GREATER
C       THAN 2.
C
C     A,B,C
C       ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT SPECIFY THE
C       COEFFICIENTS IN THE LINEAR EQUATIONS GIVEN ABOVE.  IF MPEROD = 0
C       THE ARRAY ELEMENTS MUST NOT DEPEND UPON THE INDEX I, BUT MUST BE
C       CONSTANT.  SPECIFICALLY, THE SUBROUTINE CHECKS THE FOLLOWING
C       CONDITION
C
C             A(I) = C(1)
C             C(I) = C(1)
C             B(I) = B(1)
C
C       FOR I=1,2,...,M.
C
C     IDIMY
C       THE ROW (OR FIRST) DIMENSION OF THE TWO-DIMENSIONAL ARRAY Y AS
C       IT APPEARS IN THE PROGRAM CALLING GENBUN.  THIS PARAMETER IS
C       USED TO SPECIFY THE VARIABLE DIMENSION OF Y.  IDIMY MUST BE AT
C       LEAST M.
C
C     Y
C       A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE VALUES OF THE RIGHT
C       SIDE OF THE LINEAR SYSTEM OF EQUATIONS GIVEN ABOVE.  Y MUST BE
C       DIMENSIONED AT LEAST M*N.
C
C     W
C       A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED BY THE USER FOR
C       WORK SPACE.  W MAY REQUIRE UP TO 4*N + (10 + INT(LOG2(N)))*M
C       LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS USED IS COMPUTED BY
C       GENBUN AND IS RETURNED IN LOCATION W(1).
C
C
C             * * * * * *   ON OUTPUT     * * * * * *
C
C     Y
C       CONTAINS THE SOLUTION X.
C
C     IERROR
C       AN ERROR FLAG THAT INDICATES INVALID INPUT PARAMETERS  EXCEPT
C       FOR NUMBER ZERO, A SOLUTION IS NOT ATTEMPTED.
C
C       = 0  NO ERROR.
C       = 1  M .LE. 2  .
C       = 2  N .LE. 2
C       = 3  IDIMY .LT. M
C       = 4  NPEROD .LT. 0 OR NPEROD .GT. 4
C       = 5  MPEROD .LT. 0 OR MPEROD .GT. 1
C       = 6  A(I) .NE. C(1) OR C(I) .NE. C(1) OR B(I) .NE. B(1) FOR
C            SOME I=1,2,...,M.
C       = 7  A(1) .NE. 0 OR C(M) .NE. 0 AND MPEROD = 1
C
C     W
C       W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C     * * * * * * *   PROGRAM SPECIFICATIONS    * * * * * * * * * * * *
C
C     DIMENSION OF   A(M),B(M),C(M),Y(IDIMY,N),W(SEE PARAMETER LIST)
C     ARGUMENTS
C
C     LATEST         JUNE 1, 1976
C     REVISION
C
C     SUBPROGRAMS    GENBUN,POISD2,POISN2,POISP2,COSGEN,MERGE,TRIX,TRI3,
C     REQUIRED       PIMACH
C
C     SPECIAL        NONE
C     CONDITIONS
C
C     COMMON         NONE
C     BLOCKS
C
C     I/O            NONE
C
C     PRECISION      SINGLE
C
C     SPECIALIST     ROLAND SWEET
C
C     LANGUAGE       FORTRAN
C
C     HISTORY        STANDARDIZED APRIL 1, 1973
C                    REVISED AUGUST 20,1973
C                    REVISED JANUARY 1, 1976
C
C     ALGORITHM      THE LINEAR SYSTEM IS SOLVED BY A CYCLIC REDUCTION
C                    ALGORITHM DESCRIBED IN THE REFERENCE.
C
C     SPACE          4944(DECIMAL) = 11520(OCTAL) LOCATIONS ON THE NCAR
C     REQUIRED       CONTROL DATA 7600
C
C     TIMING AND        THE EXECUTION TIME T ON THE NCAR CONTROL DATA
C     ACCURACY       7600 FOR SUBROUTINE GENBUN IS ROUGHLY PROPORTIONAL
C                    TO M*N*LOG2(N), BUT ALSO DEPENDS ON THE INPUT
C                    PARAMETER NPEROD.  SOME TYPICAL VALUES ARE LISTED
C                    IN THE TABLE BELOW.  MORE COMPREHENSIVE TIMING
C                    CHARTS MAY BE FOUND IN THE REFERENCE.
C                       TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                    UNIFORM RANDOM NUMBER GENERATOR WAS USED TO CREATE
C                    A SOLUTION ARRAY X FOR THE SYSTEM GIVEN IN THE
C                    "PURPOSE" WITH
C
C                       A(I) = C(I) = -0.5*B(I) = 1,       I=1,2,...,M
C
C                    AND, WHEN MPEROD = 1
C
C                       A(1) = C(M) = 0
C                       A(M) = C(1) = 2.
C
C                    THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN SYS-
C                    TEM AND, USING DOUBLE PRECISION, A RIGHT SIDE Y WAS
C                    COMPUTED.  USING THIS ARRAY Y SUBROUTINE GENBUN WAS
C                    CALLED TO PRODUCE AN APPROXIMATE SOLUTION Z.  THEN
C                    THE RELATIVE ERROR, DEFINED AS
C
C                       E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
C
C                    WHERE THE TWO MAXIMA ARE TAKEN OVER ALL I=1,2,...,M
C                    AND J=1,2,...,N, WAS COMPUTED.  THE VALUE OF E IS
C                    GIVEN IN THE TABLE BELOW FOR SOME TYPICAL VALUES OF
C                    M AND N.
C
C
C                       M (=N)    MPEROD    NPEROD    T(MSECS)    E
C                       ------    ------    ------    --------  ------
C
C                         31        0         0          36     6.E-14
C                         31        1         1          21     4.E-13
C                         31        1         3          41     3.E-13
C                         32        0         0          29     9.E-14
C                         32        1         1          32     3.E-13
C                         32        1         3          48     1.E-13
C                         33        0         0          36     9.E-14
C                         33        1         1          30     4.E-13
C                         33        1         3          34     1.E-13
C                         63        0         0         150     1.E-13
C                         63        1         1          91     1.E-12
C                         63        1         3         173     2.E-13
C                         64        0         0         122     1.E-13
C                         64        1         1         128     1.E-12
C                         64        1         3         199     6.E-13
C                         65        0         0         143     2.E-13
C                         65        1         1         120     1.E-12
C                         65        1         3         138     4.E-13
C
C     PORTABILITY    AMERICAN NATIONAL STANDARDS INSTITUE FORTRAN.
C                    ALL MACHINE DEPENDENT CONSTANTS ARE LOCATED IN THE
C                    FUNCTION PIMACH.
C
C     REQUIRED       COS
C     RESIDENT
C     ROUTINES
C
C     REFERENCE      SWEET, R., "A CYCLIC REDUCTION ALGORITHM FOR
C                    SOLVING BLOCK TRIDIAGONAL SYSTEMS OF ARBITRARY
C                    DIMENSIONS," SIAM J. ON NUMER. ANAL.,
C                    14(SEPT., 1977), PP. 706-720.
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
      DIMENSION       Y(IDIMY,1)
      DIMENSION       W(1)       ,B(1)       ,A(1)       ,C(1)
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
      IF (N .LE. 2) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.0 .OR. NPEROD.GT.4) IERROR = 4
      IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
      IF (MPEROD .EQ. 1) GO TO 102
      DO 101 I=2,M
         IF (A(I) .NE. C(1)) GO TO 103
         IF (C(I) .NE. C(1)) GO TO 103
         IF (B(I) .NE. B(1)) GO TO 103
  101 CONTINUE
      GO TO 104
  102 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7
      GO TO 104
  103 IERROR = 6
  104 IF (IERROR .NE. 0) RETURN
      MP1 = M+1
      IWBA = MP1
      IWBB = IWBA+M
      IWBC = IWBB+M
      IWB2 = IWBC+M
      IWB3 = IWB2+M
      IWW1 = IWB3+M
      IWW2 = IWW1+M
      IWW3 = IWW2+M
      IWD = IWW3+M
      IWTCOS = IWD+M
      IWP = IWTCOS+4*N
      DO 106 I=1,M
         K = IWBA+I-1
         W(K) = -A(I)
         K = IWBC+I-1
         W(K) = -C(I)
         K = IWBB+I-1
         W(K) = 2.-B(I)
         DO 105 J=1,N
            Y(I,J) = -Y(I,J)
  105    CONTINUE
  106 CONTINUE
      MP = MPEROD+1
      NP = NPEROD+1
      GO TO (114,107),MP
  107 GO TO (108,109,110,111,123),NP
  108 CALL POISP2 (M,N,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      GO TO 112
  109 CALL POISD2 (M,N,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWW1),
     1             W(IWD),W(IWTCOS),W(IWP))
      GO TO 112
  110 CALL POISN2 (M,N,1,2,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      GO TO 112
  111 CALL POISN2 (M,N,1,1,W(IWBA),W(IWBB),W(IWBC),Y,IDIMY,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
  112 IPSTOR = W(IWW1)
      IREV = 2
      IF (NPEROD .EQ. 4) GO TO 124
  113 GO TO (127,133),MP
  114 CONTINUE
C
C     REORDER UNKNOWNS WHEN MP =0
C
      MH = (M+1)/2
      MHM1 = MH-1
      MODD = 1
      IF (MH*2 .EQ. M) MODD = 2
      DO 119 J=1,N
         DO 115 I=1,MHM1
            MHPI = MH+I
            MHMI = MH-I
            W(I) = Y(MHMI,J)-Y(MHPI,J)
            W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  115    CONTINUE
         W(MH) = 2.*Y(MH,J)
         GO TO (117,116),MODD
  116    W(M) = 2.*Y(M,J)
  117    CONTINUE
         DO 118 I=1,M
            Y(I,J) = W(I)
  118    CONTINUE
  119 CONTINUE
      K = IWBC+MHM1-1
      I = IWBA+MHM1
      W(K) = 0.
      W(I) = 0.
      W(K+1) = 2.*W(K+1)
      GO TO (120,121),MODD
  120 CONTINUE
      K = IWBB+MHM1-1
      W(K) = W(K)-W(I-1)
      W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
      GO TO 122
  121 W(IWBB-1) = W(K+1)
  122 CONTINUE
      GO TO 107
C
C     REVERSE COLUMNS WHEN NPEROD = 4.
C
  123 IREV = 1
      NBY2 = N/2
  124 DO 126 J=1,NBY2
         MSKIP = N+1-J
         DO 125 I=1,M
            A1 = Y(I,J)
            Y(I,J) = Y(I,MSKIP)
            Y(I,MSKIP) = A1
  125    CONTINUE
  126 CONTINUE
      GO TO (110,113),IREV
  127 CONTINUE
      DO 132 J=1,N
         DO 128 I=1,MHM1
            MHMI = MH-I
            MHPI = MH+I
            W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
            W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  128    CONTINUE
         W(MH) = .5*Y(MH,J)
         GO TO (130,129),MODD
  129    W(M) = .5*Y(M,J)
  130    CONTINUE
         DO 131 I=1,M
            Y(I,J) = W(I)
  131    CONTINUE
  132 CONTINUE
  133 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
C
      W(1) = IPSTOR+IWP-1
      RETURN
      END
      SUBROUTINE CHKSN4(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR)
C
C     THIS SUBROUTINE CHECKS IF THE PDE   SEPX4
C     MUST SOLVE IS A SINGULAR OPERATOR
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      LOGICAL         SINGLR
      EXTERNAL COFX
      SINGLR = .FALSE.
C
C     CHECK IF THE BOUNDARY CONDITIONS ARE
C     ENTIRELY PERIODIC AND/OR MIXED
C
      IF ((MBDCND.NE.0 .AND. MBDCND.NE.3) .OR.
     1    (NBDCND.NE.0 .AND. NBDCND.NE.3)) RETURN
C
C     CHECK THAT MIXED CONDITIONS ARE PURE NEUMAN
C
      IF (MBDCND .NE. 3) GO TO  10
      IF (ALPHA.NE.0.0 .OR. BETA.NE.0.0) RETURN
   10 CONTINUE
C
C     CHECK THAT NON-DERIVATIVE COEFFICIENT FUNCTIONS
C     ARE ZERO
C
      DO  30 I=IS,MS
         XI = AIT+FLOAT(I-1)*DLX
         CALL COFX (XI,AI,BI,CI)
         IF (CI .NE. 0.0) RETURN
   30 CONTINUE
C
C     THE OPERATOR MUST BE SINGULAR IF THIS POINT IS REACHED
C
      SINGLR = .TRUE.
      RETURN
      END
      SUBROUTINE POISP2 (M,N,A,BB,C,Q,IDIMQ,B,B2,B3,W,W2,W3,D,TCOS,P)
C
C     SUBROUTINE TO SOLVE POISSON EQUATION WITH PERIODIC BOUNDARY
C     CONDITIONS.
C
      DIMENSION       A(1)       ,BB(1)      ,C(1)       ,Q(IDIMQ,1) ,
     1                B(1)       ,B2(1)      ,B3(1)      ,W(1)       ,
     2                W2(1)      ,W3(1)      ,D(1)       ,TCOS(1)    ,
     3                P(1)
      MR = M
      NR = (N+1)/2
      NRM1 = NR-1
      IF (2*NR .NE. N) GO TO 107
C
C     EVEN NUMBER OF UNKNOWNS
C
      DO 102 J=1,NRM1
         NRMJ = NR-J
         NRPJ = NR+J
         DO 101 I=1,MR
            S = Q(I,NRMJ)-Q(I,NRPJ)
            T = Q(I,NRMJ)+Q(I,NRPJ)
            Q(I,NRMJ) = S
            Q(I,NRPJ) = T
  101    CONTINUE
  102 CONTINUE
      DO 103 I=1,MR
         Q(I,NR) = 2.*Q(I,NR)
         Q(I,N) = 2.*Q(I,N)
  103 CONTINUE
      CALL POISD2 (MR,NRM1,1,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P)
      IPSTOR = W(1)
      CALL POISN2 (MR,NR+1,1,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D,
     1             TCOS,P)
      IPSTOR = MAX0(IPSTOR,INT(W(1)))
      DO 105 J=1,NRM1
         NRMJ = NR-J
         NRPJ = NR+J
         DO 104 I=1,MR
            S = .5*(Q(I,NRPJ)+Q(I,NRMJ))
            T = .5*(Q(I,NRPJ)-Q(I,NRMJ))
            Q(I,NRMJ) = S
            Q(I,NRPJ) = T
  104    CONTINUE
  105 CONTINUE
      DO 106 I=1,MR
         Q(I,NR) = .5*Q(I,NR)
         Q(I,N) = .5*Q(I,N)
  106 CONTINUE
      GO TO 118
  107 CONTINUE
C
C     ODD  NUMBER OF UNKNOWNS
C
      DO 109 J=1,NRM1
         NRPJ = N+1-J
         DO 108 I=1,MR
            S = Q(I,J)-Q(I,NRPJ)
            T = Q(I,J)+Q(I,NRPJ)
            Q(I,J) = S
            Q(I,NRPJ) = T
  108    CONTINUE
  109 CONTINUE
      DO 110 I=1,MR
         Q(I,NR) = 2.*Q(I,NR)
  110 CONTINUE
      LH = NRM1/2
      DO 112 J=1,LH
         NRMJ = NR-J
         DO 111 I=1,MR
            S = Q(I,J)
            Q(I,J) = Q(I,NRMJ)
            Q(I,NRMJ) = S
  111    CONTINUE
  112 CONTINUE
      CALL POISD2 (MR,NRM1,2,A,BB,C,Q,IDIMQ,B,W,D,TCOS,P)
      IPSTOR = W(1)
      CALL POISN2 (MR,NR,2,1,A,BB,C,Q(1,NR),IDIMQ,B,B2,B3,W,W2,W3,D,
     1             TCOS,P)
      IPSTOR = MAX0(IPSTOR,INT(W(1)))
      DO 114 J=1,NRM1
         NRPJ = NR+J
         DO 113 I=1,MR
            S = .5*(Q(I,NRPJ)+Q(I,J))
            T = .5*(Q(I,NRPJ)-Q(I,J))
            Q(I,NRPJ) = T
            Q(I,J) = S
  113    CONTINUE
  114 CONTINUE
      DO 115 I=1,MR
         Q(I,NR) = .5*Q(I,NR)
  115 CONTINUE
      DO 117 J=1,LH
         NRMJ = NR-J
         DO 116 I=1,MR
            S = Q(I,J)
            Q(I,J) = Q(I,NRMJ)
            Q(I,NRMJ) = S
  116    CONTINUE
  117 CONTINUE
  118 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
C
      W(1) = IPSTOR
      RETURN
      END
      SUBROUTINE POISN2 (M,N,ISTAG,MIXBND,A,BB,C,Q,IDIMQ,B,B2,B3,W,W2,
     1                   W3,D,TCOS,P)
C
C     SUBROUTINE TO SOLVE POISSON"S EQUATION WITH NEUMANN BOUNDARY
C     CONDITIONS.
C
C     ISTAG = 1 IF THE LAST DIAGONAL BLOCK IS A.
C     ISTAG = 2 IF THE LAST DIAGONAL BLOCK IS A-I.
C     MIXBND = 1 IF HAVE NEUMANN BOUNDARY CONDITIONS AT BOTH BOUNDARIES.
C     MIXBND = 2 IF HAVE NEUMANN BOUNDARY CONDITIONS AT BOTTOM AND
C     DIRICHLET CONDITION AT TOP.  (FOR THIS CASE, MUST HAVE ISTAG = 1.)
C
      DIMENSION       A(1)       ,BB(1)      ,C(1)       ,Q(IDIMQ,1) ,
     1                B(1)       ,B2(1)      ,B3(1)      ,W(1)       ,
     2                W2(1)      ,W3(1)      ,D(1)       ,TCOS(1)    ,
     3                K(4)       ,P(1)
      EQUIVALENCE     (K(1),K1)  ,(K(2),K2)  ,(K(3),K3)  ,(K(4),K4)
      FISTAG = 3-ISTAG
      FNUM = 1./FLOAT(ISTAG)
      FDEN = 0.5*FLOAT(ISTAG-1)
      MR = M
      IP = -MR
      IPSTOR = 0
      I2R = 1
      JR = 2
      NR = N
      NLAST = N
      KR = 1
      LR = 0
      GO TO (101,103),ISTAG
  101 CONTINUE
      DO 102 I=1,MR
         Q(I,N) = .5*Q(I,N)
  102 CONTINUE
      GO TO (103,104),MIXBND
  103 IF (N .LE. 3) GO TO 155
  104 CONTINUE
      JR = 2*I2R
      NROD = 1
      IF ((NR/2)*2 .EQ. NR) NROD = 0
      GO TO (105,106),MIXBND
  105 JSTART = 1
      GO TO 107
  106 JSTART = JR
      NROD = 1-NROD
  107 CONTINUE
      JSTOP = NLAST-JR
      IF (NROD .EQ. 0) JSTOP = JSTOP-I2R
      CALL COSGEN (I2R,1,0.5,0.0,TCOS)
      I2RBY2 = I2R/2
      IF (JSTOP .GE. JSTART) GO TO 108
      J = JR
      GO TO 116
  108 CONTINUE
C
C     REGULAR REDUCTION.
C
      DO 115 J=JSTART,JSTOP,JR
         JP1 = J+I2RBY2
         JP2 = J+I2R
         JP3 = JP2+I2RBY2
         JM1 = J-I2RBY2
         JM2 = J-I2R
         JM3 = JM2-I2RBY2
         IF (J .NE. 1) GO TO 109
         JM1 = JP1
         JM2 = JP2
         JM3 = JP3
  109    CONTINUE
         IF (I2R .NE. 1) GO TO 111
         IF (J .EQ. 1) JM2 = JP2
         DO 110 I=1,MR
            B(I) = 2.*Q(I,J)
            Q(I,J) = Q(I,JM2)+Q(I,JP2)
  110    CONTINUE
         GO TO 113
  111    CONTINUE
         DO 112 I=1,MR
            FI = Q(I,J)
            Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2)
            B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3)
  112    CONTINUE
  113    CONTINUE
         CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
         DO 114 I=1,MR
            Q(I,J) = Q(I,J)+B(I)
  114    CONTINUE
C
C     END OF REDUCTION FOR REGULAR UNKNOWNS.
C
  115 CONTINUE
C
C     BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN.
C
      J = JSTOP+JR
  116 NLAST = J
      JM1 = J-I2RBY2
      JM2 = J-I2R
      JM3 = JM2-I2RBY2
      IF (NROD .EQ. 0) GO TO 128
C
C     ODD NUMBER OF UNKNOWNS
C
      IF (I2R .NE. 1) GO TO 118
      DO 117 I=1,MR
         B(I) = FISTAG*Q(I,J)
         Q(I,J) = Q(I,JM2)
  117 CONTINUE
      GO TO 126
  118 DO 119 I=1,MR
         B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  119 CONTINUE
      IF (NRODPR .NE. 0) GO TO 121
      DO 120 I=1,MR
         II = IP+I
         Q(I,J) = Q(I,JM2)+P(II)
  120 CONTINUE
      IP = IP-MR
      GO TO 123
  121 CONTINUE
      DO 122 I=1,MR
         Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2)
  122 CONTINUE
  123 IF (LR .EQ. 0) GO TO 124
      CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1))
      GO TO 126
  124 CONTINUE
      DO 125 I=1,MR
         B(I) = FISTAG*B(I)
  125 CONTINUE
  126 CONTINUE
      CALL COSGEN (KR,1,0.5,FDEN,TCOS)
      CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
      DO 127 I=1,MR
         Q(I,J) = Q(I,J)+B(I)
  127 CONTINUE
      KR = KR+I2R
      GO TO 151
  128 CONTINUE
C
C     EVEN NUMBER OF UNKNOWNS
C
      JP1 = J+I2RBY2
      JP2 = J+I2R
      IF (I2R .NE. 1) GO TO 135
      DO 129 I=1,MR
         B(I) = Q(I,J)
  129 CONTINUE
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      IP = 0
      IPSTOR = MR
      GO TO (133,130),ISTAG
  130 DO 131 I=1,MR
         P(I) = B(I)
         B(I) = B(I)+Q(I,N)
  131 CONTINUE
      TCOS(1) = 1.
      TCOS(2) = 0.
      CALL TRIX (1,1,MR,A,BB,C,B,TCOS,D,W)
      DO 132 I=1,MR
         Q(I,J) = Q(I,JM2)+P(I)+B(I)
  132 CONTINUE
      GO TO 150
  133 CONTINUE
      DO 134 I=1,MR
         P(I) = B(I)
         Q(I,J) = Q(I,JM2)+2.*Q(I,JP2)+3.*B(I)
  134 CONTINUE
      GO TO 150
  135 CONTINUE
      DO 136 I=1,MR
         B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  136 CONTINUE
      IF (NRODPR .NE. 0) GO TO 138
      DO 137 I=1,MR
         II = IP+I
         B(I) = B(I)+P(II)
  137 CONTINUE
      GO TO 140
  138 CONTINUE
      DO 139 I=1,MR
         B(I) = B(I)+Q(I,JP2)-Q(I,JP1)
  139 CONTINUE
  140 CONTINUE
      CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
      IP = IP+MR
      IPSTOR = MAX0(IPSTOR,IP+MR)
      DO 141 I=1,MR
         II = IP+I
         P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
         B(I) = P(II)+Q(I,JP2)
  141 CONTINUE
      IF (LR .EQ. 0) GO TO 142
      CALL COSGEN (LR,1,0.5,FDEN,TCOS(I2R+1))
      CALL MERGE (TCOS,0,I2R,I2R,LR,KR)
      GO TO 144
  142 DO 143 I=1,I2R
         II = KR+I
         TCOS(II) = TCOS(I)
  143 CONTINUE
  144 CALL COSGEN (KR,1,0.5,FDEN,TCOS)
      IF (LR .NE. 0) GO TO 145
      GO TO (146,145),ISTAG
  145 CONTINUE
      CALL TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W)
      GO TO 148
  146 CONTINUE
      DO 147 I=1,MR
         B(I) = FISTAG*B(I)
  147 CONTINUE
  148 CONTINUE
      DO 149 I=1,MR
         II = IP+I
         Q(I,J) = Q(I,JM2)+P(II)+B(I)
  149 CONTINUE
  150 CONTINUE
      LR = KR
      KR = KR+JR
  151 CONTINUE
      GO TO (152,153),MIXBND
  152 NR = (NLAST-1)/JR+1
      IF (NR .LE. 3) GO TO 155
      GO TO 154
  153 NR = NLAST/JR
      IF (NR .LE. 1) GO TO 192
  154 I2R = JR
      NRODPR = NROD
      GO TO 104
  155 CONTINUE
C
C      BEGIN SOLUTION
C
      J = 1+JR
      JM1 = J-I2R
      JP1 = J+I2R
      JM2 = NLAST-I2R
      IF (NR .EQ. 2) GO TO 184
      IF (LR .NE. 0) GO TO 170
      IF (N .NE. 3) GO TO 161
C
C     CASE N = 3.
C
      GO TO (156,168),ISTAG
  156 CONTINUE
      DO 157 I=1,MR
         B(I) = Q(I,2)
  157 CONTINUE
      TCOS(1) = 0.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 158 I=1,MR
         Q(I,2) = B(I)
         B(I) = 4.*B(I)+Q(I,1)+2.*Q(I,3)
  158 CONTINUE
      TCOS(1) = -2.
      TCOS(2) = 2.
      I1 = 2
      I2 = 0
      CALL TRIX (I1,I2,MR,A,BB,C,B,TCOS,D,W)
      DO 159 I=1,MR
         Q(I,2) = Q(I,2)+B(I)
         B(I) = Q(I,1)+2.*Q(I,2)
  159 CONTINUE
      TCOS(1) = 0.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 160 I=1,MR
         Q(I,1) = B(I)
  160 CONTINUE
      JR = 1
      I2R = 0
      GO TO 194
C
C     CASE N = 2**P+1
C
  161 CONTINUE
      GO TO (162,170),ISTAG
  162 CONTINUE
      DO 163 I=1,MR
         B(I) = Q(I,J)+.5*Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2)
  163 CONTINUE
      CALL COSGEN (JR,1,0.5,0.0,TCOS)
      CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
      DO 164 I=1,MR
         Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
         B(I) = Q(I,1)+2.*Q(I,NLAST)+4.*Q(I,J)
  164 CONTINUE
      JR2 = 2*JR
      CALL COSGEN (JR,1,0.0,0.0,TCOS)
      DO 165 I=1,JR
         I1 = JR+I
         I2 = JR+1-I
         TCOS(I1) = -TCOS(I2)
  165 CONTINUE
      CALL TRIX (JR2,0,MR,A,BB,C,B,TCOS,D,W)
      DO 166 I=1,MR
         Q(I,J) = Q(I,J)+B(I)
         B(I) = Q(I,1)+2.*Q(I,J)
  166 CONTINUE
      CALL COSGEN (JR,1,0.5,0.0,TCOS)
      CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
      DO 167 I=1,MR
         Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I)
  167 CONTINUE
      GO TO 194
C
C     CASE OF GENERAL N WITH NR = 3 .
C
  168 DO 169 I=1,MR
         B(I) = Q(I,2)
         Q(I,2) = 0.
         B2(I) = Q(I,3)
         B3(I) = Q(I,1)
  169 CONTINUE
      JR = 1
      I2R = 0
      J = 2
      GO TO 177
  170 CONTINUE
      DO 171 I=1,MR
         B(I) = .5*Q(I,1)-Q(I,JM1)+Q(I,J)
  171 CONTINUE
      IF (NROD .NE. 0) GO TO 173
      DO 172 I=1,MR
         II = IP+I
         B(I) = B(I)+P(II)
  172 CONTINUE
      GO TO 175
  173 DO 174 I=1,MR
         B(I) = B(I)+Q(I,NLAST)-Q(I,JM2)
  174 CONTINUE
  175 CONTINUE
      DO 176 I=1,MR
         T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
         Q(I,J) = T
         B2(I) = Q(I,NLAST)+T
         B3(I) = Q(I,1)+2.*T
  176 CONTINUE
  177 CONTINUE
      K1 = KR+2*JR-1
      K2 = KR+JR
      TCOS(K1+1) = -2.
      K4 = K1+3-ISTAG
      CALL COSGEN (K2+ISTAG-2,1,0.0,FNUM,TCOS(K4))
      K4 = K1+K2+1
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4))
      CALL MERGE (TCOS,K1,K2,K1+K2,JR-1,0)
      K3 = K1+K2+LR
      CALL COSGEN (JR,1,0.5,0.0,TCOS(K3+1))
      K4 = K3+JR+1
      CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4))
      CALL MERGE (TCOS,K3,JR,K3+JR,KR,K1)
      IF (LR .EQ. 0) GO TO 178
      CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4))
      CALL MERGE (TCOS,K3,JR,K3+JR,LR,K3-LR)
      CALL COSGEN (KR,1,0.5,FDEN,TCOS(K4))
  178 K3 = KR
      K4 = KR
      CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 179 I=1,MR
         B(I) = B(I)+B2(I)+B3(I)
  179 CONTINUE
      TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 180 I=1,MR
         Q(I,J) = Q(I,J)+B(I)
         B(I) = Q(I,1)+2.*Q(I,J)
  180 CONTINUE
      CALL COSGEN (JR,1,0.5,0.0,TCOS)
      CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
      IF (JR .NE. 1) GO TO 182
      DO 181 I=1,MR
         Q(I,1) = B(I)
  181 CONTINUE
      GO TO 194
  182 CONTINUE
      DO 183 I=1,MR
         Q(I,1) = .5*Q(I,1)-Q(I,JM1)+B(I)
  183 CONTINUE
      GO TO 194
  184 CONTINUE
      IF (N .NE. 2) GO TO 188
C
C     CASE  N = 2
C
      DO 185 I=1,MR
         B(I) = Q(I,1)
  185 CONTINUE
      TCOS(1) = 0.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 186 I=1,MR
         Q(I,1) = B(I)
         B(I) = 2.*(Q(I,2)+B(I))*FISTAG
  186 CONTINUE
      TCOS(1) = -FISTAG
      TCOS(2) = 2.
      CALL TRIX (2,0,MR,A,BB,C,B,TCOS,D,W)
      DO 187 I=1,MR
         Q(I,1) = Q(I,1)+B(I)
  187 CONTINUE
      JR = 1
      I2R = 0
      GO TO 194
  188 CONTINUE
C
C     CASE OF GENERAL N AND NR = 2 .
C
      DO 189 I=1,MR
         II = IP+I
         B3(I) = 0.
         B(I) = Q(I,1)+2.*P(II)
         Q(I,1) = .5*Q(I,1)-Q(I,JM1)
         B2(I) = 2.*(Q(I,1)+Q(I,NLAST))
  189 CONTINUE
      K1 = KR+JR-1
      TCOS(K1+1) = -2.
      K4 = K1+3-ISTAG
      CALL COSGEN (KR+ISTAG-2,1,0.0,FNUM,TCOS(K4))
      K4 = K1+KR+1
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K4))
      CALL MERGE (TCOS,K1,KR,K1+KR,JR-1,0)
      CALL COSGEN (KR,1,0.5,FDEN,TCOS(K1+1))
      K2 = KR
      K4 = K1+K2+1
      CALL COSGEN (LR,1,0.5,FDEN,TCOS(K4))
      K3 = LR
      K4 = 0
      CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 190 I=1,MR
         B(I) = B(I)+B2(I)
  190 CONTINUE
      TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 191 I=1,MR
         Q(I,1) = Q(I,1)+B(I)
  191 CONTINUE
      GO TO 194
  192 DO 193 I=1,MR
         B(I) = Q(I,NLAST)
  193 CONTINUE
      GO TO 196
  194 CONTINUE
C
C     START BACK SUBSTITUTION.
C
      J = NLAST-JR
      DO 195 I=1,MR
         B(I) = Q(I,NLAST)+Q(I,J)
  195 CONTINUE
  196 JM2 = NLAST-I2R
      IF (JR .NE. 1) GO TO 198
      DO 197 I=1,MR
         Q(I,NLAST) = 0.
  197 CONTINUE
      GO TO 202
  198 CONTINUE
      IF (NROD .NE. 0) GO TO 200
      DO 199 I=1,MR
         II = IP+I
         Q(I,NLAST) = P(II)
  199 CONTINUE
      IP = IP-MR
      GO TO 202
  200 DO 201 I=1,MR
         Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2)
  201 CONTINUE
  202 CONTINUE
      CALL COSGEN (KR,1,0.5,FDEN,TCOS)
      CALL COSGEN (LR,1,0.5,FDEN,TCOS(KR+1))
      IF (LR .NE. 0) GO TO 204
      DO 203 I=1,MR
         B(I) = FISTAG*B(I)
  203 CONTINUE
  204 CONTINUE
      CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
      DO 205 I=1,MR
         Q(I,NLAST) = Q(I,NLAST)+B(I)
  205 CONTINUE
      NLASTP = NLAST
  206 CONTINUE
      JSTEP = JR
      JR = I2R
      I2R = I2R/2
      IF (JR .EQ. 0) GO TO 222
      GO TO (207,208),MIXBND
  207 JSTART = 1+JR
      GO TO 209
  208 JSTART = JR
  209 CONTINUE
      KR = KR-JR
      IF (NLAST+JR .GT. N) GO TO 210
      KR = KR-JR
      NLAST = NLAST+JR
      JSTOP = NLAST-JSTEP
      GO TO 211
  210 CONTINUE
      JSTOP = NLAST-JR
  211 CONTINUE
      LR = KR-JR
      CALL COSGEN (JR,1,0.5,0.0,TCOS)
      DO 221 J=JSTART,JSTOP,JSTEP
         JM2 = J-JR
         JP2 = J+JR
         IF (J .NE. JR) GO TO 213
         DO 212 I=1,MR
            B(I) = Q(I,J)+Q(I,JP2)
  212    CONTINUE
         GO TO 215
  213    CONTINUE
         DO 214 I=1,MR
            B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2)
  214    CONTINUE
  215    CONTINUE
         IF (JR .NE. 1) GO TO 217
         DO 216 I=1,MR
            Q(I,J) = 0.
  216    CONTINUE
         GO TO 219
  217    CONTINUE
         JM1 = J-I2R
         JP1 = J+I2R
         DO 218 I=1,MR
            Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  218    CONTINUE
  219    CONTINUE
         CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
         DO 220 I=1,MR
            Q(I,J) = Q(I,J)+B(I)
  220    CONTINUE
  221 CONTINUE
      NROD = 1
      IF (NLAST+I2R .LE. N) NROD = 0
      IF (NLASTP .NE. NLAST) GO TO 194
      GO TO 206
  222 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
C
      W(1) = IPSTOR
      RETURN
      END
      SUBROUTINE TRIX (IDEGBR,IDEGCR,M,A,B,C,Y,TCOS,D,W)
C
C     SUBROUTINE TO SOLVE A SYSTEM OF LINEAR EQUATIONS WHERE THE
C     COEFFICIENT MATRIX IS A RATIONAL FUNCTION IN THE MATRIX GIVEN BY
C     TRIDIAGONAL  ( . . . , A(I), B(I), C(I), . . . ).
C
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,Y(1)       ,
     1                TCOS(1)    ,D(1)       ,W(1)
      MM1 = M-1
      FB = IDEGBR+1
      FC = IDEGCR+1
      L = FB/FC
      LINT = 1
      DO 108 K=1,IDEGBR
         X = TCOS(K)
         IF (K .NE. L) GO TO 102
         I = IDEGBR+LINT
         XX = X-TCOS(I)
         DO 101 I=1,M
            W(I) = Y(I)
            Y(I) = XX*Y(I)
  101    CONTINUE
  102    CONTINUE
         Z = 1./(B(1)-X)
         D(1) = C(1)*Z
         Y(1) = Y(1)*Z
         DO 103 I=2,MM1
            Z = 1./(B(I)-X-A(I)*D(I-1))
            D(I) = C(I)*Z
            Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  103    CONTINUE
         Z = B(M)-X-A(M)*D(MM1)
         IF (Z .NE. 0.) GO TO 104
         Y(M) = 0.
         GO TO 105
  104    Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  105    CONTINUE
         DO 106 IP=1,MM1
            I = M-IP
            Y(I) = Y(I)-D(I)*Y(I+1)
  106    CONTINUE
         IF (K .NE. L) GO TO 108
         DO 107 I=1,M
            Y(I) = Y(I)+W(I)
  107    CONTINUE
         LINT = LINT+1
         L = (FLOAT(LINT)*FB)/FC
  108 CONTINUE
      RETURN
      END
C FISHPAK23  FROM PORTLIB                                  03/12/81
C
C
C     THIS FILE CONTAINS FOUR SUBROUTINES USED BY SUBROUTINES GENBUN
C     (FILE 15) AND POISTG (FILE 17).
C
C
      SUBROUTINE COSGEN (N,IJUMP,FNUM,FDEN,A)
      DIMENSION       A(1)
C
C
C     THIS SUBROUTINE COMPUTES REQUIRED COSINE VALUES IN ASCENDING
C     ORDER.  WHEN IJUMP .GT. 1 THE ROUTINE COMPUTES VALUES
C
C        2*COS(J*PI/L) , J=1,2,...,L AND J .NE. 0(MOD N/IJUMP+1)
C
C     WHERE L = IJUMP*(N/IJUMP+1).
C
C
C     WHEN IJUMP = 1 IT COMPUTES
C
C            2*COS((J-FNUM)*PI/(N+FDEN)) ,  J=1, 2, ... ,N
C
C     WHERE
C        FNUM = 0.5, FDEN = 0.0,  FOR REGULAR REDUCTION VALUES
C        FNUM = 0.0, FDEN = 1.0, FOR B-R AND C-R WHEN ISTAG = 1
C        FNUM = 0.0, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2
C        FNUM = 0.5, FDEN = 0.5, FOR B-R AND C-R WHEN ISTAG = 2
C                                IN POISN2 ONLY.
C
C
      PI = PIMACH(DUM)
      IF (N .EQ. 0) GO TO 105
      IF (IJUMP .EQ. 1) GO TO 103
      K3 = N/IJUMP+1
      K4 = K3-1
      PIBYN = PI/FLOAT(N+IJUMP)
      DO 102 K=1,IJUMP
         K1 = (K-1)*K3
         K5 = (K-1)*K4
         DO 101 I=1,K4
            X = K1+I
            K2 = K5+I
            A(K2) = -2.*COS(X*PIBYN)
  101    CONTINUE
  102 CONTINUE
      GO TO 105
  103 CONTINUE
      NP1 = N+1
      Y = PI/(FLOAT(N)+FDEN)
      DO 104 I=1,N
         X = FLOAT(NP1-I)-FNUM
         A(I) = 2.*COS(X*Y)
  104 CONTINUE
  105 CONTINUE
      RETURN
      END
      SUBROUTINE DX4(U,IDMN,I,J,UXXX,UXXXX)
C
C     THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE
C     APPROXIMATIONS TO THE THIRD AND FOURTH X
C     PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       U(IDMN,1)
      IF (I.GT.2 .AND. I.LT.(K-1)) GO TO  50
      IF (I .EQ. 1) GO TO  10
      IF (I .EQ. 2) GO TO  30
      IF (I .EQ. K-1) GO TO  60
      IF (I .EQ. K) GO TO  80
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A
C
   10 IF (KSWX .EQ. 1) GO TO  20
      UXXX = (-5.0*U(1,J)+18.0*U(2,J)-24.0*U(3,J)+14.0*U(4,J)-
     1                                               3.0*U(5,J))/(TDLX3)
      UXXXX = (3.0*U(1,J)-14.0*U(2,J)+26.0*U(3,J)-24.0*U(4,J)+
     1                                      11.0*U(5,J)-2.0*U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A
C
   20 UXXX = (-U(K-2,J)+2.0*U(K-1,J)-2.0*U(2,J)+U(3,J))/(TDLX3)
      UXXXX = (U(K-2,J)-4.0*U(K-1,J)+6.0*U(1,J)-4.0*U(2,J)+U(3,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=A+DLX
C
   30 IF (KSWX .EQ. 1) GO TO  40
      UXXX = (-3.0*U(1,J)+10.0*U(2,J)-12.0*U(3,J)+6.0*U(4,J)-U(5,J))/
     1       TDLX3
      UXXXX = (2.0*U(1,J)-9.0*U(2,J)+16.0*U(3,J)-14.0*U(4,J)+6.0*U(5,J)-
     1                                                      U(6,J))/DLX4
      RETURN
C
C     PERIODIC AT X=A+DLX
C
   40 UXXX = (-U(K-1,J)+2.0*U(1,J)-2.0*U(3,J)+U(4,J))/(TDLX3)
      UXXXX = (U(K-1,J)-4.0*U(1,J)+6.0*U(2,J)-4.0*U(3,J)+U(4,J))/DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR
C
   50 CONTINUE
      UXXX = (-U(I-2,J)+2.0*U(I-1,J)-2.0*U(I+1,J)+U(I+2,J))/TDLX3
      UXXXX = (U(I-2,J)-4.0*U(I-1,J)+6.0*U(I,J)-4.0*U(I+1,J)+U(I+2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B-DLX
C
   60 IF (KSWX .EQ. 1) GO TO  70
      UXXX = (U(K-4,J)-6.0*U(K-3,J)+12.0*U(K-2,J)-10.0*U(K-1,J)+
     1                                                 3.0*U(K,J))/TDLX3
      UXXXX = (-U(K-5,J)+6.0*U(K-4,J)-14.0*U(K-3,J)+16.0*U(K-2,J)-
     1                                     9.0*U(K-1,J)+2.0*U(K,J))/DLX4
      RETURN
C
C     PERIODIC AT X=B-DLX
C
   70 UXXX = (-U(K-3,J)+2.0*U(K-2,J)-2.0*U(1,J)+U(2,J))/TDLX3
      UXXXX = (U(K-3,J)-4.0*U(K-2,J)+6.0*U(K-1,J)-4.0*U(1,J)+U(2,J))/
     1        DLX4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT X=B
C
   80 UXXX = -(3.0*U(K-4,J)-14.0*U(K-3,J)+24.0*U(K-2,J)-18.0*U(K-1,J)+
     1                                                 5.0*U(K,J))/TDLX3
      UXXXX = (-2.0*U(K-5,J)+11.0*U(K-4,J)-24.0*U(K-3,J)+26.0*U(K-2,J)-
     1                                    14.0*U(K-1,J)+3.0*U(K,J))/DLX4
      RETURN
      END
      SUBROUTINE TRI3 (M,A,B,C,K,Y1,Y2,Y3,TCOS,D,W1,W2,W3)
      DIMENSION       A(1)       ,B(1)       ,C(1)       ,K(4)       ,
     1                TCOS(1)    ,Y1(1)      ,Y2(1)      ,Y3(1)      ,
     2                D(1)       ,W1(1)      ,W2(1)      ,W3(1)
C
C     SUBROUTINE TO SOLVE THREE LINEAR SYSTEMS WHOSE COMMON COEFFICIENT
C     MATRIX IS A RATIONAL FUNCTION IN THE MATRIX GIVEN BY
C
C                  TRIDIAGONAL (...,A(I),B(I),C(I),...)
C
      MM1 = M-1
      K1 = K(1)
      K2 = K(2)
      K3 = K(3)
      K4 = K(4)
      F1 = K1+1
      F2 = K2+1
      F3 = K3+1
      F4 = K4+1
      K2K3K4 = K2+K3+K4
      IF (K2K3K4 .EQ. 0) GO TO 101
      L1 = F1/F2
      L2 = F1/F3
      L3 = F1/F4
      LINT1 = 1
      LINT2 = 1
      LINT3 = 1
      KINT1 = K1
      KINT2 = KINT1+K2
      KINT3 = KINT2+K3
  101 CONTINUE
      DO 115 N=1,K1
         X = TCOS(N)
         IF (K2K3K4 .EQ. 0) GO TO 107
         IF (N .NE. L1) GO TO 103
         DO 102 I=1,M
            W1(I) = Y1(I)
  102    CONTINUE
  103    IF (N .NE. L2) GO TO 105
         DO 104 I=1,M
            W2(I) = Y2(I)
  104    CONTINUE
  105    IF (N .NE. L3) GO TO 107
         DO 106 I=1,M
            W3(I) = Y3(I)
  106    CONTINUE
  107    CONTINUE
         Z = 1./(B(1)-X)
         D(1) = C(1)*Z
         Y1(1) = Y1(1)*Z
         Y2(1) = Y2(1)*Z
         Y3(1) = Y3(1)*Z
         DO 108 I=2,M
            Z = 1./(B(I)-X-A(I)*D(I-1))
            D(I) = C(I)*Z
            Y1(I) = (Y1(I)-A(I)*Y1(I-1))*Z
            Y2(I) = (Y2(I)-A(I)*Y2(I-1))*Z
            Y3(I) = (Y3(I)-A(I)*Y3(I-1))*Z
  108    CONTINUE
         DO 109 IP=1,MM1
            I = M-IP
            Y1(I) = Y1(I)-D(I)*Y1(I+1)
            Y2(I) = Y2(I)-D(I)*Y2(I+1)
            Y3(I) = Y3(I)-D(I)*Y3(I+1)
  109    CONTINUE
         IF (K2K3K4 .EQ. 0) GO TO 115
         IF (N .NE. L1) GO TO 111
         I = LINT1+KINT1
         XX = X-TCOS(I)
         DO 110 I=1,M
            Y1(I) = XX*Y1(I)+W1(I)
  110    CONTINUE
         LINT1 = LINT1+1
         L1 = (FLOAT(LINT1)*F1)/F2
  111    IF (N .NE. L2) GO TO 113
         I = LINT2+KINT2
         XX = X-TCOS(I)
         DO 112 I=1,M
            Y2(I) = XX*Y2(I)+W2(I)
  112    CONTINUE
         LINT2 = LINT2+1
         L2 = (FLOAT(LINT2)*F1)/F3
  113    IF (N .NE. L3) GO TO 115
         I = LINT3+KINT3
         XX = X-TCOS(I)
         DO 114 I=1,M
            Y3(I) = XX*Y3(I)+W3(I)
  114    CONTINUE
         LINT3 = LINT3+1
         L3 = (FLOAT(LINT3)*F1)/F4
  115 CONTINUE
      RETURN
      END
      SUBROUTINE MERGE (TCOS,I1,M1,I2,M2,I3)
      DIMENSION       TCOS(1)
C
C
C     THIS SUBROUTINE MERGES TWO ASCENDING STRINGS OF NUMBERS IN THE
C     ARRAY TCOS.  THE FIRST STRING IS OF LENGTH M1 AND STARTS AT
C     TCOS(I1+1).  THE SECOND STRING IS OF LENGTH M2 AND STARTS AT
C     TCOS(I2+1).  THE MERGED STRING GOES INTO TCOS(I3+1).
C
C
      J1 = 1
      J2 = 1
      J = I3
      IF (M1 .EQ. 0) GO TO 107
      IF (M2 .EQ. 0) GO TO 104
  101 J = J+1
      L = J1+I1
      X = TCOS(L)
      L = J2+I2
      Y = TCOS(L)
      IF (X-Y) 102,102,103
  102 TCOS(J) = X
      J1 = J1+1
      IF (J1 .GT. M1) GO TO 106
      GO TO 101
  103 TCOS(J) = Y
      J2 = J2+1
      IF (J2 .LE. M2) GO TO 101
      IF (J1 .GT. M1) GO TO 109
  104 K = J-J1+1
      DO 105 J=J1,M1
         M = K+J
         L = J+I1
         TCOS(M) = TCOS(L)
  105 CONTINUE
      GO TO 109
  106 CONTINUE
      IF (J2 .GT. M2) GO TO 109
  107 K = J-J2+1
      DO 108 J=J2,M2
         M = K+J
         L = J+I2
         TCOS(M) = TCOS(L)
  108 CONTINUE
  109 CONTINUE
      RETURN
      END
      SUBROUTINE POISD2 (MR,NR,ISTAG,BA,BB,BC,Q,IDIMQ,B,W,D,TCOS,P)
C
C     SUBROUTINE TO SOLVE POISSON"S EQUATION FOR DIRICHLET BOUNDARY
C     CONDITIONS.
C
C     ISTAG = 1 IF THE LAST DIAGONAL BLOCK IS THE MATRIX A.
C     ISTAG = 2 IF THE LAST DIAGONAL BLOCK IS THE MATRIX A+I.
C
      DIMENSION       Q(IDIMQ,1) ,BA(1)      ,BB(1)      ,BC(1)      ,
     1                TCOS(1)    ,B(1)       ,D(1)       ,W(1)       ,
     2                P(1)
      M = MR
      N = NR
      JSH = 0
      FI = 1./FLOAT(ISTAG)
      IP = -M
      IPSTOR = 0
      GO TO (101,102),ISTAG
  101 KR = 0
      IRREG = 1
      IF (N .GT. 1) GO TO 106
      TCOS(1) = 0.
      GO TO 103
  102 KR = 1
      JSTSAV = 1
      IRREG = 2
      IF (N .GT. 1) GO TO 106
      TCOS(1) = -1.
  103 DO 104 I=1,M
         B(I) = Q(I,1)
  104 CONTINUE
      CALL TRIX (1,0,M,BA,BB,BC,B,TCOS,D,W)
      DO 105 I=1,M
         Q(I,1) = B(I)
  105 CONTINUE
      GO TO 183
  106 LR = 0
      DO 107 I=1,M
         P(I) = 0.
  107 CONTINUE
      NUN = N
      JST = 1
      JSP = N
C
C     IRREG = 1 WHEN NO IRREGULARITIES HAVE OCCURRED, OTHERWISE IT IS 2.
C
  108 L = 2*JST
      NODD = 2-2*((NUN+1)/2)+NUN
C
C     NODD = 1 WHEN NUN IS ODD, OTHERWISE IT IS 2.
C
      GO TO (110,109),NODD
  109 JSP = JSP-L
      GO TO 111
  110 JSP = JSP-JST
      IF (IRREG .NE. 1) JSP = JSP-L
  111 CONTINUE
C
C     REGULAR REDUCTION
C
      CALL COSGEN (JST,1,0.5,0.0,TCOS)
      IF (L .GT. JSP) GO TO 118
      DO 117 J=L,JSP,L
         JM1 = J-JSH
         JP1 = J+JSH
         JM2 = J-JST
         JP2 = J+JST
         JM3 = JM2-JSH
         JP3 = JP2+JSH
         IF (JST .NE. 1) GO TO 113
         DO 112 I=1,M
            B(I) = 2.*Q(I,J)
            Q(I,J) = Q(I,JM2)+Q(I,JP2)
  112    CONTINUE
         GO TO 115
  113    DO 114 I=1,M
            T = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2)
            B(I) = T+Q(I,J)-Q(I,JM3)-Q(I,JP3)
            Q(I,J) = T
  114    CONTINUE
  115    CONTINUE
         CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W)
         DO 116 I=1,M
            Q(I,J) = Q(I,J)+B(I)
  116    CONTINUE
  117 CONTINUE
C
C     REDUCTION FOR LAST UNKNOWN
C
  118 GO TO (119,136),NODD
  119 GO TO (152,120),IRREG
C
C     ODD NUMBER OF UNKNOWNS
C
  120 JSP = JSP+L
      J = JSP
      JM1 = J-JSH
      JP1 = J+JSH
      JM2 = J-JST
      JP2 = J+JST
      JM3 = JM2-JSH
      GO TO (123,121),ISTAG
  121 CONTINUE
      IF (JST .NE. 1) GO TO 123
      DO 122 I=1,M
         B(I) = Q(I,J)
         Q(I,J) = 0.
  122 CONTINUE
      GO TO 130
  123 GO TO (124,126),NODDPR
  124 DO 125 I=1,M
         IP1 = IP+I
         B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+P(IP1)+Q(I,J)
  125 CONTINUE
      GO TO 128
  126 DO 127 I=1,M
         B(I) = .5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))+Q(I,JP2)-Q(I,JP1)+Q(I,J)
  127 CONTINUE
  128 DO 129 I=1,M
         Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  129 CONTINUE
  130 CALL TRIX (JST,0,M,BA,BB,BC,B,TCOS,D,W)
      IP = IP+M
      IPSTOR = MAX0(IPSTOR,IP+M)
      DO 131 I=1,M
         IP1 = IP+I
         P(IP1) = Q(I,J)+B(I)
         B(I) = Q(I,JP2)+P(IP1)
  131 CONTINUE
      IF (LR .NE. 0) GO TO 133
      DO 132 I=1,JST
         KRPI = KR+I
         TCOS(KRPI) = TCOS(I)
  132 CONTINUE
      GO TO 134
  133 CONTINUE
      CALL COSGEN (LR,JSTSAV,0.,FI,TCOS(JST+1))
      CALL MERGE (TCOS,0,JST,JST,LR,KR)
  134 CONTINUE
      CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS)
      CALL TRIX (KR,KR,M,BA,BB,BC,B,TCOS,D,W)
      DO 135 I=1,M
         IP1 = IP+I
         Q(I,J) = Q(I,JM2)+B(I)+P(IP1)
  135 CONTINUE
      LR = KR
      KR = KR+L
      GO TO 152
C
C     EVEN NUMBER OF UNKNOWNS
C
  136 JSP = JSP+L
      J = JSP
      JM1 = J-JSH
      JP1 = J+JSH
      JM2 = J-JST
      JP2 = J+JST
      JM3 = JM2-JSH
      GO TO (137,138),IRREG
  137 CONTINUE
      JSTSAV = JST
      IDEG = JST
      KR = L
      GO TO 139
  138 CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS)
      CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1))
      IDEG = KR
      KR = KR+JST
  139 IF (JST .NE. 1) GO TO 141
      IRREG = 2
      DO 140 I=1,M
         B(I) = Q(I,J)
         Q(I,J) = Q(I,JM2)
  140 CONTINUE
      GO TO 150
  141 DO 142 I=1,M
         B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  142 CONTINUE
      GO TO (143,145),IRREG
  143 DO 144 I=1,M
         Q(I,J) = Q(I,JM2)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  144 CONTINUE
      IRREG = 2
      GO TO 150
  145 CONTINUE
      GO TO (146,148),NODDPR
  146 DO 147 I=1,M
         IP1 = IP+I
         Q(I,J) = Q(I,JM2)+P(IP1)
  147 CONTINUE
      IP = IP-M
      GO TO 150
  148 DO 149 I=1,M
         Q(I,J) = Q(I,JM2)+Q(I,J)-Q(I,JM1)
  149 CONTINUE
  150 CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W)
      DO 151 I=1,M
         Q(I,J) = Q(I,J)+B(I)
  151 CONTINUE
  152 NUN = NUN/2
      NODDPR = NODD
      JSH = JST
      JST = 2*JST
      IF (NUN .GE. 2) GO TO 108
C
C     START SOLUTION.
C
      J = JSP
      DO 153 I=1,M
         B(I) = Q(I,J)
  153 CONTINUE
      GO TO (154,155),IRREG
  154 CONTINUE
      CALL COSGEN (JST,1,0.5,0.0,TCOS)
      IDEG = JST
      GO TO 156
  155 KR = LR+JST
      CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS)
      CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1))
      IDEG = KR
  156 CONTINUE
      CALL TRIX (IDEG,LR,M,BA,BB,BC,B,TCOS,D,W)
      JM1 = J-JSH
      JP1 = J+JSH
      GO TO (157,159),IRREG
  157 DO 158 I=1,M
         Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
  158 CONTINUE
      GO TO 164
  159 GO TO (160,162),NODDPR
  160 DO 161 I=1,M
         IP1 = IP+I
         Q(I,J) = P(IP1)+B(I)
  161 CONTINUE
      IP = IP-M
      GO TO 164
  162 DO 163 I=1,M
         Q(I,J) = Q(I,J)-Q(I,JM1)+B(I)
  163 CONTINUE
  164 CONTINUE
C
C     START BACK SUBSTITUTION.
C
      JST = JST/2
      JSH = JST/2
      NUN = 2*NUN
      IF (NUN .GT. N) GO TO 183
      DO 182 J=JST,N,L
         JM1 = J-JSH
         JP1 = J+JSH
         JM2 = J-JST
         JP2 = J+JST
         IF (J .GT. JST) GO TO 166
         DO 165 I=1,M
            B(I) = Q(I,J)+Q(I,JP2)
  165    CONTINUE
         GO TO 170
  166    IF (JP2 .LE. N) GO TO 168
         DO 167 I=1,M
            B(I) = Q(I,J)+Q(I,JM2)
  167    CONTINUE
         IF (JST .LT. JSTSAV) IRREG = 1
         GO TO (170,171),IRREG
  168    DO 169 I=1,M
            B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2)
  169    CONTINUE
  170    CONTINUE
         CALL COSGEN (JST,1,0.5,0.0,TCOS)
         IDEG = JST
         JDEG = 0
         GO TO 172
  171    IF (J+L .GT. N) LR = LR-JST
         KR = JST+LR
         CALL COSGEN (KR,JSTSAV,0.0,FI,TCOS)
         CALL COSGEN (LR,JSTSAV,0.0,FI,TCOS(KR+1))
         IDEG = KR
         JDEG = LR
  172    CONTINUE
         CALL TRIX (IDEG,JDEG,M,BA,BB,BC,B,TCOS,D,W)
         IF (JST .GT. 1) GO TO 174
         DO 173 I=1,M
            Q(I,J) = B(I)
  173    CONTINUE
         GO TO 182
  174    IF (JP2 .GT. N) GO TO 177
  175    DO 176 I=1,M
            Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))+B(I)
  176    CONTINUE
         GO TO 182
  177    GO TO (175,178),IRREG
  178    IF (J+JSH .GT. N) GO TO 180
         DO 179 I=1,M
            IP1 = IP+I
            Q(I,J) = B(I)+P(IP1)
  179    CONTINUE
         IP = IP-M
         GO TO 182
  180    DO 181 I=1,M
            Q(I,J) = B(I)+Q(I,J)-Q(I,JM1)
  181    CONTINUE
  182 CONTINUE
      L = L/2
      GO TO 164
  183 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
C
      W(1) = IPSTOR
      RETURN
      END
      FUNCTION PIMACH (DUM)
C
C     THIS SUBPROGRAM SUPPLIES THE VALUE OF THE CONSTANT PI CORRECT TO
C     MACHINE PRECISION WHERE
C
C     PI=3.1415926535897932384626433832795028841971693993751058209749446
C
      PIMACH = 3.14159265358979
      RETURN
      END
      SUBROUTINE DY4(U,IDMN,I,J,UYYY,UYYYY)
C
C     THIS PROGRAM COMPUTES SECOND ORDER FINITE DIFFERENCE
C     APPROXIMATIONS TO THE THIRD AND FOURTH Y
C     PARTIAL DERIVATIVES OF U AT THE (I,J) MESH POINT
C
      COMMON /SPL4/   KSWX       ,KSWY       ,K          ,L          ,
     1                AIT        ,BIT        ,CIT        ,DIT        ,
     2                MIT        ,NIT        ,IS         ,MS         ,
     3                JS         ,NS         ,DLX        ,DLY        ,
     4                TDLX3      ,TDLY3      ,DLX4       ,DLY4
      DIMENSION       U(IDMN,1)
      IF (J.GT.2 .AND. J.LT.(L-1)) GO TO  50
      IF (J .EQ. 1) GO TO  10
      IF (J .EQ. 2) GO TO  30
      IF (J .EQ. L-1) GO TO  60
      IF (J .EQ. L) GO TO  80
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C
C
   10 IF (KSWY .EQ. 1) GO TO  20
      UYYY = (-5.0*U(I,1)+18.0*U(I,2)-24.0*U(I,3)+14.0*U(I,4)-
     1                                                 3.0*U(I,5))/TDLY3
      UYYYY = (3.0*U(I,1)-14.0*U(I,2)+26.0*U(I,3)-24.0*U(I,4)+
     1                                      11.0*U(I,5)-2.0*U(I,6))/DLY4
      RETURN
C
C     PERIODIC AT X=A
C
   20 UYYY = (-U(I,L-2)+2.0*U(I,L-1)-2.0*U(I,2)+U(I,3))/TDLY3
      UYYYY = (U(I,L-2)-4.0*U(I,L-1)+6.0*U(I,1)-4.0*U(I,2)+U(I,3))/DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=C+DLY
C
   30 IF (KSWY .EQ. 1) GO TO  40
      UYYY = (-3.0*U(I,1)+10.0*U(I,2)-12.0*U(I,3)+6.0*U(I,4)-U(I,5))/
     1       TDLY3
      UYYYY = (2.0*U(I,1)-9.0*U(I,2)+16.0*U(I,3)-14.0*U(I,4)+6.0*U(I,5)-
     1                                                      U(I,6))/DLY4
      RETURN
C
C     PERIODIC AT Y=C+DLY
C
   40 UYYY = (-U(I,L-1)+2.0*U(I,1)-2.0*U(I,3)+U(I,4))/TDLY3
      UYYYY = (U(I,L-1)-4.0*U(I,1)+6.0*U(I,2)-4.0*U(I,3)+U(I,4))/DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS ON THE INTERIOR
C
   50 CONTINUE
      UYYY = (-U(I,J-2)+2.0*U(I,J-1)-2.0*U(I,J+1)+U(I,J+2))/TDLY3
      UYYYY = (U(I,J-2)-4.0*U(I,J-1)+6.0*U(I,J)-4.0*U(I,J+1)+U(I,J+2))/
     1        DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D-DLY
C
   60 IF (KSWY .EQ. 1) GO TO  70
      UYYY = (U(I,L-4)-6.0*U(I,L-3)+12.0*U(I,L-2)-10.0*U(I,L-1)+
     1                                                 3.0*U(I,L))/TDLY3
      UYYYY = (-U(I,L-5)+6.0*U(I,L-4)-14.0*U(I,L-3)+16.0*U(I,L-2)-
     1                                     9.0*U(I,L-1)+2.0*U(I,L))/DLY4
      RETURN
C
C     PERIODIC AT Y=D-DLY
C
   70 CONTINUE
      UYYY = (-U(I,L-3)+2.0*U(I,L-2)-2.0*U(I,1)+U(I,2))/TDLY3
      UYYYY = (U(I,L-3)-4.0*U(I,L-2)+6.0*U(I,L-1)-4.0*U(I,1)+U(I,2))/
     1        DLY4
      RETURN
C
C     COMPUTE PARTIAL DERIVATIVE APPROXIMATIONS AT Y=D
C
   80 UYYY = -(3.0*U(I,L-4)-14.0*U(I,L-3)+24.0*U(I,L-2)-18.0*U(I,L-1)+
     1                                                 5.0*U(I,L))/TDLY3
      UYYYY = (-2.0*U(I,L-5)+11.0*U(I,L-4)-24.0*U(I,L-3)+26.0*U(I,L-2)-
     1                                    14.0*U(I,L-1)+3.0*U(I,L))/DLY4
      RETURN
      END
