C
C     file sepx4.f
C
      SUBROUTINE SEPX4 (IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1                  NBDCND,BDC,BDD,COFX,GRHS,USOL,IDMN,W,PERTRB,
     2                  IERROR)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
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 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        NOVEMBER 1988
C
C PURPOSE                SEPX4 SOLVES FOR EITHER THE SECOND-ORDER
C                        FINITE DIFFERENCE APPROXIMATION OR A
C                        FOURTH-ORDER APPROXIMATION TO A SEPARABLE
C                        ELLIPTIC EQUATION
C
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
C                        A 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.  IF BOUNDARY
C                        CONDITIONS IN THE X DIRECTION ARE PERIODIC
C                        (SEE MBDCND=0 BELOW) THEN THE COEFFICIENTS
C                        MUST SATISFY
C
C                          AF(X)=C1,BF(X)=0,CF(X)=C2 FOR ALL X.
C
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
C                              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
C                              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
C                              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 ON INPUT               IORDER
C                          = 2 IF A SECOND-ORDER APPROXIMATION IS
C                              SOUGHT
C                          = 4 IF A FOURTH-ORDER APPROXIMATION IS
C                              SOUGHT
C
C                        A,B
C                          THE RANGE OF THE X-INDEPENDENT VARIABLE,
C                          I.E., X IS GREATER THAN OR EQUAL TO A
C                          AND LESS THAN OR EQUAL TO B.  A MUST BE
C                          LESS THAN B.
C
C                        M
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (A,B) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE M+1 GRID POINTS IN THE X-
C                          DIRECTION GIVEN BY XI=A+(I-1)*DLX
C                          FOR I=1,2,...,M+1 WHERE DLX=(B-A)/M IS
C                          THE PANEL WIDTH.  M MUST BE LESS THAN
C                          IDMN AND GREATER THAN 5.
C
C                        MBDCND
C                          INDICATES THE TYPE OF BOUNDARY CONDITION
C                          AT 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
C                              AND 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
C                              AND THE BOUNDARY CONDITION IS MIXED AT
C                              X=B, I.E., U(A,Y) AND
C                              DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 3 IF THE BOUNDARY CONDITIONS AT X=A AND
C                              X=B ARE MIXED, I.E.,
C                              DU(A,Y)/DX+ALPHA*U(A,Y) AND
C                              DU(B,Y)/DX+BETA*U(B,Y) ARE SPECIFIED
C                              FOR ALL Y
C                          = 4 IF THE BOUNDARY CONDITION AT X=A IS
C                              MIXED AND THE SOLUTION IS SPECIFIED
C                              AT X=B, I.E., DU(A,Y)/DX+ALPHA*U(A,Y)
C                              AND U(B,Y) ARE SPECIFIED FOR ALL Y
C
C                        BDA
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF
C                          DU(A,Y)/DX+ ALPHA*U(A,Y) AT X=A, WHEN
C                          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
C                          A DUMMY PARAMETER.
C
C                        ALPHA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN CASE
C                          OF A MIXED BOUNDARY CONDITION AT X=A
C                          (SEE ARGUMENT BDA).  IF MBDCND IS NOT EQUAL
C                          TO EITHER 3 OR 4, THEN ALPHA IS A DUMMY
C                          PARAMETER.
C
C                        BDB
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH N+1 THAT
C                          SPECIFIES THE VALUES OF
C                          DU(B,Y)/DX+ BETA*U(B,Y) AT X=B.
C                          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
C                          A DUMMY PARAMETER.
C
C                        BETA
C                          THE SCALAR MULTIPLYING THE SOLUTION IN
C                          CASE OF A MIXED BOUNDARY CONDITION AT X=B
C                          (SEE ARGUMENT BDB).  IF MBDCND IS NOT EQUAL
C                          TO 2 OR 3, THEN BETA IS A 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
C                          THAN D.
C
C                        N
C                          THE NUMBER OF PANELS INTO WHICH THE
C                          INTERVAL (C,D) IS SUBDIVIDED.  HENCE,
C                          THERE WILL BE N+1 GRID POINTS IN THE Y-
C                          DIRECTION GIVEN BY YJ=C+(J-1)*DLY FOR
C                          J=1,2,...,N+1 WHERE DLY=(D-C)/N IS THE
C                          PANEL WIDTH.  IN ADDITION, N MUST BE
C                          GREATER THAN 4.
C
C                        NBDCND
C                          INDICATES THE TYPES OF BOUNDARY CONDITIONS
C                          AT Y=C AND Y=D
C                          = 0 IF THE SOLUTION IS PERIODIC IN Y,
C                              I.E., U(X,Y+D-C)=U(X,Y) FOR ALL X,Y
C                          = 1 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND Y = D, I.E., U(X,C)  AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 2 IF THE SOLUTION IS SPECIFIED AT Y=C
C                              AND THE BOUNDARY CONDITION IS MIXED
C                              AT Y=D, I.E., DU(X,C)/DY AND U(X,D)
C                              ARE SPECIFIED FOR ALL X
C                          = 3 IF THE BOUNDARY CONDITIONS ARE MIXED
C                              AT Y=CAND Y=D I.E.,
C                              DU(X,D)/DY AND DU(X,D)/DY ARE
C                              SPECIFIED FOR ALL X
C                          = 4 IF THE BOUNDARY CONDITION IS MIXED
C                              AT Y=C AND THE SOLUTION IS SPECIFIED
C                              AT Y=D, I.E. DU(X,C)/DY+GAMA*U(X,C)
C                              AND U(X,D) 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 AT Y=C.
C
C                          WHEN NBDCND=3 OR 4
C                            BDC(I) = DU(XI,C)/DY I=1,2,...,M+1.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDC IS
C                          A DUMMY PARAMETER.
C
C                        BDD
C                          A ONE-DIMENSIONAL ARRAY OF LENGTH M+1 THAT
C                          SPECIFIED THE VALUE OF DU(X,D)/DY AT Y=D.
C
C                          WHEN NBDCND=2 OR 3
C                            BDD(I)=DU(XI,D)/DY I=1,2,...,M+1.
C
C                          WHEN NBDCND HAS ANY OTHER VALUE, BDD IS
C                          A DUMMY PARAMETER.
C
C                        COFX
C                          A USER-SUPPLIED SUBPROGRAM WITH PARAMETERS
C                          X, AFUN, BFUN, CFUN WHICH RETURNS THE
C                          VALUES OF THE X-DEPENDENT COEFFICIENTS
C                          AF(X), BF(X), CF(X) IN THE ELLIPTIC
C                          EQUATION AT X.  IF BOUNDARY CONDITIONS IN
C                          THE X DIRECTION ARE PERIODIC THEN THE
C                          COEFFICIENTS MUST SATISFY AF(X)=C1,BF(X)=0,
C                          CF(X)=C2 FOR ALL X.  HERE C1.GT.0
C                          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
C                          ELLIPTIC EQUATION, I.E.,GRHS(I,J)=G(XI,YI),
C                          FOR I=2,...,M, J=2,...,N.  AT THE
C                          BOUNDARIES, 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
C                          IN 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
C                          OF 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
C                          BE CHOSEN.
C                          FOR EXAMPLE, IF MBDCND=2 AND NBDCND=4,
C                          THEN U(A,C), U(A,D),U(B,D) MUST BE CHOSEN
C                          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 SEPELI.  THIS PARAMETER IS USED
C                          TO SPECIFY THE VARIABLE DIMENSION OF GRHS
C                          AND USOL.  IDMN MUST BE AT LEAST 7 AND
C                          GREATER THAN OR EQUAL TO M+1.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.
C                          10*N+(16+INT(LOG2(N+1)))*(M+1)+11 WILL
C                          SUFFICE AS A LENGTH FOR W.  THE ACTUAL
C                          LENGTH OF W IN THE CALLING ROUTINE
C                          MUST BE SET IN W(1) (SEE IERROR=11).
C
C
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
C                          WITH IORDER=4.
C
C                        W
C                          CONTAINS INTERMEDIATE VALUES THAT MUST NOT
C                          BE DESTROYED IF SEPELI IS CALLED AGAIN
C                          WITH INTL=1.  IN ADDITION W(1) CONTAINS
C                          THE EXACT MINIMAL LENGTH (IN FLOATING POINT)
C                          REQUIRED 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
C                          ALL X THEN A SOLUTION TO THE DISCRETIZED
C                          MATRIX EQUATION MAY NOT EXIST
C                          (REFLECTING THE NON-UNIQUENESS OF SOLUTIONS
C                          TO THE PDE).
C                          PERTRB IS A CONSTANT CALCULATED AND
C                          SUBTRACTED FROM THE RIGHT HAND SIDE OF THE
C                          MATRIX EQUATION INSURING THE EXISTENCE OF A
C                          SOLUTION.  SEPX4 COMPUTES THIS SOLUTION
C                          WHICH IS A WEIGHTED MINIMAL LEAST SQUARES
C                          SOLUTION TO THE ORIGINAL PROBLEM.  IF
C                          SINGULARITY IS NOT DETECTED PERTRB=0.0 IS
C                          RETURNED BY SEPX4.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS OR FAILURE TO FIND A SOLUTION
C
C                          =  0 NO ERROR
C                          =  1 IF A GREATER THAN B OR C GREATER
C                               THAN D
C                          =  2 IF MBDCND LESS THAN 0 OR MBDCND
C                               GREATER THAN 4
C                          =  3 IF NBDCND LESS THAN 0 OR NBDCND
C                               GREATER 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
C                               OF IDMN)
C                          =  6 IF M IS TOO SMALL OR TOO LARGE
C                               (SEE 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 SOME
C                               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 SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C REQUIRED LIBRARY       COMF, GENBUN, GNBNAUX, AND SEPAUX
C FILES                  FROM FISHPACK
C
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       NONE
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                SEPX4 WAS DEVELOPED AT NCAR BY JOHN C.
C                        ADAMS OF THE SCIENTIFIC COMPUTING DIVISION
C                        IN OCTOBER 1978.  THE BASIS OF THIS CODE IS
C                        NCAR ROUTINE SEPELI.  BOTH PACKAGES WERE
C                        RELEASED ON NCAR'S PUBLIC LIBRARIES IN
C                        JANUARY 1980.
C
C PORTABILITY            FORTRAN 77
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 DEFFERRED
C                        CORRECTIONS REFERENCED BELOW.
C
C TIMING                 WHEN POSSIBLE, SEPX4 SHOULD BE USED INSTEAD
C                        OF PACKAGE SEPELI.  THE INCREASE IN SPEED
C                        IS AT LEAST A FACTOR OF THREE.
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***********************************************************************
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
C
C     CHECK INPUT PARAMETERS
C
      CALL C4KPRM(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 S4ELIP(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1            NBDCND,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 S4ELIP(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1                  NBDCND,BDC,BDD,COFX,AN,BN,CN,DN,UN,ZN,AM,BM,
     2                  CM,DM,UM,ZM,GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C     S4ELIP SETS UP VECTORS AND ARRAYS FOR INPUT TO BLKTRI
C     AND COMPUTES A SECOND ORDER SOLUTION IN USOL.  A RETURN JUMP TO
C     SEPELI OCCURRS IF IORDER=2.  IF IORDER=4 A FOURTH ORDER
C     SOLUTION IS GENERATED IN USOL.
C
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      DIMENSION       GRHS(IDMN,1)           ,USOL(IDMN,1)
      DIMENSION       AN(*)      ,BN(*)      ,CN(*)      ,DN(*)      ,
     1                UN(*)      ,ZN(*)
      DIMENSION       AM(*)      ,BM(*)      ,CM(*)      ,DM(*)      ,
     1                UM(*)      ,ZM(*)
      COMMON /SPLP/   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     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
      DYJ=1.0
      EYJ=-2.0
      FYJ=1.0
      DO 120 J=1,NIT
         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 C4KSNG(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR)
C
C     COMPUTE NON-ZERO EIGENVECTOR IN NULL SPACE OF TRANSPOSE
C     IF SINGULAR
C
      IF (SINGLR) CALL SEPTRI (MIT,AM,BM,CM,DM,UM,ZM)
      IF (SINGLR) CALL SEPTRI (NIT,AN,BN,CN,DN,UN,ZN)
C
C     ADJUST RIGHT HAND SIDE IF NECESSARY
C
  360 CONTINUE
      IF (SINGLR) CALL SEPORT (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 SEPMIN (USOL,IDMN,ZN,ZM,PRTRB)
C
C     RETURN IF DEFERRED 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 D4FER(COFX,IDMN,USOL,GRHS)
      GO TO 360
      END
      SUBROUTINE C4KPRM(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERR
     1OR)
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 C4KSNG(MBDCND,NBDCND,ALPHA,BETA,COFX,SINGLR)
C
C     THIS SUBROUTINE CHECKS IF THE PDE   SEPELI
C     MUST SOLVE IS A SINGULAR OPERATOR
C
      COMMON /SPLP/   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
      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 D4FER(COFX,IDMN,USOL,GRHS)
C
C     THIS SUBROUTINE FIRST APPROXIMATES THE TRUNCATION 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 TRUNCATION 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 /SPLP/   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)
C
C
C     COMPUTE TRUNCATION 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 SEPDX (USOL,IDMN,I,J,UXXX,UXXXX)
            CALL SEPDY (USOL,IDMN,I,J,UYYY,UYYYY)
            TX = AI*UXXXX/12.0+BI*UXXX/6.0
             TY=UYYYY/12.0
C
C     RESET FORM OF TRUNCATION 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
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


      program GF_sde_asub   ! Calculation of the half-space
                            ! electromagnetic Green's tensor
                            ! by the short-dsitance expansion
                            ! for the case of a metal substrate.
                            !
                            ! ONLY the reflected part, GR, is computed
c------------------------------------------------------------------
c               Authors:
c                  George Y. Panasyuk, Vadim A. Markel, John C. Schotland
c                  University of Pennsylvania
c               E-mail address for questions and comments:
c                  vmarkel@mail.med.upenn.edu
c               For updates and additional info check
c                  URL: http://whale.seas.upenn.edu/CODES/
c------------------------------------------------------------------
      implicit none

      integer*4 idummy, kl, nl, key, nord
      logical*4 logscale
      character*4 hdummy, output_prec, lambda_scale

      real*8 rdummy
      real*8 t, gd, ru, rz, two, three, twopi
      real*8 z1, z2, z_p, eps0, dlambda, rlambda, power
      real*8 lambda_p, lambda, lambda_min, lambda_max, k1, rho
      real*8 zh_p, zh_p_2, eps_1, eps_2_r, eps_2_i
      real*8 L, Lhat, Lhat_2, Lhat_3, Zhat, Rhat, RZLhat, LZRhat

      complex*16 cu, cz
      complex*16 eps, eps_m, eps_p, eps_s, eps_c
      complex*16 c1, c2, c3, c4, c5, c6, c7, Lam
      complex*16 eps_2, s
      complex*16 GRxx(0:3), GRyy(0:3), GRzz(0:3), GRxz(0:3)

      complex*16 Kxx0, Kyy0, Kzz0, Kxz0
      complex*16 Kxx2, Kyy2, Kzz2, Kxz2
      complex*16 Kxx3, Kyy3, Kzz3, Kxz3

      complex*16 GRxx0, GRyy0, GRzz0, GRxz0
      complex*16 GRxx2, GRyy2, GRzz2, GRxz2
      complex*16 GRxx3, GRyy3, GRzz3, GRxz3
c
c------ Mathematical constants ------------------------------------
c
      rz = 0.0d0
      ru = 1.0d0
      cu = (0.0d0, 1.0d0)
      cz = (0.0d0, 0.0d0)

      two   = 2.0d0
      three = 3.0d0
      twopi = 4.0d0*dasin(ru)
c
c---------- Reading input parameters -----------------------------------
c
      open(unit=70, file='GF.par', status='old', err=101)
      read(70,*) hdummy
      read(70,*) hdummy

      read(70,*, err=101) key
      if(key .eq. 0) then
         write(*,*) 'Assuming a metallic substrate;'
         write(*,*) 'Drude formula will be used for eps_2'
      else if (key .eq. 1) then
         write(*,*) 'Assuming that the substrate has a'
         write(*,*) '   ... wavelength-independent permittivity'
         write(*,*) '   ... eps_2 = eps_2_r + i*eps_2_i'
         write(*,*) '   ... where eps_2_r, eps_2_i are given in GF.par'
         write(*,*) 'If you dont like this, use KEY=2'
         write(*,*) '   ... and program your own formula for eps_2'
      else if (key .eq. 2) then
         write(*,*) 'KEY=2 is used for user-defined permittivity'
         write(*,*) 'This option requires additional programming'
         write(*,*) 'But this has not been done so far'
         write(*,*) 'Go to the line "if(key .eq. 2)" below'
         write(*,*) ' ...and add your code directly after that line'
         write(*,*) 'Then comment this message out'
         write(*,*) 'For now, I am exiting. Goodby'
         stop
      else
         write(*,*) 'Error. Incorrect parameter: KEY=', key
         write(*,*) 'key is allowed to take only the values 0,1,2'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*,err=101) nord
      if(nord .lt. 0) then
         write(*,*) 'Warning. You have requested NORD<0.'
         write(*,*) 'This option is used only in GF_k2g'
         write(*,*) 'For GF_sde_asub, the sign of NORD does not matter'
         write(*,*) 'I will set NORD=|NORD| and continue.'
         nord = -nord
         write(*,*) 'NORD=', nord
         write(*,*) '--------------------------------------------'
      end if
      if (nord .eq. 1) then
         write(*,*) 'The first order correction is identicallyz zero'
         write(*,*) '    (see paper)'
         write(*,*) 'Therefore, there is no difference between NORD=0'
         write(*,*) '    and NORD=1'
         write(*,*) 'I will set NORD=0 and continue'
         write(*,*) 'The result is not affected. Goodby.'
         nord = 0
      else if(nord .gt. 3) then
         write(*,*) 'Warning. You have requested NORD>3'
         write(*,*) 'GF_sde_asub only allows NORD<=3'
         write(*,*) 'Note that GF_sde_tsub will allow |NORD|<=7'
         write(*,*) 'I will now set NORD=3 and continue'
         write(*,*) 'If this is not OK, either use GF_sde_tsub'
         write(*,*) '   ... or edit GF.par and try again'
         write(*,*) 'Continue with NORD=3?'
         pause
         nord = 3
         write(*,*) 'NORD=', nord
      else if(nord .gt. 7) then
         write(*,*) 'Error. Incorrect parameter: NORD>7'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,2,err=101) output_prec
      if(output_prec .eq. 'S') goto 3
      if(output_prec .eq. 's') goto 3
      if(output_prec .eq. 'D') goto 3
      if(output_prec .eq. 'd') goto 3
         write(*,*) 'Incorrect parameter OUTPUT_PREC'
         write(*,*) 'Only chars S, s, D, d are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 3    continue

      read(70,4,err=101) lambda_scale
      if(lambda_scale .eq. 'LOG') goto 5
      if(lambda_scale .eq. 'log') goto 5
      if(lambda_scale .eq. 'LIN') goto 5
      if(lambda_scale .eq. 'lin') goto 5
         write(*,*) 'Incorrect parameter LAMBDA_SCALE'
         write(*,*) 'Only "LOG", "log", "LIN", "lin" are allowed'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
 5    continue

      read(70,*,err=101) lambda_min, lambda_max, nl
      write(*,*) 'lambda_min,lambda_max:', sngl(lambda_min),
     $                                     sngl(lambda_max), '  [nm]'
      write(*,*) 'nl:', nl
      if(lambda_min.lt.rz) then
         write(*,*) 'Error. Incorrect parameters: lambda_min<0'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if(lambda_min.gt.lambda_max) then
         write(*,*) 'Error. Incorrect parameters: lambda_min>lambda_max'
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if((lambda_min.eq.lambda_max) .and. (nl.ne.1) ) then
         write(*,*) 'Warning. lambda_min=lambda_max but nl=/=1'
         write(*,*) 'Setting nl=1 and continuing'
         nl=1
      else if((lambda_min .lt. lambda_max) .and. (nl.lt.2)) then
         write(*,*) 'Warning. lambda_min<lambda_max but nl<2'
         write(*,*) 'Setting nl=2 and continuing'
         nl=2
      end if

      read(70,*,err=101) z1, z2, rho
      if(z1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z1<=0; z1=', z1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(z2.le.rz) then
         write(*,*) 'Error. Incorrect parameter: z2<=0; z2=', z2
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if
      if(rho.le.rz) then
         write(*,*) 'Error. Incorrect parameter: rho<=0; rho=', rho
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) eps_2_r, eps_2_i
      if(eps_2_i.lt.rz) then
         write(*,*) 'Error. Incorrect parameter: eps_2_i<0; eps_2_i=',
     $                                                     eps_2_i
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*,err=101) lambda_p
      if(lambda_p.le.rz) then
         write(*,*) 'Error. Incorrect parameter: lambda_p<=0;
     $                                           lambda_p=', lambda_p
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*,err=101) gd
      if(gd.lt.rz) then
         write(*,*) 'Error. Incorrect parameter: gd<0; gd=', gd
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      else if(gd. lt. 0.001) then
         write(*,*) 'Warning. Unrealistically small value: gd=', gd
         write(*,*) 'This can cause slow numerical convergence'
         write(*,*) 'Check convergence by increasing N1, N2, N3'
         write(*,*) '   ... by the factor of 10'
         write(*,*) 'Or better yet, use GD>=0.002 (the value for Ag)'
      end if

      read(70,*,err=101) eps0

      read(70,*,err=101) eps_1
      if(eps_1.le.rz) then
         write(*,*) 'Error. Incorrect parameter: eps_1<=0; eps_1=',
     $                                                     eps_1
         write(*,*) 'Correct the error in GF.par and try again'
         stop
      end if

      read(70,*) idummy
      read(70,*) idummy
      read(70,*) idummy

      read(70,*) rdummy, rdummy

      close(unit=70)
c
c------- End reading parameters -----------------------------
c

c
c------- Input-dependent constants --------------------------
c
      if(nl .gt. 1) then
         dlambda = (lambda_max - lambda_min)/dfloat(nl-1)
      else
         dlambda = rz
      end if

      z_p    = z2 + z1
      L      = dsqrt(rho*rho + z_p*z_p)
      zh_p   = z_p/L
      zh_p_2 = zh_p*zh_p

      logscale = .false.
      if(lambda_scale .eq. 'LOG') logscale=.true.
      if(lambda_scale .eq. 'log') logscale=.true.
      if(logscale) then
         if(lambda_min .eq. rz) then
            write(*,*) 'If using logscale, lambda_min=0 is not allowed'
            write(*,*) 'Correct GF.par and try again; exiting'
            stop
         end if
         rlambda = lambda_max/lambda_min
      end if
c
c-------- End input-dependent constants block ------------------------
c
      open(71, file='GRxx_asub', status='unknown', err=102)
      open(72, file='GRyy_asub', status='unknown', err=102)
      open(73, file='GRzz_asub', status='unknown', err=102)
      open(74, file='GRxz_asub', status='unknown', err=102)

      open(76, file='Kxx_asub', status='unknown', err=102)
      open(77, file='Kyy_asub', status='unknown', err=102)
      open(78, file='Kzz_asub', status='unknown', err=102)
      open(79, file='Kxz_asub', status='unknown', err=102)
c
c------- Start loop over wavelengths ---------------------------------
c
      do 1, kl=1,nl
      if(logscale) then
         power = dfloat(kl-1)/dfloat(nl-1)
         lambda = lambda_min * rlambda**power
      else
         lambda = lambda_min + dlambda*dfloat(kl-1)
      end if
      write(*,*) kl, ':   lambda=', sngl(lambda), '[nm]'
      k1 = twopi*dsqrt(eps_1)/lambda
      Lhat   = L*k1
      Lhat_2 = Lhat*Lhat
      Lhat_3 = Lhat_2*Lhat
      Zhat   = z_p*k1
      Rhat   = rho*k1
      LZRhat = (Lhat - Zhat)/Rhat
      RZLhat = Rhat*Zhat/Lhat_2

      if(key.eq.0) then
         t = lambda_p/lambda
         eps_2 = (eps0 - ru/t/(t + cu*gd))
      else if(key .eq. 1) then
         eps_2 = eps_2_r + cu*eps_2_i
      else if(key .eq. 2) then
         ! Enter your own formula for eps_2 here
         continue
         ! Do not edit past this line
      else
         write(*,*) 'Unexpected error 1; exiting'
         write(*,*) 'Please report this error to code developers'
         stop
      end if

      eps   = eps_2/eps_1
      eps_m = eps - ru
      eps_p = eps + ru
      eps_s = eps*eps
      eps_c = eps_s*eps
      s     = eps_m/eps_p

      c1 = cdsqrt(eps_p)
      c2 = eps_p*eps_p
      c3 = cdsqrt(eps)
      c4 = (ru + c1)/(eps + c3*c1)
      c5 = three*(c3 + ru)
      c6 = (ru - three*(c3-eps) + two*eps**2) / c5
      c7 = ru + c3 + two*eps*(ru+c3-eps*c3) - eps_c
      Lam = (eps/eps_m/c1)*cdlog(c4)

      Kxx3 = (cu*eps/c2)*(c6 + Lam)
      Kyy3 = Kxx3
      Kxz3 = rz
      Kzz3 = -(Two*cu/c2)*(c7/c5 + Lam*eps_s)

      Kxx0 = s*(three*zh_p_2 - Two)
      Kyy0 = s
      Kzz0 = s*(three*zh_p_2 - ru)
      Kxz0 = s*three*RZLhat

      Kxx2 = s*zh_p*((s - ru)/(ru + zh_p) + zh_p) / two
      Kyy2 = s*(s + zh_p)/Two/(ru + zh_p)
      Kzz2 = s*(zh_p_2 + s + Two)/Two
      Kxz2 = s*(eps*LZRhat/eps_p + RZLhat/two)

      GRxx0 = Kxx0/Lhat_3
      GRyy0 = Kyy0/Lhat_3
      GRzz0 = Kzz0/Lhat_3
      GRxz0 = Kxz0/Lhat_3

      GRxx2 = Kxx2/Lhat
      GRyy2 = Kyy2/Lhat
      GRzz2 = Kzz2/Lhat
      GRxz2 = Kxz2/Lhat

      GRxx3 = Kxx3
      GRyy3 = Kyy3
      GRzz3 = Kzz3
      GRxz3 = Kxz3

      GRxx(0) = GRxx0
      GRxz(0) = GRxz0
      GRyy(0) = GRyy0
      GRzz(0) = GRzz0

      GRxx(2) = GRxx(0) + GRxx2
      GRyy(2) = GRyy(0) + GRyy2
      GRzz(2) = GRzz(0) + GRzz2
      GRxz(2) = GRxz(0) + GRxz2

      GRxx(3) = GRxx(2) + GRxx3
      GRyy(3) = GRyy(2) + GRyy3
      GRzz(3) = GRzz(2) + GRzz3
      GRxz(3) = GRxz(2) + GRxz3

      if((output_prec.eq.'S') .or. (output_prec.eq.'s')) then

         write(71,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxx(nord))), sngl(dimag(GRxx(nord)))
         write(72,6,err=102) sngl(lambda),
     $      sngl(dreal(GRyy(nord))), sngl(dimag(GRyy(nord)))
         write(73,6,err=102) sngl(lambda),
     $      sngl(dreal(GRzz(nord))), sngl(dimag(GRzz(nord)))
         write(74,6,err=102) sngl(lambda),
     $      sngl(dreal(GRxz(nord))), sngl(dimag(GRxz(nord)))

         write(76,8,err=102) sngl(lambda),
     $      sngl(dreal(Kxx0)), sngl(dimag(Kxx0)),
     $      sngl(dreal(Kxx2)), sngl(dimag(Kxx2)),
     $      sngl(dreal(Kxx3)), sngl(dimag(Kxx3))
         write(77,8,err=102) sngl(lambda),
     $      sngl(dreal(Kyy0)), sngl(dimag(Kyy0)),
     $      sngl(dreal(Kyy2)), sngl(dimag(Kyy2)),
     $      sngl(dreal(Kyy3)), sngl(dimag(Kyy3))
         write(78,8,err=102) sngl(lambda),
     $      sngl(dreal(Kzz0)), sngl(dimag(Kzz0)),
     $      sngl(dreal(Kzz2)), sngl(dimag(Kzz2)),
     $      sngl(dreal(Kzz3)), sngl(dimag(Kzz3))
         write(79,8,err=102) sngl(lambda),
     $      sngl(dreal(Kxz0)), sngl(dimag(Kxz0)),
     $      sngl(dreal(Kxz2)), sngl(dimag(Kxz2)),
     $      sngl(dreal(Kxz3)), sngl(dimag(Kxz3))

      else if((output_prec.eq.'D') .or. (output_prec.eq.'d')) then

         write(71,10,err=102) sngl(lambda),
     $                       dreal(GRxx(nord)), dimag(GRxx(nord))
         write(72,10,err=102) sngl(lambda),
     $                       dreal(GRyy(nord)), dimag(GRyy(nord))
         write(73,10,err=102) sngl(lambda),
     $                       dreal(GRzz(nord)), dimag(GRzz(nord))
         write(74,10,err=102) sngl(lambda),
     $                       dreal(GRxz(nord)), dimag(GRxz(nord))

         write(76,12,err=102) sngl(lambda),
     $      dreal(Kxx0), dimag(Kxx0),
     $      dreal(Kxx2), dimag(Kxx2),
     $      dreal(Kxx3), dimag(Kxx3)
         write(77,12,err=102) sngl(lambda),
     $      dreal(Kyy0), dimag(Kyy0),
     $      dreal(Kyy2), dimag(Kyy2),
     $      dreal(Kyy3), dimag(Kyy3)
         write(78,12,err=102) sngl(lambda),
     $      dreal(Kzz0), dimag(Kzz0),
     $      dreal(Kzz2), dimag(Kzz2),
     $      dreal(Kzz3), dimag(Kzz3)
         write(79,12,err=102) sngl(lambda),
     $      dreal(Kxz0), dimag(Kxz0),
     $      dreal(Kxz2), dimag(Kxz2),
     $      dreal(Kxz3), dimag(Kxz3)

      else

          write(*,*) 'Unexpected error 2; exiting'
          write(*,*) 'Please report this error to code developers'
          stop

      end if

c$$$  These lines to be used for debugging only
c$$$      write(*,*) '---------------------------------------------'
c$$$      write(*,*) 'XX:', dreal(GRxx(nord)), dimag(GRxx(nord))
c$$$      write(*,*) 'YY:', dreal(GRyy(nord)), dimag(GRyy(nord))
c$$$      write(*,*) 'ZZ:', dreal(GRzz(nord)), dimag(GRzz(nord))
c$$$      write(*,*) 'XZ:', dreal(GRxz(nord)), dimag(GRxz(nord))

 1    continue
      close(unit=71)
      close(unit=72)
      close(unit=73)
      close(unit=74)
      close(unit=75)
      close(unit=76)
      close(unit=77)
      close(unit=78)
      close(unit=79)

      stop

 101  continue
      write(*,*) 'Error opening or reading input file GF.par; exiting'
      stop

 102  continue
      write(*,*) 'Error opening or writing to an output file; exiting'
      stop

 2    format(a1)
 4    format(a3)
 6    format(3G16.7E3)
 8    format(7G16.7E3)
 10   format(G16.7E3,2G23.14E3)
 12   format(G16.7E3,6G23.14E3)

      end


! ==============================================================================
!  Riemann solver for the one-dimensional shallow water equations
!
!  Uses an fwave HLL type of approach and includes bathymetry terms.  The
!  common block must contain values for the acceleration due to gravity `g` and
!  the tolerance used to decide whether a cell is dry or not `dry_tolerance`.
! ==============================================================================
subroutine rp1(maxmx, num_eqn, num_waves, num_aux, num_ghost, mx, ql, qr,      &
               auxl, auxr, fwave, s, amdq, apdq)

    implicit none

    ! Input
    integer, intent(in) :: maxmx, num_eqn, num_waves, num_ghost, num_aux, mx
    real(kind=8), intent(in out) :: ql(num_eqn,1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: qr(num_eqn,1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: auxl(num_aux,1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: auxr(num_aux,1-num_ghost:maxmx+num_ghost)

    ! Output
    real(kind=8), intent(in out) :: s(num_waves, 1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: fwave(num_eqn, num_waves, 1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: amdq(num_eqn, 1-num_ghost:maxmx+num_ghost)
    real(kind=8), intent(in out) :: apdq(num_eqn, 1-num_ghost:maxmx+num_ghost)

    ! Locals
    integer :: i, mw
    real(kind=8) :: h_l, h_r, hu_l, hu_r, u_l, u_r, b_l, b_r, phi_l, phi_r
    real(kind=8) :: delta(2), beta(2)

    ! Common block
    integer :: mcapa
    real(kind=8) :: g, dry_tolerance, earth_radius, deg2rad
    common /cparam/ g, dry_tolerance, earth_radius, deg2rad, mcapa

    fwave = 0.d0
    s = 0.d0
    amdq = 0.d0
    apdq = 0.d0

    do i=2-num_ghost,mx+num_ghost
        ! Extract state
        h_l = qr(1, i-1)
        h_r = ql(1, i)
        hu_l = qr(2, i-1)
        hu_r = ql(2, i)
        b_l = auxr(1, i-1)
        b_r = auxl(1, i)

        if (h_l < dry_tolerance) then
            u_l = 0.d0
        else
            u_l = hu_l / h_l
        end if

        if (h_r < dry_tolerance) then
            u_r = 0.d0
        else
            u_r = hu_r / h_r
        end if

        phi_l = h_l * u_l**2 + 0.5d0 * g * h_l**2
        phi_r = h_r * u_r**2 + 0.5d0 * g * h_r**2

        ! Speeds
        s(1, i) = u_l - sqrt(g * h_l)
        s(2, i) = u_r + sqrt(g * h_r)

        ! Solve for wave strengths
        delta(1) = hu_r - hu_l
        delta(2) = phi_r - phi_l + g * 0.5d0 * (h_r + h_l) * (b_r - b_l)

        beta(1) = (s(2, i) * delta(1) - delta(2)) / (s(2, i) - s(1, i))
        beta(2) = (delta(2) - s(1, i) * delta(1)) / (s(2, i) - s(1, i))

        ! Construct waves
        fwave(1, 1, i) = beta(1)
        fwave(2, 1, i) = beta(1) * s(1, i)

        fwave(1, 2, i) = beta(2)
        fwave(2, 2, i) = beta(2) * s(2, i)

        ! Calculate accumulated flux
        do mw=1,num_waves
            if (s(mw, i) < 0.d0) then
                amdq(:, i) = amdq(:, i) + fwave(:, mw, i)
            else if (s(mw, i) > 0.d0) then
                apdq(:, i) = apdq(:, i) + fwave(:, mw, i)
            else
                amdq(:, i) = amdq(:, i) + 0.5d0 * fwave(:, mw, i)
                apdq(:, i) = apdq(:, i) + 0.5d0 * fwave(:, mw, i)
            end if
        end do
    enddo

end subroutine rp1


Real Function pnska(srt)
  Save
  If (srt>3.0) Then
     pnska = 0
     Return
  End If
  ala = 1.116
  aka = 0.498
  ana = 0.939
  asa = 1.197
  t1 = asa + aka
  If (srt<=t1) Then
     pnska = 0
     Return
  End If
  If (srt<1.9) sbb1 = (0.7/0.218)*(srt-t1)
  If (srt>=1.9) sbb1 = 0.14/(srt-1.7)
  sbb2 = 0.
  If (srt>1.682) sbb2 = 0.5*(1.-0.75*(srt-1.682))
  pnska = 0.25*(sbb1+sbb2)
  pnska = pnska/10.
  Return
End Function pnska


FUNCTION vertex (coo_b, n1, n2, n3)

  ! check if angle < 165 degs - THIS IS MORE NATURAL IN GiD
  ! OLD: check if angle < 160 degs

  USE ctrl_db, ONLY: ndime

  IMPLICIT NONE
  LOGICAL :: vertex
  !        INPUT
  INTEGER (kind=4) :: n1, n2, n3   !number of nodes in contour line
  REAL    (kind=8) :: coo_b(:,:)   !(ndime,nelem) coordinates of contour nodes

  ! local
  REAL    (kind=8) :: t1(ndime),t2(ndime),xl,cosine
  !REAL    (kind=8), PARAMETER :: climit = -0.939692621d0 ! cos (160)
  REAL    (kind=8), PARAMETER :: climit = -0.965925826289068d0 ! cos (165)

  !=============================

  vertex = .FALSE.

  t1 = coo_b(1:ndime,n1) - coo_b(1:ndime,n2)   !vector n2-n1
  t2 = coo_b(1:ndime,n3) - coo_b(1:ndime,n2)   !vector n2-n3
  CALL vecuni (ndime, t1, xl)                  !normalization of t1
  CALL vecuni (ndime, t2, xl)                  !normalization of t2
  cosine = DOT_PRODUCT(t1, t2)              !cosine of the angle betw. t1, t2
  IF (cosine > climit) vertex = .TRUE.         !angle < 160

  RETURN

END FUNCTION  vertex


      PROGRAM TSTFFT
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C                       VERSION 4  APRIL 1985
C
C                         A TEST DRIVER FOR
C          A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE FAST FOURIER
C           TRANSFORM OF PERIODIC AND OTHER SYMMETRIC SEQUENCES
C
C                              BY
C
C                       PAUL N SWARZTRAUBER
C
C       NATIONAL CENTER FOR ATMOSPHERIC RESEARCH  BOULDER,COLORADO 80307
C
C        WHICH IS SPONSORED BY THE NATIONAL SCIENCE FOUNDATION
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C             THIS PROGRAM TESTS THE PACKAGE OF FAST FOURIER
C     TRANSFORMS FOR BOTH COMPLEX AND REAL PERIODIC SEQUENCES AND
C     CERTIAN OTHER SYMMETRIC SEQUENCES THAT ARE LISTED BELOW.
C
C     1.   RFFTI     INITIALIZE  RFFTF AND RFFTB
C     2.   RFFTF     FORWARD TRANSFORM OF A REAL PERIODIC SEQUENCE
C     3.   RFFTB     BACKWARD TRANSFORM OF A REAL COEFFICIENT ARRAY
C
C     4.   EZFFTI    INITIALIZE EZFFTF AND EZFFTB
C     5.   EZFFTF    A SIMPLIFIED REAL PERIODIC FORWARD TRANSFORM
C     6.   EZFFTB    A SIMPLIFIED REAL PERIODIC BACKWARD TRANSFORM
C
C     7.   SINTI     INITIALIZE SINT
C     8.   SINT      SINE TRANSFORM OF A REAL ODD SEQUENCE
C
C     9.   COSTI     INITIALIZE COST
C     10.  COST      COSINE TRANSFORM OF A REAL EVEN SEQUENCE
C
C     11.  SINQI     INITIALIZE SINQF AND SINQB
C     12.  SINQF     FORWARD SINE TRANSFORM WITH ODD WAVE NUMBERS
C     13.  SINQB     UNNORMALIZED INVERSE OF SINQF
C
C     14.  COSQI     INITIALIZE COSQF AND COSQB
C     15.  COSQF     FORWARD COSINE TRANSFORM WITH ODD WAVE NUMBERS
C     16.  COSQB     UNNORMALIZED INVERSE OF COSQF
C
C     17.  CFFTI     INITIALIZE CFFTF AND CFFTB
C     18.  CFFTF     FORWARD TRANSFORM OF A COMPLEX PERIODIC SEQUENCE
C     19.  CFFTB     UNNORMALIZED INVERSE OF CFFTF
C
C
      DIMENSION ND(10),X(200),Y(200),W(2000),
     1          A(100),B(100),AH(100),BH(100),
     2          XH(200),CX(200),CY(200)
      COMPLEX CX,CY
      DATA ND(1),ND(2),ND(3),ND(4),ND(5),ND(6),ND(7)/120,54,49,32,4,3,2/
      SQRT2 = SQRT(2.)
      NNS = 7
      DO 157 NZ=1,NNS
         N = ND(NZ)
         MODN = MOD(N,2)
         FN = FLOAT(N)
         TFN = FN+FN
         NP1 = N+1
         NM1 = N-1
         DO 101 J=1,NP1
            X(J) = SIN(FLOAT(J)*SQRT2)
            Y(J) = X(J)
            XH(J) = X(J)
  101    CONTINUE
C
C     TEST SUBROUTINES RFFTI,RFFTF AND RFFTB
C
         CALL RFFTI (N,W)
         PI = 3.14159265358979
         DT = (PI+PI)/FN
         NS2 = (N+1)/2
         IF (NS2 .LT. 2) GO TO 104
         DO 103 K=2,NS2
            SUM1 = 0.
            SUM2 = 0.
            ARG = FLOAT(K-1)*DT
            DO 102 I=1,N
               ARG1 = FLOAT(I-1)*ARG
               SUM1 = SUM1+X(I)*COS(ARG1)
               SUM2 = SUM2+X(I)*SIN(ARG1)
  102       CONTINUE
            Y(2*K-2) = SUM1
            Y(2*K-1) = -SUM2
  103    CONTINUE
  104    SUM1 = 0.
         SUM2 = 0.
         DO 105 I=1,NM1,2
            SUM1 = SUM1+X(I)
            SUM2 = SUM2+X(I+1)
  105    CONTINUE
         IF (MODN .EQ. 1) SUM1 = SUM1+X(N)
         Y(1) = SUM1+SUM2
         IF (MODN .EQ. 0) Y(N) = SUM1-SUM2
         CALL RFFTF (N,X,W)
         RFTF = 0.
         DO 106 I=1,N
            RFTF = AMAX1(RFTF,ABS(X(I)-Y(I)))
            X(I) = XH(I)
  106    CONTINUE
         RFTF = RFTF/FN
         DO 109 I=1,N
            SUM = .5*X(1)
            ARG = FLOAT(I-1)*DT
            IF (NS2 .LT. 2) GO TO 108
            DO 107 K=2,NS2
               ARG1 = FLOAT(K-1)*ARG
               SUM = SUM+X(2*K-2)*COS(ARG1)-X(2*K-1)*SIN(ARG1)
  107       CONTINUE
  108       IF (MODN .EQ. 0) SUM = SUM+.5*FLOAT((-1)**(I-1))*X(N)
            Y(I) = SUM+SUM
  109    CONTINUE
         CALL RFFTB (N,X,W)
         RFTB = 0.
         DO 110 I=1,N
            RFTB = AMAX1(RFTB,ABS(X(I)-Y(I)))
            X(I) = XH(I)
            Y(I) = XH(I)
  110    CONTINUE
         CALL RFFTB (N,Y,W)
         CALL RFFTF (N,Y,W)
         CF = 1./FN
         RFTFB = 0.
         DO 111 I=1,N
            RFTFB = AMAX1(RFTFB,ABS(CF*Y(I)-X(I)))
  111    CONTINUE
C
C     TEST SUBROUTINES SINTI AND SINT
C
         DT = PI/FN
         DO 112 I=1,NM1
            X(I) = XH(I)
  112    CONTINUE
         DO 114 I=1,NM1
            Y(I) = 0.
            ARG1 = FLOAT(I)*DT
            DO 113 K=1,NM1
               Y(I) = Y(I)+X(K)*SIN(FLOAT(K)*ARG1)
  113       CONTINUE
            Y(I) = Y(I)+Y(I)
  114    CONTINUE
         CALL SINTI (NM1,W)
         CALL SINT (NM1,X,W)
         CF = .5/FN
         SINTT = 0.
         DO 115 I=1,NM1
            SINTT = AMAX1(SINTT,ABS(X(I)-Y(I)))
            X(I) = XH(I)
            Y(I) = X(I)
  115    CONTINUE
         SINTT = CF*SINTT
         CALL SINT (NM1,X,W)
         CALL SINT (NM1,X,W)
         SINTFB = 0.
         DO 116 I=1,NM1
            SINTFB = AMAX1(SINTFB,ABS(CF*X(I)-Y(I)))
  116    CONTINUE
C
C     TEST SUBROUTINES COSTI AND COST
C
         DO 117 I=1,NP1
            X(I) = XH(I)
  117    CONTINUE
         DO 119 I=1,NP1
            Y(I) = .5*(X(1)+FLOAT((-1)**(I+1))*X(N+1))
            ARG = FLOAT(I-1)*DT
            DO 118 K=2,N
               Y(I) = Y(I)+X(K)*COS(FLOAT(K-1)*ARG)
  118       CONTINUE
            Y(I) = Y(I)+Y(I)
  119    CONTINUE
         CALL COSTI (NP1,W)
         CALL COST (NP1,X,W)
         COSTT = 0.
         DO 120 I=1,NP1
            COSTT = AMAX1(COSTT,ABS(X(I)-Y(I)))
            X(I) = XH(I)
            Y(I) = XH(I)
  120    CONTINUE
         COSTT = CF*COSTT
         CALL COST (NP1,X,W)
         CALL COST (NP1,X,W)
         COSTFB = 0.
         DO 121 I=1,NP1
            COSTFB = AMAX1(COSTFB,ABS(CF*X(I)-Y(I)))
  121    CONTINUE
C
C     TEST SUBROUTINES SINQI,SINQF AND SINQB
C
         CF = .25/FN
         DO 122 I=1,N
            Y(I) = XH(I)
  122    CONTINUE
         DT = PI/(FN+FN)
         DO 124 I=1,N
            X(I) = 0.
            ARG = DT*FLOAT(I)
            DO 123 K=1,N
               X(I) = X(I)+Y(K)*SIN(FLOAT(K+K-1)*ARG)
  123       CONTINUE
            X(I) = 4.*X(I)
  124    CONTINUE
         CALL SINQI (N,W)
         CALL SINQB (N,Y,W)
         SINQBT = 0.
         DO 125 I=1,N
            SINQBT = AMAX1(SINQBT,ABS(Y(I)-X(I)))
            X(I) = XH(I)
  125    CONTINUE
         SINQBT = CF*SINQBT
         DO 127 I=1,N
            ARG = FLOAT(I+I-1)*DT
            Y(I) = .5*FLOAT((-1)**(I+1))*X(N)
            DO 126 K=1,NM1
               Y(I) = Y(I)+X(K)*SIN(FLOAT(K)*ARG)
  126       CONTINUE
            Y(I) = Y(I)+Y(I)
  127    CONTINUE
         CALL SINQF (N,X,W)
         SINQFT = 0.
         DO 128 I=1,N
            SINQFT = AMAX1(SINQFT,ABS(X(I)-Y(I)))
            Y(I) = XH(I)
            X(I) = XH(I)
  128    CONTINUE
         CALL SINQF (N,Y,W)
         CALL SINQB (N,Y,W)
         SINQFB = 0.
         DO 129 I=1,N
            SINQFB = AMAX1(SINQFB,ABS(CF*Y(I)-X(I)))
  129    CONTINUE
C
C     TEST SUBROUTINES COSQI,COSQF AND COSQB
C
         DO 130 I=1,N
            Y(I) = XH(I)
  130    CONTINUE
         DO 132 I=1,N
            X(I) = 0.
            ARG = FLOAT(I-1)*DT
            DO 131 K=1,N
               X(I) = X(I)+Y(K)*COS(FLOAT(K+K-1)*ARG)
  131       CONTINUE
            X(I) = 4.*X(I)
  132    CONTINUE
         CALL COSQI (N,W)
         CALL COSQB (N,Y,W)
         COSQBT = 0.
         DO 133 I=1,N
            COSQBT = AMAX1(COSQBT,ABS(X(I)-Y(I)))
            X(I) = XH(I)
  133    CONTINUE
         COSQBT = CF*COSQBT
         DO 135 I=1,N
            Y(I) = .5*X(1)
            ARG = FLOAT(I+I-1)*DT
            DO 134 K=2,N
               Y(I) = Y(I)+X(K)*COS(FLOAT(K-1)*ARG)
  134       CONTINUE
            Y(I) = Y(I)+Y(I)
  135    CONTINUE
         CALL COSQF (N,X,W)
         COSQFT = 0.
         DO 136 I=1,N
            COSQFT = AMAX1(COSQFT,ABS(Y(I)-X(I)))
            X(I) = XH(I)
            Y(I) = XH(I)
  136    CONTINUE
         COSQFT = CF*COSQFT
         CALL COSQB (N,X,W)
         CALL COSQF (N,X,W)
         COSQFB = 0.
         DO 137 I=1,N
            COSQFB = AMAX1(COSQFB,ABS(CF*X(I)-Y(I)))
  137    CONTINUE
C
C     TEST PROGRAMS EZFFTI,EZFFTF,EZFFTB
C
         CALL EZFFTI(N,W)
         DO 138 I=1,N
            X(I) = XH(I)
  138    CONTINUE
         TPI = 8.*ATAN(1.)
         DT = TPI/FLOAT(N)
         NS2 = (N+1)/2
         CF = 2./FLOAT(N)
         NS2M = NS2-1
         IF (NS2M .LE. 0) GO TO 141
         DO 140 K=1,NS2M
            SUM1 = 0.
            SUM2 = 0.
            ARG = FLOAT(K)*DT
            DO 139 I=1,N
               ARG1 = FLOAT(I-1)*ARG
               SUM1 = SUM1+X(I)*COS(ARG1)
               SUM2 = SUM2+X(I)*SIN(ARG1)
  139       CONTINUE
            A(K) = CF*SUM1
            B(K) = CF*SUM2
  140    CONTINUE
  141    NM1 = N-1
         SUM1 = 0.
         SUM2 = 0.
         DO 142 I=1,NM1,2
            SUM1 = SUM1+X(I)
            SUM2 = SUM2+X(I+1)
  142    CONTINUE
         IF (MODN .EQ. 1) SUM1 = SUM1+X(N)
         AZERO = .5*CF*(SUM1+SUM2)
         IF (MODN .EQ. 0) A(NS2) = .5*CF*(SUM1-SUM2)
         CALL EZFFTF (N,X,AZEROH,AH,BH,W)
         DEZF1 = ABS(AZEROH-AZERO)
         IF (MODN .EQ. 0) DEZF1 = AMAX1(DEZF1,ABS(A(NS2)-AH(NS2)))
         IF (NS2M .LE. 0) GO TO 144
         DO 143 I=1,NS2M
            DEZF1 = AMAX1(DEZF1,ABS(AH(I)-A(I)),ABS(BH(I)-B(I)))
  143    CONTINUE
  144    NS2 = N/2
         IF (MODN .EQ. 0) B(NS2) = 0.
         DO 146 I=1,N
            SUM = AZERO
            ARG1 = FLOAT(I-1)*DT
            DO 145 K=1,NS2
               ARG2 = FLOAT(K)*ARG1
               SUM = SUM+A(K)*COS(ARG2)+B(K)*SIN(ARG2)
  145       CONTINUE
            X(I) = SUM
  146    CONTINUE
         CALL EZFFTB (N,Y,AZERO,A,B,W)
         DEZB1 = 0.
         DO 147 I=1,N
            DEZB1 = AMAX1(DEZB1,ABS(X(I)-Y(I)))
            X(I) = XH(I)
  147    CONTINUE
         CALL EZFFTF (N,X,AZERO,A,B,W)
         CALL EZFFTB (N,Y,AZERO,A,B,W)
         DEZFB = 0.
         DO 148 I=1,N
            DEZFB = AMAX1(DEZFB,ABS(X(I)-Y(I)))
  148    CONTINUE
C
C     TEST  CFFTI,CFFTF,CFFTB
C
         DO 149 I=1,N
            CX(I) = CMPLX(COS(SQRT2*FLOAT(I)),SIN(SQRT2*FLOAT(I*I)))
  149    CONTINUE
         DT = (PI+PI)/FN
         DO 151 I=1,N
            ARG1 = -FLOAT(I-1)*DT
            CY(I) = (0.,0.)
            DO 150 K=1,N
               ARG2 = FLOAT(K-1)*ARG1
               CY(I) = CY(I)+CMPLX(COS(ARG2),SIN(ARG2))*CX(K)
  150       CONTINUE
  151    CONTINUE
         CALL CFFTI (N,W)
         CALL CFFTF (N,CX,W)
         DCFFTF = 0.
         DO 152 I=1,N
            DCFFTF = AMAX1(DCFFTF,CABS(CX(I)-CY(I)))
            CX(I) = CX(I)/FN
  152    CONTINUE
         DCFFTF = DCFFTF/FN
         DO 154 I=1,N
            ARG1 = FLOAT(I-1)*DT
            CY(I) = (0.,0.)
            DO 153 K=1,N
               ARG2 = FLOAT(K-1)*ARG1
               CY(I) = CY(I)+CMPLX(COS(ARG2),SIN(ARG2))*CX(K)
  153       CONTINUE
  154    CONTINUE
         CALL CFFTB (N,CX,W)
         DCFFTB = 0.
         DO 155 I=1,N
            DCFFTB = AMAX1(DCFFTB,CABS(CX(I)-CY(I)))
            CX(I) = CY(I)
  155    CONTINUE
         CF = 1./FN
         CALL CFFTF (N,CX,W)
         CALL CFFTB (N,CX,W)
         DCFB = 0.
         DO 156 I=1,N
            DCFB = AMAX1(DCFB,CABS(CF*CX(I)-CY(I)))
  156    CONTINUE
         WRITE (6,1001) N,RFTF,RFTB,RFTFB,SINTT,SINTFB,COSTT,COSTFB,
     1                  SINQFT,SINQBT,SINQFB,COSQFT,COSQBT,COSQFB,DEZF1,
     2                  DEZB1,DEZFB,DCFFTF,DCFFTB,DCFB
  157 CONTINUE
C
C
C
 1001 FORMAT (2H0N,I5,8H RFFTF  ,E10.3,8H RFFTB  ,E10.3,8H RFFTFB ,
     1        E10.3,8H SINT   ,E10.3,8H SINTFB ,E10.3,8H COST   ,E10.3/
     2        7X,8H COSTFB ,E10.3,8H SINQF  ,E10.3,8H SINQB  ,E10.3,
     3        8H SINQFB ,E10.3,8H COSQF  ,E10.3,8H COSQB  ,E10.3/7X,
     4        8H COSQFB ,E10.3,8H DEZF   ,E10.3,8H DEZB   ,E10.3,
     5        8H DEZFB  ,E10.3,8H CFFTF  ,E10.3,8H CFFTB  ,E10.3/
     6        7X,8H CFFTFB ,E10.3)
C
      END


program pythagorean_3body
    use physics
    use bulirsch_stoer
    implicit none
    ! to do:
    !   figure out how to make it so I don't have to explicitly use 'accuracy.f08'
    !       within bulirsch_stoer.f08
    !       -- that would help make this a bit easier to use modularly

    integer, parameter                       :: n_bodies = 3
    ! 3-position, 3-velocity
    real(kind=precision), dimension(n_bodies, 3)    :: x, v
    real(kind=precision), dimension(n_bodies)       :: mass

    real(kind=precision), parameter     :: H_big = 1./real(10**(4), kind=precision) ! large step size
    real(kind=precision)                :: t
    real(kind=precision), parameter     :: t_max = 70.

    type(accuracy_state)         :: state_initial, state_final

    integer                      :: i,j     ! loop variables

    integer, dimension(n_bodies) :: save_file_units
    character(len=6)             :: jth_body_str ! tmp variable used in filenames
    character(len=15)            :: filename     ! tmp variable used in filenames
    character(len=15)            :: data_format  ! for saving

    do j=1, n_bodies
        write (jth_body_str, "(I3.3)") j
        filename = 'body_'//trim(jth_body_str)//'.dat'

        open(newunit=save_file_units(j), file=filename, status='unknown')
        write(save_file_units(j), *) "t",achar(9),achar(9),achar(9),achar(9),&
            "x",achar(9),achar(9),achar(9),achar(9),&
            "y",achar(9),achar(9),achar(9),achar(9),&
            "z"
    end do
    data_format = "(4e13.5)"

    !initialize
    mass(1) = 3.
    x(1, 1) = 1.          ! body 1, x position
    x(1, 2) = 3.          ! body 1, y position
    x(1, 3) = 0.          ! body 1, z position

    mass(2) =  4.
    x(2, 1) = -2.          ! body 2, x position
    x(2, 2) = -1.          ! body 2, y position
    x(2, 3) =  0.          ! body 2, z position

    mass(3) =  5.
    x(3, 1) =  1.          ! body 3, x position
    x(3, 2) = -1.          ! body 3, y position
    x(3, 3) =  0.          ! body 3, z position

    v = 0.     ! all bodies, all velocities

    call state_initial%initialize(n_bodies, x, v, mass)

    print *, 'energy (initial): '
    print *,  state_initial%energy

    print *, 'angular momentum (initial): '
    print *,  state_initial%angular_momentum

    t = 0.
    do i=1,int(t_max/ H_big)
        t = t + H_big
        call bulirsch_stoer_step(n_bodies, x, v, mass, H_big)

        if (mod(i, int(.1 / H_big)).eq.0) then
!             print *, 't = '
!             print *, i * H_big
            do j=1, n_bodies
                write(save_file_units(j),data_format) t, x(j,1), x(j,2), x(j,3)
            end do
        endif
    end do

    call state_final%initialize(n_bodies, x, v, mass)

    print *, ""
    print *, 'energy (final): '
    print *,  state_final%energy

    print *, 'angular momentum (final): '
    print *,  state_final%angular_momentum

    print *, "overall conservation:"
    print *, "energy err:"
    print *, abs( (state_final%energy - state_initial%energy) / state_initial%energy )
    print *, "angular momentum err:"
    print *, abs( state_final%angular_momentum - state_initial%angular_momentum )

end program


program sw_oned
  implicit none
  integer, parameter :: DP = kind(1.0d0)
  integer, parameter :: ITER_MAX = 100000
  integer, parameter :: N = 500
  real(DP), parameter :: GG = 9.8d0
  real(DP), parameter :: CFL = 0.45d0
  real(DP), parameter :: TIME_FIN = 7.0d0
  real(DP), parameter :: L = 50.0d0
  real(DP), parameter :: XL = 0.0d0
  real(DP), parameter :: X_DAM = 10.0d0
  real(DP), parameter :: DEPTH_LEFT = 1.0d0
  real(DP), parameter :: VELOCITY_LEFT = 2.5d0
  real(DP), parameter :: DEPTH_RIGHT = 0.1d0
  real(DP), parameter :: VELOCITY_RIGHT = 0.0d0
  real(DP), parameter :: BC_U_LEFT = 1.0d0
  real(DP), parameter :: BC_U_RIGHT = 1.0d0
  real(DP), parameter :: DX = L / DFLOAT(N)
  character(len=20), parameter :: OUTPUT_FILE = 'res.dat'

  integer :: it=0
  real(DP) :: dt=1.d-8, time=0.0d0
  real(DP) :: t_start, t_end
  real(DP), allocatable :: x(:), h(:), u(:), h_cons(:), u_cons(:)
  real(DP), allocatable :: h_flux(:), u_flux(:)

  allocate(x(0:N+1), h(0:N+1), u(0:N+1), h_cons(0:N+1), u_cons(0:N+1))
  allocate(h_flux(0:N+1), u_flux(0:N+1))

  call cpu_time(t_start)

  call set_mesh(x)
  call set_ic_dambreak(x, h, u)
  do while(time<TIME_FIN)
    if (it.ge.ITER_MAX) exit
    dt = dt_from(h, u)
    if (dt>TIME_FIN-time) dt = TIME_FIN-time
    call set_bc(h, u)
    call riemann_fluxes(h, u, h_flux, u_flux)
    call prim_to_cons(h, u, h_cons, u_cons)
    call godunov(h_cons, u_cons, h_flux, u_flux)
    call cons_to_prim(h_cons, u_cons, h, u)

    it=it+1
    time=time+dt
  enddo
  call output_solution(OUTPUT_FILE, x, h, u)

  call cpu_time(t_end)
  deallocate(x, h, u, h_cons, u_cons, h_flux, u_flux)

  print*, 'cpu time:  ', t_end - t_start
  print*, 'time:      ', time
  print*, 'iterations:', it

contains

! INITIALISATION PROCEDURES

subroutine set_mesh(x)
  real(DP), intent(out) :: x(0:N+1)
  integer :: i

  do i=0,N+1
    x(i) = XL+0.5d0*dx+DFLOAT(i-1)*DX
  enddo
end

subroutine set_ic_dambreak(x, h, u)
  real(DP), intent(in) :: x(0:N+1)
  real(DP), intent(out) :: h(0:N+1), u(0:N+1)
  integer :: i

  do i=1,N
    if (x(i).le.X_DAM) then
      h(i)=DEPTH_LEFT
      u(i)=VELOCITY_LEFT
    else
      h(i)=DEPTH_RIGHT
      u(i)=VELOCITY_RIGHT
    endif
  enddo
end

subroutine set_bc(h, u)
  real(DP), intent(inout) :: h(0: N+1), u(0: N+1)

  h(0) = h(1)
  u(0) = BC_U_LEFT * u(1)
  h(N+1) = h(N)
  u(N+1) = BC_U_RIGHT * u(N)
end

real(DP) function dt_from(h,u)
  implicit none
  real(DP), dimension(0:N+1), intent(in) :: h, u
  real(DP) :: cmax
  integer :: i

  cmax = 0.0d0
  do i=1,N
    cmax = max( cmax, dabs(u(i)) + dsqrt(GG*h(i)) )
  enddo
  dt_from = CFL*dx/cmax
end

subroutine riemann_fluxes(h, u, h_flux, u_flux)
  implicit none
  real(DP), dimension(0:N+1), intent(in) :: h,u
  real(DP), dimension(0:N+1), intent(out) :: h_flux, u_flux
  real(DP) :: hl,ul,hr,ur,f1,f2
  integer :: i

  do i=0,N
    hl=h(i)
    ul=u(i)

    hr=h(i+1)
    ur=u(i+1)

    call rusanov(hl, ul, hr, ur, f1, f2)
    h_flux(i) = f1
    u_flux(i) = f2
  enddo
end

subroutine rusanov(hl,ul,hr,ur,f1,f2)
  implicit none
  real(DP), intent(in) :: hl,ul,hr,ur
  real(DP), intent(out) :: f1,f2
  real(DP) :: pl,al,pr,ar
  real(DP) :: h_cons_l, h_cons_r, u_cons_l, u_cons_r
  real(DP) :: h_flux_l, h_flux_r, u_flux_l, u_flux_r
  real(DP) :: sl,sr,sl1,sr1,sl2,sr2,smid

  pl = 0.5d0*GG*hl*hl
  al = DSQRT(GG*hl)
  pr = 0.5d0*GG*hr*hr
  ar = DSQRT(GG*hr)

  ! Wave speed estimation
  ! Davis S.F.(1988), 'Simplified second order Godunov type methods',
  ! SIAM J. Sci. and Stat. Comput., N3, 445-473.
  sl1=ul-al; sl2=ur-ar
  sr1=ul+al; sr2=ur+ar
  sl=DMIN1(sl1,sl2); sr=DMAX1(sr1,sr2)
  smid=dmax1(dabs(sl),dabs(sr))

  h_cons_l=hl   ;	  h_flux_l=hl*ul
  u_cons_l=hl*ul;	  u_flux_l=hl*ul*ul+pl

  h_cons_r=hr   ;   h_flux_r=hr*ur
  u_cons_r=hr*ur;   u_flux_r=hr*ur*ur+pr

  f1 = 0.5d0*(h_flux_l + h_flux_r) - 0.5d0*smid*(h_cons_r - h_cons_l)
  f2 = 0.5d0*(u_flux_l + u_flux_r) - 0.5d0*smid*(u_cons_r - u_cons_l)
end

subroutine godunov(h_cons, u_cons, h_flux, u_flux)
  implicit none
  real(DP), dimension(0:N+1), intent(in) :: h_flux, u_flux
  real(DP), dimension(0:N+1), intent(inout) :: h_cons, u_cons
  integer :: i
  do i=1,N
    h_cons(i) = h_cons(i) - (h_flux(i) - h_flux(i-1)) * dt / dx
    u_cons(i) = u_cons(i) - (u_flux(i) - u_flux(i-1)) * dt / dx
  enddo
end

! AUX PROCEDURES

subroutine prim_to_cons(h, u, h_cons, u_cons)
  real(DP), intent(in) :: h(0:N+1), u(0:N+1)
  real(DP), intent(out) :: h_cons(0:N+1), u_cons(0:N+1)
  integer :: i

  do i = 1, N
    h_cons(i) = h(i)
    u_cons(i) = h(i) * u(i)
  enddo

end

subroutine cons_to_prim(h_cons, u_cons, h, u)
  real(DP), intent(in) :: h_cons(0:N+1), u_cons(0:N+1)
  real(DP), intent(out) :: h(0:N+1), u(0:N+1)
  integer :: i

  do i = 1, N
    h(i) = h_cons(i)
    u(i) = u_cons(i) / h(i)
  enddo

end

subroutine output_solution(filename, x, h, u)
  character(len=20), intent(in) :: filename
  real(DP), dimension(0:N+1), intent(in) :: x, h, u
  integer :: i

  open(unit=10,file=filename)
  do i=1,N
    write(10,*) x(i), h(i), u(i)
  enddo
  close(10)
end

end program sw_oned


      SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )
*
*  -- LAPACK auxiliary routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      INTEGER            INCX, INCY, N
      DOUBLE PRECISION   SSMIN
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   X( * ), Y( * )
*     ..
*
*  Purpose
*  =======
*
*  Given two column vectors X and Y, let
*
*                       A = ( X Y ).
*
*  The subroutine first computes the QR factorization of A = Q*R,
*  and then computes the SVD of the 2-by-2 upper triangular matrix R.
*  The smaller singular value of R is returned in SSMIN, which is used
*  as the measurement of the linear dependency of the vectors X and Y.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The length of the vectors X and Y.
*
*  X       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCX)
*          On entry, X contains the N-vector X.
*          On exit, X is overwritten.
*
*  INCX    (input) INTEGER
*          The increment between successive elements of X. INCX > 0.
*
*  Y       (input/output) DOUBLE PRECISION array,
*                         dimension (1+(N-1)*INCY)
*          On entry, Y contains the N-vector Y.
*          On exit, Y is overwritten.
*
*  INCY    (input) INTEGER
*          The increment between successive elements of Y. INCY > 0.
*
*  SSMIN   (output) DOUBLE PRECISION
*          The smallest singular value of the N-by-2 matrix A = ( X Y ).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      DOUBLE PRECISION   A11, A12, A22, C, SSMAX, TAU
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT
*     ..
*     .. External Subroutines ..
      EXTERNAL           DAXPY, DLARFG, DLAS2
*     ..
*     .. Executable Statements ..
*
*     Quick return if possible
*
      IF( N.LE.1 ) THEN
         SSMIN = ZERO
         RETURN
      END IF
*
*     Compute the QR factorization of the N-by-2 matrix ( X Y )
*
      CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
      A11 = X( 1 )
      X( 1 ) = ONE
*
      C = -TAU*DDOT( N, X, INCX, Y, INCY )
      CALL DAXPY( N, C, X, INCX, Y, INCY )
*
      CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
*
      A12 = Y( 1 )
      A22 = Y( 1+INCY )
*
*     Compute the SVD of 2-by-2 Upper triangular matrix.
*
      CALL DLAS2( A11, A12, A22, SSMIN, SSMAX )
*
      RETURN
*
*     End of DLAPLL
*
      END


    Program zgesdd_example

!     ZGESDD Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: zgesdd
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nb = 64, nin = 5, nout = 6, prerr = 0
!     .. Local Scalars ..
      Integer :: i, info, lda, ldu, ldvt, lwork, m, n
!     .. Local Arrays ..
      Complex (Kind=dp), Allocatable :: a(:, :), a_copy(:, :), b(:), u(:, :), &
        vt(:, :), work(:)
      Complex (Kind=dp) :: dummy(1, 1)
      Real (Kind=dp), Allocatable :: rwork(:), s(:)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min, nint, real
!     .. Executable Statements ..
      Write (nout, *) 'ZGESDD Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldu = m
      ldvt = n
      Allocate (a(lda,n), a_copy(m,n), s(m), u(ldu,m), vt(ldvt,n), b(m), &
        rwork((5*m+7)*n), iwork(8*m))

!     Read the m by n matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, m)

!     Read the right hand side of the linear system
      Read (nin, *) b(1:m)

      a_copy(1:m, 1:n) = a(1:m, 1:n)

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call zgesdd('A', m, n, a, lda, s, u, ldu, vt, ldvt, dummy, lwork, rwork, &
        iwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = max((2*m+2)*m+2*n+nb*(m+n), nint(real(dummy(1,1))))
      Allocate (work(lwork))

!     Compute the singular values and left and right singular vectors
!     of A.

      Call zgesdd('A', m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, rwork, &
        iwork, info)

      If (info/=0) Then
        Write (nout, 100) 'Failure in ZGESDD. INFO =', info
100     Format (1X, A, I4)
        Go To 120
      End If

!     Print the significant singular values of A

      Write (nout, *) 'Singular values of A:'
      Write (nout, 110) s(1:min(m,n))
110   Format (1X, 4(3X,F11.4))

      If (prerr>0) Then
        Call compute_error_bounds(m, n, s)
      End If

      If (m<n) Then
!       Compute V*Inv(S)*U^T * b to get minimum norm solution.
        Call compute_minimum_norm(m, n, a_copy, m, u, ldu, vt, ldvt, s, b)
      End If

120   Continue

    Contains
      Subroutine compute_minimum_norm(m, n, a, lda, u, ldu, vt, ldvt, s, b)

!       .. Use Statements ..
        Use blas_interfaces, Only: dznrm2, zgemv
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: lda, ldu, ldvt, m, n
!       .. Array Arguments ..
        Complex (Kind=dp), Intent (In) :: a(lda, n), u(ldu, m), vt(ldvt, n)
        Complex (Kind=dp), Intent (Inout) :: b(m)
        Real (Kind=dp), Intent (In) :: s(m)
!       .. Local Scalars ..
        Complex (Kind=dp) :: alpha, beta
        Real (Kind=dp) :: norm
!       .. Local Arrays ..
        Complex (Kind=dp), Allocatable :: x(:), y(:)
!       .. Intrinsic Procedures ..
        Intrinsic :: allocated, cmplx
!       .. Executable Statements ..
        Allocate (x(n), y(m))

!       Compute V*Inv(S)*U^H * b to get least squares solution.

!       y = U^H b
        alpha = cmplx(1.0_dp, 0.0_dp, kind=dp)
        beta = cmplx(0.0_dp, 0.0_dp, kind=dp)
        Call zgemv('C', m, m, alpha, u, ldu, b, 1, beta, y, 1)

        y(1:m) = y(1:m)/s(1:m)

!       x = V y
        Call zgemv('C', m, n, alpha, vt, ldvt, y, 1, beta, x, 1)

        Write (nout, *)
        Write (nout, *) 'Minimum norm solution:'
        Write (nout, 100) x(1:n)

        norm = dznrm2(n, x, 1)

        Write (nout, *)
        Write (nout, *) 'Norm of Solution:'
        Write (nout, 110) norm

!       Find norm of residual ||b-Ax||, should be zero.
        alpha = cmplx(-1.0_dp, 0.0_dp, kind=dp)
        beta = cmplx(1._dp, 0.0_dp, kind=dp)
        Call zgemv('N', m, n, alpha, a, lda, x, 1, beta, b, 1)

        norm = dznrm2(m, b, 1)

        Write (nout, *)
        Write (nout, *) 'Norm of Residual:'
        Write (nout, 110) norm

        If (allocated(x)) Then
          Deallocate (x)
        End If
        If (allocated(y)) Then
          Deallocate (y)
        End If

100     Format (4X, '(', F8.4, ',', F8.4, ')')
110     Format (4X, F11.4)

      End Subroutine

      Subroutine compute_error_bounds(m, n, s)

!       Error estimates for singular values and vectors is computed
!       and printed here.

!       .. Use Statements ..
        Use lapack_interfaces, Only: ddisna
        Use lapack_precision, Only: dp
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: m, n
!       .. Array Arguments ..
        Real (Kind=dp), Intent (In) :: s(m)
!       .. Local Scalars ..
        Real (Kind=dp) :: eps, serrbd
        Integer :: i, info
!       .. Local Arrays ..
        Real (Kind=dp), Allocatable :: rcondu(:), rcondv(:), uerrbd(:), &
          verrbd(:)
!       .. Intrinsic Procedures ..
        Intrinsic :: epsilon
!       .. Executable Statements ..
        Allocate (rcondu(n), rcondv(n), uerrbd(n), verrbd(n))

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed singular values.  Note that for
!       the 2-norm, S(1) = norm(A)

        eps = epsilon(1.0E0_dp)
        serrbd = eps*s(1)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors

        Call ddisna('Left', m, n, s, rcondu, info)
        Call ddisna('Right', m, n, s, rcondv, info)

!       Compute the error estimates for the singular vectors

        Do i = 1, n
          uerrbd(i) = serrbd/rcondu(i)
          verrbd(i) = serrbd/rcondv(i)
        End Do

!       Print the approximate error bounds for the singular values
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Error estimate for the singular values'
        Write (nout, 100) serrbd
        Write (nout, *)
        Write (nout, *) 'Error estimates for the left singular vectors'
        Write (nout, 100) uerrbd(1:n)
        Write (nout, *)
        Write (nout, *) 'Error estimates for the right singular vectors'
        Write (nout, 100) verrbd(1:n)

100     Format (4X, 1P, 6E11.1)

      End Subroutine

    End Program


C
C	$Id: csscoordd.f,v 1.4 2008-07-27 03:10:07 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSSCOORDD (PX,PY,PZ, PLAT,PLON,PNRM)
      DOUBLE PRECISION PX, PY, PZ, PLAT, PLON, PNRM
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   08/27/90
C
C   This subroutine converts a point P from Cartesian coor-
C dinates to spherical coordinates.
C
C
C On input:
C
C       PX,PY,PZ = Cartesian coordinates of P.
C
C Input parameters are not altered by this routine.
C
C On output:
C
C       PLAT = Latitude of P in the range -PI/2 to PI/2, or
C              0 if PNRM = 0.  PLAT should be scaled by
C              180/PI to obtain the value in degrees.
C
C       PLON = Longitude of P in the range -PI to PI, or 0
C              if P lies on the Z-axis.  PLON should be
C              scaled by 180/PI to obtain the value in
C              degrees.
C
C       PNRM = Magnitude (Euclidean norm) of P.
C
C Modules required by CSSCOORD:  None
C
C Intrinsic functions called by CSSCOORD:  ASIN, ATAN2, SQRT
C
C***********************************************************
C
      PNRM = SQRT(PX*PX + PY*PY + PZ*PZ)
      IF (PX .NE. 0.D0  .OR.  PY .NE. 0.D0) THEN
        PLON = ATAN2(PY,PX)
      ELSE
        PLON = 0.D0
      ENDIF
      IF (PNRM .NE. 0.D0) THEN
        PLAT = ASIN(PZ/PNRM)
      ELSE
        PLAT = 0.D0
      ENDIF
      RETURN
      END


      SUBROUTINE SSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU,
     $                   V, LDV, TAU, WORK, RESULT )
*
*  -- LAPACK test routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            ITYPE, KBAND, LDA, LDU, LDV, M, N
*     ..
*     .. Array Arguments ..
      REAL               A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
     $                   TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*       SSYT22  generally checks a decomposition of the form
*
*               A U = U S
*
*       where A is symmetric, the columns of U are orthonormal, and S
*       is diagonal (if KBAND=0) or symmetric tridiagonal (if
*       KBAND=1).  If ITYPE=1, then U is represented as a dense matrix,
*       otherwise the U is expressed as a product of Householder
*       transformations, whose vectors are stored in the array "V" and
*       whose scaling constants are in "TAU"; we shall use the letter
*       "V" to refer to the product of Householder transformations
*       (which should be equal to U).
*
*       Specifically, if ITYPE=1, then:
*
*               RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and*
*               RESULT(2) = | I - U'U | / ( m ulp )
*
*  Arguments
*  =========
*
*  ITYPE   INTEGER
*          Specifies the type of tests to be performed.
*          1: U expressed as a dense orthogonal matrix:
*             RESULT(1) = | A - U S U' | / ( |A| n ulp )   *and*
*             RESULT(2) = | I - UU' | / ( n ulp )
*
*  UPLO    CHARACTER
*          If UPLO='U', the upper triangle of A will be used and the
*          (strictly) lower triangle will not be referenced.  If
*          UPLO='L', the lower triangle of A will be used and the
*          (strictly) upper triangle will not be referenced.
*          Not modified.
*
*  N       INTEGER
*          The size of the matrix.  If it is zero, SSYT22 does nothing.
*          It must be at least zero.
*          Not modified.
*
*  M       INTEGER
*          The number of columns of U.  If it is zero, SSYT22 does
*          nothing.  It must be at least zero.
*          Not modified.
*
*  KBAND   INTEGER
*          The bandwidth of the matrix.  It may only be zero or one.
*          If zero, then S is diagonal, and E is not referenced.  If
*          one, then S is symmetric tri-diagonal.
*          Not modified.
*
*  A       REAL array, dimension (LDA , N)
*          The original (unfactored) matrix.  It is assumed to be
*          symmetric, and only the upper (UPLO='U') or only the lower
*          (UPLO='L') will be referenced.
*          Not modified.
*
*  LDA     INTEGER
*          The leading dimension of A.  It must be at least 1
*          and at least N.
*          Not modified.
*
*  D       REAL array, dimension (N)
*          The diagonal of the (symmetric tri-) diagonal matrix.
*          Not modified.
*
*  E       REAL array, dimension (N)
*          The off-diagonal of the (symmetric tri-) diagonal matrix.
*          E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
*          Not referenced if KBAND=0.
*          Not modified.
*
*  U       REAL array, dimension (LDU, N)
*          If ITYPE=1 or 3, this contains the orthogonal matrix in
*          the decomposition, expressed as a dense matrix.  If ITYPE=2,
*          then it is not referenced.
*          Not modified.
*
*  LDU     INTEGER
*          The leading dimension of U.  LDU must be at least N and
*          at least 1.
*          Not modified.
*
*  V       REAL array, dimension (LDV, N)
*          If ITYPE=2 or 3, the lower triangle of this array contains
*          the Householder vectors used to describe the orthogonal
*          matrix in the decomposition.  If ITYPE=1, then it is not
*          referenced.
*          Not modified.
*
*  LDV     INTEGER
*          The leading dimension of V.  LDV must be at least N and
*          at least 1.
*          Not modified.
*
*  TAU     REAL array, dimension (N)
*          If ITYPE >= 2, then TAU(j) is the scalar factor of
*          v(j) v(j)' in the Householder transformation H(j) of
*          the product  U = H(1)...H(n-2)
*          If ITYPE < 2, then TAU is not referenced.
*          Not modified.
*
*  WORK    REAL array, dimension (2*N**2)
*          Workspace.
*          Modified.
*
*  RESULT  REAL array, dimension (2)
*          The values computed by the two tests described above.  The
*          values are currently limited to 1/ulp, to avoid overflow.
*          RESULT(1) is always modified.  RESULT(2) is modified only
*          if LDU is at least N.
*          Modified.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E0, ONE = 1.0E0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, JJ, JJ1, JJ2, NN, NNP1
      REAL               ANORM, ULP, UNFL, WNORM
*     ..
*     .. External Functions ..
      REAL               SLAMCH, SLANSY
      EXTERNAL           SLAMCH, SLANSY
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SSYMM
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, REAL
*     ..
*     .. Executable Statements ..
*
      RESULT( 1 ) = ZERO
      RESULT( 2 ) = ZERO
      IF( N.LE.0 .OR. M.LE.0 )
     $   RETURN
*
      UNFL = SLAMCH( 'Safe minimum' )
      ULP = SLAMCH( 'Precision' )
*
*     Do Test 1
*
*     Norm of A:
*
      ANORM = MAX( SLANSY( '1', UPLO, N, A, LDA, WORK ), UNFL )
*
*     Compute error matrix:
*
*     ITYPE=1: error = U' A U - S
*
      CALL SSYMM( 'L', UPLO, N, M, ONE, A, LDA, U, LDU, ZERO, WORK, N )
      NN = N*N
      NNP1 = NN + 1
      CALL SGEMM( 'T', 'N', M, M, N, ONE, U, LDU, WORK, N, ZERO,
     $            WORK( NNP1 ), N )
      DO 10 J = 1, M
         JJ = NN + ( J-1 )*N + J
         WORK( JJ ) = WORK( JJ ) - D( J )
   10 CONTINUE
      IF( KBAND.EQ.1 .AND. N.GT.1 ) THEN
         DO 20 J = 2, M
            JJ1 = NN + ( J-1 )*N + J - 1
            JJ2 = NN + ( J-2 )*N + J
            WORK( JJ1 ) = WORK( JJ1 ) - E( J-1 )
            WORK( JJ2 ) = WORK( JJ2 ) - E( J-1 )
   20    CONTINUE
      END IF
      WNORM = SLANSY( '1', UPLO, M, WORK( NNP1 ), N, WORK( 1 ) )
*
      IF( ANORM.GT.WNORM ) THEN
         RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
      ELSE
         IF( ANORM.LT.ONE ) THEN
            RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
         ELSE
            RESULT( 1 ) = MIN( WNORM / ANORM, REAL( M ) ) / ( M*ULP )
         END IF
      END IF
*
*     Do Test 2
*
*     Compute  U'U - I
*
      IF( ITYPE.EQ.1 )
     $   CALL SORT01( 'Columns', N, M, U, LDU, WORK, 2*N*N,
     $                RESULT( 2 ) )
*
      RETURN
*
*     End of SSYT22
*
      END


	INCLUDE 'VICMAIN_FOR'
	SUBROUTINE MAIN44
	REAL*4 V(2,900),P(6)

	CALL XVUNIT(IU,'INP',1,IST,' ')
	CALL XVOPEN(IU,IST,' ')
	CALL XVREAD(IU,V,IST,' ')
	CALL XVCLOSE(IU,IST,' ')
	CALL XVPARM('NROW',NR,ICNT,IDEF,0)
	CALL XVPARM('NCOL',NC,ICNT,IDEF,0)
C	CL = V(1,NR*NC/2+1)
C	CS = V(2,NR*NC/2+1)

	CALL XVPARM('OFFSET',P,ICNT,IDEF,0)
	IF (ICNT .EQ. 2) THEN
		A = 1
		B = 0
		C = 0
		D = 1
		E = P(1)
		F = P(2)
	END IF
	CALL XVPARM('ROTOFF',P,ICNT,IDEF,0)
	IF (ICNT .EQ. 3) THEN
		PR = 3.1415926*P(3)/180.
		ST = SIN(PR)
		CT = COS(PR)
		A = CT
		B = -ST
		C = ST
		D = CT
		E = P(1)
		F = P(2)
	END IF
	CALL XVPARM('SCALEOFF',P,ICNT,IDEF,0)
	IF (ICNT .EQ. 3) THEN
		A = P(3)
		B = 0
		C = 0
		D = P(3)
		E = P(1)
		F = P(2)
	END IF
	CALL XVPARM('SRO',P,ICNT,IDEF,0)
	IF (ICNT .EQ. 4) THEN
		PR = 3.1415926*P(3)/180.
		ST = SIN(PR)
		CT = COS(PR)
		A = P(4)*CT
		B = -P(4)*ST
		C = P(4)*ST
		D = P(4)*CT
		E = P(1)
		F = P(2)
	END IF
	CALL XVPARM('UNC',P,ICNT,IDEF,0)
	IF (ICNT .EQ. 6) THEN
		A = P(1)
		B = P(2)
		C = P(3)
		D = P(4)
		E = P(5)
		F = P(6)
	END IF

	PRINT 1, A,B,E
	PRINT 1, C,D,F
1	FORMAT(3(5X,F12.4))

	DO 10 I=1,900
	VL = V(1,I)
	VS = V(2,I)
	V(1,I) = A*VL + B*VS + E
10	V(2,I) = C*VL + D*VS + F

	CALL XVUNIT(IO,'OUT',1,IST,' ')
	CALL XVOPEN(IO,IST,'OP','WRITE',' ')
	CALL XVWRIT(IO,V,IST,' ')
	CALL XVCLOSE(IO,IST,' ')

C	CALL PGRID(V,NR,NC,DUM,0)
	RETURN
	END