////////////////////////////////////////////////////////////////
//
//                           HG_SDF
//
//     GLSL LIBRARY FOR BUILDING SIGNED DISTANCE BOUNDS
//
//     version 2016-01-10
//
//     Check http://mercury.sexy/hg_sdf for updates
//     and usage examples. Send feedback to spheretracing@mercury.sexy.
//
//     Brought to you by MERCURY http://mercury.sexy
//
//
//
// Released as Creative Commons Attribution-NonCommercial (CC BY-NC)
//
////////////////////////////////////////////////////////////////

#define PI 3.14159265359
#define PHI (sqrt(5)*0.5 + 0.5)

// Clamp to [0,1] - this operation is free under certain circumstances.
// For further information see
// http://www.humus.name/Articles/Persson_LowLevelThinking.pdf and
// http://www.humus.name/Articles/Persson_LowlevelShaderOptimization.pdf
#define saturate(x) clamp(x, 0, 1)

// Sign function that doesn't return 0
float sgn(float x) {
    return (x<0)?-1:1;
}

vec2 sgn(vec2 v) {
    return vec2((v.x<0)?-1:1, (v.y<0)?-1:1);
}

float square (float x) {
    return x*x;
}

vec2 square (vec2 x) {
    return x*x;
}

vec3 square (vec3 x) {
    return x*x;
}

float lengthSqr(vec3 x) {
    return dot(x, x);
}

// Maximum/minumum elements of a vector
float vmax(vec2 v) {
    return max(v.x, v.y);
}

float vmax(vec3 v) {
    return max(max(v.x, v.y), v.z);
}

float vmax(vec4 v) {
    return max(max(v.x, v.y), max(v.z, v.w));
}

float vmin(vec2 v) {
    return min(v.x, v.y);
}

float vmin(vec3 v) {
    return min(min(v.x, v.y), v.z);
}

float vmin(vec4 v) {
    return min(min(v.x, v.y), min(v.z, v.w));
}

////////////////////////////////////////////////////////////////
//
//             PRIMITIVE DISTANCE FUNCTIONS
//
////////////////////////////////////////////////////////////////
//
// Conventions:
//
// Everything that is a distance function is called fSomething.
// The first argument is always a point in 2 or 3-space called <p>.
// Unless otherwise noted, (if the object has an intrinsic "up"
// side or direction) the y axis is "up" and the object is
// centered at the origin.
//
////////////////////////////////////////////////////////////////

float fSphere(vec3 p, float r) {
    return length(p) - r;
}

// Plane with normal n (n is normalized) at some distance from the origin
float fPlane(vec3 p, vec3 n, float distanceFromOrigin) {
    return dot(p, n) + distanceFromOrigin;
}

// Cheap Box: distance to corners is overestimated
float fBoxCheap(vec3 p, vec3 b) { //cheap box
    return vmax(abs(p) - b);
}

// Box: correct distance to corners
float fBox(vec3 p, vec3 b) {
    vec3 d = abs(p) - b;
    return length(max(d, vec3(0))) + vmax(min(d, vec3(0)));
}

// Same as above, but in two dimensions (an endless box)
float fBox2Cheap(vec2 p, vec2 b) {
    return vmax(abs(p)-b);
}

float fBox2(vec2 p, vec2 b) {
    vec2 d = abs(p) - b;
    return length(max(d, vec2(0))) + vmax(min(d, vec2(0)));
}

// Endless "corner"
float fCorner (vec2 p) {
    return length(max(p, vec2(0))) + vmax(min(p, vec2(0)));
}

// Blobby ball object. You've probably seen it somewhere. This is not a correct distance bound, beware.
float fBlob(vec3 p) {
    p = abs(p);
    if (p.x < max(p.y, p.z)) p = p.yzx;
    if (p.x < max(p.y, p.z)) p = p.yzx;
    float b = max(max(max(
        dot(p, normalize(vec3(1, 1, 1))),
        dot(p.xz, normalize(vec2(PHI+1, 1)))),
        dot(p.yx, normalize(vec2(1, PHI)))),
        dot(p.xz, normalize(vec2(1, PHI))));
    float l = length(p);
    return l - 1.5 - 0.2 * (1.5 / 2)* cos(min(sqrt(1.01 - b / l)*(PI / 0.25), PI));
}

// Cylinder standing upright on the xz plane
float fCylinder(vec3 p, float r, float height) {
    vec2 d = abs(vec2(length(p.xz),p.y)) - vec2(r, height);
    return min(max(d.x,d.y),0.0) + length(max(d,0.0));
    // return d;
}

// Capsule: A Cylinder with round caps on both sides
float fCapsule(vec3 p, float r, float c) {
    return mix(length(p.xz) - r, length(vec3(p.x, abs(p.y) - c, p.z)) - r, step(c, abs(p.y)));
}

// Distance to line segment between <a> and <b>, used for fCapsule() version 2below
float fLineSegment(vec3 p, vec3 a, vec3 b) {
    vec3 ab = b - a;
    float t = saturate(dot(p - a, ab) / dot(ab, ab));
    return length((ab*t + a) - p);
}

// Capsule version 2: between two end points <a> and <b> with radius r
float fCapsule(vec3 p, vec3 a, vec3 b, float r) {
    return fLineSegment(p, a, b) - r;
}

// Torus in the XZ-plane
float fTorus(vec3 p, float smallRadius, float largeRadius) {
    return length(vec2(length(p.xz) - largeRadius, p.y)) - smallRadius;
}

// A circle line. Can also be used to make a torus by subtracting the smaller radius of the torus.
float fCircle(vec3 p, float r) {
    float l = length(p.xz) - r;
    return length(vec2(p.y, l));
}

// A circular disc with no thickness (i.e. a cylinder with no height).
// Subtract some value to make a flat disc with rounded edge.
float fDisc(vec3 p, float r) {
    float l = length(p.xz) - r;
    return l < 0 ? abs(p.y) : length(vec2(p.y, l));
}

// Hexagonal prism, circumcircle variant
float fHexagonCircumcircle(vec3 p, vec2 h) {
    vec3 q = abs(p);
    return max(q.y - h.y, max(q.x*sqrt(3)*0.5 + q.z*0.5, q.z) - h.x);
    //this is mathematically equivalent to this line, but less efficient:
    //return max(q.y - h.y, max(dot(vec2(cos(PI/3), sin(PI/3)), q.zx), q.z) - h.x);
}

// Hexagonal prism, incircle variant
float fHexagonIncircle(vec3 p, vec2 h) {
    return fHexagonCircumcircle(p, vec2(h.x*sqrt(3)*0.5, h.y));
}

float fTriPrism(vec3 p, float hx, float hy)
{
    vec3 q = abs(p);
    return max(q.z-hy,max(q.x*0.866025+p.y*0.5,-p.y)-hx*0.5);
}

// Cone with correct distances to tip and base circle. Y is up, 0 is in the middle of the base.
float fCone(vec3 p, float radius, float height) {
    vec2 q = vec2(length(p.xz), p.y);
    vec2 tip = q - vec2(0, height);
    vec2 mantleDir = normalize(vec2(height, radius));
    float mantle = dot(tip, mantleDir);
    float d = max(mantle, -q.y);
    float projected = dot(tip, vec2(mantleDir.y, -mantleDir.x));

    // distance to tip
    if ((q.y > height) && (projected < 0)) {
        d = max(d, length(tip));
    }

    // distance to base ring
    if ((q.x > radius) && (projected > length(vec2(height, radius)))) {
        d = max(d, length(q - vec2(radius, 0)));
    }
    return d;
}

//
// "Generalized Distance Functions" by Akleman and Chen.
// see the Paper at https://www.viz.tamu.edu/faculty/ergun/research/implicitmodeling/papers/sm99.pdf
//
// This set of constants is used to construct a large variety of geometric primitives.
// Indices are shifted by 1 compared to the paper because we start counting at Zero.
// Some of those are slow whenever a driver decides to not unroll the loop,
// which seems to happen for fIcosahedron und fTruncatedIcosahedron on nvidia 350.12 at least.
// Specialized implementations can well be faster in all cases.
//

const vec3 GDFVectors[19] = vec3[](
    normalize(vec3(1, 0, 0)),
    normalize(vec3(0, 1, 0)),
    normalize(vec3(0, 0, 1)),

    normalize(vec3(1, 1, 1 )),
    normalize(vec3(-1, 1, 1)),
    normalize(vec3(1, -1, 1)),
    normalize(vec3(1, 1, -1)),

    normalize(vec3(0, 1, PHI+1)),
    normalize(vec3(0, -1, PHI+1)),
    normalize(vec3(PHI+1, 0, 1)),
    normalize(vec3(-PHI-1, 0, 1)),
    normalize(vec3(1, PHI+1, 0)),
    normalize(vec3(-1, PHI+1, 0)),

    normalize(vec3(0, PHI, 1)),
    normalize(vec3(0, -PHI, 1)),
    normalize(vec3(1, 0, PHI)),
    normalize(vec3(-1, 0, PHI)),
    normalize(vec3(PHI, 1, 0)),
    normalize(vec3(-PHI, 1, 0))
);

// Version with variable exponent.
// This is slow and does not produce correct distances, but allows for bulging of objects.
float fGDF(vec3 p, float r, float e, int begin, int end) {
    float d = 0;
    for (int i = begin; i <= end; ++i)
        d += pow(abs(dot(p, GDFVectors[i])), e);
    return pow(d, 1/e) - r;
}

// Version with without exponent, creates objects with sharp edges and flat faces
float fGDF(vec3 p, float r, int begin, int end) {
    float d = 0;
    for (int i = begin; i <= end; ++i)
        d = max(d, abs(dot(p, GDFVectors[i])));
    return d - r;
}

// Primitives follow:

float fOctahedron(vec3 p, float r, float e) {
    return fGDF(p, r, e, 3, 6);
}

float fDodecahedron(vec3 p, float r, float e) {
    return fGDF(p, r, e, 13, 18);
}

float fIcosahedron(vec3 p, float r, float e) {
    return fGDF(p, r, e, 3, 12);
}

float fTruncatedOctahedron(vec3 p, float r, float e) {
    return fGDF(p, r, e, 0, 6);
}

float fTruncatedIcosahedron(vec3 p, float r, float e) {
    return fGDF(p, r, e, 3, 18);
}

float fOctahedron(vec3 p, float r) {
    return fGDF(p, r, 3, 6);
}

float fDodecahedron(vec3 p, float r) {
    return fGDF(p, r, 13, 18);
}

float fIcosahedron(vec3 p, float r) {
    return fGDF(p, r, 3, 12);
}

float fTruncatedOctahedron(vec3 p, float r) {
    return fGDF(p, r, 0, 6);
}

float fTruncatedIcosahedron(vec3 p, float r) {
    return fGDF(p, r, 3, 18);
}

// Rotate around a coordinate axis (i.e. in a plane perpendicular to that axis) by angle <a>.
// Read like this: R(p.xz, a) rotates "x towards z".
// This is fast if <a> is a compile-time constant and slower (but still practical) if not.
void pR(inout vec2 p, float a) {
    p = cos(a)*p + sin(a)*vec2(p.y, -p.x);
}

vec2 pOpRotate(in vec2 p, float a) {
    return cos(a)*p + sin(a)*vec2(p.y, -p.x);
}

// Shortcut for 45-degrees rotation
void pR45(inout vec2 p) {
    p = (p + vec2(p.y, -p.x))*sqrt(0.5);
}

// Repeat space along one axis. Use like this to repeat along the x axis:
// <float cell = pMod1(p.x,5);> - using the return value is optional.
float pMod1(inout float p, float size) {
    float halfsize = size*0.5;
    float c = floor((p + halfsize)/size);
    p = mod(p + halfsize, size) - halfsize;
    return c;
}

// Same, but mirror every second cell so they match at the boundaries
float pModMirror1(inout float p, float size) {
    float halfsize = size*0.5;
    float c = floor((p + halfsize)/size);
    p = mod(p + halfsize,size) - halfsize;
    p *= mod(c, 2.0)*2 - 1;
    return c;
}

// Repeat the domain only in positive direction. Everything in the negative half-space is unchanged.
float pModSingle1(inout float p, float size) {
    float halfsize = size*0.5;
    float c = floor((p + halfsize)/size);
    if (p >= 0)
        p = mod(p + halfsize, size) - halfsize;
    return c;
}

// Repeat only a few times: from indices <start> to <stop> (similar to above, but more flexible)
float pModInterval1(inout float p, float size, float start, float stop) {
    float halfsize = size*0.5;
    float c = floor((p + halfsize)/size);
    p = mod(p+halfsize, size) - halfsize;
    if (c > stop) { //yes, this might not be the best thing numerically.
        p += size*(c - stop);
        c = stop;
    }
    if (c <start) {
        p += size*(c - start);
        c = start;
    }
    return c;
}

// Repeat around the origin by a fixed angle.
// For easier use, num of repetitions is use to specify the angle.
float pModPolar(inout vec2 p, float repetitions) {
    float angle = 2*PI/repetitions;
    float a = atan(p.y, p.x) + angle/2.;
    float r = length(p);
    float c = floor(a/angle);
    a = mod(a,angle) - angle/2.;
    p = vec2(cos(a), sin(a))*r;
    // For an odd number of repetitions, fix cell index of the cell in -x direction
    // (cell index would be e.g. -5 and 5 in the two halves of the cell):
    if (abs(c) >= (repetitions/2)) c = abs(c);
    return c;
}

// Repeat in two dimensions
vec2 pMod2(inout vec2 p, vec2 size) {
    vec2 c = floor((p + size*0.5)/size);
    p = mod(p + size*0.5,size) - size*0.5;
    return c;
}

// Same, but mirror every second cell so all boundaries match
vec2 pModMirror2(inout vec2 p, vec2 size) {
    vec2 halfsize = size*0.5;
    vec2 c = floor((p + halfsize)/size);
    p = mod(p + halfsize, size) - halfsize;
    p *= mod(c,vec2(2))*2 - vec2(1);
    return c;
}

// Same, but mirror every second cell at the diagonal as well
vec2 pModGrid2(inout vec2 p, vec2 size) {
    vec2 c = floor((p + size*0.5)/size);
    p = mod(p + size*0.5, size) - size*0.5;
    p *= mod(c,vec2(2))*2 - vec2(1);
    p -= size/2;
    if (p.x > p.y) p.xy = p.yx;
    return floor(c/2);
}

// Repeat in three dimensions
vec3 pMod3(inout vec3 p, vec3 size) {
    vec3 c = floor((p + size*0.5)/size);
    p = mod(p + size*0.5, size) - size*0.5;
    return c;
}

// Mirror at an axis-aligned plane which is at a specified distance <dist> from the origin.
float pMirror (inout float p, float dist) {
    float s = sgn(p);
    p = abs(p)-dist;
    return s;
}

// Mirror in both dimensions and at the diagonal, yielding one eighth of the space.
// translate by dist before mirroring.
vec2 pMirrorOctant (inout vec2 p, vec2 dist) {
    vec2 s = sgn(p);
    pMirror(p.x, dist.x);
    pMirror(p.y, dist.y);
    if (p.y > p.x)
        p.xy = p.yx;
    return s;
}

// Reflect space at a plane
float pReflect(inout vec3 p, vec3 planeNormal, float offset) {
    float t = dot(p, planeNormal)+offset;
    if (t < 0) {
        p = p - (2*t)*planeNormal;
    }
    return sgn(t);
}

// The "Chamfer" flavour makes a 45-degree chamfered edge (the diagonal of a square of size <r>):
float fOpUnionChamfer(float a, float b, float r) {
    return min(min(a, b), (a - r + b)*sqrt(0.5));
}

// Intersection has to deal with what is normally the inside of the resulting object
// when using union, which we normally don't care about too much. Thus, intersection
// implementations sometimes differ from union implementations.
float fOpIntersectionChamfer(float a, float b, float r) {
    return max(max(a, b), (a + r + b)*sqrt(0.5));
}

// Difference can be built from Intersection or Union:
float fOpDifferenceChamfer (float a, float b, float r) {
    return fOpIntersectionChamfer(a, -b, r);
}

// The "Round" variant uses a quarter-circle to join the two objects smoothly:
float fOpUnionRound(float a, float b, float r) {
    vec2 u = max(vec2(r - a,r - b), vec2(0));
    return max(r, min (a, b)) - length(u);
}

float fOpIntersectionRound(float a, float b, float r) {
    vec2 u = max(vec2(r + a,r + b), vec2(0));
    return min(-r, max (a, b)) + length(u);
}

float fOpDifferenceRound (float a, float b, float r) {
    return fOpIntersectionRound(a, -b, r);
}

// The "Columns" flavour makes n-1 circular columns at a 45 degree angle:
float fOpUnionColumns(float a, float b, float r, float n) {
    if ((a < r) && (b < r)) {
        vec2 p = vec2(a, b);
        float columnradius = r*sqrt(2)/((n-1)*2+sqrt(2));
        pR45(p);
        p.x -= sqrt(2)/2*r;
        p.x += columnradius*sqrt(2);
        if (mod(n,2) == 1) {
            p.y += columnradius;
        }
        // At this point, we have turned 45 degrees and moved at a point on the
        // diagonal that we want to place the columns on.
        // Now, repeat the domain along this direction and place a circle.
        pMod1(p.y, columnradius*2);
        float result = length(p) - columnradius;
        result = min(result, p.x);
        result = min(result, a);
        return min(result, b);
    } else {
        return min(a, b);
    }
}

float fOpDifferenceColumns(float a, float b, float r, float n) {
    a = -a;
    float m = min(a, b);
    //avoid the expensive computation where not needed (produces discontinuity though)
    if ((a < r) && (b < r)) {
        vec2 p = vec2(a, b);
        float columnradius = r*sqrt(2)/n/2.0;
        columnradius = r*sqrt(2)/((n-1)*2+sqrt(2));

        pR45(p);
        p.y += columnradius;
        p.x -= sqrt(2)/2*r;
        p.x += -columnradius*sqrt(2)/2;

        if (mod(n,2) == 1) {
            p.y += columnradius;
        }
        pMod1(p.y,columnradius*2);

        float result = -length(p) + columnradius;
        result = max(result, p.x);
        result = min(result, a);
        return -min(result, b);
    } else {
        return -m;
    }
}

float fOpIntersectionColumns(float a, float b, float r, float n) {
    return fOpDifferenceColumns(a,-b,r, n);
}

// The "Stairs" flavour produces n-1 steps of a staircase:
// much less stupid version by paniq
float fOpUnionStairs(float a, float b, float r, float n) {
    float s = r/n;
    float u = b-r;
    return min(min(a,b), 0.5 * (u + a + abs ((mod (u - a + s, 2 * s)) - s)));
}

// We can just call Union since stairs are symmetric.
float fOpIntersectionStairs(float a, float b, float r, float n) {
    return -fOpUnionStairs(-a, -b, r, n);
}

float fOpDifferenceStairs(float a, float b, float r, float n) {
    return -fOpUnionStairs(-a, b, r, n);
}

// Similar to fOpUnionRound, but more lipschitz-y at acute angles
// (and less so at 90 degrees). Useful when fudging around too much
// by MediaMolecule, from Alex Evans' siggraph slides
float fOpUnionSoft(float a, float b, float r) {
    float e = max(r - abs(a - b), 0);
    return min(a, b) - e*e*0.25/r;
}

// produces a cylindical pipe that runs along the intersection.
// No objects remain, only the pipe. This is not a boolean operator.
float fOpPipe(float a, float b, float r) {
    return length(vec2(a, b)) - r;
}

// first object gets a v-shaped engraving where it intersect the second
float fOpEngrave(float a, float b, float r) {
    return max(a, (a + r - abs(b))*sqrt(0.5));
}

// first object gets a capenter-style groove cut out
float fOpGroove(float a, float b, float ra, float rb) {
    return max(a, min(a + ra, rb - abs(b)));
}

// first object gets a capenter-style tongue attached
float fOpTongue(float a, float b, float ra, float rb) {
    return min(a, max(a - ra, abs(b) - rb));
}

float fPrism(vec3 p, vec3 b, float angle)
{
    vec3 q = p;
    q.x = abs(q.x);
    pR(q.xy, angle);
    return max(fBox(q, b), fBox(p - vec3(0,0.1,0), b));
}


program testpoly

      use polynomial_module
!      use quadrature_module
      implicit none

      type(polynomial) :: p1
      type(polynomial) :: p2
      type(polynomial) :: p1der1,p1der2,p1der3
      real*8 :: coeffarray(3),coeffs(2)
      real*8 :: cmul1(2),cmul2(2)
      real*8 :: val
      type(polynomial) :: pmult
      integer :: i
      type(polynomial) :: pmul1,pmul2
      type(polynomial) :: temp
      type(polynomial) :: parray(4)
      real*8 :: endp(4)

      coeffarray(1)=1.0
      coeffarray(2)=2.0
      coeffarray(3)=3.0

      call polyinitialize(p1,2,coeffarray)

      coeffs(1)=-5.0
      coeffs(2)=2.0

      call polyinitialize(p2,1,coeffs)

      cmul1(1)=1.0
      cmul1(2)=-1.0

      cmul2(1)=1.0
      cmul2(2)=1.0

      call polyinitialize(pmul1,1,cmul1)
      call polyinitialize(pmul2,1,cmul2)
      !call zeropolyinitialize(pmult,2)

      print *,"init pmult"
      call polymultiply(pmul1,pmul2,pmult)
      print *,pmult%coeffs(1:pmult%n+1)

      !call zeropolyinitialize(temp,3)
      print *,"init temp"
      call polymultiply(pmult,p2,temp)
      print *,"multiplied"

      pmult=temp

      print *,pmult%coeffs(1:pmult%n+1)

      endp(1)=-1.d0
      endp(2)=-0.33
      endp(3)=0.33
      endp(4)=1.d0

      print *,"lagrange polynomials"
      call createlagrangepoly(endp,4,parray)

      do i=1,4
        print *,"order =",parray(i)%n
      	print *,parray(i)%coeffs(1:parray(i)%n+1)
      enddo

    !  call convolvetrapz(p1,p2,0.d0,1.d0,10,val)
    !  print *,"integral = ",val
    !  call convolvetrapz(p1,p2,0.d0,1.d0,100,val)
    !  print *,"integral = ",val

      call polyderivative(p1,p1der1)
      call polyderivative(p1der1,p1der2)
      call polyderivative(p1der2,p1der3)

      print *,"p1der order :",p1der3%n
      print *,"val at 5=",polyfindval(p1der3,5.d0)

end program testpoly


c> \file subsm.f

c> \brief Performs the subspace minimization.
c>
c> Given xcp, l, u, r, an index set that specifies
c> the active set at xcp, and an l-BFGS matrix B
c> (in terms of WY, WS, SY, WT, head, col, and theta),
c> this subroutine computes an approximate solution
c> of the subspace problem
c>
c> (P)   min Q(x) = r'(x-xcp) + 1/2 (x-xcp)' B (x-xcp)
c>
c> subject to l<=x<=u
c>           x_i=xcp_i for all i in A(xcp)
c>
c> along the subspace unconstrained Newton direction
c>
c>    d = -(Z'BZ)^(-1) r.
c>
c> The formula for the Newton direction, given the L-BFGS matrix
c> and the Sherman-Morrison formula, is
c>
c>    d = (1/theta)r + (1/theta*2) Z'WK^(-1)W'Z r.
c>
c> where
c>           K = [-D -Y'ZZ'Y/theta     L_a'-R_z'  ]
c>               [L_a -R_z           theta*S'AA'S ]
c>
c> Note that this procedure for computing d differs
c> from that described in [1]. One can show that the matrix K is
c> equal to the matrix M^[-1]N in that paper.
c>
c> @param n On entry n is the dimension of the problem.

c>          On exit n is unchanged.
c>
c> @param m On entry m is the maximum number of variable metric corrections
c>             used to define the limited memory matrix.

c>          On exit m is unchanged.
c>
c> @param nsub On entry nsub is the number of free variables.

c>             On exit nsub is unchanged.
c>
c> @param ind On entry ind specifies the coordinate indices of free variables.

c>            On exit ind is unchanged.
c>
c> @param l On entry l is the lower bound of x.

c>          On exit l is unchanged.
c>
c> @param u On entry u is the upper bound of x.

c>          On exit u is unchanged.
c>
c> @param nbd On entry nbd represents the type of bounds imposed on the
c>               variables, and must be specified as follows:
c>               nbd(i)=

0 if x(i) is unbounded,

c>
1 if x(i) has only a lower bound,

c>
2 if x(i) has both lower and upper bounds, and

c>
3 if x(i) has only an upper bound.

c>            On exit nbd is unchanged.
c>
c> @param x On entry x specifies the Cauchy point xcp.

c>          On exit x(i) is the minimizer of Q over the subspace of
c>                                                        free variables.
c>
c> @param d On entry d is the reduced gradient of Q at xcp.

c>          On exit d is the Newton direction of Q.
c>
c> @param xp used to safeguard the projected Newton direction

c>
c> @param xx On entry it holds the current iterate.

c>           On output it is unchanged.
c>
c> @param gg On entry it holds the gradient at the current iterate.

c>           On output it is unchanged.
c>
c> @param ws On entry this stores S, a set of s-vectors, that defines the
c>              limited memory BFGS matrix.

c>           On exit this array is unchanged.
c>
c> @param wy On entry this stores Y, a set of y-vectors, that defines the
c>              limited memory BFGS matrix.

c>           On exit this array is unchanged.
c>
c> @param theta On entry theta is the scaling factor specifying B_0 = theta I.

c>              On exit theta is unchanged.
c>
c> @param col On entry col is the actual number of variable metric
c>               corrections stored so far.

c>            On exit col is unchanged.
c>
c> @param head On entry head is the location of the first s-vector (or y-vector)
c>                in S (or Y).

c>             On exit col is unchanged.
c>
c> @param iword On entry iword is unspecified.

c>              On exit iword specifies the status of the subspace solution.
c>                 iword =

0 if the solution is in the box,

c>
1 if some bound is encountered.

c>
c> @param wv working array
c>
c> @param wn On entry the upper triangle of wn stores the LEL^T factorization
c>              of the indefinite matrix

c>                   K = [-D -Y'ZZ'Y/theta     L_a'-R_z'  ]
c>                       [L_a -R_z           theta*S'AA'S ]

c>              where E = [-I  0]
c>                        [ 0  I]

c>           On exit wn is unchanged.
c>
c> @param iprint must be set by the user;
c>               It controls the frequency and type of output generated:

c>
iprint<0    no output is generated;

c>
iprint=0    print only one line at the last iteration;

c>
0<iprint<99 print also f and |proj g| every iprint iterations;

c>
iprint=99   print details of every iteration except n-vectors;

c>
iprint=100  print also the changes of active set and final x;

c>
iprint>100  print details of every iteration including x and g;

c>               When iprint > 0, the file iterate.dat will be created to
c>                                summarize the iteration.
c>
c> @param info On entry info is unspecified.

c>             On exit info =

0       for normal return,

c>
nonzero for abnormal return
c>                                        when the matrix K is ill-conditioned.

      subroutine subsm ( n, m, nsub, ind, l, u, nbd, x, d, xp, ws, wy,
     +                   theta, xx, gg,
     +                   col, head, iword, wv, wn, iprint, info )
      implicit none
      integer          n, m, nsub, col, head, iword, iprint, info,
     +                 ind(nsub), nbd(n)
      double precision theta,
     +                 l(n), u(n), x(n), d(n), xp(n), xx(n), gg(n),
     +                 ws(n, m), wy(n, m),
     +                 wv(2*m), wn(2*m, 2*m)

c     **********************************************************************
c
c     This routine contains the major changes in the updated version.
c     The changes are described in the accompanying paper
c
c      Jose Luis Morales, Jorge Nocedal
c      "Remark On Algorithm 788: L-BFGS-B: Fortran Subroutines for Large-Scale
c       Bound Constrained Optimization". Decemmber 27, 2010.
c
c             J.L. Morales  Departamento de Matematicas,
c                           Instituto Tecnologico Autonomo de Mexico
c                           Mexico D.F.
c
c             J, Nocedal    Department of Electrical Engineering and
c                           Computer Science.
c                           Northwestern University. Evanston, IL. USA
c
c                           January 17, 2011
c
c      **********************************************************************
c
c     References:
c
c       [1] R. H. Byrd, P. Lu, J. Nocedal and C. Zhu, ``A limited
c       memory algorithm for bound constrained optimization'',
c       SIAM J. Scientific Computing 16 (1995), no. 5, pp. 1190--1208.
c
c                           *  *  *
c
c     NEOS, November 1994. (Latest revision June 1996.)
c     Optimization Technology Center.
c     Argonne National Laboratory and Northwestern University.
c     Written by
c                        Ciyou Zhu
c     in collaboration with R.H. Byrd, P. Lu-Chen and J. Nocedal.
c
c
c     ************

      integer          pointr,m2,col2,ibd,jy,js,i,j,k
      double precision alpha, xk, dk, temp1, temp2
      double precision one,zero
      parameter        (one=1.0d0,zero=0.0d0)
c
      double precision dd_p

      if (nsub .le. 0) return
      if (iprint .ge. 99) write (6,1001)

c     Compute wv = W'Zd.

      pointr = head
      do 20 i = 1, col
         temp1 = zero
         temp2 = zero
         do 10 j = 1, nsub
            k = ind(j)
            temp1 = temp1 + wy(k,pointr)*d(j)
            temp2 = temp2 + ws(k,pointr)*d(j)
  10     continue
         wv(i) = temp1
         wv(col + i) = theta*temp2
         pointr = mod(pointr,m) + 1
  20  continue

c     Compute wv:=K^(-1)wv.

      m2 = 2*m
      col2 = 2*col

      !call dtrsl(wn,m2,col2,wv,11,info)
      !if (info .ne. 0) return
      call dtrsm('l','u','t','n',col2,1,one,wn,m2,wv,col2)
      info = 0

      do 25 i = 1, col
         wv(i) = -wv(i)
  25     continue

      !call dtrsl(wn,m2,col2,wv,01,info)
      !if (info .ne. 0) return
      call dtrsm('l','u','n','n',col2,1,one,wn,m2,wv,col2)
      info = 0

c     Compute d = (1/theta)d + (1/theta**2)Z'W wv.

      pointr = head
      do 40 jy = 1, col
         js = col + jy
         do 30 i = 1, nsub
            k = ind(i)
            d(i) = d(i) + wy(k,pointr)*wv(jy)/theta
     +                  + ws(k,pointr)*wv(js)
  30     continue
         pointr = mod(pointr,m) + 1
  40  continue

      call dscal( nsub, one/theta, d, 1 )
c
c-----------------------------------------------------------------
c     Let us try the projection, d is the Newton direction

      iword = 0

      call dcopy ( n, x, 1, xp, 1 )
c
      do 50 i=1, nsub
         k  = ind(i)
         dk = d(i)
         xk = x(k)
         if ( nbd(k) .ne. 0 ) then
c
            if ( nbd(k).eq.1 ) then          ! lower bounds only
               x(k) = max( l(k), xk + dk )
               if ( x(k).eq.l(k) ) iword = 1
            else
c
               if ( nbd(k).eq.2 ) then       ! upper and lower bounds
                  xk   = max( l(k), xk + dk )
                  x(k) = min( u(k), xk )
                  if ( x(k).eq.l(k) .or. x(k).eq.u(k) ) iword = 1
               else
c
                  if ( nbd(k).eq.3 ) then    ! upper bounds only
                     x(k) = min( u(k), xk + dk )
                     if ( x(k).eq.u(k) ) iword = 1
                  end if
               end if
            end if
c
         else                                ! free variables
            x(k) = xk + dk
         end if
 50   continue
c
      if ( iword.eq.0 ) then
         go to 911
      end if
c
c     check sign of the directional derivative
c
      dd_p = zero
      do 55 i=1, n
         dd_p  = dd_p + (x(i) - xx(i))*gg(i)
 55   continue
      if ( dd_p .gt.zero ) then
         call dcopy( n, xp, 1, x, 1 )
         write(6,*) ' Positive dir derivative in projection '
         write(6,*) ' Using the backtracking step '
      else
         go to 911
      endif
c
c-----------------------------------------------------------------
c
      alpha = one
      temp1 = alpha
      ibd   = 0
      do 60 i = 1, nsub
         k = ind(i)
         dk = d(i)
         if (nbd(k) .ne. 0) then
            if (dk .lt. zero .and. nbd(k) .le. 2) then
               temp2 = l(k) - x(k)
               if (temp2 .ge. zero) then
                  temp1 = zero
               else if (dk*alpha .lt. temp2) then
                  temp1 = temp2/dk
               endif
            else if (dk .gt. zero .and. nbd(k) .ge. 2) then
               temp2 = u(k) - x(k)
               if (temp2 .le. zero) then
                  temp1 = zero
               else if (dk*alpha .gt. temp2) then
                  temp1 = temp2/dk
               endif
            endif
            if (temp1 .lt. alpha) then
               alpha = temp1
               ibd = i
            endif
         endif
 60   continue

      if (alpha .lt. one) then
         dk = d(ibd)
         k = ind(ibd)
         if (dk .gt. zero) then
            x(k) = u(k)
            d(ibd) = zero
         else if (dk .lt. zero) then
            x(k) = l(k)
            d(ibd) = zero
         endif
      endif
      do 70 i = 1, nsub
         k    = ind(i)
         x(k) = x(k) + alpha*d(i)
 70   continue
cccccc
 911  continue

      if (iprint .ge. 99) write (6,1004)

 1001 format (/,'----------------SUBSM entered-----------------',/)
 1004 format (/,'----------------exit SUBSM --------------------',/)

      return

      end


submodule (maptran) utils

implicit none (type, external)

contains

module procedure enu2uvw
!! # enu2uvw   convert from ENU to UVW coordinates
!!
!! ## Inputs
!!
!! * e,n,up:  East, North, Up coordinates of point(s) (meters)
!! * lat0,lon0: geodetic coordinates of observer/reference point (degrees)
!! * deg: ,true. degrcees
!!
!! ## outputs
!!
!! * u,v,w:   coordinates of test point(s) (meters)

real(wp) :: t, lat0, lon0
logical :: d

d=.true.
if (present(deg)) d = deg

lat0 = llat0
lon0 = llon0
if (d) then
  lat0 = radians(lat0)
  lon0 = radians(lon0)
endif

t = cos(lat0) * up - sin(lat0) * north
w = sin(lat0) * up + cos(lat0) * north

u = cos(lon0) * t - sin(lon0) * east
v = sin(lon0) * t + cos(lon0) * east

end procedure enu2uvw

module procedure anglesep
! angular separation between two points on sphere
! all input/output in DEGREES

real(wp) :: la0,lo0,la1,lo1

la0 = radians(lat0)
lo0 = radians(lon0)
la1 = radians(lat1)
lo1 = radians(lon1)

anglesep = degrees(2 * asin(sqrt(haversine(la1 - la0) + &
                   cos(la0) * cos(la1) * haversine(lo1 - lo0))))

end procedure anglesep

end submodule utils


module def_parame

!-----------------------------------------------------------------------
!
!     Parameters
!
!-----------------------------------------------------------------------
  use typre

! Frequently used mathematical constants (with precision to spare):
  real(rp),    parameter :: pi=3.141592653589793238462643383279502884197_rp
  real(rp),    parameter :: pio2=1.57079632679489661923132169163975144209858_rp
  real(rp),    parameter :: twopi=6.283185307179586476925286766559005768394_rp
  real(rp),    parameter :: sqrt2=1.41421356237309504880168872420969807856967_rp
  real(rp),    parameter :: euler=0.5772156649015328606065120900824024310422_rp
  real(rp),    parameter :: zero_rp=epsilon(0.0_rp)

! Yes/No, Load/Unload and figures
  integer(ip), parameter :: yes=1,no=0
  integer(ip), parameter :: mone=-1,zero=0,one=1,two=2,three=3,four=4
  integer(ip), parameter :: five=5,six=6,seven=7,eight=8,nine=9

! ! Initial allocation parameter arrays to avoid unassociated pointers
!   real(rp),    target :: raux1(1)=0.0_rp
!   real(rp),    target :: raux2(1,1)=0.0_rp
!   real(rp),    target :: raux3(1,1,1)=0.0_rp
!   real(rp),    target :: raux4(1,1,1,1)=0.0_rp
!   integer(ip), target :: iaux1(1)=0

end module def_parame


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlsep3                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.31
!  Written by Gordon A. Fenton, Mar. 24, 1994
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in a 3-D random field
!           having a separable Markovian covariance function.
!
!  This function returns the covariance between two points in the field
!  separated by lag vector {X,Y,Z}. The covariance function for this field
!  is given by
!
!      B(X,Y,Z) = var*exp{-(2|X|/dthx)}*exp{-(2|Y|/dthy)}*exp{-(2|Z|/dthz)}
!
!  where var is the point variance, and dthx, dthy, and dthz are the scales of
!  fluctuation in the x-, y-, and z-directions, respectively. These parameters
!  are brought in through the common block /dparam/.
!
!  NOTE: this function is NOT isotropic even if dthx = dthy = dthz.
!
!  If var < 0, then this function computes the variance of a local average
!  of the random field, averaged over a domain having side dimensions {X,Y,Z}.
!  For a separable covariance function, the variance function is also
!  separable and can be written as the product of three 1-D variance
!  functions corresponding to the Markovian correlation function
!
!         V(X,Y,Z) = V(X)*V(Y)*V(Z)
!
!  where individual functions are based on the 1-D analytical model
!
!                     dthx^2
!         V(X) = 2 * ------- [(2|X|/dthx) + exp{-2|X|/dthx} - 1]
!                     4*X^2
!
!  The variance of the local average is then given by var*V(X,Y,Z). See page
!  186 of "Random Fields" by E. Vanmarcke and G.A. Fenton's thesis for more
!  details.
!
!  The data value `eund' is designed to avoid underflow errors arising from
!  exp(-a) for a > eund. We quite happily accept a zero in this case.
!
!  REVISION HISTORY
!  1.1	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 1/00)
!  1.11	minor changes to documentation above (Jul 14/00)
!  1.2	eliminated lvarfn -- now return covariances only if var < 0 (Apr 9/01)
!  1.3	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.31	revised above documentation to reflect revision 1.3 (May 9/01)
!---------------------------------------------------------------------------
      real*8 function dlsep3( X, Y, Z )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, dpb, dthx, dthy, dthz
      data zero/0.d0/, half/0.5d0/, one/1.d0/, two/2.d0/, eight/8.d0/
      data eund/300.d0/
      exp(s) = dexp(s)
      abs(s) = dabs(s)

      if( var .lt. zero ) then			! return variance function
!							x-direction var func
         a = two*abs(X)/dthx
         if( X .eq. zero ) then
            dsepa = half
         elseif( a .lt. eund ) then
            dsepa = (a + exp(-a) - one)/(a*a)
         else
            dsepa = (a - one)/(a*a)
         endif
!							y-direction var func
         b = two*abs(Y)/dthy
         if( Y .eq. zero ) then
            dsepb = half
         elseif( b .lt. eund ) then
            dsepb = (b + exp(-b) - one)/(b*b)
         else
            dsepb = (b - one)/(b*b)
         endif

!							z-direction var func
         c = two*abs(Z)/dthz
         if( Z .eq. zero ) then
            dsepc = half
         elseif( c .lt. eund ) then
            dsepc = (c + exp(-c) - one)/(c*c)
         else
            dsepc = (c - one)/(c*c)
         endif
!							final variance function
         dlsep3 = -eight*var*dsepa*dsepb*dsepc

      else					! return covariance
         if( dthx .eq. zero ) then
            if( X .eq. zero ) then
               a = zero
            else
               dlsep2 = zero
               return
            endif
         else
            a = two*abs(X)/dthx
         endif
         if( dthy .eq. zero ) then
            if( Y .eq. zero ) then
               b = zero
            else
               dlsep2 = zero
               return
            endif
         else
            b = two*abs(Y)/dthy
         endif
         if( dthz .eq. zero ) then
            if( Z .eq. zero ) then
               c = zero
            else
               dlsep2 = zero
               return
            endif
         else
            b = two*abs(Z)/dthz
         endif
         abc = a + b + c
         if( abc .gt. eund ) then
            dlsep3 = zero
         else
            dlsep3 = var*exp(-abc)
         endif
      endif

      return
      end


module aerosols
  ! This module replaces the more comprehensive version from the Shipway
  ! microphysics scheme - to be used in setting up aerosol distributions

  ! For setting aerosol
  Use class_species, only: species_allocate
  Use column_variables, only: aerosol_init
  Use parameters, only: num_aero_moments, num_aero_bins, nz, naerosol
  Use switches, only: l_ainit
  Use physconst, only : pi

  Implicit None

  integer, parameter ::                                     &
       FourByteReal = selected_real_kind(P =  6, R =  37)   &
       ,EightByteReal = selected_real_kind(P = 13, R =  307)

  integer, parameter ::                 &
     !       wp=FourByteReal                  & ! real working precision
     wp=EightByteReal                    ! real working precision

contains

  function moment_logn(N, rm, sigma, p)
    !
    ! Calculate the moments of a lognormal distribution
    !
    ! int_0^infinty r^p*n(r)dr
    !
    ! where
    !
    !    n(r) = N/(r*sqrt(2*pi)*log(sigma)) &
    !            *exp(-.5*(log(r/rm)/log(sigma))^2)
    !
    ! rm = median radius
    ! log(rm) = mean of log(n(r)/N)
    ! log(sigma) = s.d. of log(n(r)/N)
    !

    real(wp) :: N, rm, sigma
    real(wp) :: p ! calculate pth moment
    real(wp) :: moment_logn

    moment_logn=N*rm**p*exp(.5*p*p*log(sigma)**2)

  end function moment_logn

  subroutine set_aerosol(Ninit, indices, lainits_in, Nds_in, sigmas_in, rds_in, densitys_in, fscale)

    integer, intent(in) :: Ninit
    integer, intent(in) :: indices(Ninit)
    logical, intent(in) :: lainits_in(Ninit)
    real(wp), intent(in) :: Nds_in(Ninit)
    real(wp), intent(in) :: sigmas_in(Ninit)
    real(wp), intent(in) :: rds_in(Ninit)
    real(wp), intent(in) :: densitys_in(Ninit)
    real(wp), intent(in) :: fscale(nz)

    real(wp) :: nd, sigma, rd, density
    integer :: in, ih, k

    do in=1, Ninit
      ih=indices(in)
      if (lainits_in(ih).and.ih<=naerosol)then
        l_ainit(ih)=.True.
        Nd=Nds_in(ih)
        sigma=sigmas_in(ih)
        rd=rds_in(ih)
        density=densitys_in(ih)
        do k=1,nz
          call species_allocate(aerosol_init(k,ih) &
             , num_aero_moments(ih), num_aero_bins(ih), ih, 0.)
          if (num_aero_moments(ih) > 0) &
             aerosol_init(k,ih)%moments(1,1)=Nd
          if (num_aero_moments(ih) > 1) &
             aerosol_init(k,ih)%moments(1,2)=(4.*pi*density/3.)*moment_logn(Nd, rd, sigma, 3._wp)*fscale(k)
        end do
      end if
    end do

  end subroutine set_aerosol

end module aerosols


recursive function gcd_rec(u, v) result(gcd)
    integer             :: gcd
    integer, intent(in) :: u, v

    if (mod(u, v) /= 0) then
        gcd = gcd_rec(v, mod(u, v))
    else
        gcd = v
    end if
end function gcd_rec


      subroutine ecef_to_geodetic(latitude,lon,h,posx,posy,posz,num)
      ! converts from ECEF coordinates to Geodetic
      ! posx,y,z is the 3 elements of positions in km
      ! latitude returned in Radians
      ! longitude returned in Radians
      ! h is the geodetic altitude, returned in km

      ! pos is (x,y,z) in ECEF coordinates
      INTEGER num, i
      real*8 posx(num), posy(num), posz(num)
      real*8 a,b,ellip,e2,p,e_prime,theta,r_n
      real*8 lon(num), latitude(num), h(num)
      real*8 pi

cf2py intent(in) posx, posy, posz
Cf2py intent(out)  latitude, lon, h
Cf2py integer intent(hide), depend(posx) :: num=shape(posx,0)

      pi = 4.D0*DATAN(1.D0)
      ! interpret height as geodetic limit
      ! take current position in lat,lon, and final height
      ! convert to ECEF and use as a limit
      ! equivalent geocentric height
      ! closed form solution
      b = 6356.75231424518d0
      a = 6378.1370d0
      ellip = dsqrt(1.d0-b**2/a**2)
      ! first eccentricity squared
      e2 = ellip**2 !6.6943799901377997E-3
      ! radial position from z, think rho and cylindrical coords
      DO i=1,num
      p = dsqrt(posx(i)**2+posy(i)**2)
      e_prime = dsqrt((a**2-b**2)/b**2)
      theta = datan(posz(i)*a/(p*b))
      latitude(i) = datan( (posz(i)+e_prime**2*b*dsin(theta)**3)/
     &(p-ellip**2*a*dcos(theta)**3))

      r_n = a/dsqrt(1.d0-ellip**2*dsin(latitude(i))**2)
      ! geodetic height
      h(i) = p/dcos(latitude(i)) - r_n

      lon(i) = datan(posy(i)/posx(i))
      ! Based on values from atan2() from Python
      if (posx(i).lt.0) then
         if (posy(i).lt.0) lon(i)=lon(i)-pi
         if (posy(i).ge.0) lon(i)=lon(i)+pi
      end if
      if (posx(i).eq.0) then
         if (posy(i).gt.0) lon(i)=lon(i)+pi/2.D0
         if (posy(i).lt.0) lon(i)=lon(i)-pi/2.D0
      end if
      p=180.D0/pi
      latitude(i)=latitude(i)*p
      lon(i)=lon(i)*p
      end do

      return
      end


    Function nagf_blas_dpyth(a, b)
!
!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md
!
!     NAGF_BLAS_DPYTH returns the value
!
!        p = sqrt( a*a + b*b )
!
!     via the function name.
!
!
!     Nag Fortran 77 O( 1 ) basic linear algebra routine.
!
!     -- Written on 17-January-1985.
!     Sven Hammarling, Nag Central Office.
!

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Function Return Value ..
      Real (Kind=dp) :: nagf_blas_dpyth
!     .. Parameters ..
      Real (Kind=dp), Parameter :: zero = 0.0E+0_dp
!     .. Scalar Arguments ..
      Real (Kind=dp) :: a, b
!     .. Local Scalars ..
      Real (Kind=dp) :: p
!     .. Intrinsic Procedures ..
      Intrinsic :: abs, sqrt
!     .. Executable Statements ..
      If (a==zero) Then
        p = abs(b)
      Else If (b==zero) Then
        p = abs(a)
      Else If (abs(a)>=abs(b)) Then
        p = abs(a)*sqrt(1+(b/a)**2)
      Else
        p = abs(b)*sqrt(1+(a/b)**2)
      End If
!
      nagf_blas_dpyth = p
      Return
!
!     End of NAGF_BLAS_DPYTH. ( SPYTH )
!
    End Function


c fishpk30 from portlib                                  12/30/83
c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                        f i s h p a k                          *
c     *                                                               *
c     *                                                               *
c     *     a package of fortran subprograms for the solution of      *
c     *                                                               *
c     *      separable elliptic partial differential equations        *
c     *                                                               *
c     *                  (version 3.1 , october 1980)                  *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *        john adams, paul swarztrauber and roland sweet         *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the national center for atmospheric research          *
c     *                                                               *
c     *                boulder, colorado  (80307)  u.s.a.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the national science foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c     program to illustrate the use of subroutine hstcrt to solve
c     the equation
c
c    (d/dx)(du/dx) + (d/dy)(du/dy) - 2*u = -2(pi**2+1)sin(pi*x)cos(pi*y)
c
c     where  1 .le. x .le. 3 and -1 .le. y .le. 1 and the boundary
c     conditions are
c
c     u = 0 on x = 1,  du/dx = -pi*cos(pi*y) on x = 3
c
c     and u is periodic in y .
c
c     we want to have 48 unknowns in the x-interval and 53 unknowns
c     in the y-interval.
c
      program thstcrt
      dimension       f(50,53)   ,bda(53)    ,bdb(53)    ,w(1076)    ,
     1                x(48)      ,y(53)
      dimension bdc(1), bdd(1)
c
c     from the dimension statement we get idimf = 50.  also note that
c     w is dimensioned (13 + int(log2(n))*m + 4*n.
c
      idimf = 50
      a = 1.
      b = 3.
      m = 48
      dx = (b-a)/float(m)
      mbdcnd = 2
      c = -1.
      d = 1.
      n = 53
      dy = (d-c)/float(n)
      nbdcnd = 0
      elmbda = -2.
c
c     auxiliary quantities
c
      pi = pimach(dum)
      pisq = pi*pi
c
c     generate and store grid points for computation of boundary data
c     and the right side of the helmholtz equation.
c
      do 101 i=1,m
         x(i) = a+(float(i)-0.5)*dx
  101 continue
      do 102 j=1,n
         y(j) = c+(float(j)-0.5)*dy
  102 continue
c
c     generate boundary data.
c
      do 103 j=1,n
         bda(j) = 0.
         bdb(j) = -pi*cos(pi*y(j))
  103 continue
c
c     bdc and bdd are dummy arguments in this example.
c
c     generate right side of equation.
c
      t = -2.*(pisq+1.)
      do 105 i=1,m
         do 104 j=1,n
            f(i,j) = t*sin(pi*x(i))*cos(pi*y(j))
  104    continue
  105 continue
      call hstcrt (a,b,m,mbdcnd,bda,bdb,c,d,n,nbdcnd,bdc,bdd,elmbda,f,
     1             idimf,pertrb,ierror,w)
c
c     compute discretization error.  the exact solution is
c
c               u(x,y) = sin(pi*x)*cos(pi*y) .
c
      err = 0.
      do 107 i=1,m
         do 106 j=1,n
            t = abs(f(i,j)-sin(pi*x(i))*cos(pi*y(j)))
            if (t .gt. err) err = t
  106    continue
  107 continue
      print 1001 , ierror,err,w(1)
      stop
c
 1001 format (1h1,20x,25hsubroutine hstcrt example///
     1        10x,46hthe output from the ncar control data 7600 was//
     2        32x,10hierror = 0/
     3        18x,34hdiscretization error = 1.26001e-03/
     4        12x,32hrequired length of w array = 884//
     5        10x,32hthe output from your computer is//
     6        32x,8hierror =,i2/18x,22hdiscretization error =,e12.5/
     7        12x,28hrequired length of w array =,f4.0)
c
      end
c     compute discretization error.  the exact solution is


program main
    ! calculate the exact solution of the Schrodinger equation of a particle in 2-dimension infinite square potential well

    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)

    ! local vars
    real(dp) :: L = 1.d0
    integer :: Nx
    integer :: n
    real(dp) :: dx, x, y

    ! excutable
    Nx = -1
    do while (Nx <= 0)
        write(*,*) 'Please specify the # number of slices between [0,L], Nx ='
        read(*,*) Nx
    end do

    write(*,*) 'The # of the energy level, n ='
    read(*,*) n

    x = 0.d0
    dx = L / Nx
    open(unit = 1,file = '1-wavefunction-exact.txt',status = 'unknown')
    do while (x < L + dx)
        y = sqrt(2.d0 / L) * sin(n * pi * x / L)
        write(1, '(2f20.8)') x, y
        x = x + dx
    end do
    close(1)

end program main


! OPEN_PRODUCTS
! op_ve             Open product between two 1st order tensors (3 components) [i x j] giving matrix 3x3 out
! op_ve_9           Open product between two 1st order tensors (3 components) [i x j] giving 9 voigt out
! op_V9             Open product between two 2nd order tensors (9 components) [ij x kl]
! op_a_V9           Non-standard open product "above" between two 2nd order tensors (9 components) [ik x jl]
! op_b_V9           Non-standard open product "below" between two 2nd order tensors (9 components) [il x jk]
! Pop_V9            c_ijkl = 0.25*( a_ik b_jl+a_il b_jk+b_ik a_jl+b_il a_jk )
!
! Open products between 4th and - 2nd order tensors
! v9_op_v9x9        a_ij B_klmn - 2nd order in first position
! v9x9_op_v9        A_ijkl b_mn - 2nd order in last position
! v9_opc_v9x9       c_kl D_ijmn - 2nd order in center position
! ilmn_jk           c_ijklmn = a_ilmn * b_jk
! ikmn_jl           c_ijklmn = a_ikmn * b_jl
!
! 6-component functions
! op_V6             Open product between two 2nd order tensors (6 components)

Module Open_products
Implicit none
CONTAINS

!==============================================================================
FUNCTION op_ve(a,b) RESULT (c)
implicit none

    DOUBLE PRECISION, INTENT (IN) :: a(3),b(3)
    DOUBLE PRECISION :: c(3,3)
    INTEGER I,J
    DO I=1,3
       DO J=1,3
             c(I,J)=a(I)*b(J)
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

!==============================================================================
function op_ve_9(a,b) result (c)
    implicit none
    double precision, intent(in) :: a(3), b(3)
    double precision :: c(9)
    c(1) = a(1)*b(1)
    c(2) = a(2)*b(2)
    c(3) = a(3)*b(3)
    c(4) = a(1)*b(2)
    c(5) = a(2)*b(3)
    c(6) = a(3)*b(1)
    c(7) = a(1)*b(3)
    c(8) = a(2)*b(1)
    c(9) = a(3)*b(2)
end function op_ve_9
!==============================================================================

!==============================================================================
FUNCTION op_V9(a,b) RESULT (c)
implicit none

    DOUBLE PRECISION, INTENT (IN) :: a(9),b(9)
    DOUBLE PRECISION :: c(9,9)
    INTEGER I,J
    DO I=1,9
       DO J=1,9
             c(I,J)=a(I)*b(J)
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION op_a_V9(b,c) RESULT (a)
implicit none

    DOUBLE PRECISION, INTENT (IN) :: b(9),c(9)
    DOUBLE PRECISION :: a(9,9)

    ! Derived from matlab program derive_expr
    a(1,1)=b(1)*c(1); a(1,2)=b(4)*c(4); a(1,3)=b(7)*c(7);
    a(1,4)=b(1)*c(4); a(1,5)=b(4)*c(7); a(1,6)=b(7)*c(1);
    a(1,7)=b(1)*c(7); a(1,8)=b(4)*c(1); a(1,9)=b(7)*c(4);
    a(2,1)=b(8)*c(8); a(2,2)=b(2)*c(2); a(2,3)=b(5)*c(5);
    a(2,4)=b(8)*c(2); a(2,5)=b(2)*c(5); a(2,6)=b(5)*c(8);
    a(2,7)=b(8)*c(5); a(2,8)=b(2)*c(8); a(2,9)=b(5)*c(2);
    a(3,1)=b(6)*c(6); a(3,2)=b(9)*c(9); a(3,3)=b(3)*c(3);
    a(3,4)=b(6)*c(9); a(3,5)=b(9)*c(3); a(3,6)=b(3)*c(6);
    a(3,7)=b(6)*c(3); a(3,8)=b(9)*c(6); a(3,9)=b(3)*c(9);
    a(4,1)=b(1)*c(8); a(4,2)=b(4)*c(2); a(4,3)=b(7)*c(5);
    a(4,4)=b(1)*c(2); a(4,5)=b(4)*c(5); a(4,6)=b(7)*c(8);
    a(4,7)=b(1)*c(5); a(4,8)=b(4)*c(8); a(4,9)=b(7)*c(2);
    a(5,1)=b(8)*c(6); a(5,2)=b(2)*c(9); a(5,3)=b(5)*c(3);
    a(5,4)=b(8)*c(9); a(5,5)=b(2)*c(3); a(5,6)=b(5)*c(6);
    a(5,7)=b(8)*c(3); a(5,8)=b(2)*c(6); a(5,9)=b(5)*c(9);
    a(6,1)=b(6)*c(1); a(6,2)=b(9)*c(4); a(6,3)=b(3)*c(7);
    a(6,4)=b(6)*c(4); a(6,5)=b(9)*c(7); a(6,6)=b(3)*c(1);
    a(6,7)=b(6)*c(7); a(6,8)=b(9)*c(1); a(6,9)=b(3)*c(4);
    a(7,1)=b(1)*c(6); a(7,2)=b(4)*c(9); a(7,3)=b(7)*c(3);
    a(7,4)=b(1)*c(9); a(7,5)=b(4)*c(3); a(7,6)=b(7)*c(6);
    a(7,7)=b(1)*c(3); a(7,8)=b(4)*c(6); a(7,9)=b(7)*c(9);
    a(8,1)=b(8)*c(1); a(8,2)=b(2)*c(4); a(8,3)=b(5)*c(7);
    a(8,4)=b(8)*c(4); a(8,5)=b(2)*c(7); a(8,6)=b(5)*c(1);
    a(8,7)=b(8)*c(7); a(8,8)=b(2)*c(1); a(8,9)=b(5)*c(4);
    a(9,1)=b(6)*c(8); a(9,2)=b(9)*c(2); a(9,3)=b(3)*c(5);
    a(9,4)=b(6)*c(2); a(9,5)=b(9)*c(5); a(9,6)=b(3)*c(8);
    a(9,7)=b(6)*c(5); a(9,8)=b(9)*c(8); a(9,9)=b(3)*c(2);

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION op_b_V9(b,c) RESULT (a)
implicit none

    DOUBLE PRECISION, INTENT (IN) :: b(9),c(9)
    DOUBLE PRECISION :: a(9,9)

    ! Derived from matlab program derive_expr
    a(1,1)=b(1)*c(1);a(1,2)=b(4)*c(4);a(1,3)=b(7)*c(7);
    a(1,4)=b(4)*c(1);a(1,5)=b(7)*c(4);a(1,6)=b(1)*c(7);
    a(1,7)=b(7)*c(1);a(1,8)=b(1)*c(4);a(1,9)=b(4)*c(7);
    a(2,1)=b(8)*c(8);a(2,2)=b(2)*c(2);a(2,3)=b(5)*c(5);
    a(2,4)=b(2)*c(8);a(2,5)=b(5)*c(2);a(2,6)=b(8)*c(5);
    a(2,7)=b(5)*c(8);a(2,8)=b(8)*c(2);a(2,9)=b(2)*c(5);
    a(3,1)=b(6)*c(6);a(3,2)=b(9)*c(9);a(3,3)=b(3)*c(3);
    a(3,4)=b(9)*c(6);a(3,5)=b(3)*c(9);a(3,6)=b(6)*c(3);
    a(3,7)=b(3)*c(6);a(3,8)=b(6)*c(9);a(3,9)=b(9)*c(3);
    a(4,1)=b(1)*c(8);a(4,2)=b(4)*c(2);a(4,3)=b(7)*c(5);
    a(4,4)=b(4)*c(8);a(4,5)=b(7)*c(2);a(4,6)=b(1)*c(5);
    a(4,7)=b(7)*c(8);a(4,8)=b(1)*c(2);a(4,9)=b(4)*c(5);
    a(5,1)=b(8)*c(6);a(5,2)=b(2)*c(9);a(5,3)=b(5)*c(3);
    a(5,4)=b(2)*c(6);a(5,5)=b(5)*c(9);a(5,6)=b(8)*c(3);
    a(5,7)=b(5)*c(6);a(5,8)=b(8)*c(9);a(5,9)=b(2)*c(3);
    a(6,1)=b(6)*c(1);a(6,2)=b(9)*c(4);a(6,3)=b(3)*c(7);
    a(6,4)=b(9)*c(1);a(6,5)=b(3)*c(4);a(6,6)=b(6)*c(7);
    a(6,7)=b(3)*c(1);a(6,8)=b(6)*c(4);a(6,9)=b(9)*c(7);
    a(7,1)=b(1)*c(6);a(7,2)=b(4)*c(9);a(7,3)=b(7)*c(3);
    a(7,4)=b(4)*c(6);a(7,5)=b(7)*c(9);a(7,6)=b(1)*c(3);
    a(7,7)=b(7)*c(6);a(7,8)=b(1)*c(9);a(7,9)=b(4)*c(3);
    a(8,1)=b(8)*c(1);a(8,2)=b(2)*c(4);a(8,3)=b(5)*c(7);
    a(8,4)=b(2)*c(1);a(8,5)=b(5)*c(4);a(8,6)=b(8)*c(7);
    a(8,7)=b(5)*c(1);a(8,8)=b(8)*c(4);a(8,9)=b(2)*c(7);
    a(9,1)=b(6)*c(8);a(9,2)=b(9)*c(2);a(9,3)=b(3)*c(5);
    a(9,4)=b(9)*c(8);a(9,5)=b(3)*c(2);a(9,6)=b(6)*c(5);
    a(9,7)=b(3)*c(8);a(9,8)=b(6)*c(2);a(9,9)=b(9)*c(5);

END FUNCTION
!==============================================================================

!==============================================================================
FUNCTION Pop_V9(b,c) RESULT (a)
! P operator: c_ijkl = 0.25*( a_ik b_jl+a_il b_jk+b_ik a_jl+b_il a_jk )
implicit none

    DOUBLE PRECISION, INTENT (IN) :: b(9),c(9)
    DOUBLE PRECISION :: a(9,9)

    a=0.25d0*( op_a_V9(b,c) + op_a_V9(c,b) + op_b_V9(b,c) + op_b_V9(c,b) )

END FUNCTION
!==============================================================================

! Open products between 4th and - 2nd order tensors
!==============================================================================
function v9_op_v9x9(a,b) result (c)
    implicit none
    double precision, intent(in) :: a(9),b(9,9)
    double precision             :: c(9,9,9)
    integer k1, k2, k3

    do k1=1,9
        do k2=1,9
            do k3=1,9
                c(k1,k2,k3)=a(k1)*b(k2,k3)
            enddo
        enddo
    enddo

end function v9_op_v9x9
!==============================================================================

!==============================================================================
function v9x9_op_v9(a,b) result (c)
    implicit none
    double precision, intent(in) :: a(9,9),b(9)
    double precision             :: c(9,9,9)
    integer k1, k2, k3

    do k1=1,9
        do k2=1,9
            do k3=1,9
                c(k1,k2,k3)=a(k1,k2)*b(k3)
            enddo
        enddo
    enddo

end function v9x9_op_v9
!==============================================================================

!==============================================================================
function v9_opc_v9x9(a,b) result (c)
    implicit none
    double precision, intent(in) :: a(9),b(9,9)
    double precision             :: c(9,9,9)
    integer k1, k2, k3

    do k1=1,9
        do k2=1,9
            do k3=1,9
                c(k1,k2,k3)=a(k2)*b(k1,k3)
            enddo
        enddo
    enddo

end function v9_opc_v9x9
!==============================================================================

!==============================================================================
function ilmn_jk(a,b) result (c)
    !Calculates c_ijklmn = a_ilmn * b_jk
    implicit none
    double precision, intent(in) :: a(9,9),b(9)
    double precision             :: c(9,9,9)
    integer k1, k2, k3, v_voigt(9,2), m_voigt(3,3), ind1, ind2

    ! Define voigt numbering
    v_voigt(:,1) = (/1, 2, 3, 1, 2, 3, 1, 2, 3/)
    v_voigt(:,2) = (/1, 2, 3, 2, 3, 1, 3, 1, 2/)
    m_voigt(1,:) = (/1, 4, 7/)
    m_voigt(2,:) = (/8, 2, 5/)
    m_voigt(3,:) = (/6, 9, 3/)

    do k1 = 1,9 !ij
        do k2 = 1,9 !kl
            do k3 = 1,9 !mn
                ind1 = m_voigt(v_voigt(k1,1), v_voigt(k2,2)) !il (i is 1st index in k1, l is 2nd index in k2)
                ind2 = m_voigt(v_voigt(k1,2), v_voigt(k2,1)) !jk (j is 2nd index in k1, k is 1st index in k2)
                c(k1,k2,k3) = a(ind1,k3)*b(ind2)
            enddo
        enddo
    enddo

end function ilmn_jk
!==============================================================================

!==============================================================================
function ikmn_jl(a,b) result (c)
    !Calculates c_ijklmn = a_ikmn * b_jl
    implicit none
    double precision, intent(in) :: a(9,9),b(9)
    double precision             :: c(9,9,9)
    integer k1, k2, k3, v_voigt(9,2), m_voigt(3,3), ind1, ind2

    ! Define voigt numbering
    v_voigt(:,1) = (/1, 2, 3, 1, 2, 3, 1, 2, 3/)
    v_voigt(:,2) = (/1, 2, 3, 2, 3, 1, 3, 1, 2/)
    m_voigt(1,:) = (/1, 4, 7/)
    m_voigt(2,:) = (/8, 2, 5/)
    m_voigt(3,:) = (/6, 9, 3/)

    do k1 = 1,9 !ij
        do k2 = 1,9 !kl
            do k3 = 1,9 !mn
                ind1 = m_voigt(v_voigt(k1,1), v_voigt(k2,1)) !ik (i is 1st index in k1, k is 1st index in k2)
                ind2 = m_voigt(v_voigt(k1,2), v_voigt(k2,2)) !jl (j is 2nd index in k1, l is 2nd index in k2)
                c(k1,k2,k3) = a(ind1,k3)*b(ind2)
            enddo
        enddo
    enddo

end function ikmn_jl
!==============================================================================

! 6-component voigt functions
!==============================================================================
FUNCTION op_V6(a,b) RESULT (c)
! Old name: us_open_stand6
implicit none

    DOUBLE PRECISION, INTENT (IN) :: a(6),b(6)
    DOUBLE PRECISION :: c(6,6)
    INTEGER I,J
    DO I=1,6
       DO J=1,6
          IF ((I.GE.4).AND.(J.GE.4)) THEN
             c(I,J)=a(I)*b(J)*2.d0
          ELSE
             c(I,J)=a(I)*b(J)
          ENDIF
       ENDDO
    ENDDO

END FUNCTION
!==============================================================================

END MODULE


      PROGRAM xsvdfit
C     driver for routine svdfit
      INTEGER NPOL,NPT
      REAL SPREAD
      PARAMETER(NPT=100,SPREAD=0.02,NPOL=5)
      INTEGER i,idum,mp,np
      REAL chisq,gasdev
      REAL x(NPT),y(NPT),sig(NPT),a(NPOL),cvm(NPOL,NPOL)
      REAL u(NPT,NPOL),v(NPOL,NPOL),w(NPOL)
      EXTERNAL fpoly,fleg
C     polynomial fit
      idum=-911
      mp=NPT
      np=NPOL
      do 11 i=1,NPT
        x(i)=0.02*i
        y(i)=1.0+x(i)*(2.0+x(i)*(3.0+x(i)*(4.0+x(i)*5.0)))
        y(i)=y(i)*(1.0+SPREAD*gasdev(idum))
        sig(i)=y(i)*SPREAD
11    continue
      call svdfit(x,y,sig,NPT,a,NPOL,u,v,w,mp,np,chisq,fpoly)
      call svdvar(v,NPOL,np,w,cvm,NPOL)
      write(*,*) 'Polynomial fit:'
      do 12 i=1,NPOL
        write(*,'(1x,f12.6,a,f10.6)') a(i),'  +-',sqrt(cvm(i,i))
12    continue
      write(*,'(1x,a,f12.6/)') 'Chi-squared',chisq
      call svdfit(x,y,sig,NPT,a,NPOL,u,v,w,mp,np,chisq,fleg)
      call svdvar(v,NPOL,np,w,cvm,NPOL)
      write(*,*) 'Legendre polynomial fit'
      do 13 i=1,NPOL
        write(*,'(1x,f12.6,a,f10.6)') a(i),'  +-',sqrt(cvm(i,i))
13    continue
      write(*,'(1x,a,f12.6/)') 'Chi-squared',chisq
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xsvdfit.for


integer i,j,imax,prime_max
logical, allocatable :: primes(:)

write(*,*) 'Input largest number for search'
read(*,*) prime_max

allocate(primes(prime_max))
primes=.true. ! Sets all elements of array to 1
imax=sqrt(real(prime_max))

do i=2,imax
    do j=2*i,prime_max,i
        primes(j)=.false.
    enddo
enddo

do i=2,prime_max
    if (primes(i)) write(*,*)i
enddo
end


SUBROUTINE rel_schwarzschild (Zsat, Zearth, GMearth, beta, gama, clight, a_Schwarzschild)

! ----------------------------------------------------------------------
! SUBROUTINE: rel_schwarzschild.f90
! ----------------------------------------------------------------------
! Purpose:
! Relativistic effects : Schwarzschild field
!  Relativistic corrections (Schwarzschild term) to the acceleration of an
!  Earth artificial satellite according to the formula adopted by the IERS
!  Conventions 2010.
! ----------------------------------------------------------------------
! Input arguments:
! - Zsat     :		Satellite's state vector with respect to the Earth
! - Zearth   : 		Earth's state vector with respect to the Sun
!   				z = [x y z Vx Vy Vz]'
! - GMearth	: 		Gravitational coefficient of Earth
! - beta	: 		PPN (parameterized post-Newtonian) parameters
!   gama
! - clight	: 		Speed of light
!
! Output arguments:
! - a_Schwarzschild:	Satellite acceleration vector of relativistic corrections
!               		a_relativ = [ax; ay; az]
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	24 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      !USE mdl_num
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(6) :: Zsat, Zearth
      REAL (KIND = prec_q), INTENT(IN) :: GMearth
      REAL (KIND = prec_q), INTENT(IN) :: beta, gama
      REAL (KIND = prec_q), INTENT(IN) :: clight

! OUT
      REAL (KIND = prec_q), INTENT(OUT), DIMENSION(3) :: a_Schwarzschild
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q), DIMENSION(3) :: rsat,vsat , rearth,vearth , Jearth
      REAL (KIND = prec_q) :: lsat, learth
      REAL (KIND = prec_q) :: prod_rv , prod_vv
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Satellite vectors
rsat = (/Zsat(1), Zsat(2), Zsat(3) /)
vsat = (/ Zsat(4), Zsat(5), Zsat(6) /)

! Earth-Satellite distance
lsat = sqrt( rsat(1)**2 + rsat(2)**2 + rsat(3)**2 )
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Earth vectors
rearth = (/ Zearth(1), Zearth(2), Zearth(3) /)
vearth = (/ Zearth(4), Zearth(5), Zearth(6) /)

! Earth's angular momentum per unit mass
      CALL productcross (rearth,vearth , Jearth)

! Sun-Earth distance
learth = sqrt(rearth(1)**2 + rearth(2)**2 + rearth(3)**2)
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Relativistic effects: Schwarzschild term
! ---------------------------------------------------------------------------
      CALL productdot(vsat,vsat , prod_vv)
      CALL productdot(rsat,vsat , prod_rv)

! Schwarzschild terms
a_Schwarzschild = (GMearth / (clight**2 * lsat**3)) *									&
                  ( 																	&
                  ( 2.0D0 * (beta+gama) * (GMearth/lsat) - gama * prod_vv ) * rsat 		&
                  + 2.0D0 * (1.0D0 + gama) * prod_rv * vsat 							&
                  )
! ---------------------------------------------------------------------------

END


PROGRAM test_invert

  USE auxil, ONLY: check_SM, invert_SM, invert_mSM
  USE utilities, ONLY: DP, time_type, timinfo, initiate_clock, trimlr, pring
  USE matrices, ONLY: invert_cholesky, invert_matrix, determinant_matrix
  IMPLICIT NONE

  INTEGER, PARAMETER :: N = 65, Ntry = 1000000
  INTEGER :: i
  INTEGER, DIMENSION(2) :: pos
  REAL(DP) :: delta, detV, detV2
  REAL(DP), DIMENSION(4,4) :: C0, invC0, C, invC
  REAL(DP), DIMENSION(3,3) :: A0, invA0, A1, A, invA, invAC
  REAL(DP), DIMENSION(N,N) :: S, R, V, invV
  REAL(DP), DIMENSION(N,N) :: V2, invVS, invVC
  LOGICAL :: noposdef
  TYPE(time_type) :: timestr

  !! Sherman-Morrison (ex via Sherman&Morrison50)
  !!------------------
  C0(1,:) = [2.384_DP, 1.238_DP, 0.861_DP, 2.413_DP]
  C0(2,:) = [0.648_DP, 1.113_DP, 0.761_DP, 0.137_DP]
  C0(3,:) = [1.119_DP, 0.643_DP, 3.172_DP, 1.139_DP]
  C0(4,:) = [0.745_DP, 2.137_DP, 1.268_DP, 0.542_DP]

  C(:,:) = C0(:,:)
  C(2,4) = C0(2,4) + 0.4

  invC0(1,:) = [0.2220_DP, 2.5275_DP, -0.1012_DP, -1.4145_DP]
  invC0(2,:) = [-0.04806_DP, -0.2918_DP, -0.1999_DP, 0.7079_DP]
  invC0(3,:) = [-0.1692_DP, 0.01195_DP, 0.3656_DP, -0.01824_DP]
  invC0(4,:) = [0.2801_DP, -2.3517_DP, 0.07209_DP, 1.0409_DP]

  CALL check_SM(C, C0, pos, delta)
  invC(:,:) = invert_SM(C, invC0, pos, delta)
  PRINT*, '- invC via Sherman-Morrison: '
  PRINT*, invC
  PRINT*

  invC(:,:) = invert_matrix(C)
  PRINT*, '- invC via LU: '
  PRINT*, invC
  PRINT*

  !! Modified Sherman-Morrison
  !!---------------------------
  A0(1,:) = [2._DP, -1._DP, 0._DP]
  A0(2,:) = [-1._DP, 2._DP, -1._DP]
  A0(3,:) = [0._DP, -1._DP, 2._DP]

  A1(:,:) = A0(:,:)
  A1(2,3) = A0(2,3) + 0.4
  PRINT*, '- A1: '
  PRINT*, A1
  PRINT*

  A(:,:) = A1(:,:)
  A(3,2) = A1(3,2) + 0.4
  PRINT*, '- A: '
  PRINT*, A
  PRINT*

  invA0(:,:) = invert_cholesky(A0)
  PRINT*, '- invA0 via Cholesky: '
  PRINT*, invA0
  PRINT*

  CALL check_SM(A, A1, pos, delta)
  PRINT*, 'pos = ', pos
  PRINT*, 'delta = ', delta
  PRINT*
  invA(:,:) = invert_mSM(A, invA0, pos, delta)
  invAC(:,:) = invert_cholesky(A)
  PRINT*, '- invA via modified Sherman-Morrison: '
  PRINT*, invA
  PRINT*
  PRINT*, '- discrepancy between invA and invAC: '
  PRINT*, invA - invAC
  PRINT*

  !! Speed mesurement
  !!------------------

  ! Initial matrix
  PRINT*, "INITIAL MATRIX"
  PRINT*
  S(:,:) = 0._DP
  R(:,:) = 0.2_DP
  FORALL (i=1:N)
     S(i,i) = i
     R(i,i) = 1._DP
  END FORALL
  V(:,:) = MATMUL(MATMUL(S(:,:),R(:,:)),S(:,:))
  invV(:,:) = INVERT_CHOLESKY(V(:,:), DETERMINANT=detV)
  IF (N <= 5) THEN
    PRINT*, "V="
    DO i=1,N
      PRINT*, REAL(V(i,:))
    END DO
    PRINT*
    PRINT*, "V-1="
    DO i=1,N
      PRINT*, REAL(invV(i,:))
    END DO
    PRINT*
  END IF

  PRINT*, "UPDATING THE MATRIX"
  PRINT*
  pos = [2,3]
  delta = 0.3_DP
  V2(:,:) = V(:,:)
  V2(pos(1),pos(2)) = V2(pos(1),pos(2)) + delta
  V2(pos(2),pos(1)) = V2(pos(2),pos(1)) + delta

  ! Cholesky
  CALL INITIATE_CLOCK(timestr)
  DO i=1,Ntry
    invVC(:,:) = INVERT_CHOLESKY(V2(:,:), DETERMINANT=detV2, &
                                 NOPOSDEF=noposdef)
  END DO
  PRINT*, "Cholesky ("//TRIMLR(PRING(N))//"x"//TRIMLR(PRING(N))//"), " &
          //TRIMLR(PRING(Ntry))//" times: "//TIMINFO(timestr)
  IF (N <= 5) THEN
    PRINT*, "V2-1(Cholesky)="
    DO i=1,N
      PRINT*, REAL(invVC(i,:))
    END DO
    PRINT*, "detV2", detV2
    PRINT*
  END IF

  ! Sherman-Morrison
  CALL INITIATE_CLOCK(timestr)
  DO i=1,Ntry
    invVS(:,:) = INVERT_MSM(V(:,:),invV(:,:),pos(:),delta, &
                            DETA=detV,DETERMINANT=detV2)!, &
                            ! NOPOSDEF=noposdef)
  END DO
  PRINT*, "Sherman-Morrison ("//TRIMLR(PRING(N))//"x"//TRIMLR(PRING(N))//"), " &
          //TRIMLR(PRING(Ntry))//" times: "//TIMINFO(timestr)
  IF (N <= 5) THEN
    PRINT*, "V2-1(SHERMANN-MORRISON)="
    DO i=1,N
      PRINT*, REAL(invVS(i,:))
    END DO
    PRINT*, "detV2", detV2
    PRINT*
  END IF

END PROGRAM test_invert


  module Miller_Rabin
  use PrimeDecompose
  implicit none

  integer, parameter :: max_decompose = 100

  private :: int_rrand, max_decompose

contains

  function int_rrand(from, to)
    integer(huge) :: int_rrand
    integer(huge), intent(in) :: from, to

    real :: o
    call random_number(o)
    int_rrand = floor(from + o * real(max(from,to) - min(from, to)))
  end function int_rrand

  function miller_rabin_test(n, k) result(res)
    logical :: res
    integer(huge), intent(in) :: n
    integer, intent(in) :: k

    integer(huge), dimension(max_decompose) :: f
    integer(huge)                     :: s, d, i, a, x, r

    res = .true.
    f = 0

    if ( (n <= 2) .and. (n > 0) ) return
    if ( mod(n, 2) == 0 ) then
       res = .false.
       return
    end if

    call find_factors(n-1, f)
    s = count(f == 2)
    d = (n-1) / (2 ** s)
    loop:  do i = 1, k
       a = int_rrand(2_huge, n-2)
       x = mod(a ** d, n)

       if ( x == 1 ) cycle
       do r = 0, s-1
          if ( x == ( n - 1 ) ) cycle loop
          x = mod(x*x, n)
       end do
       if ( x == (n-1) ) cycle
       res = .false.
       return
    end do loop
    res = .true.
  end function miller_rabin_test

end module Miller_Rabin


      INTEGER FUNCTION ILCM( M, N )
*
*  -- ScaLAPACK tools routine (version 1.7) --
*     University of Tennessee, Knoxville, Oak Ridge National Laboratory,
*     and University of California, Berkeley.
*     May 1, 1997
*
*     .. Scalar Arguments ..
      INTEGER            M, N
*     ..
*
*  Purpose
*  =======
*
*  ILCM computes and returns the Least Common Multiple (LCM) of two
*  positive integers M and N. In fact the routine computes the greatest
*  common divisor (GCD) and use the fact that M*N = GCD*LCM.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          On entry, M >=0. Unchanged on exit.
*
*  N       (input) INTEGER
*          On entry, N >=0. Unchanged on exit.
*
*  =====================================================================
*
*     .. Local Scalars ..
      INTEGER            IA, IQ, IR
*     ..
*     .. Executable Statements ..
*
      IF( M.GE.N ) THEN
         IA = M
         ILCM = N
      ELSE
         IA = N
         ILCM = M
      ENDIF
*
   10 CONTINUE
         IQ = IA / ILCM
         IR = IA - IQ * ILCM
         IF( IR.EQ.0 ) THEN
            ILCM = ( M * N ) / ILCM
            RETURN
         END IF
         IA = ILCM
         ILCM = IR
      GO TO 10
*
*     End of ILCM
*
      END


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!
!
!
!     3/97
!
!     a program for testing all divergence, vorticity and idvt(ec, es, gc, gs) routines
!
!     (1) first set a valid vector field by setting a stream function sf and velocity
!         potential function sv as polys in x, y, z restricted to the sphere.  Then
!         derive (v, w) and dv, vt from sf and sv analytically by differentiation.
!         (see tvha.f)
!
!     (2) compute the coefficients br, bi, cr, ci of (v, w) using vector analysis
!
!     (3) compute the divergence and vorticity of (v, w) using div, vrt (es, ec, gc, gs)
!
!     (4) compare with divergence and vorticity from (1)
!
!     (5) invert dv, vt with idvt(ec, es, gc, gs) and compare with vector field from (1)
!
program tidvt
use spherepack
    implicit none
    real(wp) :: ad
    real(wp) :: av
    real(wp) :: bd
    real(wp) :: bi
    real(wp) :: br
    real(wp) :: bv
    real(wp) :: ci
    real(wp) :: cosp
    real(wp) :: cost
    real(wp) :: cr
    real(wp) :: dlat
    real(wp) :: dphi
    real(wp) :: dv
    real(wp) :: dvsav
    real(wp) :: err2d
    real(wp) :: err2v
    real(wp) :: err2w
    integer(ip) :: i
    integer(ip) :: icase
    integer(ip) :: ier
    integer(ip) :: ierror
    integer(ip) :: isym
    integer(ip) :: ityp
    integer(ip) :: j
    integer(ip) :: k
    integer(ip) :: kk
    integer(ip) :: ldwork
    integer(ip) :: lldwork
    integer(ip) :: lleng
    integer(ip) :: llsav
    integer(ip) :: lsave
    integer(ip) :: lwork
    integer(ip) :: mdab
    integer(ip) :: mdb
    integer(ip) :: mmdab
    integer(ip) :: mmdb
    integer(ip) :: nlat
    integer(ip) :: nlon
    integer(ip) :: nmax
    integer(ip) :: nnlat
    integer(ip) :: nnlon
    integer(ip) :: nnt
    integer(ip) :: nt
    real(wp) :: phi

    real(wp) :: prtbd
    real(wp) :: prtbv
    real(wp) :: ptrbd
    real(wp) :: ptrbv
    real(wp) :: sinp
    real(wp) :: sint
    real(wp) :: theta
    real(wp) :: thetag
    real(wp) :: v
    real(wp) :: vsav
    real(wp) :: vt
    real(wp) :: vtsav
    real(wp) :: w
    real(wp) :: work
    real(wp) :: wsav
    real(wp) :: wsave
    real(wp) :: x
    real(wp) :: y
    real(wp) :: z
    !
    !     set dimensions with parameter statements
    !
    parameter(nnlat= 25, nnlon= 16, nnt = 3)
    parameter(mmdab = (nnlon+2)/2, mmdb = (nnlon+1)/2)
    parameter (lleng= 5*nnlat*nnlat*nnlon, llsav=15*nnlat*nnlat*nnlon)
    dimension work(lleng), wsave(llsav)
    parameter (lldwork = 4*nnlat*nnlat)
    real dwork(lldwork)
    dimension br(mmdb, nnlat, nnt), bi(mmdb, nnlat, nnt)
    dimension cr(mmdb, nnlat, nnt), ci(mmdb, nnlat, nnt)
    dimension ad(mmdab, nnlat, nnt), bd(mmdab, nnlat, nnt)
    dimension av(mmdab, nnlat, nnt), bv(mmdab, nnlat, nnt)
    dimension dv(nnlat, nnlon, nnt), vt(nnlat, nnlon, nnt)
    dimension dvsav(nnlat, nnlon, nnt), vtsav(nnlat, nnlon, nnt)
    dimension thetag(nnlat), dtheta(nnlat), dwts(nnlat)
    dimension v(nnlat, nnlon, nnt), w(nnlat, nnlon, nnt)
    dimension vsav(nnlat, nnlon, nnt), wsav(nnlat, nnlon, nnt)
    dimension ptrbd(nnt), ptrbv(nnt)
    real dtheta, dwts
    !
    !     set dimension variables
    !
    nlat = nnlat
    nlon = nnlon
    mdab = mmdab
    mdb = mmdb
    nmax = max(nlat, nlon)

    lwork = lleng
    lsave = llsav
    nt = nnt
    call iout(nlat, "nlat")
    call iout(nlon, "nlon")
    call iout(nt, "  nt")
    isym = 0
    ityp = 0
    !
    !     set equally spaced colatitude and longitude increments
    !
    dphi = (pi+pi)/nlon
    dlat = pi/(nlat-1)
    !
    !     compute nlat gaussian points in thetag
    !
    ldwork = lldwork
    call compute_gaussian_latitudes_and_weights(nlat, dtheta, dwts, ier)
    do  i=1, nlat
        thetag(i) = dtheta(i)
    end do

    call name("gaqd")
    call iout(ier, " ier")
    call vecout(thetag, "thtg", nlat)
    !
    !     test all divergence and inverse divergence subroutines
    !
    do icase=1, 4
        !
        !     icase=1 corresponds to "ec"
        !     icase=2 corresponds to "es"
        !     icase=3 corresponds to "gc"
        !     icase=4 corresponds to "gs"

        call name("****")
        call name("****")
        call iout(icase, "icas")
        !
        !     set vector field v, w
        !
        do k=1, nt
            do j=1, nlon
                phi = (j-1)*dphi
                sinp = sin(phi)
                cosp = cos(phi)
                do i=1, nlat
                    theta = (i-1)*dlat
                    if (icase>2) theta=thetag(i)
                    cost = cos(theta)
                    sint = sin(theta)
                    x = sint*cosp
                    y = sint*sinp
                    z = cost
                    if (k ==1) then
                        !              sf = x
                        !              sv = y
                        !
                        !          v = -1/sint*dstdp + dsvdt
                        !
                        !          w =  1/sint*dsvdp + dstdt
                        !
                        !          dv = 1/sint*[d(sint*v)/dt + dwdp]  = dvdt + ct/st*v + 1/st*dwdp
                        !
                        !          vt = 1/sint*[-dv/dp + d(sint*w)/dt) = dwdt + ct/st*w - 1/st*dvdp

                        v(i, j, k) = sinp + cost*sinp
                        w(i, j, k) = cosp + cost*cosp
                        dv(i, j, k) = -2.0*sint*sinp
                        vt(i, j, k) = -2.0*sint*cosp
                    else if (k==2) then
                        !              sf = y
                        !              sv = z
                        v(i, j, k) = -cosp-sint
                        w(i, j, k) = cost*sinp
                        vt(i, j, k) = -2.*sint*sinp
                        dv(i, j, k) = -2.*cost
                    else if (k==3) then
                        !              st = x
                        !              sv = z
                        v(i, j, k) = sinp - sint
                        w(i, j, k) = cost*cosp
                        vt(i, j, k) = -2.*sint*cosp
                        dv(i, j, k) = -2.*cost
                    end if
                    !
                    !      save derived vector field, vorticity, divergence for latter comparison
                    !
                    vtsav(i, j, k) = vt(i, j, k)
                    dvsav(i, j, k) = dv(i, j, k)
                    vsav(i, j, k) = v(i, j, k)
                    wsav(i, j, k) = w(i, j, k)
                end do
            end do
        end do

        if (icase==1) then

            call name("**ec")
            !
            !     analyze vector field
            !
            call vhaeci(nlat, nlon, wsave, ierror)
            call name("vhai")
            call iout(ierror, "ierr")

            call vhaec(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdb, &
                nlat, wsave, ierror)
            call name("vha ")
            call iout(ierror, "ierr")
            !
            !     compute divergence, vorticity of (v, w) in dv, vt
            !

            call shseci(nlat, nlon, wsave, ierror)
            call name("shsi")
            call iout(ierror, "ierr")

            call divec(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wsave, ierror)
            call name("div ")
            call iout(ierror, "ierr")

            call vrtec(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdb, nlat, &
                wsave, ierror)
            call name("vrt ")
            call iout(ierror, "ierr")

        else if (icase==2) then

            call name("**es")
            !
            !     analyze vector field
            !
            call vhaesi(nlat, nlon, wsave, ierror)
            call name("vhai")
            call iout(ierror, "ierr")
            call vhaes(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdb, &
                nlat, wsave, ierror)
            call name("vha ")
            call iout(ierror, "ierr")

            call shsesi(nlat, nlon, wsave, ierror)
            call name("shsi")
            call iout(ierror, "ierr")

            call dives(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wsave, ierror)
            call name("div ")
            call iout(ierror, "ierr")
            call vrtes(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdb, nlat, &
                wsave, ierror)
            call name("vrt ")
            call iout(ierror, "ierr")

        else if (icase == 3) then

            call name("**gc")
            !
            !     analyze vector field
            !
            call vhagci(nlat, nlon, wsave, ierror)
            call name("vhai")
            call iout(ierror, "ierr")
            call vhagc(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdb, &
                nlat, wsave, ierror)
            call name("vha ")
            call iout(ierror, "ierr")

            call shsgci(nlat, nlon, wsave, ierror)
            call name("shsi")
            call iout(ierror, "ierr")

            call divgc(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wsave, ierror)
            call name("div ")
            call iout(ierror, "ierr")
            call vrtgc(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdb, nlat, &
                wsave, ierror)
            call name("vrt ")
            call iout(ierror, "ierr")

        else if (icase == 4) then

            call name("**gs")
            !
            !     analyze vector field
            !
            call vhagsi(nlat, nlon, wsave, ierror)
            call name("vhai")
            call iout(ierror, "ierr")
            call vhags(nlat, nlon, isym, nt, v, w, nlat, nlon, br, bi, cr, ci, mdb, &
                nlat, wsave, ierror)
            call name("vha ")
            call iout(ierror, "ierr")

            call shsgsi(nlat, nlon, wsave, ierror)
            call name("shsi")
            call iout(ierror, "ierr")

            call divgs(nlat, nlon, isym, nt, dv, nlat, nlon, br, bi, mdb, nlat, &
                wsave, ierror)
            call name("div ")
            call iout(ierror, "ierr")
            call vrtgs(nlat, nlon, isym, nt, vt, nlat, nlon, cr, ci, mdb, nlat, &
                wsave, ierror)
            call name("vrt ")
            call iout(ierror, "ierr")

        end if
        !
        !     compute "error" in dv, vt
        !
        err2d = 0.0
        err2v = 0.0
        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    err2d = err2d + (dv(i, j, k)-dvsav(i, j, k))**2
                    err2v = err2v + (vt(i, j, k)-vtsav(i, j, k))**2
                end do
            end do
        end do
        !
        !     set and print least squares error in dv
        !
        err2d = sqrt(err2d/(nt*nlat*nlon))
        call vout(err2d, "errd")
        err2v = sqrt(err2v/(nt*nlat*nlon))
        call vout(err2v, "errv")
        !
        !     now recompute (v, w) inverting dv, vt using idvt(ec, es, gc, gs)
        !
        do kk=1, nt
            do j=1, nlon
                do i=1, nlat
                    v(i, j, kk) = 0.0
                    w(i, j, kk) = 0.0
                end do
            end do
        end do

        select case (icase)
        	case (1)

        		call name("**ec")

        		call shaeci(nlat, nlon, wsave, ierror)
        		call name("shai")
        		call iout(ierror, "ierr")

        		call shaec(nlat, nlon, isym, nt, dv, nlat, nlon, ad, bd, &
        		mdab, nlat, wsave, ierror)
        		call shaec(nlat, nlon, isym, nt, vt, nlat, nlon, av, bv, &
        		mdab, nlat, wsave, ierror)
        		call name("sha ")
        		call iout(ierror, "ierr")
        		call iout(lsave, "lsav")
        		call iout(lwork, "lwrk")

        		call vhseci(nlat, nlon, wsave, ierror)
        		call name("idvi")
        		call iout(ierror, "ierr")

        		call idvtec(nlat, nlon, isym, nt, v, w, nlat, nlon, ad, bd, av, bv, &
        		mdab, nlat, wsave, lsave, work, lwork, ptrbd, ptrbv, ierror)
        		call name("idvt")
        		call iout(ierror, "ierr")
        		call vecout(prtbd, "prtd", nt)
        		call vecout(prtbv, "prtv", nt)
        	case (2)

        		call name("**es")

        		call shaesi(nlat, nlon, wsave, ierror)
        		call name("shai")
        		call iout(ierror, "ierr")

        		call shaes(nlat, nlon, isym, nt, dv, nlat, nlon, ad, bd, &
        		mdab, nlat, wsave, ierror)
        		call shaes(nlat, nlon, isym, nt, vt, nlat, nlon, av, bv, &
        		mdab, nlat, wsave, ierror)

        		call name("sha ")
        		call iout(ierror, "ierr")
        		call iout(lsave, "lsav")
        		call iout(lwork, "lwrk")

        		call vhsesi(nlat, nlon, wsave, ierror)
        		call name("idvi")
        		call iout(ierror, "ierr")

        		call idvtes(nlat, nlon, isym, nt, v, w, nlat, nlon, ad, bd, av, bv, &
        		mdab, nlat, wsave, lsave, work, lwork, ptrbd, ptrbv, ierror)
        		call name("idvt")
        		call iout(ierror, "ierr")
        		call vecout(prtbd, "prtd", nt)
        		call vecout(prtbv, "prtv", nt)
        	case (3)

        		call name("**gc")

        		call shagci(nlat, nlon, wsave, ierror)
        		call name("shai")
        		call iout(ierror, "ierr")

        		call shagc(nlat, nlon, isym, nt, dv, nlat, nlon, ad, bd, &
        		mdab, nlat, wsave, ierror)
        		call shagc(nlat, nlon, isym, nt, vt, nlat, nlon, av, bv, &
        		mdab, nlat, wsave, ierror)

        		call name("sha ")
        		call iout(ierror, "ierr")
        		call iout(lsave, "lsav")
        		call iout(lwork, "lwrk")

        		call vhsgci(nlat, nlon, wsave, ierror)
        		call name("idvi")
        		call iout(ierror, "ierr")

        		call idvtgc(nlat, nlon, isym, nt, v, w, nlat, nlon, ad, bd, av, bv, &
        		mdab, nlat, wsave, lsave, work, lwork, ptrbd, ptrbv, ierror)
        		call name("idvt")
        		call iout(ierror, "ierr")
        		call vecout(prtbd, "prtd", nt)
        		call vecout(prtbv, "prtv", nt)
        	case (4)

        		call name("**gs")

        		call shagsi(nlat, nlon, wsave, ierror)
        		call name("shai")
        		call iout(ierror, "ierr")

        		call shags(nlat, nlon, isym, nt, dv, nlat, nlon, ad, bd, &
        		mdab, nlat, wsave, ierror)
        		call shags(nlat, nlon, isym, nt, vt, nlat, nlon, av, bv, &
        		mdab, nlat, wsave, ierror)

        		call name("sha ")
        		call iout(ierror, "ierr")
        		call iout(lsave, "lsav")
        		call iout(lwork, "lwrk")

        		call vhsgsi(nlat, nlon, wsave, ierror)
        		call name("idvi")
        		call iout(ierror, "ierr")

        		call idvtgs(nlat, nlon, isym, nt, v, w, nlat, nlon, ad, bd, av, bv, &
        		mdab, nlat, wsave, lsave, work, lwork, ptrbd, ptrbv, ierror)
        		call name("idvt")
        		call iout(ierror, "ierr")
        		call vecout(prtbd, "prtd", nt)
        		call vecout(prtbv, "prtv", nt)
        end select

        !
        !     compare this v, w with original derived from sf, sv
        !
        err2v = 0.0
        err2w = 0.0
        do k=1, nt
            do j=1, nlon
                do i=1, nlat
                    err2v = err2v + (v(i, j, k)-vsav(i, j, k))**2
                    err2w = err2w + (w(i, j, k)-wsav(i, j, k))**2
                end do
            end do
        end do
        err2v = sqrt(err2v/(nlat*nlon*nt))
        err2w = sqrt(err2w/(nlat*nlon*nt))
        call vout(err2v, "errv")
        call vout(err2w, "errw")
    !
    !     end of icase loop
    !
    end do

end program tidvt


      SUBROUTINE FACTR (N,A,IP,NDIM)
C
C     SUBROUTINE TO FACTOR A MATRIX INTO A UNIT LOWER TRIANGULAR MATRIX
C     AND AN UPPER TRIANGULAR MATRIX USING THE GAUSS-DOOLITTLE ALGORITHM
C     PRESENTED ON PAGES 411-416 OF A. RALSTON--A FIRST COURSE IN
C     NUMERICAL ANALYSIS.  COMMENTS BELOW REFER TO COMMENTS IN RALSTONS
C     TEXT.    (MATRIX TRANSPOSED.
C
      COMPLEX A,D,ARJ
      DIMENSION A(NDIM,NDIM), IP(NDIM)
      COMMON /SCRATM/ D(600)
      INTEGER R,RM1,RP1,PJ,PR
      IFLG=0
      DO 9 R=1,N
C
C     STEP 1
C
      DO 1 K=1,N
      D(K)=A(K,R)
1     CONTINUE
C
C     STEPS 2 AND 3
C
      RM1=R-1
      IF (RM1.LT.1) GO TO 4
      DO 3 J=1,RM1
      PJ=IP(J)
      ARJ=D(PJ)
      A(J,R)=ARJ
      D(PJ)=D(J)
      JP1=J+1
      DO 2 I=JP1,N
      D(I)=D(I)-A(I,J)*ARJ
2     CONTINUE
3     CONTINUE
4     CONTINUE
C
C     STEP 4
C
      DMAX=REAL(D(R)*CONJG(D(R)))
      IP(R)=R
      RP1=R+1
      IF (RP1.GT.N) GO TO 6
      DO 5 I=RP1,N
      ELMAG=REAL(D(I)*CONJG(D(I)))
      IF (ELMAG.LT.DMAX) GO TO 5
      DMAX=ELMAG
      IP(R)=I
5     CONTINUE
6     CONTINUE
      IF (DMAX.LT.1.E-10) IFLG=1
      PR=IP(R)
      A(R,R)=D(PR)
      D(PR)=D(R)
C
C     STEP 5
C
      IF (RP1.GT.N) GO TO 8
      ARJ=1./A(R,R)
      DO 7 I=RP1,N
      A(I,R)=D(I)*ARJ
7     CONTINUE
8     CONTINUE
      IF (IFLG.EQ.0) GO TO 9
      PRINT 10,  R,DMAX
      IFLG=0
9     CONTINUE
      RETURN
C
10    FORMAT (1H ,6HPIVOT(,I3,2H)=,1P,E16.8)
      END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Tests folding of SQRT()
module m
  implicit none
  ! +Inf
  real(8), parameter :: inf8 = z'7ff0000000000000'
  logical, parameter :: test_inf8 = sqrt(inf8) == inf8
  ! max finite
  real(8), parameter :: h8 = huge(1.0_8), h8z = z'7fefffffffffffff'
  logical, parameter :: test_h8 = h8 == h8z
  real(8), parameter :: sqrt_h8 = sqrt(h8), sqrt_h8z = z'5fefffffffffffff'
  logical, parameter :: test_sqrt_h8 = sqrt_h8 == sqrt_h8z
  real(8), parameter :: sqr_sqrt_h8 = sqrt_h8 * sqrt_h8, sqr_sqrt_h8z = z'7feffffffffffffe'
  logical, parameter :: test_sqr_sqrt_h8 = sqr_sqrt_h8 == sqr_sqrt_h8z
  ! -0 (sqrt is -0)
  real(8), parameter :: n08 = z'8000000000000000'
  real(8), parameter :: sqrt_n08 = sqrt(n08)
!WARN: division by zero
  real(8), parameter :: inf_n08 = 1.0_8 / sqrt_n08, inf_n08z = z'fff0000000000000'
  logical, parameter :: test_n08 = inf_n08 == inf_n08z
  ! min normal
  real(8), parameter :: t8 = tiny(1.0_8), t8z = z'0010000000000000'
  logical, parameter :: test_t8 = t8 == t8z
  real(8), parameter :: sqrt_t8 = sqrt(t8), sqrt_t8z = z'2000000000000000'
  logical, parameter :: test_sqrt_t8 = sqrt_t8 == sqrt_t8z
  real(8), parameter :: sqr_sqrt_t8 = sqrt_t8 * sqrt_t8
  logical, parameter :: test_sqr_sqrt_t8 = sqr_sqrt_t8 == t8
  ! max subnormal
  real(8), parameter :: maxs8 = z'000fffffffffffff'
  real(8), parameter :: sqrt_maxs8 = sqrt(maxs8), sqrt_maxs8z = z'2000000000000000'
  logical, parameter :: test_sqrt_maxs8 = sqrt_maxs8 == sqrt_maxs8z
  ! min subnormal
  real(8), parameter :: mins8 = z'1'
  real(8), parameter :: sqrt_mins8 = sqrt(mins8), sqrt_mins8z = z'1e60000000000000'
  logical, parameter :: test_sqrt_mins8 = sqrt_mins8 == sqrt_mins8z
  real(8), parameter :: sqr_sqrt_mins8 = sqrt_mins8 * sqrt_mins8
  logical, parameter :: test_sqr_sqrt_mins8 = sqr_sqrt_mins8 == mins8
end module


  !! ----------------------------------------------------------------------- !!
  !>
  !! Bathymetry depth hh(:,:) ( in m-unit ) must be filled here.
  !<
  block

    integer :: i, j
    !! --

    do i=1, nx
       do j=1, 60
          hh(i,ny-j+1) = 500.0
       end do
       do j=61, 400
          hh(i,ny-j+1) = 500 + (j-60) * dy * tan( 2.0 * PI / 180 )
       end do
    end do

  end block


implicit none
real :: x, xold, f, fprime, top, bot, tol
integer :: m, counter, interationlimit

m = 5
x = 1.5
xold = 23.3
tol = 1.0e-11
interationlimit = 1000

print*, 'Start of program'

do while (abs(xold - x) > tol)
  xold = x
  top = f(x)
  bot = fprime(x)

  if (abs(top) < tol) then
    print*, 'The function value is less than ', tol
    print*, 'I declare victory! x = ', x
    print*
  end if
end do

stop
end

4670 Numerical Analysis/Class Examples/mod2.f90


module physicf
implicit none
contains

    subroutine gmag(m1, m2, r, force_mag)
        use constants
        implicit none
        real, intent(in)    :: m1, m2, r
        real, intent(out)   :: force_mag

        force_mag = G*m1/r/r*m2
        return
    end subroutine gmag

    subroutine force_gravity(nd, m1, m2, r1, r2, f)
        use mathf
        implicit none
        integer, intent(in) :: nd
        real, intent(in)    :: m1, m2
        real, intent(in), dimension(nd)  ::  r1, r2
        real, intent(out) ::  f(nd)
        real, dimension(nd) :: rel
        real    :: g_mag, r_mag

        rel = r2 - r1
        call mag(nd, rel, r_mag)
        call gmag(m1, m2, r_mag, g_mag)
        call unit(nd, rel, f)
        f = f * g_mag

        return
    end subroutine force_gravity

    subroutine net_force(n, nd, masses, positions, forces)
        implicit none
        integer, intent(in) :: n, nd
        real, intent(in), dimension(n)      :: masses
        real, intent(in), dimension(n, nd)   :: positions
        real, intent(out), dimension(n, nd)  :: forces
        real, dimension(nd)  :: force
        integer     :: i, j

        do i=1, n
            do j=1, nd
                forces(i, j) = 0.
            end do
        end do

        do i=1, n
            do j=1, n
                if (i /= j) then
                    call force_gravity(nd, masses(i), masses(j), positions(i, :),&
                                       positions(j, :), force)
                    forces(i, :) = forces(i, :) + force(:)
                end if
            end do
        end do
    end subroutine net_force

    subroutine leapfrog(n, nd, ipos, ivel, masses, dt, fpos, fvel)
        implicit none
        integer, intent(in) :: n, nd
        real, intent(in), dimension(n, nd)    ::  ipos, ivel
        real, intent(in), dimension(n)    :: masses
        real, intent(in)    :: dt
        integer     ::  i
        real, dimension(n, nd)   :: forces, hvel, accels
        real, intent(out), dimension(n, nd)   :: fpos, fvel

        call net_force(n, nd, masses, ipos, forces)
        do i=1, n
            accels(i, :) = forces(i, :) / masses(i)
        end do

        hvel(:, :) = ivel(:, :) + dt/2.*accels(:, :)

        fpos(:, :) = ipos(:, :) + hvel(:, :)*dt

        call net_force(n, nd, masses, fpos, forces)
        do i=1, n
            accels(i, :) = forces(i, :) / masses(i)
        end do
        fvel(:, :) = hvel(:, :) + 0.5*dt*accels(:, :)

    end subroutine leapfrog

end module physicf


program eval_entropy
!
! Purpose: To evaluate the entropy of a given probability
! distribution function. The binning should be linearly
! graduated.
!
! Record of revisions:
!  Date         Who                Description
! ==========   ===============    =====================================
! 9-12-2011     ThMosqueiro        Original code.
!
!

  implicit none

  character(len=100)     :: bugger, inputfile
  real(8)                :: Entropy, dx, logbase

! Volatile variables
  real(8)                :: x, prob

! Purely auxiliary variables
  real(8)                :: x0, x1, prob0, prob1
  integer                :: Reason

! Reading input file name into inputfile variable.
  call getarg(1, bugger)
  read(bugger,*) inputfile

! This makes the correct base for entropy
  logbase = 1.d0/dlog(2.d0)

! Openning as read-only the inputfile
  open(unit=27, file=inputfile, action="read", status="old")

! Initial condition for variables
  Entropy = 0.d0

  read(27,*) x0, prob0
  read(27,*) x1, prob1

  dx = dabs(x0 - x1)

  if ( prob0 .ne. 0.d0 ) then
     Entropy = - prob0*dx*dlog(prob0*dx)*logbase + Entropy
  end if
  if ( prob1 .ne. 0.d0 ) then
     Entropy = - prob1*dx*dlog(prob1*dx)*logbase + Entropy
  end if

! Now read every line of the file and evaluate its contribution to
! the entropy.
  do
     read(27, *, IOSTAT=Reason) x, prob

     if ( Reason .lt. 0 ) then
        close(27)
        exit
     else

        if ( prob .ne. 0.d0 ) then
           Entropy = - prob*dx*dlog(prob*dx)*logbase + Entropy
        end if

     end if

  end do

  close(27)

  write(*,*) Entropy

  stop
end program eval_entropy