C
C
C       $Id: terp1.f,v 1.1 1994-08-11 23:17:36 boote Exp $
C
C PACKAGE CUBSPL         NOTE--DOCUMENTATION FOR INDIVIDUAL ROUTINES
C                              FOLLOWS THE GENERAL PACKAGE INFORMATION
C
C LATEST REVISION        JANUARY 1985
C
C PURPOSE                TO PERFORM ONE AND TWO-DIMENSIONAL CUBIC SPLINE
C                        INTERPOLATION WITH CHOICE OF BOUNDARY
C                        CONDITIONS.  THE FUNCTION AND SELECTED
C                        DERIVATIVES MAY BE EVALUATED AT ANY POINT WHERE
C                        INTERPOLATION IS REQUIRED.  IN THE
C                        TWO-DIMENSIONAL CASE, THE GIVEN DATA POINTS
C                        MUST BE ON A RECTANGULAR GRID, WHICH NEED NOT
C                        BE EQUALLY SPACED.  THE PACKAGE CUBSPL CONTAINS
C                        SEVEN ROUTINES.
C
C                        SUBROUTINE COEFF1
C                          COMPUTES THE COEFFICIENTS FOR ONE-DIMENSIONAL
C                          CUBIC SPLINE INTERPOLATION USING ONE OF
C                          THE FOLLOWING BOUNDARY CONDITIONS AT
C                          EACH END OF THE RANGE.
C                            . SECOND DERIVATIVE GIVEN AT BOUNDARY.
C                            . FIRST DERIVATIVE GIVEN AT BOUNDARY.
C                            . PERIODIC BOUNDARY CONDITION.
C                            . FIRST DERIVATIVE DETERMINED BY FITTING A
C                              CUBIC TO THE FOUR POINTS NEAREST TO THE
C                              BOUNDARY.
C
C                        SUBROUTINE TERP1
C                          USING THE COEFFICIENTS COMPUTED BY COEFF1,
C                          THIS ROUTINE EVALUATES THE FUNCTION AND/OR
C                          FIRST AND SECOND DERIVATIVES AT ANY POINT
C                          WHERE INTERPOLATION IS REQUIRED.
C
C                        SUBROUTINE COEFF2
C                          COMPUTES THE COEFFICIENTS FOR TWO-DIMENSIONAL
C                          BICUBIC SPLINE INTERPOLATION WITH THE SAME
C                          CHOICE OF BOUNDARY CONDITIONS AS FOR COEFF1.
C
C                        FUNCTION TERP2
C                          USING THE COEFFICIENTS PRODUCED BY COEFF2,
C                          THIS SUBROUTINE EVALUATES THE FUNCTION OR A
C                          SELECTED DERIVATIVE AT ANY POINT WHERE
C                          TWO-DIMENSIONAL INTERPOLATION IS REQUIRED.
C
C                        SUBROUTINE TRIP
C                          A SIMPLE PERIODIC, TRIDIAGONAL LINEAR
C                          EQUATION SOLVER USED BY COEFF1.
C
C                        SUBROUTINE SEARCH
C                          PERFORMS A BINARY SEARCH IN A ONE-DIMENSIONAL
C                          FLOATING POINT TABLE ARRANGED IN ASCENDING
C                          ORDER.  THIS ROUTINE IS CALLED BY TERP1 AND
C                          TERP2.
C
C                        SUBROUTINE INTERP
C                          GIVEN COEFFICIENTS PROVIDED BY COEFF1 AND THE
C                          POSITION OF THE INTERPOLATION POINT IN THE
C                          INDEPENDENT VARIABLE TABLE, THIS ROUTINE
C                          PERFORMS ONE-DIMENSIONAL INTERPOLATION FOR
C                          THE FUNCTION VALUE, FIRST AND SECOND
C                          DERIVATIVE, AS DESIRED.  THIS ROUTINE IS
C                          CALLED BY TERP1 AND TERP2.
C
C USAGE                  FOR ONE-DIMENSIONAL CUBIC SPLINE INTERPOLATION,
C                        THE USER FIRST CALLS COEFF1 BY
C
C                          CALL COEFF1 (N,X,F,W,IOP,INT,WK)
C
C                        THIS SUBROUTINE RETURNS THE COEFFICIENTS
C                        NEEDED FOR THE SUBSEQUENT INTERPOLATION
C                        IN THE ARRAY W.  THE USER THEN CALLS
C                        SUBROUTINE TERP1 BY
C
C                          CALL TERP1 (N,X,F,W,Y,INT,TAB,ITAB)
C
C                        IN ORDER TO COMPUTE THE VALUE OF THE
C                        FUNCTION AND/OR ITS DERIVATIVES.  THE USER
C                        SPECIFIES Y, THE VALUE OF THE INDEPENDENT
C                        VARIABLE WHERE THE INTERPOLATION IS TO BE
C                        PERFORMED.  THE INTERPOLATED VALUES ARE
C                        RETURNED IN TAB.  THE PARAMETERS
C                        N,X,F,W, AND INT MUST NOT BE CHANGED
C                        BETWEEN THE SUBROUTINE CALLS.
C
C                        FOR TWO-DIMENSIONAL CUBIC SPLINE INTERPOLATION
C                        THE USER FIRST CALLS COEFF2 BY
C
C                          CALL COEFF2 (NX,X,NY,Y,F,FXX,FYY,FXXYY,
C                                       IDM,IBD,WK)
C
C                        THIS SUBROUTINE RETURNS THE COEFFICIENTS
C                        NEEDED FOR THE SUBSEQUENT INTERPOLATION IN
C                        THE ARRAYS FXX, FYY, FXXYY.  THE USER THEN
C                        CALLS THE ROUTINE TERP2 BY
C
C                          R = TERP2 (XB,YB,NX,X,NY,Y,F,FXX,FYY,FXXYY,
C                                     IDM,IXD,IYD)
C
C                        IN ORDER TO PERFORM THE INTERPOLATION AT THE
C                        POINT SPECIFIED BY THE VALUES OF XB AND YB.
C                        DEPENDING ON THE VALUES INPUT IN IXD AND IYD,
C                        THE ROUTINE RETURNS AN INTERPOLATED VALUE
C                        FOR THE FUNCTION OR ONE OF ITS PARTIAL
C                        DERIVATIVES.  THE PARAMETERS NX,X,NY,Y,F,FXX,
C                        FYY,FXXYY, AND IDM MUST NOT BE CHANGED
C                        BETWEEN THE CALLS TO COEFF2 AND TERP2.
C
C SPECIAL CONDITIONS     TABLES OF INDEPENDENT VARIABLES MUST BE
C                        ARRANGED IN ASCENDING ORDER.  FOR
C                        TWO-DIMENSIONAL INTERPOLATION, THE DATA POINTS
C                        MUST LIE ON A RECTANGULAR MESH.
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       NONE
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                THIS PACKAGE IS BASED ON THE ROUTINES
C                            LA E 102A, SPL1D1
C                            LA E 103A, SPL1D2
C                            LA E 104A, SPL2D1
C                            LA E 105A, SPL2D2
C                        OF THE LOS ALAMOS CUBIC SPLINE PACKAGE WRITTEN
C                        BY THOMAS J. JORDAN AND BERTHA FAGAN, 1968.
C                        THE ROUTINES HAVE BEEN STREAMLINED AND
C                        STANDARDIZED.  THE ALGORITHM FOR
C                        TWO-DIMENSIONAL INTERPOLATION IS CONSIDERABLY
C                        MODIFIED.
C
C ALGORITHM              FOR ONE-DIMENSIONAL INTERPOLATION, THE CUBIC
C                        SPLINE IS EXPRESSED IN TERMS OF THE FUNCTION
C                        VALUES AND SECOND DERIVATIVES AT THE DATA
C                        POINTS.  THE SECOND DERIVATIVES ARE
C                        DETERMINED FROM A TRIDIAGONAL LINEAR SYSTEM
C                        WHICH DESCRIBES THE CONTINUITY OF THE FIRST
C                        DERIVATIVE AND INCORPORATES THE GIVEN
C                        BOUNDARY CONDITIONS.  COEFF1  SETS UP THIS
C                        SYSTEM AND CALLS SUBROUTINE TRIP TO SOLVE IT.
C
C                        THE CUBIC SEGMENT BETWEEN TWO ADJACENT
C                        TABULAR POINTS IS CONSTRUCTED FROM THE
C                        FUNCTION VALUES AND SECOND DERIVATIVES AT
C                        THESE POINTS.  THESE PROVIDE THE FOUR
C                        CONSTANTS NEEDED TO DEFINE THE CUBIC
C                        UNIQUELY.  FROM THIS CUBIC, VALUES OF THE
C                        FUNCTION AND ITS FIRST AND SECOND
C                        DERIVATIVES ARE READILY DETERMINED AT ANY
C                        INTERMEDIATE POINT.  ONE-DIMENSIONAL
C                        INTERPOLATION IS PERFORMED BY THE ROUTINE
C                        TERP1.  FOR TWO-DIMENSIONAL INTERPOLATION,
C                        THE BICUBIC SPLINE IS DESCRIBED IN TERMS OF
C                        VALUES OF F,FXX,FYY, AND FXXYY  AT EACH
C                        POINT ON THE GIVEN TWO-DIMENSIONAL
C                        RECTANGULAR GRID OF DATA POINTS.  HERE F
C                        IS THE FUNCTION VALUE,
C
C                          FXX = (D/DX)**2*F
C
C                        AND SO ON.  THE COEFFICIENTS ARE DETERMINED
C                        BY COEFF2, WHICH USES SUCCESSIVE
C                        APPLICATIONS OF COEFF1.
C
C                        1.  THE ARRAY FXX IS DETERMINED BY APPLYING
C                            COEFF1 TO F ALONG EACH LINE IN THE
C                            X-DIRECTION.
C
C                        2.  THE ARRAY FYY IS DETERMINED BY APPLYING
C                            COEFF1 TO F ALONG EACH LINE IN THE
C                            Y-DIRECTION.
C
C                        3.  FXXYY IS DETERMINED ON THE CONSTANT Y
C                            BOUNDARIES BY APPLYING COEFF1 TO FYY
C                            ALONG THESE BOUNDARIES.
C
C                        4.  THE REMAINDER OF THE ARRAY FXXYY IS
C                            DETERMINED BY APPLYING COEFF1 TO FXX
C                            ALONG EACH LINE IN THE Y-DIRECTION.
C
C                        THE BICUBIC WITHIN ANY RECTANGULAR ELEMENT
C                        OF THE GRID IS CONSTRUCTED FROM THE VALUES
C                        OF F,FXX,FYY,FXXYY AT THE FOUR CORNERS.
C                        THESE PROVIDE THE 16 CONSTANTS NECESSARY
C                        TO DEFINE THE BICUBIC UNIQUELY.  TO FIND
C                        THE VALUE OF F CORRESPONDING TO A POINT
C                        (XB,YB) WITHIN THE ELEMENTARY RECTANGLE,
C                        (X(I),Y(J)),(X(I+1),Y(J)),(X(I),Y(J+1)),
C                        (X(I+1),Y(J+1)), FIVE ONE DIMENSIONAL
C                        INTERPOLATIONS ARE PERFORMED.
C
C                        1.  F AT (XB,Y(J)) AND (XB,Y(J+1)) ARE
C                            FOUND BY INTERPOLATING F IN THE
C                            X-DIRECTION USING FXX. (TWO INTERPOLATIONS)
C
C                        2.  FYY AT (XB,Y(J)) AND (XB,Y(J+1)) ARE
C                            FOUND BY INTERPOLATING FYY IN THE
C                            X-DIRECTION USING FXXYY. (TWO
C                            INTERPOLATIONS.)
C
C                        3.  FINALLY F AT (XB,YB) IS FOUND BY
C                        INTERPOLATING BETWEEN F(XB,Y(J)) AND
C                        F(XB,Y(J+1)) IN THE Y-DIRECTION USING
C                        VALUES OF FYY(XB,Y(J)) AND FYY(XB,Y(J+1))
C                        OBTAINED ABOVE. (ONE INTERPOLATION).
C
C                        TWO-DIMENSIONAL INTERPOLATION IS PERFORMED
C                        IN TERP2.
C
C REFERENCES             FOR GREATER DETAIL, SEE J.L.WALSH,
C                        J.H.AHLBERG, E.N.NILSEN, BEST APPROXIMATION
C                        PROPERTIES OF THE SPLINE FIT, JOURNAL OF
C                        MATHEMATICS AND MECHANICS, VOL.II(1962),
C                        225-234.
C
C                        T.L. JORDAN, SMOOTHING AND MULTIVARIABLE
C                        INTERPOLATION WITH SPLINES, LOS ALAMOS
C                        REPORT, LA-3137, 1965.
C
C ACCURACY               NEAR MACHINE ACCURACY WAS OBTAINED WHEN
C                        INTERPOLATING A CUBIC IN ONE DIMENSION
C                        OR A BICUBIC IN TWO DIMENSIONS.
C
C PORTABILITY            FULLY PORTABLE WITH RESPECT TO FORTRAN 66.
C***********************************************************************
C
C SUBROUTINE COEFF1 (N,X,F,W,IOP,INT,WK)
C
C DIMENSION OF           X(N),F(INT*(N-1)+1),W(INT*(N-1)+1),IOP(2),
C ARGUMENTS              WK(3*N+1)
C
C PURPOSE                SUBROUTINE COEFF1 COMPUTES THE COEFFICIENTS
C                        FOR ONE-DIMENSIONAL CUBIC SPLINE
C                        INTERPOLATION USING ONE OF THE FOLLOWING
C                        BOUNDARY CONDITIONS AT EACH END OF THE
C                        RANGE
C
C                        .  SECOND DERIVATIVES GIVEN AT BOUNDARY
C                        .  FIRST DERIVATIVE GIVEN AT BOUNDARY
C                        .  PERIODIC BOUNDARY CONDITIONS
C                        .  FIRST DERIVATIVE CALCULATED BY FITTING A
C                           CUBIC TO THE FOUR POINTS NEAREST TO THE
C                           BOUNDARY
C
C                        NOTE THAT TERP1 MUST BE CALLED TO PERFORM
C                        THE INTERPOLATION.
C
C USAGE                  CALL COEFF1 (N,X,F,W,IOP,INT,WK)
C
C ARGUMENTS
C
C ON INPUT               N
C                          THE NUMBER OF DATA POINTS.  N MUST BE AT
C                          LEAST 4.
C
C                        X
C                          TABLE OF N INDEPENDENT VARIABLE VALUES IN
C                          ASCENDING ORDER.  DIMENSION OF X IN CALLING
C                          PROGRAM MUST BE AT LEAST N.
C
C                        F
C                          TABLE OF N CORRESPONDING DEPENDENT VARIABLE
C                          VALUES.  THE VALUES ARE SEPARATED BY INTERVAL
C                          INT.  THIS IS USUALLY UNITY FOR
C                          ONE-DIMENSIONAL INTERPOLATION.  OTHER VALUES
C                          ARE USEFUL WHEN COEFF1 IS INCORPORATED IN A
C                          TWO-DIMENSIONAL INTERPOLATION SCHEME (SEE
C                          COEFF2).  DIMENSION OF F IN THE CALLING
C                          PROGRAM MUST BE AT LEAST (INT*(N-1)+1).
C
C                        IOP
C                          TWO ELEMENT INTEGER ARRAY DEFINING BOUNDARY
C                          CONDITIONS AT X(1) AND X(N) ACCORDING TO THE
C                          FOLLOWING CODE.
C
C                          FOR IOP(1)
C                          = 1  SECOND DERIVATIVE GIVEN AT X(1).  PLACE
C                               VALUE OF SECOND DERIVATIVE IN W(1)
C                               BEFORE CALL TO COEFF1.
C                          = 2  FIRST DERIVATIVE GIVEN AT X(1).  PLACE
C                               VALUE OF FIRST DERIVATIVE IN W(1) BEFORE
C                               CALL.
C                          = 3  PERIODIC BOUNDARY CONDITION.  X(1) AND
C                               X(N) ARE EQUIVALENT POINTS.  F(1) AND
C                               F(INT*(N-1)+1) ARE EQUAL.
C                          = 4  THE FIRST DERIVATIVE AT X(1) IS
C                               CALCULATED BY FITTING A CUBIC TO POINTS
C                               X(1) THROUGH X(4).
C                          SIMILARLY, IOP(2) DEFINES THE BOUNDARY
C                          CONDITION AT X(N).  WHEN IOP(2) = 1 (OR 2),
C                          THE VALUE OF THE SECOND (OR FIRST) DERIVATIVE
C                          MUST BE PLACED IN W(INT*(N-1)+1).  NOTE THAT
C                          IF IOP(1) = 3, CONSISTENCY DEMANDS THAT
C                          IOP(2) = 3 ALSO.
C
C                        INT
C                          SPACING IN F AND W TABLES.  FOR
C                          ONE-DIMENSIONAL INTERPOLATION THIS WILL
C                          USUALLY BE UNITY.
C
C                        WK
C                          WORK AREA OF DIMENSION AT LEAST (3*N+1).
C
C ON OUTPUT              W
C                          TABLE OF SECOND DERIVATIVES CORRESPONDING TO
C                          GIVEN X AND F VALUES.  THE SEPARATION OF
C                          TABULAR ENTRIES IS INT (SEE ABOVE).
C                          DIMENSION OF W IN THE CALLING PROGRAM MUST BE
C                          AT LEAST (INT*(N-1)+1).
C
C                          THE ARRAYS X, F, W ARE USED AS INPUT FOR THE
C                          ROUTINE TERP1, WHICH PERFORMS INTERPOLATION
C                          AT A GIVEN VALUE OF THE INDEPENDENT VARIABLE.
C
C TIMING                 THE TIMING IS LINEARLY PROPORTIONAL TO N, THE
C                        NUMBER OF DATA POINTS.
C***********************************************************************
C
C     SUBROUTINE TERP1 (N,X,F,W,Y,INT,TAB,ITAB)
C
C
C DIMENSION OF           X(N),F(INT*(N-1)+1),W(INT*(N-1)+1),TAB(3),
C ARGUMENTS              ITAB(3)
C
C PURPOSE                USING THE COEFFICIENTS COMPUTED BY COEFF1,
C                        THIS ROUTINE EVALUATES THE FUNCTION AND/OR
C                        FIRST AND SECOND DERIVATIVES AT ANY POINT.
C
C USAGE                  CALL TERP1 (N,X,F,W,Y,INT,TAB,ITAB)
C
C ARGUMENTS
C
C ON INPUT               N
C                          THE NUMBER OF DATA POINTS.  N MUST BE AT
C                          LEAST 4.
C
C                        X
C                          TABLE OF N INDEPENDENT VARIABLE VALUES IN
C                          ASCENDING ORDER.  DIMENSION OF X IN THE
C                          CALLING PROGRAM MUST BE AT LEAST N.
C
C                        F
C                          TABLE OF N CORRESPONDING DEPENDENT VARIABLE
C                          VALUES SEPARATED BY INTERVAL INT, USUALLY
C                          UNITY FOR ONE-DIMENSIONAL INTERPOLATION.
C                          DIMENSION OF F IN THE CALLING PROGRAM MUST BE
C                          AT LEAST (INT*(N-1)+1).
C
C                        W
C                          TABLE OF SECOND DERIVATIVES COMPUTED BY
C                          COEFF1.  THE SEPARATION OF TABULAR ENTRIES IS
C                          INT.  DIMENSION OF W IN THE CALLING PROGRAM
C                          MUST BE AT LEAST (INT*(N-1)+1).
C
C                        Y
C                          VALUE OF THE INDEPENDENT VARIABLE AT WHICH
C                          INTERPOLATION IS REQUIRED.  IF Y LIES OUTSIDE
C                          THE RANGE OF THE TABLE, EXTRAPOLATION TAKES
C                          PLACE.
C
C                        INT
C                          SPACING OF TABULAR ENTRIES IN F AND W ARRAYS.
C                          THIS IS USUALLY UNITY FOR ONE-DIMENSIONAL
C                          INTERPOLATION.
C
C                        ITAB
C                          THREE ELEMENT INTEGER ARRAY DEFINING
C                          INTERPOLATION TO BE PERFORMED AT Y.
C                            IF ITAB(1) = 1, THE FUNCTION VALUE IS
C                                            RETURNED IN TAB(1).
C                            IF ITAB(2) = 1, THE FIRST DERIVATIVE IS
C                                            RETURNED IN TAB(2).
C                            IF ITAB(3) = 1, THE SECOND DERIVATIVE IS
C                                            RETURNED IN TAB(3).
C                          IF ITAB(I) = 0 FOR I = 1, 2 OR 3, THE
C                          CORRESPONDING FUNCTION VALUE OR DERIVATIVE IS
C                          NOT COMPUTED AND TAB(I) IS NOT REFERENCED.
C
C ON OUTPUT              TAB
C                          THREE ELEMENT ARRAY IN WHICH INTERPOLATED
C                          FUNCTION VALUE, FIRST AND SECOND DERIVATIVES
C                          ARE RETURNED AS DICTATED BY ITAB (SEE ABOVE).
C
C TIMING                 THIS PROCEDURE IS FAST.  THE MAXIMUM TIME FOR
C                        THE BINARY SEARCH IS PROPORTIONAL TO ALOG(N).
C                        THE TIME FOR FUNCTION AND DERIVATIVE EVALUATION
C                        IS INDEPENDENT OF N.
C***********************************************************************
C
C     SUBROUTINE COEFF2 (NX,X,NY,Y,F,FXX,FYY,FXXYY,IDM,IBD,WK)
C
C
C DIMENSION OF           X(NX),Y(NY),F(IDM,NY),FXX(IDM,NY),FYY(IDM,NY),
C ARGUMENTS              FXXYY(IDM,NY),IBD(4),WK(3*MAX0(NX,NY)+1)
C                        (IDM MUST BE .GE. NX)
C
C PURPOSE                SUBROUTINE COEFF2 COMPUTES THE COEFFICIENTS
C                        FOR TWO-DIMENSIONAL BICUBIC SPLINE
C                        INTERPOLATION WITH THE SAME CHOICE OF
C                        BOUNDARY CONDITIONS AS FOR COEFF1.  TERP2
C                        IS CALLED TO PERFORM INTERPOLATION.
C
C USAGE                  CALL COEFF2 (NX,X,NY,Y,F,FXX,FYY,FXXYY,IDM,IBD,
C                                     WK)
C
C ARGUMENTS
C
C ON INPUT               NX
C                          NUMBER OF GRID POINTS IN THE X-DIRECTION.  NX
C                          MUST BE AT LEAST 4.
C
C                        X
C                          TABLE OF NX VALUES OF THE FIRST INDEPENDENT
C                          VARIABLE ARRANGED IN ASCENDING ORDER.
C                          DIMENSION OF X IN THE CALLING PROGRAM MUST BE
C                          AT LEAST NX.
C
C                        NY
C                          NUMBER OF GRID POINTS IN THE Y-DIRECTION.  NY
C                          MUST BE AT LEAST 4.
C
C                        Y
C                          TABLE OF NY VALUES OF THE SECOND INDEPENDENT
C                          VARIABLE ARRANGED IN ASCENDING ORDER.
C                          DIMENSION OF Y IN THE CALLING PROGRAM MUST BE
C                          AT LEAST NY.
C
C                        F
C                          TWO DIMENSIONAL ARRAY OF FUNCTION VALUES AT
C                          THE GRID POINTS DEFINED BY THE ARRAYS X AND
C                          Y.  DIMENSION OF F IN THE CALLING PROGRAM IS
C                          (IDM, NYY) WHERE
C                              IDM .GE. NX
C                              NYY .GE. NY
C
C                        IDM
C                          FIRST DIMENSION IN THE CALLING PROGRAM OF
C                          ARRAYS F, FXX, FYY, FXXYY.  IDM MUST BE AT
C                          LEAST NX.
C
C                        IBD
C                          FOUR ELEMENT INTEGER ARRAY DEFINING BOUNDARY
C                          CONDITIONS ACCORDING TO THE FOLLOWING CODE.
C                          FOR IBD(1)
C                          = 1  THE SECOND DERIVATIVE OF F WITH RESPECT
C                               TO X IS GIVEN AT (X(1),Y(J)) FOR
C                               J = 1,NY,1.  VALUES OF THIS SECOND
C                               DERIVATIVE MUST BE PLACED IN FXX(1,J)
C                               FOR J = 1,NY,1, BEFORE CALLING COEFF2.
C                          = 2  THE FIRST DERIVATIVE OF F WITH RESPECT
C                               TO X IS GIVEN AT (X(1),Y(J)) FOR
C                               J = 1,NY,1.  VALUES OF THE DERIVATIVE
C                               MUST BE PLACED IN FXX(1,J) FOR
C                               J = 1,NY,1 BEFORE CALLING COEFF2.
C                          = 3  PERIODIC BOUNDARY CONDITION IN THE
C                               X-DIRECTION.  (X(1),Y(J)) AND
C                               AND (X(NX),Y(J)) ARE EQUIVALENT POINTS
C                               FOR J = 1,NY,1.  F(1,J) AND F(NX,J) ARE
C                               EQUAL.
C                          = 4  THE FIRST DERIVATIVE OF F WITH RESPECT
C                               TO X AT (X(1),Y(J)) IS COMPUTED BY
C                               FITTING A CUBIC TO F(1,J) THROUGH F(4,J)
C                               FOR J = 1,NY,1.
C
C                          SIMILARLY, IBD(2) DEFINES THE BOUNDARY
C                          CONDITION AT (X(NX),Y(J)) FOR J = 1,NY,1.
C                          WHEN IBD(2) = 1 (OR 2) THE VALUES OF THE
C                          SECOND (OR FIRST) DERIVATIVE OF F WITH
C                          RESPECT TO X ARE PLACED IN FXX(NX,J) FOR
C                          J = 1,NY,1.
C                            NOTE THAT IF IBD(1) = 3, CONSISTENCY
C                            REQUIRES THAT IBD(2) = 3 ALSO.
C                          FOR IBD(3)
C                          = 1  THE SECOND DERIVATIVE OF F WITH RESPECT
C                               TO Y IS GIVEN AT (X(I),Y(1)).  PLACE
C                               VALUES OF THE DERIVATIVE IN FYY(I,1) FOR
C                               I = 1,NX,1 BEFORE CALLING COEFF2.
C                          = 2  THE FIRST DERIVATIVE OF F WITH RESPECT
C                               TO Y IS GIVEN AT (X(I),Y(1)).  VALUES OF
C                               THIS DERIVATIVE MUST BE PLACED IN
C                               FYY(I,1) FOR I = 1,NX,1 BEFORE CALLING
C                               COEFF2.
C                          = 3  PERIODIC BOUNDARY CONDITION IN THE
C                               Y-DIRECTION.  (X(I),Y(1)) AND
C                               (X(I),Y(NY)) ARE EQUIVALENT POINTS.
C                               F(I,1) AND F(I,NY) ARE EQUAL.
C                          = 4  THE FIRST DERIVATIVE OF F WITH RESPECT
C                               TO Y AT (X(I),Y(1)) IS COMPUTED BY
C                               FITTING A CUBIC TO F(I,1) THROUGH F(I,4)
C                               FOR I = 1,NX,1.
C
C                          SIMILARY, IBD(4) DEFINES THE BOUNDARY
C                          CONDITION AT (X(I),Y(NY)) FOR I = 1,NX,1 AND
C                          GIVEN DERIVATIVE VALUES ARE PLACED IN
C                          FYY(I,NY).
C                            NOTE THAT CONSISTENCY DEMANDS THAT IF
C                            IBD(3) = 3, THEN IBD(4) = 3 ALSO.
C
C                        WK
C                          WORK AREA OF DIMENSION AT LEAST
C                          (3*MAX0(NX,NY)+1)
C
C ON OUTPUT              FXX
C                          ARRAY OF SECOND DERIVATIVES OF F WITH RESPECT
C                          TO X COMPUTED BY COEFF2.  FXX(I,J) IS
C                          DERIVATIVE AT (X(I),Y(J)).  AS FOR F,
C                          DIMENSION OF FXX IN THE CALLING PROGRAM IS
C                          (IDM,NYY).
C
C                        FYY
C                          ARRAY OF SECOND DERIVATIVES OF F WITH RESPECT
C                          TO Y COMPUTED BY COEFF2.  DIMENSION OF FYY IN
C                          THE CALLING PROGRAM IS (IDM,NYY).
C
C                        FXXYY
C                          ARRAY OF FOURTH DERIVATIVES
C                          (D/DX)**2*(D/DY)**2*F, COMPUTED BY COEFF2.
C                          DIMENSION OF FXXYY IN THE CALLING PROGRAM IS
C                          (IDM,NYY).
C
C                        THE ARRAYS X, Y, F, FXX, FYY, FXXYY ARE USED AS
C                        INPUT FOR THE ROUTINE TERP2 WHICH PERFORMS
C                        INTERPOLATION AT REQUIRED VALUES OF THE TWO
C                        INDEPENDENT VARIABLES.
C
C TIMING                 THE TIMING IS PROPORTIONAL TO NX*NY.
C***********************************************************************
C
C     FUNCTION TERP2 (XB,YB,NX,X,NY,Y,F,FXX,FYY,FXXYY,IDM,IXD,IYD)
C
C
C DIMENSION OF           X(NX),Y(NY),F(IDM,NY),FXX(IDM,NY),FYY(IDM,NY),
C ARGUMENTS              FXXYY(IDM,NY))
C                        (IDM MUST BE .GE. NX)
C
C PURPOSE                USING THE COEFFICIENTS PRODUCED BY COEFF2,
C                        THIS ROUTINE EVALUATES THE FUNCTION ON A
C                        SELECTED DERIVATIVE OF ANY POINT WHERE
C                        TWO-DIMENSIONAL INTERPOLATION IS REQUIRED.
C
C USAGE                  R = TERP2 (XB,YB,NX,X,NY,Y,F,FXX,FYY,FXXYY,IDM,
C                                   IXD,IYD)
C
C ARGUMENTS
C
C ON INPUT               XB, YB
C                          VALUES OF THE INDEPENDENT VARIABLES, X AND Y,
C                          AT WHICH INTERPOLATION IS REQUIRED.
C
C                        NX
C                          NUMBER OF GRID POINTS IN THE X-DIRECTION.  NX
C                          MUST BE AT LEAST 4.
C
C                        X
C                          TABLE OF NX VALUES OF THE INDEPENDENT
C                          VARIABLE, X, ARRANGED IN ASCENDING ORDER.
C                          DIMENSION OF X IN THE CALLING PROGRAM MUST BE
C                          AT LEAST NX.
C
C                        NY
C                          NUMBER OF GRID POINTS IN THE Y-DIRECTION.  NY
C                          MUST BE AT LEAST 4.
C
C                        Y
C                          TABLE OF NY VALUES OF THE INDEPENDENT
C                          VARIABLE, Y, ARRANGED IN ASCENDING ORDER.
C                          DIMENSION OF Y IN THE CALLING PROGRAM MUST BE
C                          AT LEAST NY.
C
C                        F
C                          TWO-DIMENSIONAL ARRAY OF FUNCTION VALUES AT
C                          GRID POINTS DEFINED BY THE ARRAYS X AND Y.
C                          DIMENSION OF F IN THE CALLING PROGRAM IS
C                          (IDM,NYY), WHERE
C                              IDM .GE. NX
C                              NYY .GE. NY
C
C                        FXX
C                          ARRAY OF SECOND DERIVATIVES OF F WITH RESPECT
C                          TO X COMPUTED BY COEFF2.  DIMENSION OF FXX IN
C                          THE CALLING PROGRAM IS (IDM,NYY).  SEE UNDER
C                          F ABOVE.
C
C                        FYY
C                          ARRAY OF SECOND DERIVATIVES OF F WITH RESPECT
C                          TO Y COMPUTED BY COEFF2.  DIMENSION OF FYY IN
C                          THE CALLING PROGRAM IS (IDM,NYY).
C
C                        FXXYY
C                          ARRAY OF FOURTH DERIVATIVES,
C                          (D/DX)**2*(D/DY)**2*F, COMPUTED BY COEFF2.
C                          DIMENSION OF FXXYY IN THE CALLING PROGRAM IS
C                          (IDM,NYY).
C
C                        IDM
C                          FIRST DIMENSION IN THE CALLING PROGRAM OF
C                          ARRAYS F, FXX, FYY AND FXXYY,
C                              IDM .GE. NX
C
C                        IXD, IYD
C                          DEFINE DERIVATIVE TO BE RETURNED BY THE
C                          FUNCTION TERP2.  IXD, IYD MAY EACH TAKE THE
C                          THE VALUES 0, 1, 2.  THE DERIVATIVE RETURNED
C                          IS (D/DX)**IXD*(D/DY)**IYD*F.
C                            NOTE THAT IF IXD = IYD = 0, THE FUNCTION
C                            VALUE ITSELF IS RETURNED.
C
C TIMING                 THIS PROCEDURE IS FAST.  THE MAXIMUM
C                        TIME FOR THE BINARY SEARCH IS PROPORTIONAL TO
C                        ALOG(NX*NY).  THE TIME FOR FUNCTION EVALUATION
C                        IS INDEPENDENT OF N.
C***********************************************************************
      SUBROUTINE TERP1 (N,X,F,W,Y,INT,TAB,ITAB)
C
      DIMENSION       X(1)       ,F(1)       ,W(1)       ,TAB(3)     ,
     1                ITAB(3)
      SAVE
C
C PERFORM SEARCH
C
      CALL SEARCH (Y,X,N,I)
C
C CARRY OUT INTERPOLATION (OR EXTRAPOLATION)
C
      CALL INTERP (N,X,F,W,Y,I,INT,TAB,ITAB)
      RETURN
      END


subroutine colinearity(axis, origin, coords, n, x, nCon)
  implicit none
  real, dimension(3)::origin, axis
  real, dimension(n,3)::coords
  real, dimension(nCon)::x
  integer:: n, nCon

  real, dimension(n,3)::dirVec
  real, dimension(3)::resultDir
  integer:: i,j

  !Compute the direction from each point to the origin
  do i = 1,n
     do j = 1,3
        dirVec(i,j) = origin(j)-coords(i,j)
     end do
  end do

  ! compute the cross product with the desired axis. Cross product
  ! will be zero if the direction vector is the same as the axis

 !$AD II-LOOP
  do i=1,nCon
     resultDir = cross(axis,dirVec(i,:))

     x(i) = 0
     do j =1,3
        x(i) = x(i)+(resultDir(j))**2
     end do
     x(i) = sqrt(x(i))
  end do

end subroutine colinearity

subroutine planarity(axis, origin, p0, p1, p2, n, x, nCon)
  implicit none
  real, dimension(3)::origin, axis
  real, dimension(n,3)::p0,p1,p2
  real, dimension(nCon)::x
  integer:: n, nCon

  real, dimension(3*n,3)::allPoints,dist
  real, dimension(3*n)::scalarDist
  real :: tmp
  integer:: i, j

  ! copy data into all points array
  allPoints(1:n,:) = p0
  allPoints(n:2*n,:) = p1
  allPoints(2*n:3*n,:) = p2

  ! Compute the distance from the origin to each point
  x(1) = 0
  do i=1,n*3
     do j=1,3
        dist(i,j) = allPoints(i,j)-origin(j)
     end do

     !project it onto the axis
     !x(i) = dot_product(axis,dist(i,:))
     call dot(axis,dist(i,:),scalarDist(i))
     x(1) = x(1)+ scalarDist(i)**2!/(n*3)

  end do
  x(1) = sqrt(x(1))

end subroutine planarity

FUNCTION cross(a, b)
  real, DIMENSION(3) :: cross
  real, DIMENSION(3), INTENT(IN) :: a, b

  cross(1) = a(2) * b(3) - a(3) * b(2)
  cross(2) = a(3) * b(1) - a(1) * b(3)
  cross(3) = a(1) * b(2) - a(2) * b(1)
END FUNCTION cross

subroutine computeArea(p0, p1, p2, n, area)
    real, dimension (n,3):: p0, p1, p2, v1, v2
    real, dimension (n,3):: crosses
    real, dimension (n):: areas
    real, INTENT(OUT) :: area
    integer :: n
    v1 = 0.
    v2 = 0.
    crosses = 0.
    areas = 0.
    !$AD II-LOOP
    do i=1,n
        do j = 1,3
            v1(i,j) = p1(i,j) - p0(i,j)
            v2(i,j) = p2(i,j) - p0(i,j)
        end do
        crosses(i,:) = cross(v1(i,:),v2(i,:))
        do j = 1,3
            areas(i) = areas(i) + crosses(i,j)**2
        end do
        areas(i) = sqrt(areas(i))
    end do
    area = sum(areas)/2.
end subroutine

subroutine normalLengths(center, coords,n, X, nCon)

real, dimension(3)::center
real, dimension(n,3)::coords
real, dimension(nCon)::X
integer:: n,nCon

real ::refLength2,length2

refLength2 = 0
do i =1,3
 refLength2 = refLength2+(center(i)-coords(1,i))**2
end do

!$AD II-LOOP
do i =1,nCon
   length2 = 0
   do j =1,3
      Length2 = length2+(center(j)-coords(i+1,j))**2
   end do
   x(i) = sqrt(length2/reflength2)
end do
end subroutine normalLengths

SUBROUTINE PROJAREA(n, p0, p1, p2, axis, area)

  IMPLICIT NONE
! Input
  INTEGER, INTENT(IN) :: n
  REAL*8, INTENT(IN) :: p0(n, 3), p1(n, 3), p2(n, 3), axis(3)
! Output
  REAL*8, INTENT(OUT) :: area
! Working
  INTEGER :: i
  REAL*8 :: v1(3), v2(3), savec(3), pa
  DO i=1,n
    v1 = p1(i, :) - p0(i, :)
    v2 = p2(i, :) - p0(i, :)
    !CALL CROSS(v1, v2, savec)
    savec = CROSS(v1, v2)
    CALL DOT(savec, axis, pa)
    IF (pa .GT. 0) THEN
      area = area + pa
    ELSE
      pa = 0
    END IF
  END DO
  area = area/2.0

END SUBROUTINE PROJAREA

SUBROUTINE DOT(a, b, c)

  IMPLICIT NONE
  REAL*8, INTENT(IN) :: a(3), b(3)
  REAL*8, INTENT(OUT) :: c

  c = a(1)*b(1) + a(2)*b(2) + a(3)*b(3)

END SUBROUTINE DOT


*DECK RSGBA
      SUBROUTINE RSGBA (NM, N, A, B, W, MATZ, Z, FV1, FV2, IERR)
C***BEGIN PROLOGUE  RSGBA
C***PURPOSE  Compute the eigenvalues and, optionally, the eigenvectors
C            of a symmetric generalized eigenproblem.
C***LIBRARY   SLATEC (EISPACK)
C***CATEGORY  D4B1
C***TYPE      SINGLE PRECISION (RSGBA-S)
C***KEYWORDS  EIGENVALUES, EIGENVECTORS, EISPACK
C***AUTHOR  Smith, B. T., et al.
C***DESCRIPTION
C
C     This subroutine calls the recommended sequence of
C     subroutines from the eigensystem subroutine package (EISPACK)
C     to find the eigenvalues and eigenvectors (if desired)
C     for the REAL SYMMETRIC generalized eigenproblem  BAx = (LAMBDA)x.
C
C     On Input
C
C        NM must be set to the row dimension of the two-dimensional
C          array parameters, A, B, and Z, as declared in the calling
C          program dimension statement.  NM is an INTEGER variable.
C
C        N is the order of the matrices A and B.  N is an INTEGER
C          variable.  N must be less than or equal to NM.
C
C        A contains a real symmetric matrix.  A is a two-dimensional
C          REAL array, dimensioned A(NM,N).
C
C        B contains a positive definite real symmetric matrix.  B is a
C          two-dimensional REAL array, dimensioned B(NM,N).
C
C        MATZ is an INTEGER variable set equal to zero if only
C          eigenvalues are desired.  Otherwise, it is set to any
C          non-zero integer for both eigenvalues and eigenvectors.
C
C     On Output
C
C        W contains the eigenvalues in ascending order.  W is a
C          one-dimensional REAL array, dimensioned W(N).
C
C        Z contains the eigenvectors if MATZ is not zero.  Z is a
C          two-dimensional REAL array, dimensioned Z(NM,N).
C
C        IERR is an INTEGER flag set to
C          Zero       for normal return,
C          10*N       if N is greater than NM,
C          7*N+1      if B is not positive definite,
C          J          if the J-th eigenvalue has not been
C                     determined after 30 iterations.
C                     The eigenvalues should be correct for indices
C                     1, 2, ..., IERR-1, but no eigenvectors are
C                     computed.
C
C        FV1 and FV2 are one-dimensional REAL arrays used for temporary
C          storage, dimensioned FV1(N) and FV2(N).
C
C     Questions and comments should be directed to B. S. Garbow,
C     APPLIED MATHEMATICS DIVISION, ARGONNE NATIONAL LABORATORY
C     ------------------------------------------------------------------
C
C***REFERENCES  B. T. Smith, J. M. Boyle, J. J. Dongarra, B. S. Garbow,
C                 Y. Ikebe, V. C. Klema and C. B. Moler, Matrix Eigen-
C                 system Routines - EISPACK Guide, Springer-Verlag,
C                 1976.
C***ROUTINES CALLED  REBAKB, REDUC2, TQL2, TQLRAT, TRED1, TRED2
C***REVISION HISTORY  (YYMMDD)
C   760101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  RSGBA
C
      INTEGER N,NM,IERR,MATZ
      REAL A(NM,*),B(NM,*),W(*),Z(NM,*),FV1(*),FV2(*)
C
C***FIRST EXECUTABLE STATEMENT  RSGBA
      IF (N .LE. NM) GO TO 10
      IERR = 10 * N
      GO TO 50
C
   10 CALL  REDUC2(NM,N,A,B,FV2,IERR)
      IF (IERR .NE. 0) GO TO 50
      IF (MATZ .NE. 0) GO TO 20
C     .......... FIND EIGENVALUES ONLY ..........
      CALL  TRED1(NM,N,A,W,FV1,FV2)
      CALL  TQLRAT(N,W,FV2,IERR)
      GO TO 50
C     .......... FIND BOTH EIGENVALUES AND EIGENVECTORS ..........
   20 CALL  TRED2(NM,N,A,W,FV1,Z)
      CALL  TQL2(NM,N,W,FV1,Z,IERR)
      IF (IERR .NE. 0) GO TO 50
      CALL  REBAKB(NM,N,B,FV2,N,Z)
   50 RETURN
      END


      SUBROUTINE svbksb(u,w,v,m,n,mp,np,b,x)
      INTEGER m,mp,n,np,NMAX
      REAL b(mp),u(mp,np),v(np,np),w(np),x(np)
      PARAMETER (NMAX=500)
      INTEGER i,j,jj
      REAL s,tmp(NMAX)
      do 12 j=1,n
        s=0.
        if(w(j).ne.0.)then
          do 11 i=1,m
            s=s+u(i,j)*b(i)
11        continue
          s=s/w(j)
        endif
        tmp(j)=s
12    continue
      do 14 j=1,n
        s=0.
        do 13 jj=1,n
          s=s+v(j,jj)*tmp(jj)
13      continue
        x(j)=s
14    continue
      return
      END

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


      INTEGER FUNCTION INAREA (PX,PY, ILIM, X, Y)

C    Given a 2D point and fill area, determine whether point
C    is within the area, on edge, or outside.

C  Input parameters:
C    PX,PY  : 2D point
C    ILIM   : Number of vertices of fill area
C    X,Y    : vertices of fill area

C   Function returns:
C       1 : inside
C       2 : on an edge
C       3 : outside

C  Idea here is to generate a ray straight up from px,py (positive
C  y-direction), and see how many times it crosses the border.

      INTEGER   ILIM, CURSGN, IA,IB, IX, IPREV, ICROSS, ICT,ICUR

      REAL      PX,PY, X(*), Y(*), XA,YA,XB,YB, A,B,C
      REAL      XCUR,YCUR, XPREV,YPREV, YINT

C  First see if px,py is on any edge:
      DO 100 IA = 1,ILIM
         IB = MOD(IA,ILIM) + 1
         XA = X(IA)
         YA = Y(IA)
         XB = X(IB)
         YB = Y(IB)
C Given two points, calculate line coefficients
         CALL PT2COF (XA,YA, XB,YB, A,B,C)
C if not co-linear, skip
         IF (A*PX + B*PY + C .NE. 0.0) GOTO 100
C if px,py between points, it's on edge:
         IF ((XA-PX)*(XB-PX) .LE. 0 .AND.
     1       (YA-PY)*(YB-PY) .LE. 0)   THEN
            INAREA = 2
            RETURN
         ENDIF
100   CONTINUE

C OK, assume from here on that point is not on an edge;
C get point off y-axis
      DO 200 IX = 1,ILIM
         IF (X(IX) .EQ. PX) GOTO 200
         IF (X(IX) .LT. PX) THEN
            CURSGN = -1
         ELSE
            CURSGN = +1
         ENDIF
         IPREV = IX
         GOTO 210
200   CONTINUE
      INAREA = 3
      RETURN

210   CONTINUE
      ICROSS = 0
      XPREV = X(IPREV)
      YPREV = Y(IPREV)

C start of loop for checking edge segments
      DO 300 ICT = 0,ILIM-1
         ICUR = MOD(IPREV+ICT, ILIM) + 1
         XCUR = X(ICUR)
         YCUR = Y(ICUR)
C if not a definite crossing of y-axis (equal doesn't count),
C save last point and keep going ...
         IF ( (XCUR-PX)*CURSGN .GE. 0) GOTO 290

C crossed y-axis
         CURSGN = -CURSGN

C last two points (cur and prev) determine whether crossing above
C or below px,py:
         CALL PT2COF (XCUR,YCUR, XPREV,YPREV, A,B,C)

C formula for y-intercept of line:a,b,c and line:x=px
         YINT = -(A*PX + C) / B

         IF     (YINT .GT. PY) THEN
            ICROSS = ICROSS+1
         ELSEIF (YINT .EQ. PY) THEN
C aha - on edge after all ..
            INAREA = 2
            RETURN
         ENDIF

290      CONTINUE
         XPREV = XCUR
         YPREV = YCUR
300   CONTINUE
      INAREA = 3 - 2*MOD(ICROSS,2)

      END


      subroutine resid_beta_hgd_adv(ctfmp,n_BB,n_beta,np1_BB,np1_beta,x,
     &Nx,advc,ht,hx,mus,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 advc
      real*8 ht
      real*8 hx
      real*8 mus
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_BB(Nx)
      real*8 n_beta(Nx)
      real*8 np1_BB(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res
      real*8 qb
      res = 0.0D0
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = np1_beta(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      do i=2, Nx-1, 1
      qb = (-0.1D1 * n_beta(i) + np1_beta(i)) / ht - 0.2500000000000000D
     #0 * advc * np1_beta(i) * (-0.1D1 * np1_beta(i - 1) + np1_beta(i +
     #1)) / hx / ctfmp(i) - 0.5000000000000000D0 * mus * np1_BB(i) - 0.2
     #500000000000000D0 * advc * n_beta(i) * (-0.1D1 * n_beta(i - 1) + n
     #_beta(i + 1)) / hx / ctfmp(i) - 0.5000000000000000D0 * mus * n_BB(
     #i)
      res = res + qb**2
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = np1_beta(i) + myzero * x(i)
      res = res + qb**2
      end do
      endif
      res = sqrt(res/(1*Nx))
      END


! one dimensional fourier transform, to use this subroutine
! 1.define {emin,de} and make them common in the main program
! 2.define an output array for {out}
	program main

	implicit real*8(a-h,o-z)
	integer*4 Nt,i,j
	real*8 dt,Emax,x,x0,p0,a0,Pi,t(nt)
	real*8 ymin,y,en,emin,de
	complex*16 :: data(Nt)
	complex*16,intent(OUT) :: out(Nt)
        complex*16 :: im

        open(100,file='fft.dat',status='new')

	open(10,file='corr')
        do i=1,nt
          read(10,*) t(i), data(i)
        enddo

	Emax = 0.1d0
	im = (0d0,1d0)
	Pi = 4.0d0*atan(1d0)

        de = 1d0/(Nt*dt)
        emin = -0.18d0
        out = (0d0,0d0)

	i = 1
	do while (Emin+(i-1)*de < Emax)

        en = Emin + (i-1)*de
!	if(en > Emax) goto 100
        do j=1,Nt
          t = 0d0 +j*dt
!	data(j) = exp(-a0*(x-x0)**2+im*p0*(x-x0))
          out(i) = data(j)*exp(im*en*t)*dt + out(i)
        enddo

        i = i+1

        write(100,1000) y,out(i)
        end do

1000    format(1000(e14.7,1x))

        return
        end program


subroutine regcoil_diagnostics(ilambda)

  use regcoil_variables
  use stel_constants
  use stel_kinds

  implicit none

  integer, intent(in) :: ilambda
  integer :: tic, toc, countrate
  real(dp) :: factor_theta, factor_zeta
  integer :: itheta, izeta

  call system_clock(tic,countrate)

  factor_zeta  = net_poloidal_current_Amperes / twopi
  factor_theta = net_toroidal_current_Amperes / twopi

  single_valued_current_potential_mn(:,ilambda) = solution
  this_current_potential = reshape(matmul(basis_functions, solution), (/ ntheta_coil, nzeta_coil /)) ! Could use BLAS2 for this line for extra speed.
  single_valued_current_potential_thetazeta(:,:,ilambda) = this_current_potential
  do izeta = 1,nzeta_coil
     do itheta = 1,ntheta_coil
        this_current_potential(itheta,izeta) = this_current_potential(itheta,izeta) &
             + factor_zeta*zeta_coil(izeta) + factor_theta*theta_coil(itheta)
     end do
  end do
  current_potential(:,:,ilambda) = this_current_potential

  KDifference_x = d_x - matmul(f_x, solution)
  KDifference_y = d_y - matmul(f_y, solution)
  KDifference_z = d_z - matmul(f_z, solution)
  KDifference_Laplace_Beltrami = d_Laplace_Beltrami - matmul(f_Laplace_Beltrami, solution)
  this_K2_times_N = reshape(KDifference_x*KDifference_x + KDifference_y*KDifference_y + KDifference_z*KDifference_z, (/ ntheta_coil, nzeta_coil /)) &
       / norm_normal_coil
  this_Laplace_Beltrami2_times_N = reshape(KDifference_Laplace_Beltrami*KDifference_Laplace_Beltrami, (/ ntheta_coil, nzeta_coil /)) &
       / norm_normal_coil
  chi2_K(ilambda) = nfp * dtheta_coil * dzeta_coil * sum(this_K2_times_N)
  K2(:,:,ilambda) = this_K2_times_N / norm_normal_coil
  chi2_Laplace_Beltrami(ilambda) = nfp * dtheta_coil * dzeta_coil * sum(this_Laplace_Beltrami2_times_N)
  Laplace_Beltrami2(:,:,ilambda) = this_Laplace_Beltrami2_times_N / norm_normal_coil

  Bnormal_total(:,:,ilambda) = (reshape(matmul(g,solution),(/ ntheta_plasma, nzeta_plasma /)) / norm_normal_plasma) &
       + Bnormal_from_plasma_current + Bnormal_from_net_coil_currents

  max_Bnormal(ilambda) = maxval(abs(Bnormal_total(:,:,ilambda)))
  max_K(ilambda) = sqrt(maxval(K2(:,:,ilambda)))

  chi2_B(ilambda) = nfp * dtheta_plasma * dzeta_plasma &
       * sum(Bnormal_total(:,:,ilambda) * Bnormal_total(:,:,ilambda) * norm_normal_plasma)

  if (trim(target_option)=='max_K_lse') then
    max_K_lse(ilambda) = (1/target_option_p)*log(sum(norm_normal_coil*dtheta_coil*dzeta_coil*nfp &
        /area_coil*exp(target_option_p &
        *(K2(:,:,ilambda)**(0.5) - max_K(ilambda))))) + max_K(ilambda)
  else if (trim(target_option)==target_option_lp_norm_K) then
    lp_norm_K(ilambda) = (dtheta_coil*dzeta_coil*nfp*sum(norm_normal_coil* &
        K2(:,:,ilambda)**(target_option_p/2.0))/area_coil)**(1.0/target_option_p)
  end if

  call system_clock(toc)
  if (verbose) print *,"  Diagnostics: ",real(toc-tic)/countrate," sec."
  if (verbose) print "(a,es10.3,a,es10.3,a,es10.3)","   chi2_B:",chi2_B(ilambda),",  chi2_K:",chi2_K(ilambda),",  chi2_Laplace_Beltrami:",chi2_Laplace_Beltrami(ilambda)
  if (verbose) print "(a,es10.3,a,es10.3,a,es10.3)","   max(B_n):",max_Bnormal(ilambda),",  max(K):",max_K(ilambda),",  rms K:",sqrt(chi2_K(ilambda)/area_coil)
  if (trim(target_option)=='max_K_lse') then
    if (verbose) print "(a,es10.3)","    max_K_lse:",max_K_lse(ilambda)
  end if
  if (trim(target_option)=='lp_norm_K') then
    if (verbose) print "(a,es10.3)","    lp_norm_K:", lp_norm_K(ilambda)
  end if

end subroutine regcoil_diagnostics


      SUBROUTINE MB04GD( M, N, A, LDA, JPVT, TAU, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an RQ factorization with row pivoting of a
C     real m-by-n matrix A: P*A = R*Q.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrix A.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the m-by-n matrix A.
C             On exit,
C             if m <= n, the upper triangle of the subarray
C             A(1:m,n-m+1:n) contains the m-by-m upper triangular
C             matrix R;
C             if m >= n, the elements on and above the (m-n)-th
C             subdiagonal contain the m-by-n upper trapezoidal matrix R;
C             the remaining elements, with the array TAU, represent the
C             orthogonal matrix Q as a product of min(m,n) elementary
C             reflectors (see METHOD).
C
C     LDA     INTEGER
C             The leading dimension of the array A. LDA >= max(1,M).
C
C     JPVT    (input/output) INTEGER array, dimension (M)
C             On entry, if JPVT(i) .ne. 0, the i-th row of A is permuted
C             to the bottom of P*A (a trailing row); if JPVT(i) = 0,
C             the i-th row of A is a free row.
C             On exit, if JPVT(i) = k, then the i-th row of P*A
C             was the k-th row of A.
C
C     TAU     (output) DOUBLE PRECISION array, dimension (min(M,N))
C             The scalar factors of the elementary reflectors.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (3*M)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix Q is represented as a product of elementary reflectors
C
C        Q = H(1) H(2) . . . H(k), where k = min(m,n).
C
C     Each H(i) has the form
C
C        H = I - tau * v * v'
C
C     where tau is a real scalar, and v is a real vector with
C     v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit
C     in A(m-k+i,1:n-k+i-1), and tau in TAU(i).
C
C     The matrix P is represented in jpvt as follows: If
C        jpvt(j) = i
C     then the jth row of P is the ith canonical unit vector.
C
C     REFERENCES
C
C     [1] Anderson, E., Bai, Z., Bischof, C., Demmel, J., Dongarra, J.,
C         Du Croz, J., Greenbaum, A., Hammarling, S., McKenney, A.,
C         Ostrouchov, S., and Sorensen, D.
C         LAPACK Users' Guide: Second Edition.
C         SIAM, Philadelphia, 1995.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is backward stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, Sep. 1997.
C     Based on LAPACK Library routines DGEQPF and DGERQ2.
C
C     REVISIONS
C
C     V. Sima, Jan. 2010, following Bujanovic and Drmac's suggestion.
C
C     KEYWORDS
C
C     Factorization, matrix algebra, matrix operations, orthogonal
C     transformation, triangular form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
C     ..
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), DWORK( * ), TAU( * )
C     ..
C     .. Local Scalars ..
      INTEGER            I, ITEMP, J, K, MA, MKI, NFREE, NKI, PVT
      DOUBLE PRECISION   AII, TEMP, TEMP2, TOLZ
C     ..
C     .. External Functions ..
      INTEGER            IDAMAX
      DOUBLE PRECISION   DLAMCH, DNRM2
      EXTERNAL           DLAMCH, DNRM2, IDAMAX
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGERQ2, DLARF, DLARFG, DORMR2, DSWAP, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, MAX, MIN, SQRT
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB04GD', -INFO )
         RETURN
      END IF
C
      K = MIN( M, N )
C
C     Move non-free rows bottom.
C
      ITEMP = M
      DO 10 I = M, 1, -1
         IF( JPVT( I ).NE.0 ) THEN
            IF( I.NE.ITEMP ) THEN
               CALL DSWAP( N, A( I, 1 ), LDA, A( ITEMP, 1 ), LDA )
               JPVT( I ) = JPVT( ITEMP )
               JPVT( ITEMP ) = I
            ELSE
               JPVT( I ) = I
            END IF
            ITEMP = ITEMP - 1
         ELSE
            JPVT( I ) = I
         END IF
   10 CONTINUE
      NFREE = M - ITEMP
      TOLZ  = SQRT( DLAMCH( 'Epsilon' ) )
C
C     Compute the RQ factorization and update remaining rows.
C
      IF( NFREE.GT.0 ) THEN
         MA = MIN( NFREE, N )
         CALL DGERQ2( MA, N, A(M-MA+1,1), LDA, TAU(K-MA+1), DWORK,
     $                INFO )
         CALL DORMR2( 'Right', 'Transpose', M-MA, N, MA, A(M-MA+1,1),
     $                LDA, TAU(K-MA+1), A, LDA, DWORK, INFO )
      END IF
C
      IF( NFREE.LT.K ) THEN
C
C        Initialize partial row norms. The first ITEMP elements of
C        DWORK store the exact row norms. (Here, ITEMP is the number of
C        free rows, which have been permuted to be the first ones.)
C
         DO 20 I = 1, ITEMP
            DWORK( I ) = DNRM2( N-NFREE, A( I, 1 ), LDA )
            DWORK( M+I ) = DWORK( I )
   20    CONTINUE
C
C        Compute factorization.
C
         DO 40 I = K-NFREE, 1, -1
C
C           Determine ith pivot row and swap if necessary.
C
            MKI = M - K + I
            NKI = N - K + I
            PVT = IDAMAX( MKI, DWORK, 1 )
C
            IF( PVT.NE.MKI ) THEN
               CALL DSWAP( N, A( PVT, 1 ), LDA, A( MKI, 1 ), LDA )
               ITEMP = JPVT( PVT )
               JPVT( PVT ) = JPVT( MKI )
               JPVT( MKI ) = ITEMP
               DWORK( PVT )   = DWORK( MKI )
               DWORK( M+PVT ) = DWORK( M+MKI )
            END IF
C
C           Generate elementary reflector H(i) to annihilate
C           A(m-k+i,1:n-k+i-1), k = min(m,n).
C
            CALL DLARFG( NKI, A( MKI, NKI ), A( MKI, 1 ), LDA, TAU( I )
     $                 )
C
C           Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right.
C
            AII = A( MKI, NKI )
            A( MKI, NKI ) = ONE
            CALL DLARF( 'Right', MKI-1, NKI, A( MKI, 1 ), LDA,
     $                  TAU( I ), A, LDA, DWORK( 2*M+1 ) )
            A( MKI, NKI ) = AII
C
C           Update partial row norms.
C
            DO 30 J = 1, MKI - 1
               IF( DWORK( J ).NE.ZERO ) THEN
                  TEMP = ABS( A( J, NKI ) ) / DWORK( J )
                  TEMP = MAX( ( ONE + TEMP )*( ONE - TEMP ), ZERO )
                  TEMP2 = TEMP*( DWORK( J ) / DWORK( M+J ) )**2
                  IF( TEMP2.LE.TOLZ ) THEN
                     DWORK( J ) = DNRM2( NKI-1, A( J, 1 ), LDA )
                     DWORK( M+J ) = DWORK( J )
                  ELSE
                     DWORK( J ) = DWORK( J )*SQRT( TEMP )
                  END IF
               END IF
   30       CONTINUE
C
   40    CONTINUE
      END IF
C
      RETURN
C *** Last line of MB04GD ***
      END


      SUBROUTINE MFFTB7(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY COOLEY-TUKEY RADIX 3 STEP APPLIED TO A VECTOR-OF
*       2-VECTORS-OF-COMPLEX C[IMS,NM [IVS,NV [IES,NE]]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTIM, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:2),FAC(0:*)
      DOUBLE COMPLEX T0,T1,T2,F1,F2
      REAL *8 SIN60
      PARAMETER ( SIN60 =  8.6602540378443864E-1)
*..  LAM>0
          LAMF=MX
          DO 100 LAM=LSTEP,LLIM,LSTEP
            F1=FAC(LAMF)
            F2=FAC(LAMF*2)
            DO 90 MU=LAM,LAM+MLIM,MSTEP
              DO 80 IV=MU,MU+IVLIM,IVS
              DO 80 I=IV,IV+ILIM,IES
                T0=C(I,1)*F1+C(I,2)*F2
                T2=(C(I,1)*F1-C(I,2)*F2)*SIN60
                T1=C(I,0)-0.5*T0
                C(I,0)=C(I,0)+T0
                C(I,1)=(T1+DCMPLX(-DIMAG(T2),DREAL(T2)))
                C(I,2)=(T1-DCMPLX(-DIMAG(T2),DREAL(T2)))
80            CONTINUE
90          CONTINUE
            LAMF=LAMF+MX
100       CONTINUE
          DO 92 MU=0,MLIM,MSTEP
            DO 82 IV=MU,MU+IVLIM,IVS
            DO 82 I=IV,IV+ILIM,IES
                T0=C(I,1)+C(I,2)
                T2=(C(I,1)-C(I,2))*SIN60
                T1=C(I,0)-0.5*T0
                C(I,0)=C(I,0)+T0
                C(I,1)=(T1+DCMPLX(-DIMAG(T2),DREAL(T2)))
                C(I,2)=(T1-DCMPLX(-DIMAG(T2),DREAL(T2)))
82          CONTINUE
92        CONTINUE
      END


module multigrid

  implicit none

  private
  public :: mg_interface

  ! will need own private constants and parameters since entirely modular
  integer, parameter :: num=selected_real_kind(p=15)

  integer :: ix, iy

  ! data object for grid hierarchy
  type grid
    integer :: level, nx, ny
    real(num) :: dx, dy
    real(num),dimension(:,:), allocatable :: phi
    real(num),dimension(:,:), allocatable :: f
    real(num),dimension(:,:), allocatable :: residue
    real(num),dimension(:,:), allocatable :: eta, eta_xface, eta_yface
    type(grid), pointer :: next, prev
  end type grid

  type(grid), pointer :: head, tail

  ! public state object - used for better handling of optional inputs
  ! as opposed to a big list of dummies in mg_interface

  type, public :: mg_input
    ! required in constructor a=mg_state(nx = ... etc)
    integer :: nx
    integer :: ny
    real(num) :: dx, dy
    real(num),dimension(:,:), allocatable :: phi
    real(num),dimension(:,:), allocatable :: f
    character(len=20) :: bc_xmin, bc_ymin, bc_xmax, bc_ymax
    real(num) :: tol
    ! optional non-allocatable variables just set to a default
    integer :: nlevels = -1 !-1 is "auto"
    logical :: use_as_init_guess = .false.
    logical :: eta_present = .false.
    logical :: quiet = .false.
    logical :: deallocate_after = .false.
    character(len=20) :: eta_bc_xmin ='none'
    character(len=20) :: eta_bc_ymin ='none'
    character(len=20) :: eta_bc_xmax ='none'
    character(len=20) :: eta_bc_ymax ='none'
    ! optional allocatables
    real(num),dimension(:,:), allocatable :: eta
    ! optionals for constant helmholtz equation
    !(alpha - beta del**2) phi = f
    logical :: const_helmholtz = .false.
    real(num) :: ch_alpha = 0.0_num
    real(num) :: ch_beta = 0.0_num
    ! optional values for fixed phi values for inhomogeneous boundaries on the
    ! their default is zero, so simply dont set for homogeneous
    ! (currently only implemented for diriclet / 'fixed', but same variables
    ! could be used for inhomo Neumann / gradient bc)
    real(num) :: phi_bc_xmin = 0.0_num
    real(num) :: phi_bc_xmax = 0.0_num
    real(num) :: phi_bc_ymin = 0.0_num
    real(num) :: phi_bc_ymax = 0.0_num
    ! eta values for inhomogeneous dirichlet
    real(num) :: etaval_bc_xmin = 0.0_num
    real(num) :: etaval_bc_xmax = 0.0_num
    real(num) :: etaval_bc_ymin = 0.0_num
    real(num) :: etaval_bc_ymax = 0.0_num

  end type mg_input

  type(mg_input) :: mg_state

  ! characters for comparison to input bc names
  character(len=20), parameter :: periodic = 'periodic'
  character(len=20), parameter :: fixed = 'fixed'
  character(len=20), parameter :: zero_gradient = 'zero_gradient'

  ! logical for first_call options

  logical :: first_call = .true.

contains

  subroutine mg_interface(this)

    type(mg_input), intent(inout) :: this
    type(grid), pointer :: current
    real(num) :: start, finish
    mg_state = this ! all other subroutines access input via mg_state

    call sanity_checks
    call initialise_grids
    call welcome

    call cpu_time(start)
    call mg_solve
    call cpu_time(finish)

    ! set the inout(phi) = phi on finest grid to return to caller
    current => head
    this%phi(0:this%nx+1,0:this%ny+1) = current%phi

    if (.not.(mg_state%quiet)) then
      print '(" ****** total cpu_time: ",f20.3," seconds.")',finish-start
      print *,'****** (nb this is not wall time)'
      print *,'*** Multigrid finished'
    endif

    if (mg_state%deallocate_after) then
     call deallocate_grids
     first_call = .true.
     print *,'*** deallocated grids'
    endif

  end subroutine mg_interface

  subroutine welcome

    if (mg_state%quiet) return

    print *,'*** Multigrid called'
    print *,'****** nx = ',mg_state%nx
    print *,'****** ny = ',mg_state%ny
    print *,'****** nlevels ',mg_state%nlevels
    print *,'****** tolerance = ',mg_state%tol
    print *,'****** bc_xmin = ', mg_state%bc_xmin
    print *,'****** bc_xmax = ', mg_state%bc_xmax
    print *,'****** bc_ymin = ', mg_state%bc_ymin
    print *,'****** bc_ymax = ', mg_state%bc_ymax
    print *,'****** variable coefficient eta',mg_state%eta_present
  end subroutine welcome

  subroutine mg_solve
    type(grid), pointer :: current

    real(num) :: L2, L2_old

    integer :: nsteps
    integer :: c
    integer :: num_sweeps_down = 3
    integer :: num_sweeps_up = 3

    L2_old = 1e6_num
    current => head

    nsteps = 0

    mainloop: do
      nsteps = nsteps +1

      downcycle: do
        if (current%level == tail%level) exit downcycle

        if (current%level /= 1) current%phi = 0.0_num ! important

        do c = 1, num_sweeps_down
          call relax(current)
        enddo

       if (current%level == 1) then
          call residual(current)
          L2 = sqrt(sum(abs(current%residue)**2)/real(current%nx*current%ny,num))
          if (abs(L2-L2_old) <= mg_state%tol) exit mainloop
!          if (isnan(L2)) STOP
          if (nsteps > 1000) then
            print *,'MG struggling to converge, L2 =', L2
STOP
          endif
          L2_old = L2
        endif
        call residual(current)
        call restrict(current)
        current=>current%next

      enddo downcycle

      bottom_solve: do

        current%phi = 0.0_num

        do c = 1, 50 !**
          call relax(current)
          if (modulo(c-1,5)==0) then
            call residual(current)
            L2 = sqrt(sum(abs(current%residue)**2)/real(current%nx*current%ny,num))
            if (L2 < mg_state%tol) exit
!          if (isnan(L2)) STOP
          endif
        enddo
        call inject(current)
        current => current%prev
        exit bottom_solve !not really a loop / readability. Possible performance hit?

      enddo bottom_solve

      upcycle: do
        if (current%level == 1) exit upcycle
        do c = 1, num_sweeps_up
          call relax(current)
        enddo
        call inject(current)
        current => current%prev
      enddo upcycle

    enddo mainloop

    if (.not.(mg_state%quiet)) then
      print '(" ****** Finished in: ",i3.3," V cycles")',nsteps
      print '(" ****** Fine grid residual: ",e20.8," (L2)")',L2
    endif

    !** if not refining to ideal case (nx=ny=1 + ghosts) this wont automatically
    ! be solved exactly (discretely). If so, do an arbitary amount of
    ! relaxations, checking the residual, up to a max of 50. Perhaps in some
    ! problems, if you can't refine very much because of a large Lx/=Ly asoect
    ! ratio, this could cause an issue
  end subroutine mg_solve

  ! methods used in the main solver

  subroutine restrict(this)
    ! restrict the residual at level "this" (this%residue)
    ! to be the rhs of the next level (next%f)

    type(grid), pointer :: this
    type(grid), pointer :: next
    integer :: ixc, iyc

    next => this%next

    iy=  1
    do iyc = 1, next%ny
    ix = 1
    do ixc = 1, next%nx
      next%f(ixc,iyc) = 0.25_num * (this%residue(ix,iy) + this%residue(ix+1,iy) &
        & + this%residue(ix,iy+1) + this%residue(ix+1,iy+1) )
      ix = ix + 2
    enddo
    iy = iy + 2
    enddo

  end subroutine restrict

  subroutine inject(this)

    type(grid), pointer :: this
    type(grid), pointer :: prev
    integer :: ixc, iyc
    prev => this%prev

    iy=  1
    do iyc = 1, this%ny
    ix = 1
    do ixc = 1, this%nx
      prev%phi(ix,iy) = prev%phi(ix,iy) - this%phi(ixc,iyc)
      prev%phi(ix+1,iy) = prev%phi(ix+1,iy) - this%phi(ixc,iyc)
      prev%phi(ix,iy+1) = prev%phi(ix,iy+1) - this%phi(ixc,iyc)
      prev%phi(ix+1,iy+1) = prev%phi(ix+1,iy+1) - this%phi(ixc,iyc)
      ix = ix + 2
    enddo
    iy = iy + 2
    enddo

  end subroutine inject

  subroutine relax(this)

    type(grid), pointer :: this
    integer :: odd_then_even
    real(num) :: eta_ip, eta_im, eta_jp, eta_jm

    call bcs(this)

    if (mg_state%eta_present) then
      do odd_then_even = 1, 0, -1
        !$OMP PARALLEL DO
        do iy = 1, this%ny
        do ix = 1, this%nx
          if (modulo(ix+iy,2) == odd_then_even) then
            eta_ip = 0.5_num * (this%eta(ix,iy)+this%eta(ix+1,iy)) / this%dx**2
            eta_im = 0.5_num * (this%eta(ix,iy)+this%eta(ix-1,iy)) / this%dx**2
            eta_jp = 0.5_num * (this%eta(ix,iy)+this%eta(ix,iy+1)) / this%dy**2
            eta_jm = 0.5_num * (this%eta(ix,iy)+this%eta(ix,iy-1)) / this%dy**2

            this%phi(ix,iy) = eta_ip * this%phi(ix+1,iy) + eta_im*this%phi(ix-1,iy) &
              & + eta_jp * this%phi(ix,iy+1) + eta_jm * this%phi(ix,iy-1) - this%f(ix,iy)
            this%phi(ix,iy) = this%phi(ix,iy) / ( eta_ip + eta_im + eta_jp + eta_jm )
          endif
        end do
        end do
        !$OMP END PARALLEL DO
      enddo

    else if (mg_state%const_helmholtz) then

      do odd_then_even = 1, 0, -1
        !$OMP PARALLEL DO
        do iy = 1, this%ny
        do ix = 1, this%nx
          if (modulo(ix+iy,2) == odd_then_even) then

            this%phi(ix,iy) = this%phi(ix+1,iy) + this%phi(ix-1,iy) + &
                            & this%phi(ix,iy+1) + this%phi(ix,iy-1)
            this%phi(ix,iy) = (this%f(ix,iy) + mg_state%ch_beta * this%phi(ix,iy) / this%dx**2) &
                          & / (mg_state%ch_alpha + 4.0_num * mg_state%ch_beta / this%dx**2)
          endif
        end do
        end do
        !$OMP END PARALLEL DO
      enddo

    else

      do odd_then_even = 1, 0, -1
        !$OMP PARALLEL DO
        do iy = 1, this%ny
        do ix = 1, this%nx
          if (modulo(ix+iy,2) == odd_then_even) then

            this%phi(ix,iy) = 0.25_num * ( &
              & this%phi(ix+1,iy) + this%phi(ix-1,iy) + this%phi(ix,iy+1) + this%phi(ix,iy-1) &
              - this%dx**2 * this%f(ix,iy) )
          endif
        end do
        end do
        !$OMP END PARALLEL DO
      enddo

    endif
  end subroutine relax

  subroutine residual(this)

    type(grid), pointer :: this

    real(num) :: Lap ! 5 point discrete laplacian at a cell center
    real(num) :: eta_ip, eta_im, eta_jp, eta_jm

    call bcs(this)

    if (mg_state%eta_present) then
      !$OMP PARALLEL DO
      do iy = 1, this%ny
      do ix = 1, this%nx
        eta_ip = 0.5_num * (this%eta(ix,iy)+this%eta(ix+1,iy))! / this%dx**2
        eta_im = 0.5_num * (this%eta(ix,iy)+this%eta(ix-1,iy))! / this%dx**2
        eta_jp = 0.5_num * (this%eta(ix,iy)+this%eta(ix,iy+1))! / this%dy**2
        eta_jm = 0.5_num * (this%eta(ix,iy)+this%eta(ix,iy-1))! / this%dy**2

        Lap = ( eta_ip * (this%phi(ix+1,iy)-this%phi(ix,iy)) &
              &    -  eta_im * (this%phi(ix,iy)-this%phi(ix-1,iy)) ) / this%dx**2 + &
              & ( eta_jp * (this%phi(ix,iy+1)-this%phi(ix,iy)) &
              &    -  eta_jm * (this%phi(ix,iy)-this%phi(ix,iy-1)) ) / this%dy**2

        this%residue(ix,iy) = Lap - this%f(ix,iy)
      enddo
      enddo
      !$OMP END PARALLEL DO

    else if (mg_state%const_helmholtz) then

      !$OMP PARALLEL DO
      do iy = 1, this%ny
      do ix = 1, this%nx
        Lap = (this%phi(ix+1,iy) - 2.0_num*this%phi(ix,iy) + this%phi(ix-1,iy)) / this%dx**2 + &
            & (this%phi(ix,iy+1) - 2.0_num*this%phi(ix,iy) + this%phi(ix,iy-1)) / this%dy**2
        Lap = (mg_state%ch_alpha*this%phi(ix,iy) - mg_state%ch_beta * Lap)
        this%residue(ix,iy) = Lap - this%f(ix,iy)
      enddo
      enddo
      !$OMP END PARALLEL DO

    else

      !$OMP PARALLEL DO
      do iy = 1, this%ny
      do ix = 1, this%nx
        Lap = (this%phi(ix+1,iy) - 2.0_num*this%phi(ix,iy) + this%phi(ix-1,iy)) / this%dx**2 + &
            & (this%phi(ix,iy+1) - 2.0_num*this%phi(ix,iy) + this%phi(ix,iy-1)) / this%dy**2
        this%residue(ix,iy) = Lap - this%f(ix,iy)
      enddo
      enddo
      !$OMP END PARALLEL DO

    endif

  end subroutine residual

  subroutine eta_initialise
    ! restrict the residual at level "this" (this%residue)
    ! to be the rhs of the next level (next%f)

    type(grid), pointer :: current
    type(grid), pointer :: next
    integer :: ixc, iyc

    current => head
    next => current%next

    ! do the restrictions of cc eta
    do while( associated(next))
      iy=  1
      do iyc = 1, next%ny
      ix = 1
      do ixc = 1, next%nx
        next%eta(ixc,iyc) = 0.25_num * (current%eta(ix,iy) + current%eta(ix+1,iy) &
          & + current%eta(ix,iy+1) + current%eta(ix+1,iy+1) )
        ix = ix + 2
      enddo
      iy = iy + 2
      enddo
      current => current%next
      next => current%next
    enddo

    current => head
    do while( associated(current))
      ! fill the boundaries
      call eta_bcs(current)

! could be some saving by doing this once, at the start. Look into it later
      ! fill the x_face and y_face arrays
!      do iy = 0, current%ny
!      do ix = 0, current%nx
!        ! xface
!        if (iy /= 0) then
!          current%eta_xface(ix,iy) = 0.5_num * (current%eta(ix,iy) + current%eta(ix+1,iy))
!        endif
!        ! yface
!        if (ix /= 0) then
!          current%eta_yface(ix,iy) = 0.5_num * (current%eta(ix,iy) + current%eta(ix,iy+1))
!        endif
!      enddo
!      enddo
      ! next level
      current => current%next
    enddo

  end subroutine eta_initialise

  subroutine eta_bcs(this)

    type(grid), pointer :: this

    ! some logic for if level 1 vs others for homo vs inhomo bc etc will be needed
    ! eventually

   if (mg_state%eta_bc_xmin == periodic) then
     this%eta(0,:) = this%eta(this%nx,:)
   endif
   if (mg_state%eta_bc_xmax == periodic) then
     this%eta(this%nx+1,:) = this%eta(1,:)
   endif
   if (mg_state%eta_bc_ymin == periodic) then
     this%eta(:,0) = this%eta(:,this%ny)
   endif
   if (mg_state%eta_bc_ymax == periodic) then
     this%eta(:,this%ny+1) = this%eta(:,1)
   endif

   if (mg_state%eta_bc_xmin == zero_gradient) then
     this%eta(0,:) = this%eta(1,:)
   endif

   if (mg_state%eta_bc_xmax == zero_gradient) then
     this%eta(this%nx+1,:) = this%eta(this%nx,:)
   endif
   if (mg_state%eta_bc_ymin == zero_gradient) then
     this%eta(:,0) = this%eta(:,1)
   endif
   if (mg_state%eta_bc_ymax == zero_gradient) then
     this%eta(:,this%ny+1) = this%eta(:,this%ny)
   endif

   if (mg_state%eta_bc_xmin == fixed) then
!      this%eta(0,:) = -this%eta(1,:)
!!     this%eta(0,:) = this%eta(1,:)
      this%eta(0,:) = 2.0_num * mg_state%etaval_bc_xmin - this%eta(1,:)
   endif
   if (mg_state%eta_bc_xmax == fixed) then
!      this%eta(this%nx+1,:) = -this%eta(this%nx,:)
!!     this%eta(this%nx+1,:) = this%eta(this%nx,:)
      this%eta(this%nx+1,:) = 2.0_num * mg_state%etaval_bc_xmax -this%eta(this%nx,:)
   endif
   if (mg_state%eta_bc_ymin == fixed) then
!      this%eta(:,0) = -this%eta(:,1)
!!     this%eta(:,0) = this%eta(:,1)
      this%eta(:,0) = 2.0_num * mg_state%etaval_bc_ymin - this%eta(:,1)
   endif
   if (mg_state%eta_bc_ymax == fixed) then
!      this%eta(:,this%ny+1) = -this%eta(:,this%ny)
!!     this%eta(:,this%ny+1) = this%eta(:,this%ny)
      this%eta(:,this%ny+1) = 2.0_num * mg_state%etaval_bc_ymax-this%eta(:,this%ny)
   endif

  end subroutine eta_bcs

  subroutine bcs(this)

    type(grid), pointer :: this
!    print *, 'test inside subroutine bcs'
!    print *,'****** bc_xmin = ', bc_xmin
!    print *,'****** bc_xmax = ', bc_xmax
!    print *,'****** bc_ymin = ', bc_ymin
!    print *,'****** bc_ymax = ', bc_ymax
!STOP
    ! some logic for if level 1 vs others for homo vs inhomo bc etc will be needed
    ! eventually

    if (mg_state%bc_xmin == periodic) then
      this%phi(0,:) = this%phi(this%nx,:)
    endif
    if (mg_state%bc_xmax == periodic) then
      this%phi(this%nx+1,:) = this%phi(1,:)
    endif
    if (mg_state%bc_ymin == periodic) then
      this%phi(:,0) = this%phi(:,this%ny)
    endif
    if (mg_state%bc_ymax == periodic) then
      this%phi(:,this%ny+1) = this%phi(:,1)
    endif

    if (mg_state%bc_xmin == zero_gradient) then
      this%phi(0,:) = this%phi(1,:)
    endif

    if (mg_state%bc_xmax == zero_gradient) then
      this%phi(this%nx+1,:) = this%phi(this%nx,:)
    endif
    if (mg_state%bc_ymin == zero_gradient) then
      this%phi(:,0) = this%phi(:,1)
    endif
    if (mg_state%bc_ymax == zero_gradient) then
      this%phi(:,this%ny+1) = this%phi(:,this%ny)
    endif

    if (mg_state%bc_xmin == fixed) then
      this%phi(0,:) = -this%phi(1,:)
      if (this%level == 1 ) then
        this%phi(0,:) = 2.0_num * mg_state%phi_bc_xmin - this%phi(1,:)
      endif
    endif
    if (mg_state%bc_xmax == fixed) then
      this%phi(this%nx+1,:) = -this%phi(this%nx,:)
      if (this%level == 1 ) then
        this%phi(this%nx+1,:) = 2.0_num * mg_state%phi_bc_xmax - this%phi(this%nx,:)
      endif
    endif
    if (mg_state%bc_ymin == fixed) then
      this%phi(:,0) = -this%phi(:,1)
      if (this%level == 1 ) then
        this%phi(:,0) = 2.0_num * mg_state%phi_bc_ymin - this%phi(:,1)
      endif
    endif
    if (mg_state%bc_ymax == fixed) then
      this%phi(:,this%ny+1) = -this%phi(:,this%ny)
      if (this%level == 1 ) then
        this%phi(:,this%ny+1) = 2.0_num * mg_state%phi_bc_ymax - this%phi(:,this%ny)
      endif
    endif

  end subroutine bcs

  ! check everything passed to the interface is as assumed

  subroutine sanity_checks

    if (mg_state%dx /= mg_state%dy) then
      print *,'multigrid: dx =/ dy, terminating'
      stop
    endif

    if (size(mg_state%f,1) /= mg_state%nx) then
      print *, 'wrong size on f input'
      print *,'size(f,1)=',size(mg_state%f,1)
      stop
    endif

    if (size(mg_state%f,2) /= mg_state%ny) then
      print *, 'wrong size on f input'
      print *,'size(f,2)=',size(mg_state%f,2)
      stop
    endif

    if (lbound(mg_state%f,1) /= 1) then
      print *, 'wrong lbound on allocatable f input to MG'
      print *,'lbound(f,1)=',lbound(mg_state%f,1)
      stop
    endif

    if (lbound(mg_state%f,2) /= 1) then
      print *, 'wrong lbound on allocatable f input to MG'
      print *,'lbound(f,2)=',lbound(mg_state%f,2)
      stop
    endif

    if (ubound(mg_state%f,1) /= mg_state%nx) then
      print *, 'wrong ubound on allocatable f input to MG'
      print *,'ubound(f,1)=',ubound(mg_state%f,1)
      stop
    endif

    if (ubound(mg_state%f,2) /= mg_state%ny) then
      print *, 'wrong ubound on allocatable f input to MG'
      print *,'ubound(f,2)=',ubound(mg_state%f,2)
      stop
    endif

    if (lbound(mg_state%phi,1) /= -1) then
      print *, 'wrong lbound on allocatable phi input to MG'
      print *,'lbound(phi,1)=',lbound(mg_state%phi,1)
      stop
    endif

    if (lbound(mg_state%phi,2) /= -1) then
      print *, 'wrong lbound on allocatable phi input to MG'
      print *,'lbound(phi,2)=',lbound(mg_state%phi,2)
      stop
    endif

    if (ubound(mg_state%phi,1) /= mg_state%nx+2) then
      print *, 'wrong ubound on allocatable phi input to MG'
      print *,'ubound(phi,1)=',ubound(mg_state%phi,1)
      stop
    endif

    if (ubound(mg_state%phi,2) /= mg_state%ny+2) then
      print *, 'wrong ubound on allocatable phi input to MG'
      print *,'ubound(phi,2)=',ubound(mg_state%phi,2)
      stop
    endif

    if (mg_state%eta_present) then
      if (lbound(mg_state%eta,1) /= 1 ) then
        print *, 'wrong lbound on allocatable eta input to MG'
        print *,'lbound(eta,1)=',lbound(mg_state%eta,1)
        stop
      endif

      if (lbound(mg_state%eta,2) /= 1 ) then
        print *, 'wrong lbound on allocatable eta input to MG'
        print *,'lbound(eta,2)=',lbound(mg_state%eta,2)
        stop
      endif

      if (ubound(mg_state%eta,1) /= mg_state%nx) then
        print *, 'wrong ubound on allocatable eta input to MG'
        print *,'ubound(eta,1)=',ubound(mg_state%eta,1)
        stop
      endif

      if (ubound(mg_state%eta,2) /= mg_state%ny) then
        print *, 'wrong ubound on allocatable eta input to MG'
         print *,'ubound(eta,2)=',ubound(mg_state%eta,2)
        stop
      endif
    endif

    if ((mg_state%eta_present) .and. (mg_state%const_helmholtz)) then
      print *, 'both eta_present and const_helmholtz are true'
      print *, 'its one or the other at the moment, bucko'
      print *, 'stop'
      stop
    endif
  end subroutine sanity_checks

  ! Methods relating to the grid heirarchy and setup below jere

  subroutine create_grid(new_grid)
    type(grid), pointer :: new_grid
    allocate(new_grid)
    nullify(new_grid%next)
    nullify(new_grid%prev)
    new_grid%level = -1
    new_grid%nx = -1
    new_grid%ny = -1
    new_grid%dx = -1.0_num
    new_grid%dy = -1.0_num
  end subroutine create_grid

  subroutine add_grid(new_grid)
    ! add grid to a list / create a new list if 1st one
    type(grid), pointer :: new_grid
    if (.not. associated(head)) then
      head=>new_grid
      tail=>new_grid
      return
    endif
    tail%next=>new_grid
    new_grid%prev=>tail
    tail=>new_grid
  end subroutine add_grid

  subroutine allocate_arrays(new_grid)
    type(grid), pointer :: new_grid
    allocate(new_grid%phi(0:new_grid%nx+1,0:new_grid%ny+1))
    allocate(new_grid%f(1:new_grid%nx,1:new_grid%ny))
    allocate(new_grid%residue(1:new_grid%nx,1:new_grid%ny))
    new_grid%phi = 0.0_num
    new_grid%f = 0.0_num
    new_grid%residue = 0.0_num

    if (mg_state%eta_present) then
      allocate(new_grid%eta(0:new_grid%nx+1,0:new_grid%ny+1))
!      allocate(new_grid%eta_xface(0:new_grid%nx,1:new_grid%ny))
!      allocate(new_grid%eta_yface(1:new_grid%nx,0:new_grid%ny))
    endif

!print*, lbound(new_grid%eta)
!print*, ubound(new_grid%eta)
!STOP
  end subroutine allocate_arrays

  subroutine grid_report(this)
    type(grid), pointer :: this
      print *,'******'
      print *,'level',this%level
      print *,'nx',this%nx
      print *,'ny',this%ny
      print *,'dx',this%dx
      print *,'dy',this%dy
      print *,'lbound phi',lbound(this%phi)
      print *,'ubound phi',ubound(this%phi)
      print *,'lbound f',lbound(this%f)
      print *,'ubound f',ubound(this%f)

      if (mg_state%eta_present) then
        print *,'lbound eta',lbound(this%eta)
        print *,'ubound eta',ubound(this%eta)
        print *,'lbound eta_xface',lbound(this%eta_xface)
        print *,'ubound eta_xface',ubound(this%eta_xface)
        print *,'lbound eta_yface',lbound(this%eta_yface)
        print *,'ubound eta_yface',ubound(this%eta_yface)
!        print *, 'eta', this%eta
      endif

      print *,'******'
  end subroutine grid_report

  subroutine initialise_grids

    integer :: lev
    type(grid), pointer :: new
    type(grid), pointer :: current
    nullify(new)
    nullify(current)
!    nullify(head)
!    nullify(tail)

    if (mg_state%nlevels == -1) mg_state%nlevels = set_nlevels(mg_state%nx,mg_state%ny)

    if (first_call) then

      ! create a linked list of grids with blank / unallocated data
      do lev = 1, mg_state%nlevels
        call create_grid(new)
        call add_grid(new)
      enddo

      ! go through the list and set up the arrays
      current =>head
      lev = 0
      do while(associated(current))
        lev = lev + 1
        current%level = lev
        current%nx = mg_state%nx / (2**(lev-1))
        current%ny = mg_state%ny / (2**(lev-1))
        current%dx = mg_state%dx * real(2**(lev-1),num)
        current%dy = mg_state%dy * real(2**(lev-1),num)
        call allocate_arrays(current)
        current=>current%next
      enddo

    endif ! first_call = .true.

    ! set phi and f on the level-1 (finest) grid
    current => head
    current%f = mg_state%f
    current%phi = 0.0_num
    if (mg_state%use_as_init_guess) then
      current%phi = mg_state%phi(0:mg_state%nx+1, 0:mg_state%ny+1)
    endif
    if (mg_state%eta_present) then
      current%eta(1:current%nx,1:current%ny) = mg_state%eta
      call eta_initialise
    endif

!    ! cycle through the list for a report to check all is set up good
!    current => head
!    do while(associated(current))
!      call grid_report(current)
!      current=>current%next
!    enddo

    first_call = .false.

  end subroutine initialise_grids

  integer function set_nlevels(nx,ny)
    integer, intent(in) :: nx, ny

    if (nx <= ny) then
      set_nlevels = log2_int(nx) + 1
    else
      set_nlevels = log2_int(ny) + 1
    endif

  end function set_nlevels

  integer function log2_int(x)
    implicit none
    integer, intent(in) :: x

    log2_int = int( log(real(x,num)) / log(2.0_num))

  end function log2_int

  subroutine deallocate_grids

    type(grid), pointer :: current, next

    current => head
    next => current%next
    do
      deallocate(current)
      if (.not. associated(next)) exit
      current => next
      next => current%next
    enddo

    nullify(head) !important
    nullify(tail)

  endsubroutine deallocate_grids

end module multigrid


module stats_mod
    implicit none

    private

    type, public :: stats_t
        real :: sum, sum2
        integer :: n
    end type stats_t

    public :: add_stats_value

contains

    subroutine add_stats_value(stats, value)
        implicit none
        type(stats_t), intent(inout) :: stats
        real, value :: value

        stats%sum = stats%sum + value
        stats%sum2 = stats%sum2 + value**2
        stats%n = stats%n + 1
    end subroutine add_stats_value

end module stats_mod


C$Procedure BRCKTD (Bracket a double precision value within an interval)

      DOUBLE PRECISION FUNCTION BRCKTD ( NUMBER, END1, END2 )

C$ Abstract
C
C      Bracket a number. That is, given a number and an acceptable
C      interval, make sure that the number is contained in the
C      interval. (If the number is already in the interval, leave it
C      alone. If not, set it to the nearest endpoint of the interval.)
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      INTERVALS,  NUMBERS,  UTILITY
C
C$ Declarations

      DOUBLE PRECISION   NUMBER
      DOUBLE PRECISION   END1
      DOUBLE PRECISION   END2

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      NUMBER     I   Number to be bracketed.
C      END1       I   One of the bracketing endpoints for NUMBER.
C      END2       I   The other bracketing endpoint for NUMBER.
C      BRCKTD     O   Bracketed number.
C
C$ Detailed_Input
C
C      NUMBER      is the number to be bracketed. That is, the
C                  value of NUMBER is constrained to lie in the
C                  interval bounded by END1 and END2.
C
C      END1,
C      END2        are the lower and upper bounds for NUMBER. The
C                  order is not important.
C
C$ Detailed_Output
C
C      BRCKTD      is NUMBER, if it was already in the interval
C                  provided. Otherwise it is the value of the nearest
C                  bound of the interval.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      This routine provides a shorthand notation for code fragments
C      like the following
C
C            IF      ( NUMBER .LT. END1 ) THEN
C                                              NUMBER = END1
C            ELSE IF ( NUMBER .GT. END2 ) THEN
C                                              NUMBER = END2
C            END IF
C
C      which occur frequently during the processing of program inputs.
C
C$ Examples
C
C      The following illustrate the operation of BRCKTD.
C
C            BRCKTD (  -1.D0,   1.D0,  10.D0 )  =  1.D0
C            BRCKTD (  29.D0,   1.D0,  10.D0 )  = 10.D0
C            BRCKTD (   3.D0, -10.D0,  10.D0 )  =  3.D0
C            BRCKTD (   3.D0, -10.D0,  -1.D0 )  = -1.D0
C
C      The following code fragment illustrates a typical use for BRCKTD.
C
C            C
C            C     Star magnitude limit must be in the range 0-10.
C            C
C                  READ (5,*) MAGLIM
C                  MAGLIM = BRCKTD ( MAGLIM, 0.D0, 10.D0 )
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C      I.M. Underwood  (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (IMU)
C
C-&

C$ Index_Entries
C
C     bracket a d.p. value within an interval
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 30-DEC-1988 (WLT)
C
C      The routine was modified so that the order of the endpoints
C      of the bracketing interval is not needed.  The routine now
C      determines which is the left endpoint and which is the
C      right and acts appropriately.
C
C-&

C
C     What else is there to say?
C
      IF ( END1 .LT. END2 ) THEN

         BRCKTD = MAX (  END1, MIN(END2,NUMBER)  )

      ELSE

         BRCKTD = MAX (  END2, MIN(END1,NUMBER)  )

      END IF

      RETURN
      END


!	Get normal density for scaled latent vector.  Place in density.
!	Input involves linear component linth, quadrature points quadpoint, quadratic components quadth, quadrature weights quadweight, and scale
!	factor scaletheta.
function density(linth,quadpoint,quadth,quadweight,scaletheta)
implicit none
real(kind=8),intent(in)::linth(:),quadpoint(:,:),quadth(:,:),quadweight(:),scaletheta
real(kind=8)::density(size(quadweight))
!	quad counts quadrature points.
integer::quad
!	rescale density with rescale.

do quad=1,size(quadweight)
	density(quad)=scaletheta*quadweight(quad)*exp(dot_product(quadpoint(:,quad),linth+matmul(quadth,quadpoint(:,quad))))
end do

return
end function density


! PROGRAM:
! This is a Geomagnetic Field Modeling software by Don!
! this program calculates the geomagnetic field values from a spherical harmonic! model.The coefficients are all from IGRF model
! this program can get x,y,z,f of magnet and U only if we input latitude and
! longitude .In this simple program we only compute the value on surface of
! earth.
! HISTORY:
! 2011/12/5
! First release by Don

!This main program call three subroutines to finish the calculation
!variable claim
!in program   		real meaning
!g(N0*(N0+3)/2)		spherical harmonic coefficients
!h(N0*(N0+3)/2)		spherical harmonic coefficients
!p(N0*(N0+3)/2)		lerande function
!grad_p			the grad of p
!x			"longitude" range from 0 to 360
!y			"latitude"  range from 0 to 180
!u			U --u
!uz			vertically-downward component --z
!ux			northward component --x
!uy			eastward component --y
!T			total intensity --f
!r			earth's radius --a
!N0			the max n,in other word, degree

program main
use sub

integer,parameter::N0=10 !degree
real*8,parameter::r=6371200d0,pi=4d0*atan(1d0)!pi=3.14159265358979... !r is radii
real*8 g(N0*(N0+3)/2)
real*8 h(N0*(N0+3)/2)
real*8 p(N0*(N0+3)/2+1)
real*8 grad_p(N0*(N0+3)/2+1)
real*8 x,y,u,uz,ux,uy,T
!x y used to give the position

!write(*,*)"please write x,y(angel,x from -180 to 180,y from -90 to 90 )"
!read(*,*)x,y
do i=-179,179
do j=-89,89
x=i
y=j
y=90-y
x=x*pi/180d0
y=y*pi/180d0
call point(N0,x,y,p,grad_p)!to use x,y to calculate p and grad_p
call getgh(N0,g,h)!to get g and h from a file
call Utotal(N0,r,x,y,g,h,p,grad_p,u,ux,uy,uz)!to calculate magnet
T=(ux**2+uy**2+uz**2)**0.5 !to get f,total intensity
!write(*,*)"u",u
write(*,*)"x",i,j,ux
!write(*,*)"y",uy
!write(*,*)"z",uz
!write(*,*)"T",T
end do
end do
end program


c=======================================================================
c
c     subroutine CORMEAN
c
c     mean of the non-diagonal elements of the correlation matrix
c
c-----------------------------------------------------------------------
      SUBROUTINE cormean (p, cov, corrmean, info)
c-----------------------------------------------------------------------
c
c     INPUT
c            p      : number of asset(s) (p >= 1)                integer
c            cov    : covariance matrix (p*p)                     double
c
c     OUTPUT
c            corrmean   : mean of the correlation matrix values   double
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER p, info
      DOUBLE PRECISION cov(*), corrmean
c
c     local variables
      double precision temp
      integer i, j
c
c     intrinsic functions
      INTRINSIC sqrt

c
      if (p .gt. 1) then
        corrmean = 0.
        DO i = 1,p-1
            DO j = i+1,p
                temp = cov((i-1)*p+j)
                temp = temp/sqrt(cov((i-1)*p+i))
                temp = temp/sqrt(cov((j-1)*p+j))
                corrmean = temp + corrmean
            ENDDO
        ENDDO

        corrmean = corrmean
        corrmean = 2*corrmean
        corrmean = corrmean/p
        corrmean = corrmean/(p-1)
      else
        info = -1400
      endif
c
      RETURN
      END


C
C	$Id: csarcint.f,v 1.5 2008-07-27 03:10:05 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE CSARCINT (P,P1,P2,F1,F2,G1,G2,SIGMA, F,G,GN)
      DOUBLE PRECISION P(3), P1(3), P2(3), F1, F2, G1(3),
     .                 G2(3), SIGMA, F, G(3), GN
C
C***********************************************************
C
C                                              From SSRFPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   11/21/96
C
C   Given 3 points P, P1, and P2 lying on a common geodesic
C of the unit sphere with P between P1 and P2, along with
C data values and gradients at P1 and P2, this subroutine
C computes an interpolated value F and a gradient vector G
C AT P.  F and the tangential component of G are taken to be
C the value and derivative (with respect to arc-length) of
C a Hermite interpolatory tension spline defined by the end-
C point values and tangential gradient components.  The nor-
C mal component of G is obtained by linear interpolation of
C the normal components of the gradients at P1 and P2.
C
C On input:
C
C       P = Cartesian coordinates of a point lying on the
C           arc defined by P1 and P2.  P(1)**2 + P(2)**2 +
C           P(3)**2 = 1.
C
C       P1,P2 = Coordinates of distinct points on the unit
C               sphere defining an arc with length less than
C               180 degrees.
C
C       F1,F2 = Data values associated with P1 and P2,
C               respectively.
C
C       G1,G2 = Gradient vectors associated with P1 and P2.
C               G1 and G2 are orthogonal to P1 and P2,
C               respectively.
C
C       SIGMA = Tension factor associated with P1-P2.
C
C The above parameters are not altered by this routine.
C
C       G = Array of length 3.
C
C On output:
C
C       F = Interpolated value at P.
C
C       G = Interpolated gradient at P.
C
C       GN = Normal component of G with the direction
C            P1 X P2 taken to be positive.  The extrapola-
C            tion procedure requires this component.
C
C   For each vector V, V(1), V(2), and V(3) contain X, Y,
C and Z components, respectively.
C
C SSRFPACK modules required by CSARCINT:  CSARCLEN, CSSNHCSH
C
C Intrinsic functions called by CSARCINT:  ABS, EXP, SQRT
C
C***********************************************************
C
      DOUBLE PRECISION CSARCLEN
      INTEGER I, LUN
      DOUBLE PRECISION A, AL, B1, B2, CM, CMM, CM2, DUMMY,
     .                 D1, D2, E, EMS, E1, E2, GT, S, SB1,
     .                 SB2, SIG, SINH, SINH2, SM, SM2, TAU1,
     .                 TAU2, TM, TM1, TM2, TP1, TP2, TS,
     .                 UN(3), UNORM
      DATA    LUN/6/
C
C Local parameters:
C
C A =         Angle in radians (arc-length) between P1 and
C               P2
C AL =        Arc-length between P1 and P
C B1,B2 =     Local coordinates of P with respect to P1-P2
C CM,CMM =    Coshm(SIG) and Coshmm(SIG) -- refer to CSSNHCSH
C CM2 =       Coshm(SB2)
C DUMMY =     Dummy parameter for CSSNHCSH
C D1,D2 =     Scaled second differences
C E =         CM**2 - SM*Sinh = SIG*SM - 2*CMM (scaled by
C               2*EMS if SIG > .5)
C EMS =       Exp(-SIG)
C E1,E2 =     Exp(-SB1), Exp(-SB2)
C GT =        Tangential component of G -- component in the
C               direction UN X P
C I =         DO-loop index
C LUN =       Logical unit for error messages
C S =         Slope:  (F2-F1)/A
C SB1,SB2 =   SIG*B1, SIG*B2
C SIG =       Abs(SIGMA)
C SINH =      Sinh(SIGMA)
C SINH2 =     Sinh(SB2)
C SM,SM2 =    Sinhm(SIG), Sinhm(SB2)
C TAU1,TAU2 = Tangential derivatives (components of G1,G2)
C               at P1 and P2
C TM =        1-EMS
C TM1,TM2 =   1-E1, 1-E2
C TP1,TP2 =   1+E1, 1+E2
C TS =        TM**2
C UN =        Unit normal to the plane of P, P1, and P2
C UNORM =     Euclidean norm of P1 X P2 -- used to normalize
C               UN
C
C
C Compute unit normal UN.
C
      UN(1) = P1(2)*P2(3) - P1(3)*P2(2)
      UN(2) = P1(3)*P2(1) - P1(1)*P2(3)
      UN(3) = P1(1)*P2(2) - P1(2)*P2(1)
      UNORM = SQRT(UN(1)*UN(1) + UN(2)*UN(2) + UN(3)*UN(3))
      IF (UNORM .EQ. 0.) GO TO 2
C
C Normalize UN.
C
      DO 1 I = 1,3
        UN(I) = UN(I)/UNORM
    1   CONTINUE
C
C Compute tangential derivatives at the endpoints:
C   TAU1 = (G1,UN X P1) = (G1,P2)/UNORM and
C   TAU2 = (G2,UN X P2) = -(G2,P1)/UNORM.
C
      TAU1 = (G1(1)*P2(1) + G1(2)*P2(2) + G1(3)*P2(3))/UNORM
      TAU2 =-(G2(1)*P1(1) + G2(2)*P1(2) + G2(3)*P1(3))/UNORM
C
C Compute arc-lengths A, AL.
C
      A = CSARCLEN(P1,P2)
      IF (A .EQ. 0.) GO TO 2
      AL = CSARCLEN(P1,P)
C
C Compute local coordinates, slope, and second differences.
C
      B2 = AL/A
      B1 = 1. - B2
      S = (F2-F1)/A
      D1 = S - TAU1
      D2 = TAU2 - S
C
C Test the range of SIGMA.
C
      SIG = ABS(SIGMA)
      IF (SIG .LT. 1.D-9) THEN
C
C Hermite cubic interpolation.
C
        F = F1 + AL*(TAU1 + B2*(D1 + B1*(D1 - D2)))
        GT = TAU1 + B2*(D1 + D2 + 3.*B1*(D1 - D2))
      ELSEIF (SIG .LE. .5) THEN
C
C 0 < SIG .LE. .5.  Use approximations designed to avoid
C   cancellation error in the hyperbolic functions.
C
        SB2 = SIG*B2
        CALL CSSNHCSH (SIG, SM,CM,CMM)
        CALL CSSNHCSH (SB2, SM2,CM2,DUMMY)
        SINH = SM + SIG
        SINH2 = SM2 + SB2
        E = SIG*SM - CMM - CMM
        F = F1 + AL*TAU1 + A*((CM*SM2-SM*CM2)*(D1+D2) + SIG*
     .                        (CM*CM2-SINH*SM2)*D1)/(SIG*E)
        GT = TAU1 + ((CM*CM2-SM*SINH2)*(D1+D2) + SIG*
     .               (CM*SINH2-SINH*CM2)*D1)/E
      ELSE
C
C SIG > .5.  Use negative exponentials in order to avoid
C   overflow.  Note that EMS = EXP(-SIG).
C
        SB1 = SIG*B1
        SB2 = SIG - SB1
        E1 = EXP(-SB1)
        E2 = EXP(-SB2)
        EMS = E1*E2
        TM = 1. - EMS
        TS = TM*TM
        TM1 = 1. - E1
        TM2 = 1. - E2
        E = TM*(SIG*(1.+EMS) - TM - TM)
        F = F1 + AL*S + A*(TM*TM1*TM2*(D1+D2) + SIG*
     .                     ((E2*TM1*TM1-B1*TS)*D1 +
     .                      (E1*TM2*TM2-B2*TS)*D2))/(SIG*E)
        TP1 = 1. + E1
        TP2 = 1. + E2
        GT = S + (TM1*(TM*TP2-SIG*E2*TP1)*D1 -
     .            TM2*(TM*TP1-SIG*E1*TP2)*D2)/E
      ENDIF
C
C Compute GN.
C
      GN = B1*(UN(1)*G1(1) + UN(2)*G1(2) + UN(3)*G1(3)) +
     .     B2*(UN(1)*G2(1) + UN(2)*G2(2) + UN(3)*G2(3))
C
C Compute G = GT*(UN X P) + GN*UN.
C
      G(1) = GT*(UN(2)*P(3) - UN(3)*P(2)) + GN*UN(1)
      G(2) = GT*(UN(3)*P(1) - UN(1)*P(3)) + GN*UN(2)
      G(3) = GT*(UN(1)*P(2) - UN(2)*P(1)) + GN*UN(3)
      RETURN
C
C P1 X P2 = 0.  Print an error message and terminate
C   processing.
C
    2 WRITE (LUN,100) (P1(I),I=1,3), (P2(I),I=1,3)
  100 FORMAT ('1','ERROR IN CSARCINT -- P1 = ',2(F9.6,',  '),
     .        F9.6/1X,19X,'P2 = ',2(F9.6,',  '),F9.6)
      STOP
      END


program zero_vs_minus_zero
    implicit none
    real :: zero = 0.0, minus_zero

    minus_zero = sign(zero, -1.0)
    print '(A, 2F7.2)', '0 vs. -0: ', zero, minus_zero
    if (zero == minus_zero) then
        print '(A)', '0 == -0'
    else
        print '(A)', '0 /= -0'
    end if
    print '(A, F5.1)', 'sqrt(0.0) = ', sqrt(zero)
    print '(A, F5.1)', 'sqrt(-0.0) = ', sqrt(minus_zero)
end program zero_vs_minus_zero


program testingInt
    implicit none ! Turns off implicit typing

    real :: a,b,divr
    integer :: i,j,divi
    character(len=40) :: name

    ! 2 Byte integer
    integer(kind=2)::shortval

    ! 4 Byte integer
    integer(kind=4)::longval

    ! 8 byte integer
    integer(kind=8)::verylongval

    ! 16 byte integer
!    integer(kind=16)::veryverylongval error

    ! Default = 4 byte integer
    integer :: largeval

    print *,huge(shortval),huge(longval),huge(verylongval),huge(largeval)

    name="Default len is 1"
    a=2.0
    b=3.0
    i=2
    j=3
    divr=a/b
    divi=i/j
    print *,divr,divi,name,name(1:6)

end program