C
C     file poistg.f
C
      SUBROUTINE POISTG (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,IERROR,W)
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           A(M),  B(M),  C(M),  Y(IDIMY,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE LINEAR SYSTEM OF EQUATIONS
C                        FOR UNKNOWN X VALUES, WHERE I=1,2,...,M
C                        AND J=1,2,...,N
C
C                        A(I)*X(I-1,J) + B(I)*X(I,J) + C(I)*X(I+1,J)
C                        + X(I,J-1) - 2.*X(I,J) + X(I,J+1)
C                        = Y(I,J)
C
C                        THE INDICES I+1 AND I-1 ARE EVALUATED MODULO M,
C                        I.E. X(0,J) = X(M,J) AND X(M+1,J) = X(1,J), AND
C                        X(I,0) MAY BE EQUAL TO X(I,1) OR -X(I,1), AND
C                        X(I,N+1) MAY BE EQUAL TO X(I,N) OR -X(I,N),
C                        DEPENDING ON AN INPUT PARAMETER.
C
C USAGE                  CALL POISTG (NPEROD,N,MPEROD,M,A,B,C,IDIMY,Y,
C                                     IERROR,W)
C
C ARGUMENTS
C
C ON INPUT
C
C                        NPEROD
C                          INDICATES VALUES WHICH X(I,0) AND X(I,N+1)
C                          ARE ASSUMED TO HAVE.
C                          = 1 IF X(I,0) = -X(I,1) AND X(I,N+1) = -X(I,N
C                          = 2 IF X(I,0) = -X(I,1) AND X(I,N+1) =  X(I,N
C                          = 3 IF X(I,0) =  X(I,1) AND X(I,N+1) =  X(I,N
C                          = 4 IF X(I,0) =  X(I,1) AND X(I,N+1) = -X(I,N
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.
C                          N MUST BE GREATER THAN 2.
C
C                        MPEROD
C                          = 0 IF A(1) AND C(M) ARE NOT ZERO
C                          = 1 IF A(1) = C(M) = 0
C
C                        M
C                          THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.
C                          M MUST BE GREATER THAN 2.
C
C                        A,B,C
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH M THAT
C                          SPECIFY THE COEFFICIENTS IN THE LINEAR
C                          EQUATIONS GIVEN ABOVE.  IF MPEROD = 0 THE
C                          ARRAY ELEMENTS MUST NOT DEPEND ON INDEX I,
C                          BUT MUST BE CONSTANT.  SPECIFICALLY, THE
C                          SUBROUTINE CHECKS THE FOLLOWING CONDITION
C                            A(I) = C(1)
C                            B(I) = B(1)
C                            C(I) = C(1)
C                          FOR I = 1, 2, ..., M.
C
C                        IDIMY
C                          THE ROW (OR FIRST) DIMENSION OF THE TWO-
C                          DIMENSIONAL ARRAY Y AS IT APPEARS IN THE
C                          PROGRAM CALLING POISTG.  THIS PARAMETER IS
C                          USED TO SPECIFY THE VARIABLE DIMENSION OF Y.
C                          IDIMY MUST BE AT LEAST M.
C
C                        Y
C                          A TWO-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT SIDE OF THE LINEAR SYSTEM
C                          OF EQUATIONS GIVEN ABOVE.
C                          Y MUST BE DIMENSIONED AT LEAST M X N.
C
C                        W
C                          A ONE-DIMENSIONAL WORK ARRAY THAT MUST BE
C                          PROVIDED BY THE USER FOR WORK SPACE.  W MAY
C                          REQUIRE UP TO 9M + 4N + M(INT(LOG2(N)))
C                          LOCATIONS.  THE ACTUAL NUMBER OF LOCATIONS
C                          USED IS COMPUTED BY POISTG AND RETURNED IN
C                          LOCATION W(1).
C
C ON OUTPUT
C
C                        Y
C                          CONTAINS THE SOLUTION X.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBER ZERO, A
C                          SOLUTION IS NOT ATTEMPTED.
C                          = 0  NO ERROR
C                          = 1  IF M .LE. 2
C                          = 2  IF N .LE. 2
C                          = 3  IDIMY .LT. M
C                          = 4  IF NPEROD .LT. 1 OR NPEROD .GT. 4
C                          = 5  IF MPEROD .LT. 0 OR MPEROD .GT. 1
C                          = 6  IF MPEROD = 0 AND A(I) .NE. C(1)
C                               OR B(I) .NE. B(1) OR C(I) .NE. C(1)
C                               FOR SOME I = 1, 2, ..., M.
C                          = 7  IF MPEROD .EQ. 1 .AND.
C                               (A(1).NE.0 .OR. C(M).NE.0)
C
C                        W
C                          W(1) CONTAINS THE REQUIRED LENGTH OF W.
C
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       GNBNAUX AND COMF FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY, 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE IS AN IMPLEMENTATION OF THE
C                        ALGORITHM PRESENTED IN THE REFERENCE BELOW.
C
C TIMING                 FOR LARGE M AND N, THE EXECUTION TIME IS
C                        ROUGHLY PROPORTIONAL TO M*N*LOG2(N).
C
C ACCURACY               TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                        UNIFORM RANDOM NUMBER GENERATOR WAS USED TO
C                        CREATE A SOLUTION ARRAY X FOR THE SYSTEM GIVEN
C                        IN THE 'PURPOSE' SECTION ABOVE, WITH
C                          A(I) = C(I) = -0.5*B(I) = 1,    I=1,2,...,M
C                        AND, WHEN MPEROD = 1
C                          A(1) = C(M) = 0
C                          B(1) = B(M) =-1.
C
C                        THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN
C                        SYSTEM AND, USING DOUBLE PRECISION, A RIGHT SID
C                        Y WAS COMPUTED.  USING THIS ARRAY Y SUBROUTINE
C                        POISTG WAS CALLED TO PRODUCE AN APPROXIMATE
C                        SOLUTION Z.  THEN THE RELATIVE ERROR, DEFINED A
C                          E = MAX(ABS(Z(I,J)-X(I,J)))/MAX(ABS(X(I,J)))
C                        WHERE THE TWO MAXIMA ARE TAKEN OVER I=1,2,...,M
C                        AND J=1,2,...,N, WAS COMPUTED.  VALUES OF E ARE
C                        GIVEN IN THE TABLE BELOW FOR SOME TYPICAL VALUE
C                        OF M AND N.
C
C                        M (=N)    MPEROD    NPEROD      E
C                        ------    ------    ------    ------
C
C                          31        0-1       1-4     9.E-13
C                          31        1         1       4.E-13
C                          31        1         3       3.E-13
C                          32        0-1       1-4     3.E-12
C                          32        1         1       3.E-13
C                          32        1         3       1.E-13
C                          33        0-1       1-4     1.E-12
C                          33        1         1       4.E-13
C                          33        1         3       1.E-13
C                          63        0-1       1-4     3.E-12
C                          63        1         1       1.E-12
C                          63        1         3       2.E-13
C                          64        0-1       1-4     4.E-12
C                          64        1         1       1.E-12
C                          64        1         3       6.E-13
C                          65        0-1       1-4     2.E-13
C                          65        1         1       1.E-11
C                          65        1         3       4.E-13
C
C REFERENCES             SCHUMANN, U. AND R. SWEET,"A DIRECT METHOD
C                        FOR THE SOLUTION OF POISSON"S EQUATION WITH
C                        NEUMANN BOUNDARY CONDITIONS ON A STAGGERED
C                        GRID OF ARBITRARY SIZE," J. COMP. PHYS.
C                        20(1976), PP. 171-182.
C *********************************************************************
      DIMENSION       Y(IDIMY,1)
      DIMENSION       W(*)       ,B(*)       ,A(*)       ,C(*)
C
      IERROR = 0
      IF (M .LE. 2) IERROR = 1
      IF (N .LE. 2) IERROR = 2
      IF (IDIMY .LT. M) IERROR = 3
      IF (NPEROD.LT.1 .OR. NPEROD.GT.4) IERROR = 4
      IF (MPEROD.LT.0 .OR. MPEROD.GT.1) IERROR = 5
      IF (MPEROD .EQ. 1) GO TO 103
      DO 101 I=1,M
         IF (A(I) .NE. C(1)) GO TO 102
         IF (C(I) .NE. C(1)) GO TO 102
         IF (B(I) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 6
      RETURN
  103 IF (A(1).NE.0. .OR. C(M).NE.0.) IERROR = 7
  104 IF (IERROR .NE. 0) RETURN
      IWBA = M+1
      IWBB = IWBA+M
      IWBC = IWBB+M
      IWB2 = IWBC+M
      IWB3 = IWB2+M
      IWW1 = IWB3+M
      IWW2 = IWW1+M
      IWW3 = IWW2+M
      IWD = IWW3+M
      IWTCOS = IWD+M
      IWP = IWTCOS+4*N
      DO 106 I=1,M
         K = IWBA+I-1
         W(K) = -A(I)
         K = IWBC+I-1
         W(K) = -C(I)
         K = IWBB+I-1
         W(K) = 2.-B(I)
         DO 105 J=1,N
            Y(I,J) = -Y(I,J)
  105    CONTINUE
  106 CONTINUE
      NP = NPEROD
      MP = MPEROD+1
      GO TO (110,107),MP
  107 CONTINUE
      GO TO (108,108,108,119),NPEROD
  108 CONTINUE
      CALL POSTG2 (NP,N,M,W(IWBA),W(IWBB),W(IWBC),IDIMY,Y,W,W(IWB2),
     1             W(IWB3),W(IWW1),W(IWW2),W(IWW3),W(IWD),W(IWTCOS),
     2             W(IWP))
      IPSTOR = W(IWW1)
      IREV = 2
      IF (NPEROD .EQ. 4) GO TO 120
  109 CONTINUE
      GO TO (123,129),MP
  110 CONTINUE
C
C     REORDER UNKNOWNS WHEN MP =0
C
      MH = (M+1)/2
      MHM1 = MH-1
      MODD = 1
      IF (MH*2 .EQ. M) MODD = 2
      DO 115 J=1,N
         DO 111 I=1,MHM1
            MHPI = MH+I
            MHMI = MH-I
            W(I) = Y(MHMI,J)-Y(MHPI,J)
            W(MHPI) = Y(MHMI,J)+Y(MHPI,J)
  111    CONTINUE
         W(MH) = 2.*Y(MH,J)
         GO TO (113,112),MODD
  112    W(M) = 2.*Y(M,J)
  113    CONTINUE
         DO 114 I=1,M
            Y(I,J) = W(I)
  114    CONTINUE
  115 CONTINUE
      K = IWBC+MHM1-1
      I = IWBA+MHM1
      W(K) = 0.
      W(I) = 0.
      W(K+1) = 2.*W(K+1)
      GO TO (116,117),MODD
  116 CONTINUE
      K = IWBB+MHM1-1
      W(K) = W(K)-W(I-1)
      W(IWBC-1) = W(IWBC-1)+W(IWBB-1)
      GO TO 118
  117 W(IWBB-1) = W(K+1)
  118 CONTINUE
      GO TO 107
  119 CONTINUE
C
C     REVERSE COLUMNS WHEN NPEROD = 4.
C
      IREV = 1
      NBY2 = N/2
      NP = 2
  120 DO 122 J=1,NBY2
         MSKIP = N+1-J
         DO 121 I=1,M
            A1 = Y(I,J)
            Y(I,J) = Y(I,MSKIP)
            Y(I,MSKIP) = A1
  121    CONTINUE
  122 CONTINUE
      GO TO (108,109),IREV
  123 CONTINUE
      DO 128 J=1,N
         DO 124 I=1,MHM1
            MHMI = MH-I
            MHPI = MH+I
            W(MHMI) = .5*(Y(MHPI,J)+Y(I,J))
            W(MHPI) = .5*(Y(MHPI,J)-Y(I,J))
  124    CONTINUE
         W(MH) = .5*Y(MH,J)
         GO TO (126,125),MODD
  125    W(M) = .5*Y(M,J)
  126    CONTINUE
         DO 127 I=1,M
            Y(I,J) = W(I)
  127    CONTINUE
  128 CONTINUE
  129 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR W ARRAY.
C
      W(1) = IPSTOR+IWP-1
      RETURN
      END
      SUBROUTINE POSTG2 (NPEROD,N,M,A,BB,C,IDIMQ,Q,B,B2,B3,W,W2,W3,D,
     1                   TCOS,P)
C
C     SUBROUTINE TO SOLVE POISSON'S EQUATION ON A STAGGERED GRID.
C
C
      DIMENSION       A(*)       ,BB(*)      ,C(*)       ,Q(IDIMQ,*) ,
     1                B(*)       ,B2(*)      ,B3(*)      ,W(*)       ,
     2                W2(*)      ,W3(*)      ,D(*)       ,TCOS(*)    ,
     3                K(4)       ,P(*)
      EQUIVALENCE     (K(1),K1)  ,(K(2),K2)  ,(K(3),K3)  ,(K(4),K4)
      NP = NPEROD
      FNUM = 0.5*FLOAT(NP/3)
      FNUM2 = 0.5*FLOAT(NP/2)
      MR = M
      IP = -MR
      IPSTOR = 0
      I2R = 1
      JR = 2
      NR = N
      NLAST = N
      KR = 1
      LR = 0
      IF (NR .LE. 3) GO TO 142
  101 CONTINUE
      JR = 2*I2R
      NROD = 1
      IF ((NR/2)*2 .EQ. NR) NROD = 0
      JSTART = 1
      JSTOP = NLAST-JR
      IF (NROD .EQ. 0) JSTOP = JSTOP-I2R
      I2RBY2 = I2R/2
      IF (JSTOP .GE. JSTART) GO TO 102
      J = JR
      GO TO 115
  102 CONTINUE
C
C     REGULAR REDUCTION.
C
      IJUMP = 1
      DO 114 J=JSTART,JSTOP,JR
         JP1 = J+I2RBY2
         JP2 = J+I2R
         JP3 = JP2+I2RBY2
         JM1 = J-I2RBY2
         JM2 = J-I2R
         JM3 = JM2-I2RBY2
         IF (J .NE. 1) GO TO 106
         CALL COSGEN (I2R,1,FNUM,0.5,TCOS)
         IF (I2R .NE. 1) GO TO 104
         DO 103 I=1,MR
            B(I) = Q(I,1)
            Q(I,1) = Q(I,2)
  103    CONTINUE
         GO TO 112
  104    DO 105 I=1,MR
            B(I) = Q(I,1)+0.5*(Q(I,JP2)-Q(I,JP1)-Q(I,JP3))
            Q(I,1) = Q(I,JP2)+Q(I,1)-Q(I,JP1)
  105    CONTINUE
         GO TO 112
  106    CONTINUE
         GO TO (107,108),IJUMP
  107    CONTINUE
         IJUMP = 2
         CALL COSGEN (I2R,1,0.5,0.0,TCOS)
  108    CONTINUE
         IF (I2R .NE. 1) GO TO 110
         DO 109 I=1,MR
            B(I) = 2.*Q(I,J)
            Q(I,J) = Q(I,JM2)+Q(I,JP2)
  109    CONTINUE
         GO TO 112
  110    DO 111 I=1,MR
            FI = Q(I,J)
            Q(I,J) = Q(I,J)-Q(I,JM1)-Q(I,JP1)+Q(I,JM2)+Q(I,JP2)
            B(I) = FI+Q(I,J)-Q(I,JM3)-Q(I,JP3)
  111    CONTINUE
  112    CONTINUE
         CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
         DO 113 I=1,MR
            Q(I,J) = Q(I,J)+B(I)
  113    CONTINUE
C
C     END OF REDUCTION FOR REGULAR UNKNOWNS.
C
  114 CONTINUE
C
C     BEGIN SPECIAL REDUCTION FOR LAST UNKNOWN.
C
      J = JSTOP+JR
  115 NLAST = J
      JM1 = J-I2RBY2
      JM2 = J-I2R
      JM3 = JM2-I2RBY2
      IF (NROD .EQ. 0) GO TO 125
C
C     ODD NUMBER OF UNKNOWNS
C
      IF (I2R .NE. 1) GO TO 117
      DO 116 I=1,MR
         B(I) = Q(I,J)
         Q(I,J) = Q(I,JM2)
  116 CONTINUE
      GO TO 123
  117 DO 118 I=1,MR
         B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  118 CONTINUE
      IF (NRODPR .NE. 0) GO TO 120
      DO 119 I=1,MR
         II = IP+I
         Q(I,J) = Q(I,JM2)+P(II)
  119 CONTINUE
      IP = IP-MR
      GO TO 122
  120 CONTINUE
      DO 121 I=1,MR
         Q(I,J) = Q(I,J)-Q(I,JM1)+Q(I,JM2)
  121 CONTINUE
  122 IF (LR .EQ. 0) GO TO 123
      CALL COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1))
  123 CONTINUE
      CALL COSGEN (KR,1,FNUM2,0.5,TCOS)
      CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
      DO 124 I=1,MR
         Q(I,J) = Q(I,J)+B(I)
  124 CONTINUE
      KR = KR+I2R
      GO TO 141
  125 CONTINUE
C
C     EVEN NUMBER OF UNKNOWNS
C
      JP1 = J+I2RBY2
      JP2 = J+I2R
      IF (I2R .NE. 1) GO TO 129
      DO 126 I=1,MR
         B(I) = Q(I,J)
  126 CONTINUE
      TCOS(1) = 0.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      IP = 0
      IPSTOR = MR
      DO 127 I=1,MR
         P(I) = B(I)
         B(I) = B(I)+Q(I,N)
  127 CONTINUE
      TCOS(1) = -1.+2.*FLOAT(NP/2)
      TCOS(2) = 0.
      CALL TRIX (1,1,MR,A,BB,C,B,TCOS,D,W)
      DO 128 I=1,MR
         Q(I,J) = Q(I,JM2)+P(I)+B(I)
  128 CONTINUE
      GO TO 140
  129 CONTINUE
      DO 130 I=1,MR
         B(I) = Q(I,J)+.5*(Q(I,JM2)-Q(I,JM1)-Q(I,JM3))
  130 CONTINUE
      IF (NRODPR .NE. 0) GO TO 132
      DO 131 I=1,MR
         II = IP+I
         B(I) = B(I)+P(II)
  131 CONTINUE
      GO TO 134
  132 CONTINUE
      DO 133 I=1,MR
         B(I) = B(I)+Q(I,JP2)-Q(I,JP1)
  133 CONTINUE
  134 CONTINUE
      CALL COSGEN (I2R,1,0.5,0.0,TCOS)
      CALL TRIX (I2R,0,MR,A,BB,C,B,TCOS,D,W)
      IP = IP+MR
      IPSTOR = MAX0(IPSTOR,IP+MR)
      DO 135 I=1,MR
         II = IP+I
         P(II) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
         B(I) = P(II)+Q(I,JP2)
  135 CONTINUE
      IF (LR .EQ. 0) GO TO 136
      CALL COSGEN (LR,1,FNUM2,0.5,TCOS(I2R+1))
      CALL MERGE (TCOS,0,I2R,I2R,LR,KR)
      GO TO 138
  136 DO 137 I=1,I2R
         II = KR+I
         TCOS(II) = TCOS(I)
  137 CONTINUE
  138 CALL COSGEN (KR,1,FNUM2,0.5,TCOS)
      CALL TRIX (KR,KR,MR,A,BB,C,B,TCOS,D,W)
      DO 139 I=1,MR
         II = IP+I
         Q(I,J) = Q(I,JM2)+P(II)+B(I)
  139 CONTINUE
  140 CONTINUE
      LR = KR
      KR = KR+JR
  141 CONTINUE
      NR = (NLAST-1)/JR+1
      IF (NR .LE. 3) GO TO 142
      I2R = JR
      NRODPR = NROD
      GO TO 101
  142 CONTINUE
C
C      BEGIN SOLUTION
C
      J = 1+JR
      JM1 = J-I2R
      JP1 = J+I2R
      JM2 = NLAST-I2R
      IF (NR .EQ. 2) GO TO 180
      IF (LR .NE. 0) GO TO 167
      IF (N .NE. 3) GO TO 156
C
C     CASE N = 3.
C
      GO TO (143,148,143),NP
  143 DO 144 I=1,MR
         B(I) = Q(I,2)
         B2(I) = Q(I,1)+Q(I,3)
         B3(I) = 0.
  144 CONTINUE
      GO TO (146,146,145),NP
  145 TCOS(1) = -1.
      TCOS(2) = 1.
      K1 = 1
      GO TO 147
  146 TCOS(1) = -2.
      TCOS(2) = 1.
      TCOS(3) = -1.
      K1 = 2
  147 K2 = 1
      K3 = 0
      K4 = 0
      GO TO 150
  148 DO 149 I=1,MR
         B(I) = Q(I,2)
         B2(I) = Q(I,3)
         B3(I) = Q(I,1)
  149 CONTINUE
      CALL COSGEN (3,1,0.5,0.0,TCOS)
      TCOS(4) = -1.
      TCOS(5) = 1.
      TCOS(6) = -1.
      TCOS(7) = 1.
      K1 = 3
      K2 = 2
      K3 = 1
      K4 = 1
  150 CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 151 I=1,MR
         B(I) = B(I)+B2(I)+B3(I)
  151 CONTINUE
      GO TO (153,153,152),NP
  152 TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
  153 DO 154 I=1,MR
         Q(I,2) = B(I)
         B(I) = Q(I,1)+B(I)
  154 CONTINUE
      TCOS(1) = -1.+4.*FNUM
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
      DO 155 I=1,MR
         Q(I,1) = B(I)
  155 CONTINUE
      JR = 1
      I2R = 0
      GO TO 188
C
C     CASE N = 2**P+1
C
  156 CONTINUE
      DO 157 I=1,MR
         B(I) = Q(I,J)+Q(I,1)-Q(I,JM1)+Q(I,NLAST)-Q(I,JM2)
  157 CONTINUE
      GO TO (158,160,158),NP
  158 DO 159 I=1,MR
         B2(I) = Q(I,1)+Q(I,NLAST)+Q(I,J)-Q(I,JM1)-Q(I,JP1)
         B3(I) = 0.
  159 CONTINUE
      K1 = NLAST-1
      K2 = NLAST+JR-1
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(NLAST))
      TCOS(K2) = 2.*FLOAT(NP-2)
      CALL COSGEN (JR,1,0.5-FNUM,0.5,TCOS(K2+1))
      K3 = (3-NP)/2
      CALL MERGE (TCOS,K1,JR-K3,K2-K3,JR+K3,0)
      K1 = K1-1+K3
      CALL COSGEN (JR,1,FNUM,0.5,TCOS(K1+1))
      K2 = JR
      K3 = 0
      K4 = 0
      GO TO 162
  160 DO 161 I=1,MR
         FI = (Q(I,J)-Q(I,JM1)-Q(I,JP1))/2.
         B2(I) = Q(I,1)+FI
         B3(I) = Q(I,NLAST)+FI
  161 CONTINUE
      K1 = NLAST+JR-1
      K2 = K1+JR-1
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1))
      CALL COSGEN (NLAST,1,0.5,0.0,TCOS(K2+1))
      CALL MERGE (TCOS,K1,JR-1,K2,NLAST,0)
      K3 = K1+NLAST-1
      K4 = K3+JR
      CALL COSGEN (JR,1,0.5,0.5,TCOS(K3+1))
      CALL COSGEN (JR,1,0.0,0.5,TCOS(K4+1))
      CALL MERGE (TCOS,K3,JR,K4,JR,K1)
      K2 = NLAST-1
      K3 = JR
      K4 = JR
  162 CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 163 I=1,MR
         B(I) = B(I)+B2(I)+B3(I)
  163 CONTINUE
      IF (NP .NE. 3) GO TO 164
      TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
  164 DO 165 I=1,MR
         Q(I,J) = B(I)+.5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
         B(I) = Q(I,J)+Q(I,1)
  165 CONTINUE
      CALL COSGEN (JR,1,FNUM,0.5,TCOS)
      CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
      DO 166 I=1,MR
         Q(I,1) = Q(I,1)-Q(I,JM1)+B(I)
  166 CONTINUE
      GO TO 188
C
C     CASE OF GENERAL N WITH NR = 3 .
C
  167 CONTINUE
      DO 168 I=1,MR
         B(I) = Q(I,1)-Q(I,JM1)+Q(I,J)
  168 CONTINUE
      IF (NROD .NE. 0) GO TO 170
      DO 169 I=1,MR
         II = IP+I
         B(I) = B(I)+P(II)
  169 CONTINUE
      GO TO 172
  170 DO 171 I=1,MR
         B(I) = B(I)+Q(I,NLAST)-Q(I,JM2)
  171 CONTINUE
  172 CONTINUE
      DO 173 I=1,MR
         T = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
         Q(I,J) = T
         B2(I) = Q(I,NLAST)+T
         B3(I) = Q(I,1)+T
  173 CONTINUE
      K1 = KR+2*JR
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1))
      K2 = K1+JR
      TCOS(K2) = 2.*FLOAT(NP-2)
      K4 = (NP-1)*(3-NP)
      K3 = K2+1-K4
      CALL COSGEN (KR+JR+K4,1,FLOAT(K4)/2.,1.-FLOAT(K4),TCOS(K3))
      K4 = 1-NP/3
      CALL MERGE (TCOS,K1,JR-K4,K2-K4,KR+JR+K4,0)
      IF (NP .EQ. 3) K1 = K1-1
      K2 = KR+JR
      K4 = K1+K2
      CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K4+1))
      K3 = K4+KR
      CALL COSGEN (JR,1,FNUM,0.5,TCOS(K3+1))
      CALL MERGE (TCOS,K4,KR,K3,JR,K1)
      K4 = K3+JR
      CALL COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1))
      CALL MERGE (TCOS,K3,JR,K4,LR,K1+K2)
      CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K3+1))
      K3 = KR
      K4 = KR
      CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 174 I=1,MR
         B(I) = B(I)+B2(I)+B3(I)
  174 CONTINUE
      IF (NP .NE. 3) GO TO 175
      TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
  175 DO 176 I=1,MR
         Q(I,J) = Q(I,J)+B(I)
         B(I) = Q(I,1)+Q(I,J)
  176 CONTINUE
      CALL COSGEN (JR,1,FNUM,0.5,TCOS)
      CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
      IF (JR .NE. 1) GO TO 178
      DO 177 I=1,MR
         Q(I,1) = B(I)
  177 CONTINUE
      GO TO 188
  178 CONTINUE
      DO 179 I=1,MR
         Q(I,1) = Q(I,1)-Q(I,JM1)+B(I)
  179 CONTINUE
      GO TO 188
  180 CONTINUE
C
C     CASE OF GENERAL N AND NR = 2 .
C
      DO 181 I=1,MR
         II = IP+I
         B3(I) = 0.
         B(I) = Q(I,1)+P(II)
         Q(I,1) = Q(I,1)-Q(I,JM1)
         B2(I) = Q(I,1)+Q(I,NLAST)
  181 CONTINUE
      K1 = KR+JR
      K2 = K1+JR
      CALL COSGEN (JR-1,1,0.0,1.0,TCOS(K1+1))
      GO TO (182,183,182),NP
  182 TCOS(K2) = 2.*FLOAT(NP-2)
      CALL COSGEN (KR,1,0.0,1.0,TCOS(K2+1))
      GO TO 184
  183 CALL COSGEN (KR+1,1,0.5,0.0,TCOS(K2))
  184 K4 = 1-NP/3
      CALL MERGE (TCOS,K1,JR-K4,K2-K4,KR+K4,0)
      IF (NP .EQ. 3) K1 = K1-1
      K2 = KR
      CALL COSGEN (KR,1,FNUM2,0.5,TCOS(K1+1))
      K4 = K1+KR
      CALL COSGEN (LR,1,FNUM2,0.5,TCOS(K4+1))
      K3 = LR
      K4 = 0
      CALL TRI3 (MR,A,BB,C,K,B,B2,B3,TCOS,D,W,W2,W3)
      DO 185 I=1,MR
         B(I) = B(I)+B2(I)
  185 CONTINUE
      IF (NP .NE. 3) GO TO 186
      TCOS(1) = 2.
      CALL TRIX (1,0,MR,A,BB,C,B,TCOS,D,W)
  186 DO 187 I=1,MR
         Q(I,1) = Q(I,1)+B(I)
  187 CONTINUE
  188 CONTINUE
C
C     START BACK SUBSTITUTION.
C
      J = NLAST-JR
      DO 189 I=1,MR
         B(I) = Q(I,NLAST)+Q(I,J)
  189 CONTINUE
      JM2 = NLAST-I2R
      IF (JR .NE. 1) GO TO 191
      DO 190 I=1,MR
         Q(I,NLAST) = 0.
  190 CONTINUE
      GO TO 195
  191 CONTINUE
      IF (NROD .NE. 0) GO TO 193
      DO 192 I=1,MR
         II = IP+I
         Q(I,NLAST) = P(II)
  192 CONTINUE
      IP = IP-MR
      GO TO 195
  193 DO 194 I=1,MR
         Q(I,NLAST) = Q(I,NLAST)-Q(I,JM2)
  194 CONTINUE
  195 CONTINUE
      CALL COSGEN (KR,1,FNUM2,0.5,TCOS)
      CALL COSGEN (LR,1,FNUM2,0.5,TCOS(KR+1))
      CALL TRIX (KR,LR,MR,A,BB,C,B,TCOS,D,W)
      DO 196 I=1,MR
         Q(I,NLAST) = Q(I,NLAST)+B(I)
  196 CONTINUE
      NLASTP = NLAST
  197 CONTINUE
      JSTEP = JR
      JR = I2R
      I2R = I2R/2
      IF (JR .EQ. 0) GO TO 210
      JSTART = 1+JR
      KR = KR-JR
      IF (NLAST+JR .GT. N) GO TO 198
      KR = KR-JR
      NLAST = NLAST+JR
      JSTOP = NLAST-JSTEP
      GO TO 199
  198 CONTINUE
      JSTOP = NLAST-JR
  199 CONTINUE
      LR = KR-JR
      CALL COSGEN (JR,1,0.5,0.0,TCOS)
      DO 209 J=JSTART,JSTOP,JSTEP
         JM2 = J-JR
         JP2 = J+JR
         IF (J .NE. JR) GO TO 201
         DO 200 I=1,MR
            B(I) = Q(I,J)+Q(I,JP2)
  200    CONTINUE
         GO TO 203
  201    CONTINUE
         DO 202 I=1,MR
            B(I) = Q(I,J)+Q(I,JM2)+Q(I,JP2)
  202    CONTINUE
  203    CONTINUE
         IF (JR .NE. 1) GO TO 205
         DO 204 I=1,MR
            Q(I,J) = 0.
  204    CONTINUE
         GO TO 207
  205    CONTINUE
         JM1 = J-I2R
         JP1 = J+I2R
         DO 206 I=1,MR
            Q(I,J) = .5*(Q(I,J)-Q(I,JM1)-Q(I,JP1))
  206    CONTINUE
  207    CONTINUE
         CALL TRIX (JR,0,MR,A,BB,C,B,TCOS,D,W)
         DO 208 I=1,MR
            Q(I,J) = Q(I,J)+B(I)
  208    CONTINUE
  209 CONTINUE
      NROD = 1
      IF (NLAST+I2R .LE. N) NROD = 0
      IF (NLASTP .NE. NLAST) GO TO 188
      GO TO 197
  210 CONTINUE
C
C     RETURN STORAGE REQUIREMENTS FOR P VECTORS.
C
      W(1) = IPSTOR
      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


	FUNCTION PR_HGMD  ( hght )
C************************************************************************
C* PR_HGMD								*
C*									*
C* This function computes HGTD from HGHT.  The following equation is	*
C* used:								*
C*									*
C*                     HGTD = HGHT / 10.				*
C*									*
C* REAL PR_HGMD  ( HGHT )						*
C*									*
C* Input parameters:							*
C*	HGHT		REAL		Height in meters		*
C*									*
C* Output parameters:							*
C*	PR_HGMD		REAL		Height in decameters		*
C**									*
C* Log:									*
C* I. Graffman/RDS	11/84   Original source				*
C* M. Goodman/RDS  	3/86	Corrected division error		*
C* G. Huffman/GSC	7/88	Documentation				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for invalid height.
C
	IF  ( ERMISS (hght) )  THEN
	    PR_HGMD = RMISSD
	  ELSE
	    PR_HGMD = hght / 10.
	END IF
C*
	RETURN
	END


! This program uses the bisection algorithm to find a root
program bisect
implicit none
real a,b,p,f
integer i,imax
a=0.
b=3.
imax=20
if (f(a)*f(b) .gt. 0.) then
  write(*,*) 'root not bracketed'
  stop
endif
do i=1,imax
  p=(b+a)/2.
  if (f(a)*f(p) .lt. 0.) then
    b=p
  else
    a=p
  endif
  write(*,*) i,p,f(p)
  write(8,*) i,abs(p-1.)
enddo
stop
end program bisect

function f(x)
implicit none
real x,f
f=x**5-1.
return
end function f


module bar

  use Structure
  use Matrix_op
  use Gauss

  implicit none

  type :: Space_op

    double precision, dimension(:,:), allocatable :: gauss_s ! points and weight matrix.
    double precision, dimension(:,:), allocatable :: IntS
    double precision, dimension(:,:), allocatable :: B,Bw
    double precision, dimension(:,:), allocatable :: Be,Bwe

    double precision, dimension(:,:), allocatable :: He
    integer, dimension(:,:), allocatable :: gps
    integer, dimension(:,:), allocatable :: Idvs
    integer, dimension(:), allocatable :: dof_imposed
    integer, dimension(:), allocatable :: dof_free
    double precision, dimension(:,:), allocatable :: Melm,Kelm
    integer :: comp = 1

  end type Space_op

  type(Space_op) :: Sop

  contains

  subroutine Space_elm_matrices(I)

    type(Input), intent(inout) :: I
    integer :: iter,igp,ind
    integer, dimension(1,I%Nx) :: v1,v2
    double precision, dimension(I%ngps,1) :: waux
    double precision, dimension(I%ngps) :: x
    double precision, dimension(I%Nsfs,I%ngps) :: lx,dlx
    double precision, dimension(I%ngps,I%Nsfs) :: laux,dlaux
    double precision, dimension(I%Tngps,I%n) :: Bw

    ! real, dimension(I%ne,1) :: Felm

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    !! Vector that integrate any function in the space interval Ix=[0,I.L];

    ! Uni_dimensional case
    allocate(Sop%IntS(I%Tngps,1))
    Sop%gauss_s = gauss_points_weights(I%ngps)
    do igp=1,I%ngps
        waux(igp,1)=(I%dx/2)*Sop%gauss_s(igp,2)
    end do
    !print*, "SHAPE VALUE WAUX:" , shape(waux)

    !print*, "HASTA ACA:", shape(Sop%IntS)
    !print*, I%Nx, I%dx
    !call show(waux)

    Sop%IntS=kron(ones(I%Nx,1),waux)
    !call show(ones(I%Nx,1))
    !print*, "NEPE"
    !call show(Sop%IntS)

    ! Identification matrix in space:
    Sop%Idvs = vertcat( incr(1,I%Nx), incr(2,I%Nx+1) )
    !I.Idvs = vertcat(1:I.Nx,2:I.ns)

    !                       Linear shape functions in space:

    x = ( (I%dx/2)*Sop%gauss_s(:,1)+I%dx/2 )
    !xt = (x)
    lx = vertcat(1-x/I%dx,x/I%dx) ! No derivative.
    dlx = repmat( reshape( (/-1/I%dx, 1/I%dx/), (/2,1/) ), (/1,I%ngps/) ) ! First derivative.

    !                       Linear shape functions in space:

    ! Calculation of the B operator ( eps = B*u):
    laux = transpose(lx)
    dlaux = transpose(dlx)
    allocate(Sop%B(I%Tngps,I%n))  != zeros(I.Ngps,I.ns);
    do iter = 1,I%Nx
        Sop%B( incr(1+(iter-1)*I%ngps,iter*I%ngps) , incr(iter,iter+1) ) = dlaux
    end do

    ! Rigidity matrix calculation:
    Sop%Bw = spread(Sop%IntS(:,1), 2, I%n )*Sop%B
    !I.K = (I%Hooke*I%A)*( matmul(transpose(Sop%B), Bw)

    ! Elemental operators:
    Sop%Be = dlaux
    Sop%Bwe = spread( waux(:,1), 2, I%Nsfs )*Sop%Be

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Elemental matrices assignation:

    allocate( Sop%Melm(2,2)  )
    allocate( Sop%Kelm(2,2)  )
    allocate( Sop%He(1,1) )

    Sop%He = I%Hooke   ! Elastic hooke tensor.
    Sop%Kelm = ( (I%Hooke*I%A)/I%dx )*reshape( (/ 1.0, -1.0, -1.0, 1.0/), (/ 2, 2 /) )  ! Elemental stiffness matrix.
    Sop%Melm = ((I%rho*I%A*I%dx)/6)*reshape( (/ 2.0, 1.0, 1.0, 2.0/), (/ 2, 2 /) )  ! Elemental mass matrix.

    ! Identification matrix in space:
    !allocate( Sop%Idvs(2,I%Nx) )
    !v1 = incr2(1,I%Nx) ; v2 = incr2(2,I%n)
    !Sop%Idvs = vertcat(v1, v2)

    ! Dofs fixed and imposed:

    allocate( Sop%dof_imposed(2)  )
    allocate( Sop%dof_free(I%ns)  )

    Sop%dof_imposed = (/1,I%n/)
    Sop%dof_free = incr(2,I%n-1)

    !I%ntc3 = 123 ! Assignation to the "I" structure.
    !print*, I%ntc3

  end subroutine Space_elm_matrices

end module bar


C  =====================================================================
C  pgm: DDGJC .. Get frm jul-dt, cal-dt (get mo, da)
C
C  use:     CALL DDGJC(J1,Y1,M1,D1)
C
C   in: J1 ...... day of year (001-366) - INT
C   in: Y1 ...... 4-digit year number - INT
C  out: M1 ...... month number (01-12) - INT
C  out: D1 ...... day number (01-31) - INT
C
C  lvl: DD1
C
C  cmt: Alternate algorithm:      M1T = (J1T*9 + 269)/275
C  cmt:                           D1T = J1T - (M1T*275)/9 + 30
C  =====================================================================
      SUBROUTINE DDGJC(J1,Y1,M1,D1)

      INTEGER    J1,Y1,M1,D1,II,J1T,Y1T,M1T,D1T
C
C    ================================= RCS keyword statements ==========
      CHARACTER*68     RCSKW1,RCSKW2
      DATA             RCSKW1,RCSKW2 /                                 '
     .$Source: /fs/hsmb5/hydro/CVS_root/gorms/snow17/ddgjc.f,v $
     . $',                                                             '
     .$Id: ddgjc.f,v 3.0 2009-12-30 16:49:06 zcui Exp $
     . $' /
C    ===================================================================
C

        J1T = J1
        Y1T = Y1

        II = 2
        IF (         Y1T.EQ.(Y1T/4)*4
     $       .AND.   Y1T.NE.1800
     $       .AND.   Y1T.NE.1900
     $       .AND. ( Y1T.LT.2100 .OR. Y1T.EQ.(Y1T/400)*400
     $                           .OR. Y1T.NE.(Y1T/100)*100 )
     $     ) II = 1

        IF ( Y1T.EQ.1752 .AND. J1T.GT.246 ) J1T = J1T + 11

        IF ( J1T .GT. (61-II) ) J1T = J1T + II
        M1T = (J1T*67 + 2012)/2048
        D1T = J1T - (M1T*489)/16 + 30

        M1 = M1T
        D1 = D1T

      RETURN
      END


subroutine addCountxy(Count,NGrid,thisx,thisy,XX,YY,r_cutoff)
	implicit none
	integer, intent(in) :: NGrid
!f2p intent(in) ::  NGrid
	real(8), intent(inout), dimension(0:NGrid-1, 0:NGrid-1) :: Count, XX, YY
!f2p intent(in,out) :: Count, XX, YY
	real(8), intent(in) :: thisx, thisy, r_cutoff
!f2p intent(in) :: thisx, thisy, r_cutoff
	integer :: i,j,xndx(1),yndx(1)
	integer :: xlowndx, ylowndx, xhighndx, yhighndx
	real(8) :: dist, dx, dy
	real(8), dimension(0:NGrid-1) :: xvec, yvec

	dx = XX(0,1) - XX(0,0)  !assumes linspace used to generate spacing
	dy = YY(1,0) - YY(0,0)
	xvec = XX(0,:)
	yvec = YY(:,0)
	xndx = minloc(abs(xvec-thisx))
	yndx = minloc(abs(yvec-thisy))
	!write(*,*) xndx,yndx,thisx,thisy
	xlowndx = nint(xndx(1) - (r_cutoff / dx * 2.5))
	xhighndx = nint(xndx(1) + (r_cutoff / dx * 2.5))
	ylowndx = nint(yndx(1) - (r_cutoff / dy * 2.5))
	yhighndx = nint(yndx(1) + (r_cutoff / dy * 2.5))
	if (xlowndx < 0) xlowndx = 0
	if (ylowndx < 0) ylowndx = 0
	if (xhighndx > NGrid-1) xhighndx = NGrid - 1
	if (yhighndx > NGrid-1) yhighndx = Ngrid - 1
	do j = xlowndx, xhighndx
		do i = ylowndx, yhighndx
			dist = (thisx-XX(i,j))**2 + (thisy-YY(i,j))**2
			dist = sqrt(dist)
			if (dist .LT. r_cutoff) then
				Count(i,j) = Count(i,j) + 1
			end if
			!write(*,*) thisx,thisy, XX(i,j), YY(i,j), dist
		end do
	end do

end subroutine

subroutine addCountxz(Count,NGrid,thisx,thisz,XX,ZZ,r_cutoff)
	implicit none
	integer, intent(in) :: NGrid
!f2p intent(in) ::  NGrid
	real(8), intent(inout), dimension(0:NGrid-1, 0:NGrid-1) :: Count, XX, ZZ
!f2p intent(in,out) :: Count, XX, ZZ
	real(8), intent(in) :: thisx, thisz, r_cutoff
!f2p intent(in) :: thisx, thisz, r_cutoff
	integer :: i,j,xndx(1),zndx(1)
	integer :: xlowndx, zlowndx, xhighndx, zhighndx
	real(8) :: dist, dx, dz
	real(8), dimension(0:NGrid-1) :: xvec, zvec

	dx = XX(0,1) - XX(0,0)  !assumes linspace used to generate spacing
	dz = ZZ(1,0) - ZZ(0,0)
	xvec = XX(0,:)
	zvec = ZZ(:,0)
	xndx = minloc(abs(xvec-thisx))
	zndx = minloc(abs(zvec-thisz))
	!write(*,*) xndx,yndx,thisx,thisy
	xlowndx = nint(xndx(1) - (r_cutoff / dx * 2.5))
	xhighndx = nint(xndx(1) + (r_cutoff / dx * 2.5))
	zlowndx = nint(zndx(1) - (r_cutoff / dz * 2.5))
	zhighndx = nint(zndx(1) + (r_cutoff / dz * 2.5))
	if (xlowndx < 0) xlowndx = 0
	if (zlowndx < 0) zlowndx = 0
	if (xhighndx > NGrid-1) xhighndx = NGrid - 1
	if (zhighndx > NGrid-1) zhighndx = Ngrid - 1
	do j = xlowndx, xhighndx
		do i = zlowndx, zhighndx
			dist = (thisx-XX(i,j))**2 + (thisz-ZZ(i,j))**2
			dist = sqrt(dist)
			if (dist .LT. r_cutoff) then
				Count(i,j) = Count(i,j) + 1
			end if
			!write(*,*) thisx,thisy, XX(i,j), YY(i,j), dist
		end do
	end do

end subroutine

subroutine addCountyz(Count,NGrid,thisy,thisz,YY,ZZ,r_cutoff)
	implicit none
	integer, intent(in) :: NGrid
!f2p intent(in) ::  NGrid
	real(8), intent(inout), dimension(0:NGrid-1, 0:NGrid-1) :: Count, YY, ZZ
!f2p intent(in,out) :: Count, YY, ZZ
	real(8), intent(in) :: thisy, thisz, r_cutoff
!f2p intent(in) :: thisy, thisz, r_cutoff
	integer :: i,j,yndx(1),zndx(1)
	integer :: ylowndx, zlowndx, yhighndx, zhighndx
	real(8) :: dist, dy, dz
	real(8), dimension(0:NGrid-1) :: yvec, zvec

	dy = YY(0,1) - YY(0,0)  !assumes linspace used to generate spacing
	dz = ZZ(1,0) - ZZ(0,0)
	yvec = YY(0,:)
	zvec = ZZ(:,0)
	yndx = minloc(abs(yvec-thisy))
	zndx = minloc(abs(zvec-thisz))
	!write(*,*) yndx,zndx,thisy,thisz
	ylowndx = nint(yndx(1) - (r_cutoff / dy * 2.5))
	yhighndx = nint(yndx(1) + (r_cutoff / dy * 2.5))
	zlowndx = nint(zndx(1) - (r_cutoff / dz * 2.5))
	zhighndx = nint(zndx(1) + (r_cutoff / dz * 2.5))
	if (ylowndx < 0) ylowndx = 0
	if (zlowndx < 0) zlowndx = 0
	if (yhighndx > NGrid-1) yhighndx = NGrid - 1
	if (zhighndx > NGrid-1) zhighndx = Ngrid - 1
	do j = ylowndx, yhighndx
		do i = zlowndx, zhighndx
			dist = (thisy-YY(i,j))**2 + (thisz-ZZ(i,j))**2
			dist = sqrt(dist)
			if (dist .LT. r_cutoff) then
				Count(i,j) = Count(i,j) + 1
			end if
			!write(*,*) thisy,thisz, YY(i,j), ZZ(i,j), dist
		end do
	end do

end subroutine


!********************************************************************************
!   SPECIAL_POLY: Test FPML Compensated Polishing on Special Polynomials
!   Author: Thomas R. Cameron, Davidson College
!   Last Modified: 25 April 2018
!********************************************************************************
! The accuracy of FPML with compensated polishing routine is tested on several
! special polynomial.
!********************************************************************************
program special_poly
    use fpml, only : main
	use fpml_comp, only: main_comp
	use fpml_quad, only: qp, main_quad
    use mproutines
	implicit none
    ! testing variables
    integer                                     :: deg, j, poly_num
    complex(kind=dp), dimension(:), allocatable :: exact_roots
    ! FPML variables
    integer, parameter                          :: itmax = 30
    integer, allocatable                        :: conv(:)
    real(kind=dp), allocatable                  :: berr(:), cond(:)
	real(kind=qp), allocatable					:: berr_quad(:), cond_quad(:)
    complex(kind=dp), allocatable               :: p(:), roots(:)
	complex(kind=qp), allocatable				:: p_quad(:), roots_quad(:)

    ! Testing: special polynomials
    open(unit=1,file="data_files/special_poly.dat")
    write(1,'(A)') 'Poly No., FPML, FPML-Quad, FPML-Comp'
    do poly_num=1,35
        write(1, '(I10,A)', advance='no') poly_num, ', '
        ! make polynomial
        call make_poly(poly_num, deg, exact_roots, p)
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! FPML, No Polish
        call main(p, deg, roots, berr, cond, conv, itmax)
        write(1, '(ES15.2, A)', advance='no') max_rel_err(roots,exact_roots,deg), ', '
		! FPML, Quad
		p_quad = p
        call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
		roots = roots_quad
		write(1, '(ES15.2, A)', advance='no') max_rel_err(roots,exact_roots,deg), ', '
        ! FPML, Compensated Laguerre Polish
        call main_comp(p, deg, roots, itmax)
        write(1, '(ES15.2, A)') max_rel_err(roots,exact_roots,deg)
        ! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
    end do

    ! close file
    close(1)

contains
    !************************************************
    !                       make_poly               *
    !************************************************
    ! Make special polynomial corresponding to poly_num.
    !************************************************
    subroutine make_poly(poly_num, deg, exact_roots, p)
        implicit none
        ! argument variables
        integer, intent(in)                         :: poly_num
        integer, intent(out)                        :: deg
        complex(kind=dp), allocatable, intent(out)  :: exact_roots(:), p(:)
        ! local variables
        integer                                     :: j
        real(kind=dp), parameter                    :: pi = 3.141592653589793_dp

        select case (poly_num)
            case(1)
            ! Poly 1: Wilkinson deg 10
            deg = 10
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(j,0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(2)
            ! Poly 2: Wilkinson deg 15
            deg = 15
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(j,0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(3)
            ! Poly 3: Wilkinson deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(j,0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(4)
            ! Poly 4: scaled and shifted Wilkinson deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(dble(-21+2*(j-1))/10d0,0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(5)
            ! Poly 5: reverse Wilkinson deg 10
            deg = 10
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(1d0/dble(j),0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(6)
            ! Poly 6: reverse Wilkinson deg 15
            deg = 15
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(1d0/dble(j),0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(7)
            ! Poly 7: reverse Wilkinson deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(1d0/dble(j),0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(8)
            ! Poly 8: prescribed roots of varying scale deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(2d0**(-10+(j-1)),0,kind=dp), j=1,deg)/)
            ! polynomial
			p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(9)
            ! Poly 9: prescribed roots of varying scale -3 deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots = (/ (cmplx(2d0**(-10+(j-1))-3d0,0,kind=dp), j=1,deg)/)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(10)
            ! Poly 10: Chebyshev polynomial deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            p(1) = 1d0
            p(2) = 0d0
            p(3) = -200d0
            p(4) = 0d0
            p(5) = 6600d0
            p(6) = 0d0
            p(7) = -84480d0
            p(8) = 0d0
            p(9) = 549120d0
            p(10) = 0d0
            p(11) = -2050048d0
            p(12) = 0d0
            p(13) = 4659200d0
            p(14) = 0d0
            p(15) = -6553600d0
            p(16) = 0d0
            p(17) = 5570560d0
            p(18) = 0d0
            p(19) = -2621440d0
            p(20) = 0d0
            p(21) = 524288d0
            exact_roots = (/ (cmplx(cos((2.0_dp*j-1.0_dp)*pi/(2.0_dp*deg)),0,kind=dp), j=1,deg)/)
            case(11)
            ! Poly 11: z^i for i=0,20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            p = (/ (cmplx(1,0,kind=dp), j=1,deg+1)/)
            exact_roots = (/ (cmplx(cos(2*j*pi/21d0),sin(2*j*pi/21d0),kind=dp), j=1,deg)/)
            case(12)
            ! Poly 12: C. Traverso 24 MPSolve
            deg = 24
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(-3.52d2, 0d0, kind=dp)
            exact_roots(2) = cmplx(-3.52d2, 0d0, kind=dp)
            exact_roots(3) = cmplx(-2.8371450777d2, -2.9920517772d2, kind=dp)
            exact_roots(4) = cmplx(-2.8371450777d2,  2.9920517772d2, kind=dp)
            exact_roots(5) = cmplx(-2.7867414048d2,  6.1005469197d2, kind=dp)
            exact_roots(6) = cmplx(-2.7867414048d2, -6.1005469197d2, kind=dp)
            exact_roots(7) = cmplx(-2.74892372d2, 0d0, kind=dp)
            exact_roots(8) = cmplx(-2.014171531d2, 0d0, kind=dp)
            exact_roots(9) = cmplx(-1.255366582d2, 0d0, kind=dp)
            exact_roots(10) = cmplx(-9.599999999d1, 0d0, kind=dp)
            exact_roots(11) = cmplx(-8.8692435121d1,  5.5009607430d2, kind=dp)
            exact_roots(12) = cmplx(-8.869243512d1, -5.5009607430d2, kind=dp)
            exact_roots(13) = cmplx(-1.6000000000d1, 0d0, kind=dp)
            exact_roots(14) = cmplx(8.23178509855d1, 0d0, kind=dp)
            exact_roots(15) = cmplx(8.8692435121d1, -5.50096074303d2, kind=dp)
            exact_roots(16) = cmplx(8.8692435121d1,  5.5009607430d2, kind=dp)
            exact_roots(17) = cmplx(1.9293739373d2,  1.60865921259d3, kind=dp)
            exact_roots(18) = cmplx(1.929373937d2, -1.6086592125d3, kind=dp)
            exact_roots(19) = cmplx(2.0141715312d2, 0d0, kind=dp)
            exact_roots(20) = cmplx(2.7489237213d2, 0d0, kind=dp)
            exact_roots(21) = cmplx(7.52d2, 0d0, kind=dp)
            exact_roots(22) = cmplx(7.52d2, 0d0, kind=dp)
            exact_roots(23) = cmplx(9.1106065d2,  1.5722d0, kind=dp)
            exact_roots(24) = cmplx(9.1106065d2, -1.5722d0, kind=dp)
            ! polynomial
            p(1) = -54765291428198020791747503747742749163073958404455022926495744d0
            p(2) = -4052135566767965847649766745769409681058667331648450681896960d0
            p(3) = -31969984081155943263834965670035075493639295858977076674560d0
            p(4) = 575060225471570237690073740639182419333523437771848417280d0
            p(5) = 7337981286595499156409929740830030318565357725459415040d0
            p(6) = 6611223380089859336490797585290455483968982077145088d0
            p(7) = -195514288747757987122118583800597358656801082441728d0
            p(8) = -726907419403715013562762609680450059293446635520d0
            p(9) = 197178719520196724204974332265013056299335680d0
            p(10) = 5968852409133617129605588058090797893943296d0
            p(11) = 16576506891508825500182005531742679597056d0
            p(12) = 23375026506968330494765978581548924928d0
            p(13) = 2206941937668751746514177591607296d0
            p(14) = -75617855277818001758431020580864d0
            p(15) = -204797687173976372829472423936d0
            p(16) = -143150263927579584306872320d0
            p(17) =  20214880144364480233472d0
            p(18) =  453786251090072698880d0
            p(19) =  1265052493274939392d0
            p(20) = -968887355572224d0
            p(21) =  1015406084096d0
            p(22) = -3949133824d0
            p(23) =  3284992d0
            p(24) = -1728d0
            p(25) = 1d0
            case(13)
            ! Poly 13: Mandelbrot 31 MPSolve
            deg = 31
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(-1.996376137,0d0,kind=dp)
            exact_roots(2) = cmplx(-1.966773216,0d0,kind=dp)
            exact_roots(3) = cmplx(-1.907280091,0d0,kind=dp)
            exact_roots(4) = cmplx(-1.772892903,0d0,kind=dp)
            exact_roots(5) = cmplx(-1.754877666,0d0,kind=dp)
            exact_roots(6) = cmplx(-1.47601464272,0d0,kind=dp)
            exact_roots(7) = cmplx(-1.284084925525, 4.272688960406d-1,kind=dp)
            exact_roots(8) = cmplx(-1.284084925525,-4.272688960406d-1,kind=dp)
            exact_roots(9) = cmplx(-1.138000666650,-2.403324012620d-1,kind=dp)
            exact_roots(10) = cmplx(-1.138000666650, 2.403324012620d-1,kind=dp)
            exact_roots(11) = cmplx(-1d0,0d0,kind=dp)
            exact_roots(12) = cmplx(-5.968916446451269d-1, 6.629807445770295d-1,kind=dp)
            exact_roots(13) = cmplx(-5.968916446451269d-1,-6.629807445770295d-1,kind=dp)
            exact_roots(14) = cmplx(-2.17526747030511d-1,-1.11445426587329,kind=dp)
            exact_roots(15) = cmplx(-2.17526747030511d-1, 1.11445426587329,kind=dp)
            exact_roots(16) = cmplx(-1.6359826155202d-1, 1.09778064288827,kind=dp)
            exact_roots(17) = cmplx(-1.6359826155202d-1,-1.09778064288827,kind=dp)
            exact_roots(18) = cmplx(-1.225611668766536d-1,-7.4486176661974423d-1,kind=dp)
            exact_roots(19) = cmplx(-1.225611668766536d-1, 7.4486176661974423d-1,kind=dp)
            exact_roots(20) = cmplx(-1.13418655949436d-1,-8.605694725015730d-1,kind=dp)
            exact_roots(21) = cmplx(-1.13418655949436d-1,8.605694725015730d-1,kind=dp)
            exact_roots(22) = cmplx(-1.5570386020902d-2, 1.020497366498289d0,kind=dp)
            exact_roots(23) = cmplx(-1.5570386020902d-2,-1.020497366498289d0,kind=dp)
            exact_roots(24) = cmplx(3.59892739012579001d-1, 6.84762020211812856d-1,kind=dp)
            exact_roots(25) = cmplx(3.59892739012579001d-1,-6.84762020211812856d-1,kind=dp)
            exact_roots(26) = cmplx(3.8900684056977123543d-1,-2.1585065087081910777d-1,kind=dp)
            exact_roots(27) = cmplx(3.8900684056977123543d-1, 2.1585065087081910777d-1,kind=dp)
            exact_roots(28) = cmplx(3.96534570032415023d-1, 6.04181810488988837d-1,kind=dp)
            exact_roots(29) = cmplx(3.96534570032415023d-1,-6.04181810488988837d-1,kind=dp)
            exact_roots(30) = cmplx(4.433256333996235387d-1, 3.729624166628465083d-1,kind=dp)
            exact_roots(31) = cmplx(4.433256333996235387d-1,-3.729624166628465083d-1,kind=dp)
            ! polynomial
            p(1) = 1d0
            p(2) = 1d0
            p(3) = 2d0
            p(4) = 5d0
            p(5) = 14d0
            p(6) = 42d0
            p(7) = 100d0
            p(8) = 221d0
            p(9) = 470d0
            p(10) = 958d0
            p(11) = 1860d0
            p(12)= 3434d0
            p(13) = 6036d0
            p(14) = 10068d0
            p(15) = 15864d0
            p(16) = 23461d0
            p(17) = 32398d0
            p(18) = 41658d0
            p(19) = 49700d0
            p(20) = 54746d0
            p(21) = 55308d0
            p(22) = 50788d0
            p(23) = 41944d0
            p(24) = 30782d0
            p(25) = 19788d0
            p(26) = 10948d0
            p(27) = 5096d0
            p(28) = 1932d0
            p(29) = 568d0
            p(30) = 120d0
            p(31) = 16d0
            p(32) = 1d0
            case(14)
            ! Poly 14: Mandelbrot 63 MPSolve
            deg = 63
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(-1.999095682327018473210d0,0d0,kind=dp)
            exact_roots(2) = cmplx(-1.9918141725491222157325609498622881d0,0d0,kind=dp)
            exact_roots(3) = cmplx(-1.977179587006257387346088520662828616836d0,0d0,kind=dp)
            exact_roots(4) = cmplx(-1.953705894284396245427622199013653238901d0,0d0,kind=dp)
            exact_roots(5) = cmplx(-1.927147709363950262460068188946594278007d0,0d0,kind=dp)
            exact_roots(6) = cmplx(-1.8848035715866817923294780929158396496359d0,0d0,kind=dp)
            exact_roots(7) = cmplx(-1.8323152027512291920848975260425181432293d0,0d0,kind=dp)
            exact_roots(8) = cmplx(-1.76926167027683114607548022863625740038777d0, &
                5.6919500395600315304900187298015859319654d-2,kind=dp)
            exact_roots(9) = cmplx(-1.76926167027683114607548022863625740038777d0, &
                -5.6919500395600315304900187298015859319654d-2,kind=dp)
            exact_roots(10) = cmplx(-1.674066091474787971565296029172325596206403d0,0d0,kind=dp)
            exact_roots(11) = cmplx(-1.5748891397523009698199655524959742837719482d0,0d0,kind=dp)
            exact_roots(12) = cmplx(-1.408446485740072654917577008805998851928020904d0, &
                 -1.36171997304659915684707793608163610038822995d-1,kind=dp)
            exact_roots(13) = cmplx(-1.408446485740072654917577008805998851928020904d0, &
                 1.36171997304659915684707793608163610038822995d-1,kind=dp)
            exact_roots(14) = cmplx(-1.29255806103352208716418470636149411998013630326d0, &
                 4.3819881608663183712973712432734844004535476504d-1,kind=dp)
            exact_roots(15) = cmplx(-1.29255806103352208716418470636149411998013630326d0, &
                 -4.3819881608663183712973712432734844004535476504d-1,kind=dp)
            exact_roots(16) = cmplx(-1.26228728143847254301011194120806575232050489502d0, &
                 4.0810432411269038329016065742601506306041169168d-1,kind=dp)
            exact_roots(17) = cmplx(-1.26228728143847254301011194120806575232050489502d0, &
                 -4.0810432411269038329016065742601506306041169168d-1,kind=dp)
            exact_roots(18) = cmplx(-1.25273588401203794629581100256433997387062287256d0, &
                 -3.4247064788975089386187578687092843396383393805d-1,kind=dp)
            exact_roots(19) = cmplx(-1.25273588401203794629581100256433997387062287256d0, &
                 3.4247064788975089386187578687092843396383393805d-1,kind=dp)
            exact_roots(20) = cmplx(-1.02819385245481759930249745596731843328070508279421d0, &
                 -3.61376517118561592479460832997830315786692639704085d-1,kind=dp)
            exact_roots(21) = cmplx(-1.02819385245481759930249745596731843328070508279421d0, &
                 3.61376517118561592479460832997830315786692639704085d-1,kind=dp)
            exact_roots(22) = cmplx(-6.23532485956252757990016587001026776428072703359878868d-1, &
                 6.81064414225239608090835812686561539088332735217609127d-1,kind=dp)
            exact_roots(23) = cmplx(-6.23532485956252757990016587001026776428072703359878868d-1, &
                 -6.81064414225239608090835812686561539088332735217609127d-1,kind=dp)
            exact_roots(24) = cmplx(-6.2243629504129358796016350694723840189750985673649588591d-1, &
                 4.2487843647562918431157443880525338683545992964599689876d-1,kind=dp)
            exact_roots(25) = cmplx(-6.2243629504129358796016350694723840189750985673649588591d-1, &
                 -4.2487843647562918431157443880525338683545992964599689876d-1,kind=dp)
            exact_roots(26) = cmplx(-5.308278048599427289214772971196026578135170949646890946d-1, &
                 6.682887255592057714440924655647011851367651843270734380d-1,kind=dp)
            exact_roots(27) = cmplx(-5.308278048599427289214772971196026578135170949646890946d-1, &
                 -6.682887255592057714440924655647011851367651843270734380d-1,kind=dp)
            exact_roots(28) = cmplx(-2.72102461488938894219383324518026874585894699621947085d-1, &
                 -8.42364690294128145503155708242929569550778268698265965d-1,kind=dp)
            exact_roots(29) = cmplx(-2.72102461488938894219383324518026874585894699621947085d-1, &
                 8.42364690294128145503155708242929569550778268698265965d-1,kind=dp)
            exact_roots(30) = cmplx(-2.24915951286740054685326255204118310792682454680693d-1, &
                 1.11626015745499183500126825424467009109873946082435d0,kind=dp)
            exact_roots(31) = cmplx(-2.24915951286740054685326255204118310792682454680693d-1, &
                 -1.11626015745499183500126825424467009109873946082435d0,kind=dp)
            exact_roots(32) = cmplx(-2.0728383545566641282413385018667121332401155604017d-1, &
                 1.11748077249496291137377567312207879579746389236127d0,kind=dp)
            exact_roots(33) = cmplx(-2.0728383545566641282413385018667121332401155604017d-1, &
                 -1.11748077249496291137377567312207879579746389236127d0,kind=dp)
            exact_roots(34) = cmplx(-1.7457822113571696945156643266162905020167505710204d-1, &
                 1.07142767145403118922964631021955987671322451961088d0,kind=dp)
            exact_roots(35) = cmplx(-1.7457822113571696945156643266162905020167505710204d-1, &
                 -1.07142767145403118922964631021955987671322451961088d0,kind=dp)
            exact_roots(36) = cmplx(-1.57516053475965356164335109644674141293297577896685d-1, &
                 -1.10900651411360717797175198615475582901468585712356d0,kind=dp)
            exact_roots(37) = cmplx(-1.57516053475965356164335109644674141293297577896685d-1, &
                 1.10900651411360717797175198615475582901468585712356d0,kind=dp)
            exact_roots(38) = cmplx(-1.274999735463630001995395653459879637298616757217284d-1, &
                 9.874609094894567922074076807929788675642068522522938d-1,kind=dp)
            exact_roots(39) = cmplx(-1.274999735463630001995395653459879637298616757217284d-1, &
                 -9.874609094894567922074076807929788675642068522522938d-1,kind=dp)
            exact_roots(40) = cmplx(-1.42334819203540667677618453136202688358025283954839d-2, &
                 -1.0329147752136441093950134026551104360994260360822540d0,kind=dp)
            exact_roots(41) = cmplx(-1.42334819203540667677618453136202688358025283954839d-2, &
                 1.0329147752136441093950134026551104360994260360822540d0,kind=dp)
            exact_roots(42) = cmplx(-6.98356849626139181796649107548406610452886379651341d-3, &
                 -1.0036038622882895485307049669513531297649273745391915d0,kind=dp)
            exact_roots(43) = cmplx(-6.98356849626139181796649107548406610452886379651341d-3, &
                 1.0036038622882895485307049669513531297649273745391915d0,kind=dp)
            exact_roots(44) = cmplx( 1.4895466603687646529815779208794106185666477731693128d-2, &
                 -8.481487619084165277193311117832376290806619901265058603d-1,kind=dp)
            exact_roots(45) = cmplx( 1.4895466603687646529815779208794106185666477731693128d-2, &
                 8.481487619084165277193311117832376290806619901265058603d-1,kind=dp)
            exact_roots(46) = cmplx( 1.211927861059064863147044434105037593859287800520963579338d-1, &
                 6.1061169221075421167538724415035774824319702690063863369691d-1,kind=dp)
            exact_roots(47) = cmplx( 1.211927861059064863147044434105037593859287800520963579338d-1, &
                 -6.1061169221075421167538724415035774824319702690063863369691d-1,kind=dp)
            exact_roots(48) = cmplx( 3.52482539722363278193253964052161589243593334212239870706d-1, &
                 -6.98337239583330331258141954760484537633150485928512286760d-1,kind=dp)
            exact_roots(49) = cmplx( 3.52482539722363278193253964052161589243593334212239870706d-1, &
                 6.98337239583330331258141954760484537633150485928512286760d-1,kind=dp)
            exact_roots(50) = cmplx( 3.7600868184676755970480431772902286888800357334637481632029182d-1, &
                 -1.4474937132163286474711018201298830556966056842762643026975894d-1,kind=dp)
            exact_roots(51) = cmplx( 3.7600868184676755970480431772902286888800357334637481632029182d-1, &
                 1.4474937132163286474711018201298830556966056842762643026975894d-1,kind=dp)
            exact_roots(52) = cmplx( 3.76893240379311323690004017968512473363482317941533875341d-1, &
                 6.78568693190448141957540792996773280196881194582788907016d-1,kind=dp)
            exact_roots(53) = cmplx( 3.76893240379311323690004017968512473363482317941533875341d-1, &
                 -6.78568693190448141957540792996773280196881194582788907016d-1,kind=dp)
            exact_roots(54) = cmplx( 3.865391765961580265082930869043677799284877313516569138807d-1, &
                 5.693247113031029032137923571351905081619323911951388853856d-1,kind=dp)
            exact_roots(55) = cmplx( 3.865391765961580265082930869043677799284877313516569138807d-1, &
                 -5.693247113031029032137923571351905081619323911951388853856d-1,kind=dp)
            exact_roots(56) = cmplx( 4.12916024722700479197334566382612257174765142865547121703d-1, &
                 6.148067601433856949545497204007997358291659758563137777616d-1,kind=dp)
            exact_roots(57) = cmplx( 4.12916024722700479197334566382612257174765142865547121703d-1, &
                 -6.148067601433856949545497204007997358291659758563137777616d-1,kind=dp)
            exact_roots(58) = cmplx( 4.3237619264199450782466964808692137388785063987699403620424125d-1, &
                 2.267599044353486186978765599716989721202321914603899690444951d-1,kind=dp)
            exact_roots(59) = cmplx( 4.3237619264199450782466964808692137388785063987699403620424125d-1, &
                 -2.267599044353486186978765599716989721202321914603899690444951d-1,kind=dp)
            exact_roots(60) = cmplx( 4.52774498724915493508803077732546131473562000961307327749350d-1, &
                 -3.96170128033165002412596877271155937712569079351815707744770d-1,kind=dp)
            exact_roots(61) = cmplx( 4.52774498724915493508803077732546131473562000961307327749350d-1, &
                 3.96170128033165002412596877271155937712569079351815707744770d-1,kind=dp)
            exact_roots(62) = cmplx( 4.56823285823316651283953236253270107801699459631329688710054d-1, &
                 3.47758700883481983632188723200264206004781117755664551397643d-1,kind=dp)
            exact_roots(63) = cmplx( 4.56823285823316651283953236253270107801699459631329688710054d-1, &
                 -3.47758700883481983632188723200264206004781117755664551397643d-1,kind=dp)
            ! polynomial
            p(1) = 1d0
            p(2) = 1d0
            p(3) = 2d0
            p(4) = 5d0
            p(5) = 14d0
            p(6) = 42d0
            p(7) = 132d0
            p(8) = 365d0
            p(9) = 950d0
            p(10) = 2398d0
            p(11) = 5916d0
            p(12) = 14290d0
            p(13) = 33708d0
            p(14) = 77684d0
            p(15) = 175048d0
            p(16) = 385741d0
            p(17) = 831014d0
            p(18) = 1749654d0
            p(19) = 3598964d0
            p(20) = 7228014d0
            p(21) = 14162220d0
            p(22) = 27049196d0
            p(23) = 50323496d0
            p(24) = 91143114d0
            p(25) = 160617860d0
            p(26) = 275276716d0
            p(27) = 458591432d0
            p(28) = 742179284d0
            p(29) = 1166067016d0
            p(30) = 1777171560d0
            p(31) = 2625062128d0
            p(32) = 3754272037d0
            p(33) = 5193067630d0
            p(34) = 6939692682d0
            p(35) = 8948546308d0
            p(36) = 11120136162d0
            p(37) = 13299362332d0
            p(38) = 15286065700d0
            p(39) = 16859410792d0
            p(40) = 17813777994d0
            p(41) = 17999433372d0
            p(42) = 17357937708d0
            p(43) = 15941684776d0
            p(44) = 13910043524d0
            p(45) = 11500901864d0
            p(46) = 8984070856d0
            p(47) = 6609143792d0
            p(48) = 4562339774d0
            p(49) = 2943492972d0
            p(50) = 1766948340d0
            p(51) = 981900168d0
            p(52) = 502196500d0
            p(53) = 234813592d0
            p(54) = 99582920d0
            p(55) = 37945904d0
            p(56) = 12843980d0
            p(57) = 3807704d0
            p(58) = 971272d0
            p(59) = 208336d0
            p(60) = 36440d0
            p(61) = 4976d0
            p(62) = 496d0
            p(63) = 32d0
            p(64) = 1d0
            case(15)
            ! Poly 15: Jenkins Traub p1(z) with a=1e-8
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d-8,0d0,kind=dp)
            exact_roots(2) = cmplx(-1d-8,0d0,kind=dp)
            exact_roots(3) = cmplx(1d0,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(16)
            ! Poly 16: Jenkins Traub p1(z) with a=1e-15
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d-15,0d0,kind=dp)
            exact_roots(2) = cmplx(-1d-15,0d0,kind=dp)
            exact_roots(3) = cmplx(1d0,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(17)
            ! Poly 17: Jenkins Traub p1(z) with a=1e+8
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d+8,0d0,kind=dp)
            exact_roots(2) = cmplx(-1d+8,0d0,kind=dp)
            exact_roots(3) = cmplx(1d0,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(18)
            ! Poly 18: Jenkins Traub p1(z) with a=1e+15
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d+15,0d0,kind=dp)
            exact_roots(2) = cmplx(-1d+15,0d0,kind=dp)
            exact_roots(3) = cmplx(1d0,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(19)
            ! Poly 19: Jenkins Traub p3(z) deg 10
            deg = 10
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d-1,0d0,kind=dp)
            exact_roots(2) = cmplx(1d-2,0d0,kind=dp)
            exact_roots(3) = cmplx(1d-3,0d0,kind=dp)
            exact_roots(4) = cmplx(1d-4,0d0,kind=dp)
            exact_roots(5) = cmplx(1d-5,0d0,kind=dp)
            exact_roots(6) = cmplx(1d-6,0d0,kind=dp)
            exact_roots(7) = cmplx(1d-7,0d0,kind=dp)
            exact_roots(8) = cmplx(1d-8,0d0,kind=dp)
            exact_roots(9) = cmplx(1d-9,0d0,kind=dp)
            exact_roots(10) = cmplx(1d-10,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(20)
            ! Poly 20: Jenkins Traub p3(z) deg 20
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(1d-1,0d0,kind=dp)
            exact_roots(2) = cmplx(1d-2,0d0,kind=dp)
            exact_roots(3) = cmplx(1d-3,0d0,kind=dp)
            exact_roots(4) = cmplx(1d-4,0d0,kind=dp)
            exact_roots(5) = cmplx(1d-5,0d0,kind=dp)
            exact_roots(6) = cmplx(1d-6,0d0,kind=dp)
            exact_roots(7) = cmplx(1d-7,0d0,kind=dp)
            exact_roots(8) = cmplx(1d-8,0d0,kind=dp)
            exact_roots(9) = cmplx(1d-9,0d0,kind=dp)
            exact_roots(10) = cmplx(1d-10,0d0,kind=dp)
            exact_roots(11) = cmplx(1d-11,0d0,kind=dp)
            exact_roots(12) = cmplx(1d-12,0d0,kind=dp)
            exact_roots(13) = cmplx(1d-13,0d0,kind=dp)
            exact_roots(14) = cmplx(1d-14,0d0,kind=dp)
            exact_roots(15) = cmplx(1d-15,0d0,kind=dp)
            exact_roots(16) = cmplx(1d-16,0d0,kind=dp)
            exact_roots(17) = cmplx(1d-17,0d0,kind=dp)
            exact_roots(18) = cmplx(1d-18,0d0,kind=dp)
            exact_roots(19) = cmplx(1d-19,0d0,kind=dp)
            exact_roots(20) = cmplx(1d-20,0d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(21)
            ! Poly 21: Jenkins Traub p4(z)
            deg = 6
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.1_dp
            exact_roots(2) = 0.1_dp
            exact_roots(3) = 0.1_dp
            exact_roots(4) = 0.5_dp
            exact_roots(5) = 0.6_dp
            exact_roots(6) = 0.7_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(22)
            ! Poly 22: Jenkins Traub p5(z)
            deg = 10
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.1_dp
            exact_roots(2) = 0.1_dp
            exact_roots(3) = 0.1_dp
            exact_roots(4) = 0.1_dp
            exact_roots(5) = 0.2_dp
            exact_roots(6) = 0.2_dp
            exact_roots(7) = 0.2_dp
            exact_roots(8) = 0.3_dp
            exact_roots(9) = 0.3_dp
            exact_roots(10) = 0.4_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(23)
            ! Poly 23: Jenkins Traub p6(z)
            deg = 5
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.1_dp
            exact_roots(2) = 1.001_dp
            exact_roots(3) = 0.998_dp
            exact_roots(4) = 1.00002_dp
            exact_roots(5) = 0.99999_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(24)
            ! Poly 24: Jenkins Traub p7(z) with a=0
            deg = 7
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.001_dp
            exact_roots(2) = 0.01_dp
            exact_roots(3) = 0.1_dp
            exact_roots(4) = 0.1_dp
            exact_roots(5) = 0.1_dp
            exact_roots(6) = 1.0_dp
            exact_roots(7) = 10.0_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(25)
            ! Poly 25: Jenkins Traub p7(z) with a=10^(-10)
            deg = 7
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.001_dp
            exact_roots(2) = 0.01_dp
            exact_roots(3) = 0.1_dp
            exact_roots(4) = cmplx(0.1_dp,1E-10_dp,kind=dp)
            exact_roots(5) = cmplx(0.1_dp,-1E-10_dp,kind=dp)
            exact_roots(6) = 1.0_dp
            exact_roots(7) = 10.0_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(26)
            ! Poly 26: Jenkins Traub p7(z) with a=10^(-6)
            deg = 7
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 0.001_dp
            exact_roots(2) = 0.01_dp
            exact_roots(3) = 0.1_dp
            exact_roots(4) = cmplx(0.1_dp,1E-6_dp,kind=dp)
            exact_roots(5) = cmplx(0.1_dp,-1E-6_dp,kind=dp)
            exact_roots(6) = 1.0_dp
            exact_roots(7) = 10.0_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(27)
            ! Poly 27: Jenkins Traub p8(z)
            deg = 5
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = -1.0_dp
            exact_roots(2) = -1.0_dp
            exact_roots(3) = -1.0_dp
            exact_roots(4) = -1.0_dp
            exact_roots(5) = -1.0_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(28)
            ! Poly 28: Jenkins Traub p9(z)
            deg = 20
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(+1d-2,0d0,kind=dp)
            exact_roots(2) = cmplx(-1d-2,0d0,kind=dp)
            exact_roots(3) = cmplx(0d0,+1d+2,kind=dp)
            exact_roots(4) = cmplx(0d0,-1d+2,kind=dp)
            exact_roots(5) = cmplx(-95.105651629515357212d0,+30.901699437494742410d0,kind=dp)
            exact_roots(6) = cmplx(-95.105651629515357212d0,-30.901699437494742410d0,kind=dp)
            exact_roots(7) = cmplx(-0.0080901699437494742410d0,+0.0058778525229247312917d0,kind=dp)
            exact_roots(8) = cmplx(-0.0080901699437494742410d0,-0.0058778525229247312917d0,kind=dp)
            exact_roots(9) = cmplx(-58.778525229247312917d0,+80.901699437494742410d0,kind=dp)
            exact_roots(10) = cmplx(-58.778525229247312917d0,-80.901699437494742410d0,kind=dp)
            exact_roots(11) = cmplx(-0.0030901699437494742410d0,+0.0095105651629515357212d0,kind=dp)
            exact_roots(12) = cmplx(-0.0030901699437494742410d0,-0.0095105651629515357212d0,kind=dp)
            exact_roots(13) = cmplx(+95.105651629515357212d0,+30.901699437494742410d0,kind=dp)
            exact_roots(14) = cmplx(+95.105651629515357212d0,-30.901699437494742410d0,kind=dp)
            exact_roots(15) = cmplx(+0.0080901699437494742410d0,+0.0058778525229247312917d0,kind=dp)
            exact_roots(16) = cmplx(+0.0080901699437494742410d0,-0.0058778525229247312917d0,kind=dp)
            exact_roots(17) = cmplx(+58.778525229247312917d0,+80.901699437494742410d0,kind=dp)
            exact_roots(18) = cmplx(+58.778525229247312917d0,-80.901699437494742410d0,kind=dp)
            exact_roots(19) = cmplx(+0.0030901699437494742410d0,+0.0095105651629515357212d0,kind=dp)
            exact_roots(20) = cmplx(+0.0030901699437494742410d0,-0.0095105651629515357212d0,kind=dp)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(29)
            ! Poly 29: Jenkins Traub p10(z) with a=1e+3
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 1E+3_dp
            exact_roots(2) = 1.0_dp
            exact_roots(3) = 1E-3_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(30)
            ! Poly 30: Jenkins Traub p10(z) with a=1e+6
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 1E+6_dp
            exact_roots(2) = 1.0_dp
            exact_roots(3) = 1E-6_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(31)
            ! Poly 31: Jenkins Traub p10(z) with a=1e+9
            deg = 3
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = 1E+9_dp
            exact_roots(2) = 1.0_dp
            exact_roots(3) = 1E-9_dp
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(32)
            ! Poly 32: Jenkins Traub p11(z) with m=15
            deg = 60
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            do j=-14,14
                exact_roots(15+j) = cmplx(cos(j*pi/30.0_dp),sin(j*pi/30.0_dp),kind=dp)
            end do
            do j=15,45
                exact_roots(15+j) = 0.9_dp*cmplx(cos(j*pi/30.0_dp),sin(j*pi/30.0_dp),kind=dp)
            end do
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(33)
            ! Poly 33: Jenkins Traub p11(z) with m=20
            deg = 80
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            do j=-19,19
                exact_roots(20+j) = cmplx(cos(j*pi/40.0_dp),sin(j*pi/40.0_dp),kind=dp)
            end do
            do j=20,60
                exact_roots(20+j) = 0.9_dp*cmplx(cos(j*pi/40.0_dp),sin(j*pi/40.0_dp),kind=dp)
            end do
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(34)
            ! Poly 34: Jenkins Traub p11(z) with m=25
            deg = 100
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            do j=-24,24
                exact_roots(25+j) = cmplx(cos(j*pi/50.0_dp),sin(j*pi/50.0_dp),kind=dp)
            end do
            do j=25,75
                exact_roots(25+j) = 0.9_dp*cmplx(cos(j*pi/50.0_dp),sin(j*pi/50.0_dp),kind=dp)
            end do
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
            case(35)
            ! Poly 35: Cleve's Corner Polynomial
            deg = 6
            allocate(exact_roots(deg), p(deg+1))
            ! roots
            exact_roots(1) = cmplx(4,0,kind=dp)
            exact_roots(2) = cmplx(2,1,kind=dp)
            exact_roots(3) = cmplx(2,-1,kind=dp)
            exact_roots(4) = cmplx(0.25_dp,0,kind=dp)
            exact_roots(5) = 1/exact_roots(2)
            exact_roots(6) = 1/exact_roots(3)
            ! polynomial
            p(deg+1) = cmplx(1.0_dp,0.0_dp,kind=dp)
            call rootCoeffCplx(deg,exact_roots,p)
        end select
    end subroutine make_poly
    !************************************************
    !                       max_rel_err             *
    !************************************************
    ! Compute maximum relative error between roots
    ! and exact roots.
    !************************************************
    function max_rel_err(roots, exact_roots, deg) result(res)
        implicit none
        ! argument variables
        integer, intent(in)             :: deg
        complex(kind=dp), intent(in)    :: exact_roots(:), roots(:)
        ! local variables
        logical                         :: m(deg)
        integer                         :: i, j, k
        real(kind=dp)                   :: delta, err, res, relerr, rmax
        ! intrinsic procedures
        intrinsic                       :: abs, max, huge

        ! initialize
        m = .True.
        rmax = huge(1.0_dp)
        res = mu
        ! main loop
        do i=1,deg
            ! find corresponding exact root (yet to be matched)
            err = rmax
            do j=1,deg
                if(m(j)) then
                    delta = abs(exact_roots(j) - roots(i))
                    if(delta < err) then
                        err = delta
                        k = j
                    end if
                end if
            end do
            ! mark corresponding root as matched
            m(k) = .False.
            ! calculate relative error on this root and update max
            ! zero roots give unhelpful relative errors, so revert to absolute error
            if(abs(roots(i))<mu .or. abs(exact_roots(k))<mu) then
                relerr = err
            else
                relerr = err/abs(exact_roots(k))
            end if
            res = max(relerr, res)
        end do
        res = max(res,mu)
    end function max_rel_err
end program special_poly


SUBROUTINE savgol(c,np,nl,nr,ld,m)

! Numerical recipes routine for computing the Savitsky-Golay filter
! coefficients for smoothing the ld^th derivative of a function using
! np = nl+nr+1 points and an m^th order polynomial.  Coefficients are
! returned in c in wraparound order.
USE Precision
  IMPLICIT NONE
  INTEGER ld, m, nl, np, nr
  REAL(kind=long) :: c(np)
  INTEGER :: imj, ipj, j, k, kk, mm, indx(m+1)
  REAL(kind=long) :: d, fac, sum, a(m+1,m+1), b(m+1), zero=0._long, &
       one=1._long

  if (np<nl+nr+1 .or. nl<0 .or. nr<0 .or. ld>m .or. nl+nr<m) then
       write(*,'(A)') 'bad args in savgol'
       read*
! pause
  endif

  do ipj=0,2*m
     sum=zero
     if(ipj==0)sum=one
     do k=1,nr
        sum=sum+real(k,long)**ipj
     end do
     do k=1,nl
        sum=sum+real(-k,long)**ipj
     end do
     mm=min(ipj,2*m-ipj)
     do imj=-mm,mm,2
        a(1+(ipj+imj)/2,1+(ipj-imj)/2)=sum
     end do
  end do
  call ludcmp(a,m+1,m+1,indx,d)
  do j=1,m+1
     b(j)=zero
  end do
  b(ld+1)=one
  call lubksb(a,m+1,m+1,indx,b)
  do kk=1,np
     c(kk)=zero
  end do
  do k=-nl,nr
     sum=b(1)
     fac=one
     do mm=1,m
        fac=fac*k
        sum=sum+b(mm+1)*fac
     end do
     kk=mod(np-k,np)+1
     c(kk)=sum
  end do
  return
end SUBROUTINE savgol


program ch1502
    ! Polar Coordinate Example
    implicit none

    real :: omega, real_part, imag_part, magnitude, phase
    complex :: frequency_response

    print *, 'input frequency'
    read *, omega
    frequency_response = 1./cmplx(-omega*omega+1., 2.*omega)
    real_part = real(frequency_response)
    imag_part = aimag(frequency_response)
    magnitude = abs(frequency_response)
    phase = atan2(imag_part,real_part)
    print *, ' at frequency ', omega
    print *, 'response = ', real_part, ' + i ', &
        imag_part
    print *, 'in polar form'
    print *, ' magnitude = ', magnitude
    print *, ' phase = ', phase
end program


!> This file contains the subroutines for computing the one-dimensional
!! and 2-dimensional fourier transforms from the linear and non-linear
!! response functions using. It is to be compiled using f2py (included with numpy)
!! and imported within python analysis scripts as a module. The subroutines
!! are then available within the python script
!~~~~~~~~~~  f2py -c -m analysis f2py_analysis.f90  ~~~~~~~~~~~~~~~!

! One-Dimensional Fourier Transform
SUBROUTINE one_d_ft(real_response, imag_response, time, w, output)
  IMPLICIT NONE
  INTEGER :: iw, it
  REAL(8), DIMENSION(:) :: real_response
  REAL(8), DIMENSION(:) :: imag_response
  REAL(8), DIMENSION(:) :: time
  REAL(8), DIMENSION(:) :: w
  COMPLEX(8), DIMENSION(size(w)) :: output
  COMPLEX(8), DIMENSION(size(real_response)) :: response
  REAL(8) :: dw, dt
  REAL(8), PARAMETER :: pi = 3.1415926536
  REAL(8), PARAMETER :: fs2wvnbr = 33356.41
  COMPLEX(8), PARAMETER :: eye = (0.d0, 1.d0)
  output = (0.d0,0.d0) ; response = (0.d0,0.d0)
  !> Declaration of f2py variables
  !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!
  !f2py intent(in) tpts
  !f2py intent(in) real_response
  !f2py intent(in) imag_response
  !f2py intent(in) time
  !f2py intent(in) w
  !f2py intent(out) output

  CALL write_to_screen('NOTE','PERFORMING ONE-DIMENSIONAL FOURIER TRANSFORM')

  ! set up parameters
  w = w * 2.d0 * pi / fs2wvnbr
  dw = w(2) - w(1)
  dt = time(2) - time(1)

  response = DCMPLX( real_response, imag_response )

  DO iw = 1, SIZE(w(:))
     DO it = 1, SIZE(response(:))
        output(iw) = output(iw) &
             + dt * exp( -eye * w(iw) * (it-1) * dt ) * response(it)
     END DO
  END DO

    w = w / (2.d0 * pi / fs2wvnbr)

END SUBROUTINE one_d_ft

! Two-Dimensional Fourier Transform
!SUBROUTINE two_d_ft(real_response, imag_response, time1, time2, time3, &
!     w1, w3)
!  IMPLICIT NONE
!  INTEGER :: iw1, it1, iw3, it3
!  REAL(8), DIMENSION(:) :: real_response
!  REAL(8), DIMENSION(:) :: imag_response
!  REAL(8), DIMENSION(:) :: time1, time2, time3
!  REAL(8), DIMENSION(:) :: w
!  COMPLEX(8), DIMENSION(size(w)) :: output
!  COMPLEX(8), DIMENSION(size(real_response)) :: response
!  REAL(8) :: dw, dt
!  REAL(8), PARAMETER :: pi = 3.1415926536
!  REAL(8), PARAMETER :: fs2wvnbr = 33356.41
!  COMPLEX(8), PARAMETER :: eye = (0.d0, 1.d0)
!  output = (0.d0,0.d0) ; response = (0.d0,0.d0)
!  !> Declaration of f2py variables
!  !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!
!  !f2py intent(in) tpts
!  !f2py intent(in) real_response
!  !f2py intent(in) imag_response
!  !f2py intent(in) time
!  !f2py intent(in) w
!  !f2py intent(out) output
!
!
!  CALL write_to_screen('NOTE','PERFORMING TWO-DIMENSIONAL FOURIER TRANSFORM')
!
!END SUBROUTINE two_d_ft

! Apply Cosine Window function to smooth out end of response function
SUBROUTINE apply_cos_window( response, output )
  IMPLICIT NONE
  REAL(8) :: response(:), output( SIZE(response) )
  INTEGER :: itime
  REAL(8) :: pi=3.1415926536
  !> Declaration of f2py variables
  !!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~!!
  !f2py intent(in) real_response
  !f2py intent(in) imag_response
  !f2py intent(out) output

  CALL write_to_screen('NOTE','APPLYING COSINE WINDOW FUNCTION')

DO itime = 1, SIZE( response )
     response(itime) = response(itime) &
          * COS( pi * ( REAL(itime-1))/ (2.0 * ( REAL(SIZE(response)) - 1 ) ) )
  END DO

  output = response
END SUBROUTINE apply_cos_window

SUBROUTINE write_to_screen( type, message )
  IMPLICIT NONE
  CHARACTER(*) :: type
  CHARACTER (*):: message

  write(*,*) '***',type,'*** : ', message

END SUBROUTINE write_to_screen


!
!	Find the Akaike correction.
!	modeldim is the model dimension.
!	loglik is the log likelilhood.
!	totalitemsis the total number of presented items.
real(kind=8) function akaike(modeldim,loglik,totalitems)
implicit none
integer,intent(in)::modeldim
real(kind=8),intent(in)::loglik,totalitems
akaike=(-loglik+modeldim)/totalitems
return
end function akaike


*DECK ULSIA
      SUBROUTINE ULSIA (A, MDA, M, N, B, MDB, NB, RE, AE, KEY, MODE, NP,
     +   KRANK, KSURE, RNORM, W, LW, IWORK, LIW, INFO)
C***BEGIN PROLOGUE  ULSIA
C***PURPOSE  Solve an underdetermined linear system of equations by
C            performing an LQ factorization of the matrix using
C            Householder transformations.  Emphasis is put on detecting
C            possible rank deficiency.
C***LIBRARY   SLATEC
C***CATEGORY  D9
C***TYPE      SINGLE PRECISION (ULSIA-S, DULSIA-D)
C***KEYWORDS  LINEAR LEAST SQUARES, LQ FACTORIZATION,
C             UNDERDETERMINED LINEAR SYSTEM
C***AUTHOR  Manteuffel, T. A., (LANL)
C***DESCRIPTION
C
C     ULSIA computes the minimal length solution(s) to the problem AX=B
C     where A is an M by N matrix with M.LE.N and B is the M by NB
C     matrix of right hand sides.  User input bounds on the uncertainty
C     in the elements of A are used to detect numerical rank deficiency.
C     The algorithm employs a row and column pivot strategy to
C     minimize the growth of uncertainty and round-off errors.
C
C     ULSIA requires (MDA+1)*N + (MDB+1)*NB + 6*M dimensioned space
C
C   ******************************************************************
C   *                                                                *
C   *         WARNING - All input arrays are changed on exit.        *
C   *                                                                *
C   ******************************************************************
C
C     Input..
C
C     A(,)          Linear coefficient matrix of AX=B, with MDA the
C      MDA,M,N      actual first dimension of A in the calling program.
C                   M is the row dimension (no. of EQUATIONS of the
C                   problem) and N the col dimension (no. of UNKNOWNS).
C                   Must have MDA.GE.M and M.LE.N.
C
C     B(,)          Right hand side(s), with MDB the actual first
C      MDB,NB       dimension of B in the calling program. NB is the
C                   number of M by 1 right hand sides.  Since the
C                   solution is returned in B, must have MDB.GE.N. If
C                   NB = 0, B is never accessed.
C
C   ******************************************************************
C   *                                                                *
C   *         Note - Use of RE and AE are what make this             *
C   *                code significantly different from               *
C   *                other linear least squares solvers.             *
C   *                However, the inexperienced user is              *
C   *                advised to set RE=0.,AE=0.,KEY=0.               *
C   *                                                                *
C   ******************************************************************
C
C     RE(),AE(),KEY
C     RE()          RE() is a vector of length N such that RE(I) is
C                   the maximum relative uncertainty in row I of
C                   the matrix A. The values of RE() must be between
C                   0 and 1. A minimum of 10*machine precision will
C                   be enforced.
C
C     AE()          AE() is a vector of length N such that AE(I) is
C                   the maximum absolute uncertainty in row I of
C                   the matrix A. The values of AE() must be greater
C                   than or equal to 0.
C
C     KEY           For ease of use, RE and AE may be input as either
C                   vectors or scalars. If a scalar is input, the algo-
C                   rithm will use that value for each column of A.
C                   The parameter KEY indicates whether scalars or
C                   vectors are being input.
C                        KEY=0     RE scalar  AE scalar
C                        KEY=1     RE vector  AE scalar
C                        KEY=2     RE scalar  AE vector
C                        KEY=3     RE vector  AE vector
C
C
C     MODE          The integer MODE indicates how the routine
C                   is to react if rank deficiency is detected.
C                   If MODE = 0 return immediately, no solution
C                             1 compute truncated solution
C                             2 compute minimal length least squares sol
C                   The inexperienced user is advised to set MODE=0
C
C     NP            The first NP rows of A will not be interchanged
C                   with other rows even though the pivot strategy
C                   would suggest otherwise.
C                   The inexperienced user is advised to set NP=0.
C
C     WORK()        A real work array dimensioned 5*M.  However, if
C                   RE or AE have been specified as vectors, dimension
C                   WORK 4*M. If both RE and AE have been specified
C                   as vectors, dimension WORK 3*M.
C
C     LW            Actual dimension of WORK
C
C     IWORK()       Integer work array dimensioned at least N+M.
C
C     LIW           Actual dimension of IWORK.
C
C
C     INFO          Is a flag which provides for the efficient
C                   solution of subsequent problems involving the
C                   same A but different B.
C                   If INFO = 0 original call
C                      INFO = 1 subsequent calls
C                   On subsequent calls, the user must supply A, KRANK,
C                   LW, IWORK, LIW, and the first 2*M locations of WORK
C                   as output by the original call to ULSIA. MODE must
C                   be equal to the value of MODE in the original call.
C                   If MODE.LT.2, only the first N locations of WORK
C                   are accessed. AE, RE, KEY, and NP are not accessed.
C
C
C
C
C     Output..
C
C     A(,)          Contains the lower triangular part of the reduced
C                   matrix and the transformation information. It togeth
C                   with the first M elements of WORK (see below)
C                   completely specify the LQ factorization of A.
C
C     B(,)          Contains the N by NB solution matrix for X.
C
C     KRANK,KSURE   The numerical rank of A,  based upon the relative
C                   and absolute bounds on uncertainty, is bounded
C                   above by KRANK and below by KSURE. The algorithm
C                   returns a solution based on KRANK. KSURE provides
C                   an indication of the precision of the rank.
C
C     RNORM()       Contains the Euclidean length of the NB residual
C                   vectors  B(I)-AX(I), I=1,NB. If the matrix A is of
C                   full rank, then RNORM=0.0.
C
C     WORK()        The first M locations of WORK contain values
C                   necessary to reproduce the Householder
C                   transformation.
C
C     IWORK()       The first N locations contain the order in
C                   which the columns of A were used. The next
C                   M locations contain the order in which the
C                   rows of A were used.
C
C     INFO          Flag to indicate status of computation on completion
C                  -1   Parameter error(s)
C                   0 - Rank deficient, no solution
C                   1 - Rank deficient, truncated solution
C                   2 - Rank deficient, minimal length least squares sol
C                   3 - Numerical rank 0, zero solution
C                   4 - Rank .LT. NP
C                   5 - Full rank
C
C***REFERENCES  T. Manteuffel, An interval analysis approach to rank
C                 determination in linear least squares problems,
C                 Report SAND80-0655, Sandia Laboratories, June 1980.
C***ROUTINES CALLED  R1MACH, U11US, U12US, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   810801  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900510  Fixed an error message.  (RWC)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  ULSIA
      DIMENSION A(MDA,*),B(MDB,*),RE(*),AE(*),RNORM(*),W(*)
      INTEGER IWORK(*)
C
C***FIRST EXECUTABLE STATEMENT  ULSIA
      IF(INFO.LT.0 .OR. INFO.GT.1) GO TO 514
      IT=INFO
      INFO=-1
      IF(NB.EQ.0 .AND. IT.EQ.1) GO TO 501
      IF(M.LT.1) GO TO 502
      IF(N.LT.1) GO TO 503
      IF(N.LT.M) GO TO 504
      IF(MDA.LT.M) GO TO 505
      IF(LIW.LT.M+N) GO TO 506
      IF(MODE.LT.0 .OR. MODE.GT.3) GO TO 515
      IF(NB.EQ.0) GO TO 4
      IF(NB.LT.0) GO TO 507
      IF(MDB.LT.N) GO TO 508
      IF(IT.EQ.0) GO TO 4
      GO TO 400
    4 IF(KEY.LT.0.OR.KEY.GT.3) GO TO 509
      IF(KEY.EQ.0 .AND. LW.LT.5*M) GO TO 510
      IF(KEY.EQ.1 .AND. LW.LT.4*M) GO TO 510
      IF(KEY.EQ.2 .AND. LW.LT.4*M) GO TO 510
      IF(KEY.EQ.3 .AND. LW.LT.3*M) GO TO 510
      IF(NP.LT.0 .OR. NP.GT.M) GO TO 516
C
      EPS=10.*R1MACH(4)
      M1=1
      M2=M1+M
      M3=M2+M
      M4=M3+M
      M5=M4+M
C
      IF(KEY.EQ.1) GO TO 100
      IF(KEY.EQ.2) GO TO 200
      IF(KEY.EQ.3) GO TO 300
C
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      IF(AE(1).LT.0.0) GO TO 513
      DO 20 I=1,M
      W(M4-1+I)=RE(1)
      W(M5-1+I)=AE(1)
   20 CONTINUE
      CALL U11US(A,MDA,M,N,W(M4),W(M5),MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      GO TO 400
C
  100 CONTINUE
      IF(AE(1).LT.0.0) GO TO 513
      DO 120 I=1,M
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      W(M4-1+I)=AE(1)
  120 CONTINUE
      CALL U11US(A,MDA,M,N,RE,W(M4),MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      GO TO 400
C
  200 CONTINUE
      IF(RE(1).LT.0.0) GO TO 511
      IF(RE(1).GT.1.0) GO TO 512
      IF(RE(1).LT.EPS) RE(1)=EPS
      DO 220 I=1,M
      W(M4-1+I)=RE(1)
      IF(AE(I).LT.0.0) GO TO 513
  220 CONTINUE
      CALL U11US(A,MDA,M,N,W(M4),AE,MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
      GO TO 400
C
  300 CONTINUE
      DO 320 I=1,M
      IF(RE(I).LT.0.0) GO TO 511
      IF(RE(I).GT.1.0) GO TO 512
      IF(RE(I).LT.EPS) RE(I)=EPS
      IF(AE(I).LT.0.0) GO TO 513
  320 CONTINUE
      CALL U11US(A,MDA,M,N,RE,AE,MODE,NP,KRANK,KSURE,
     1            W(M1),W(M2),W(M3),IWORK(M1),IWORK(M2))
C
C     DETERMINE INFO
C
  400 IF(KRANK.NE.M) GO TO 402
          INFO=5
          GO TO 410
  402 IF(KRANK.NE.0) GO TO 404
          INFO=3
          GO TO 410
  404 IF(KRANK.GE.NP) GO TO 406
          INFO=4
          RETURN
  406 INFO=MODE
      IF(MODE.EQ.0) RETURN
  410 IF(NB.EQ.0) RETURN
C
C
C     SOLUTION PHASE
C
      M1=1
      M2=M1+M
      M3=M2+M
      IF(INFO.EQ.2) GO TO 420
      IF(LW.LT.M2-1) GO TO 510
      CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(M1),W(M1),IWORK(M1),IWORK(M2))
      RETURN
C
  420 IF(LW.LT.M3-1) GO TO 510
      CALL U12US(A,MDA,M,N,B,MDB,NB,MODE,KRANK,
     1            RNORM,W(M1),W(M2),IWORK(M1),IWORK(M2))
      RETURN
C
C     ERROR MESSAGES
C
  501 CALL XERMSG ('SLATEC', 'ULSIA',
     +   'SOLUTION ONLY (INFO=1) BUT NO RIGHT HAND SIDE (NB=0)', 1, 0)
      RETURN
  502 CALL XERMSG ('SLATEC', 'ULSIA', 'M.LT.1', 2, 1)
      RETURN
  503 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.1', 2, 1)
      RETURN
  504 CALL XERMSG ('SLATEC', 'ULSIA', 'N.LT.M', 2, 1)
      RETURN
  505 CALL XERMSG ('SLATEC', 'ULSIA', 'MDA.LT.M', 2, 1)
      RETURN
  506 CALL XERMSG ('SLATEC', 'ULSIA', 'LIW.LT.M+N', 2, 1)
      RETURN
  507 CALL XERMSG ('SLATEC', 'ULSIA', 'NB.LT.0', 2, 1)
      RETURN
  508 CALL XERMSG ('SLATEC', 'ULSIA', 'MDB.LT.N', 2, 1)
      RETURN
  509 CALL XERMSG ('SLATEC', 'ULSIA', 'KEY OUT OF RANGE', 2, 1)
      RETURN
  510 CALL XERMSG ('SLATEC', 'ULSIA', 'INSUFFICIENT WORK SPACE', 8, 1)
      INFO=-1
      RETURN
  511 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .LT. 0', 2, 1)
      RETURN
  512 CALL XERMSG ('SLATEC', 'ULSIA', 'RE(I) .GT. 1', 2, 1)
      RETURN
  513 CALL XERMSG ('SLATEC', 'ULSIA', 'AE(I) .LT. 0', 2, 1)
      RETURN
  514 CALL XERMSG ('SLATEC', 'ULSIA', 'INFO OUT OF RANGE', 2, 1)
      RETURN
  515 CALL XERMSG ('SLATEC', 'ULSIA', 'MODE OUT OF RANGE', 2, 1)
      RETURN
  516 CALL XERMSG ('SLATEC', 'ULSIA', 'NP OUT OF RANGE', 2, 1)
      RETURN
      END