C  FILE NAME: apex.f

      SUBROUTINE APEX (DATE,IGRFFILEIN,DLAT,DLON,ALT,
     +                 A,ALAT,ALON,BMAG,XMAG,YMAG,ZMAG,V)
C          Calculate apex radius, latitude, longitude; and magnetic field and
C          scalar magnetic potential.
C
C          INPUTS:
C            DATE = Year and fraction (1990.0 = 1990 January 1, 0 UT)
C            DLAT = Geodetic latitude in degrees
C            DLON = Geodetic longitude in degrees
C            ALT = Altitude in km
C
C          RETURNS:
C            A    = (Apex height + REQ)/REQ, where REQ = equatorial Earth radius.
C                   A is analogous to the L value in invariant coordinates.
C            ALAT = Apex latitude in degrees (negative in S. magnetic hemisphere)
C            ALON = Apex longitude (geomagnetic longitude of apex) in degrees
C            BMAG = geomagnetic field magnitude (nT)
C            XMAG = geomagnetic field component (nT): north
C            YMAG = geomagnetic field component (nT): east
C            ZMAG = geomagnetic field component (nT): downward
C            V    = geomagnetic potential (T-m)
C
C          COMMON BLOCKS:
C            COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP
C
C          DIPOLE has IGRF variables obtained from routines in magfld.f:
C            COLAT = Geocentric colatitude of geomagnetic dipole north pole (deg)
C            ELON  = East longitude of geomagnetic dipole north pole (deg)
C            VP    = Magnitude (T-m) of dipole component of magnetic potential at
C                    geomagnetic pole and geocentric radius of 6371.0088 km
C            CTP   = cosine of COLAT
C            STP   = sine   of COLAT
C
C------------------------------------------------------------------------------
C          HISTORY:
C          Aug 1994: First version completed on the 22nd by A.D. Richmond.
C          May 1999: Revise DS calculation in LINAPX to avoid divide by zero.
C          Apr 2004: - Change definition of earth's equatorial radius (REQ)
C                      from the IAU-1966 spheroid (6378.160 km) to the WGS-1984
C                      spheroid (6378.137 km); see description below.
C                    - Revise comments toward a consistent format so they are
C                      easy to read.
C                    - Replace computed GO TO in ITRACE with IF blocks.
C                    - Refine FNDAPX to insure |Bdown/Btot| < 1.E-6 at apex
C          Nov 2009: Change definition of earth's mean radius (RE) from 6371.2
C                    to the WGS84 value (6371.0088), by J.T. Emmert, NRL
C          Feb 2021: Modified by Ashton Reimer to pass IGRF coefficients file
C                    to the COFRM subroutine call.
C
C------------------------------------------------------------------------------
C                Reference Spheroid Change                March 2004
C
C   Apex geomagnetic coordinates are based on the International Reference
C   Geomagnetic Field (IGRF) which involves the earth's shape when converting
C   geographic latitude and altitude to geocentric coordinates.  For this
C   purpose, the earth is assumed to be an ellipsoid which is fatter at the
C   equator than the poles.  The World Geodetic System 1984 spheroid
C   (WGS-1984) is recommended in the recent release of IGRF-9 because it is
C   used to position current satellite magnetic data (EOS Volume 84 Number 46
C   November 18 2003).  This differs from previous IGRF releases which favored
C   the International Astronomical Union 1966 spheroid (IAU-1966) so the Apex
C   program conversion from geographic to geocentric coordinates in subroutine
C   CONVRT of file magfld.f has been revised from the IAU-1966 spheroid to the
C   WGS-1984 spheroid.
C
C   The spheroid used to prepare earlier IGRF releases is not always known but
C   changing spheroids now produces differences at the earth's surface less
C   than 1 nT, significantly less than other error sources: viz., 9 nT RMS
C   error for older measurements reporting 1 nT accuracy, 200 nT in the
C   vicinity of magnetized rocks, or as much as 1000 nT during and after a
C   geomagnetic storm (www.ngdc.noaa.gov/IAGA/vmod/index.html).
C
C   The elliptical shape is characterized in subroutine CONVRT by eccentricity
C   (e) which is related to the the earth's equatorial radius (a) and polar
C   radius (b) by
C
C        e**2  = 1 - (b/a)**2     (1)
C
C   This term is part of an eighth order Lagrange expansion formula (Astron.
C   J.  Vol. 66, p. 15-16, 1961) designed to give eight digit conversion
C   accuracy.  The following table summarizes the relevant spheroids:
C
C        a           b           e**2          Source
C        ----------- -----------  -----------  --------------
C        -           -        0.006722670  Astron J. 1961
C        6378.160 km 6356.775 km  0.006701642  IAU-1966
C        6378.137 km 6356.752 km  0.006694478  WGS-1984
C
C   The previous formulation in CONVRT used the oblateness factor (epsilon),
C   a surrogate for eccentricity, where
C
C        e**2 = 2*epsilon - epsilon**2
C
C   with oblateness revised from the 1961 paper's suggested 1/297 to 1/298.25
C   in accordance with the IAU-1966 spheroid.  Now CONVRT is reformulated to
C   use equation 1 with the WGS-1984 spheroid's major axis (a) and minor axis
C   (b) for which epsilon is approximately 1/298.2528.
C
C   In addition to earth's equatorial radius and polar radius, the reference
C   radius (Re) of 6371.2 km is explicit in the IGRF formula for magnetic
C   potential and implicit in the derived magnetic field coefficients.  The
C   reference radius has not changed in IGRF releases.
C
C------------------------------------------------------------------------------

      PARAMETER (RE = 6371.0088, DTOR = .01745329251994330)
      COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP

      CHARACTER(LEN=1000), intent(in) :: IGRFFILEIN
      CALL COFRM (DATE,IGRFFILEIN)
      CALL DYPOL (CLATP,POLON,VPOL)
      COLAT = CLATP
      CTP   = COS(CLATP*DTOR)
      STP   = SQRT(1. - CTP*CTP)
      ELON  = POLON
      VP    = VPOL
      CALL LINAPX (DLAT,DLON,ALT, A,ALAT,ALON,XMAG,YMAG,ZMAG,BMAG)
      XMAG = XMAG*1.E5                 ! convert from gauss to nT
      YMAG = YMAG*1.E5
      ZMAG = ZMAG*1.E5
      BMAG = BMAG*1.E5
      CALL GD2CART (DLAT,DLON,ALT,X,Y,Z)
      CALL FELDG (3, X/RE,Y/RE,Z/RE, BX,BY,BZ,V)
      RETURN
      END

      SUBROUTINE LINAPX (GDLAT,GLON,ALT, A,ALAT,ALON,XMAG,YMAG,ZMAG,F)

C          Transform geographic coordinates to Apex coordinates.
C
C          INPUTS:
C            GDLAT = Latitude  (degrees, positive northward)
C            GLON  = Longitude (degrees, positive eastward)
C            ALT   = Height of starting point (km above mean sea level)
C
C          OUTPUTS:
C            A     = (Apex height + REQ)/REQ, where REQ = equatorial Earth radius.
C                    A is analogous to the L value in invariant coordinates.
C            ALAT  = Apex Lat. (deg)
C            ALON  = Apex Lon. (deg)
C            XMAG  = Geomagnetic field component (gauss): north
C            YMAG  = Geomagnetic field component (gauss): east
C            ZMAG  = Geomagnetic field component (gauss): down
C            F     = Geomagnetic field magnitude (gauss)
C
C          Trace the geomagnetic field line from the given location to find the
C          apex of the field line.  Before starting iterations to trace along
C          the field line: (1) Establish a step size (DS, arc length in km)
C          based on the geomagnetic dipole latitude; (2) determine the step
C          direction from the sign of the vertical component of the geomagnetic
C          field; and (3) convert to geocentric cartesian coordinates.  Each
C          iteration increments a step count (NSTP) and calls ITRACE to move
C          along the the field line until reaching the iteration count limit
C          (MAXS) or passing the apex (IAPX=2) and then calling FNDAPX to
C          determine the apex location from the last three step locations
C          (YAPX); however, if reaching the iteration limit, apex coordinates
C          are calculated by DIPAPX which assumes a simplified dipole field.
C
C          COMMON BLOCKS:
C            COMMON /APXIN/   YAPX(3,3)
C            COMMON /DIPOLE/  COLAT,ELON,VP,CTP,STP
C            COMMON /FLDCOMD/ BX, BY, BZ, BB
C            COMMON /ITRA/    NSTP, Y(3), YOLD(3), SGN, DS
C
C          APXIN has step locations determined in ITRACE:
C            YAPX  = Matrix of cartesian coordinates (loaded columnwise) of the
C                    three points about the apex.  Set in subroutine ITRACE.
C
C          DIPOLE has IGRF variables obtained from routines in magfld.f:
C            COLAT = Geocentric colatitude of geomagnetic dipole north pole (deg)
C            ELON  = East longitude of geomagnetic dipole north pole (deg)
C            VP    = Magnitude (T-m) of dipole component of magnetic potential at
C                    geomagnetic pole and geocentric radius of 6371.0088 km
C            CTP   = cosine of COLAT
C            STP   = sine   of COLAT
C
C          FLDCOMD has geomagnetic field at current trace point:
C            BX    = X component (Gauss)
C            BY    = Y component (Gauss)
C            BZ    = Z component (Gauss)
C            BB    = Magnitude   (Gauss)
C
C          ITRA has field line tracing variables determined in LINAPX:
C            NSTP  = Step count.
C            Y     = Array containing current tracing point cartesian coordinates.
C            YOLD  = Array containing previous tracing point cartesian coordinates.
C            SGN   = Determines direction of trace.
C            DS    = Step size (arc length in km).
C
C          REFERENCES:
C            Stassinopoulos E. G. , Mead Gilbert D., X-841-72-17 (1971) GSFC,
C            Greenbelt, Maryland
C
C          EXTERNALS:
C            GD2CART = Convert geodetic to geocentric cartesian coordinates (in magfld.f)
C            CONVRT  = Convert geodetic to geocentric cylindrical or geocentric spherical
C                      and back (in magfld.f).
C            FELDG   = Obtain IGRF magnetic field components (in magfld.f).
C            ITRACE  = Follow a geomagnetic field line
C            DIPAPX  = Compute apex coordinates assuming a geomagnetic dipole field
C            FNDAPX  = Compute apex coordinates from the last three traced field line points
C
C------------------------------------------------------------------------------
C          HISTORY:
C          Oct 1973: Initial version completed on the 29th by Wally Clark, NOAA
C                    ERL Lab.
C          Feb 1988: Revised on the 1st by Harsh Anand Passi, NCAR.
C          Aug 1994: Revision by A. D. Richmond, NCAR.
C          Nov 2009: Change definition of earth's mean radius (RE) from 6371.2
C                    to the WGS84 value (6371.0088), by J.T. Emmert, NRL.

      PARAMETER (MAXS = 200, RTOD = 57.2957795130823,   RE =6371.0088,
     +                       DTOR = .01745329251994330, REQ=6378.137)
      COMMON /FLDCOMD/ BX, BY, BZ, BB
      COMMON /APXIN/   YAPX(3,3)
      COMMON /DIPOLE/  COLAT,ELON,VP,CTP,STP
      COMMON /ITRA/    NSTP, Y(3), YP(3), SGN, DS

C          Set step size based on the geomagnetic dipole latitude of the starting point
      CALL CONVRT (2,GDLAT,ALT,GCLAT,R)
      SINGML = CTP*SIN(GCLAT*DTOR) + STP*COS(GCLAT*DTOR)*
     +                                             COS((GLON-ELON)*DTOR)
C          May 1999: avoid possible divide by zero (when SINGML = 1.): the old version
C          limited DS to its value at 60 deg GM latitude with: DS = .06*R/(1.-SINGML*SINGML) - 370.
C                                                              IF (DS .GT. 1186.) DS = 1186.
      CGML2 = AMAX1 (0.25,1.-SINGML*SINGML)
      DS = .06*R/CGML2 - 370.

C          Initialize YAPX array
      DO 4 J=1,3
      DO 4 I=1,3
    4 YAPX(I,J) = 0.

C          Convert from geodetic to earth centered cartesian coordinates
      CALL GD2CART (GDLAT,GLON,ALT,Y(1),Y(2),Y(3))
      NSTP = 0

C          Get magnetic field components to determine the direction for
C          tracing the field line
      CALL FELDG (1,GDLAT,GLON,ALT,XMAG,YMAG,ZMAG,F)
      SGN = SIGN (1.,-ZMAG)

C          Use cartesian coordinates to get magnetic field components
C          (from which gradients steer the tracing)
   10 CALL FELDG (2, Y(1)/RE,Y(2)/RE,Y(3)/RE, BX,BY,BZ,BB)
      NSTP = NSTP + 1

      IF (NSTP .LT. MAXS) THEN
        CALL ITRACE (IAPX)                              ! trace along field line
        IF (IAPX .EQ. 1) GO TO 10
        CALL FNDAPX (ALT,ZMAG,A,ALAT,ALON)              ! (IAPX=2) => passed max radius; find its coordinates
      ELSE
        RHO = SQRT (Y(1)*Y(1) + Y(2)*Y(2))              ! too many steps; get apex from dipole approximation
        CALL CONVRT (3,XLAT,HT,RHO,Y(3))
        XLON = RTOD*ATAN2 (Y(2),Y(1))
        CALL FELDG (1,XLAT,XLON,HT,BNRTH,BEAST,BDOWN,BABS)
        CALL DIPAPX  (XLAT,XLON,HT,BNRTH,BEAST,BDOWN,A,ALON)
        ALAT = -SGN*RTOD*ACOS (SQRT(1./A))
      ENDIF

      RETURN
      END

      SUBROUTINE ITRACE (IAPX)

C          Follow a geomagnetic field line until passing its apex
C
C          INPUTS:
C            (all are in common blocks)
C          OUTPUTS:
C            IAPX = 2 (when apex passed) or 1 (not)
C
C          This uses the 4-point Adams formula after initialization.
C          First 7 iterations advance point by 3 steps.
C
C          COMMON BLOCKS:
C            COMMON /APXIN/   YAPX(3,3)
C            COMMON /FLDCOMD/ BX, BY, BZ, BB
C            COMMON /ITRA/    NSTP, Y(3), YOLD(3), SGN, DS
C
C          APXIN has step locations determined in ITRACE:
C            YAPX  = Matrix of cartesian coordinates (loaded columnwise) of the
C                    three points about the apex.  Set in subroutine ITRACE.
C
C          FLDCOMD has geomagnetic field at current trace point:
C            BX    = X component (Gauss)
C            BY    = Y component (Gauss)
C            BZ    = Z component (Gauss)
C            BB    = Magnitude   (Gauss)
C
C          ITRA has field line tracing variables determined in LINAPX:
C            NSTP  = Step count.
C            Y     = Array containing current tracing point cartesian coordinates.
C            YOLD  = Array containing previous tracing point cartesian coordinates.
C            SGN   = Determines direction of trace.
C            DS    = Step size (arc length in km).
C
C          REFERENCES:
C            Stassinopoulos E. G. , Mead Gilbert D., X-841-72-17 (1971) GSFC,
C            Greenbelt, Maryland
C------------------------------------------------------------------------------
C          HISTORY:
C          Oct 1973: Initial version completed on the 29th by W. Clark, NOAA ERL
C                    Laboratory.
C          Feb 1988: Revised by H. Passi, NCAR.
C          Apr 2004: Replace computed GO TO with IF blocks because some compilers
C                    are threatening to remove this old feature
C

      COMMON /APXIN/   YAPX(3,3)
      COMMON /FLDCOMD/ BX, BY, BZ, BB
      COMMON /ITRA/    NSTP, Y(3), YOLD(3), SGN, DS
      DIMENSION YP(3,4)
      SAVE

C          Statement function
      RDUS(D,E,F) = SQRT (D**2 + E**2 + F**2)

      IAPX = 1

C          Cartesian component magnetic field (partial) derivitives steer the trace
      YP(1,4) = SGN*BX/BB
      YP(2,4) = SGN*BY/BB
      YP(3,4) = SGN*BZ/BB

      IF (NSTP .LE. 7) THEN
        DO 10 I=1,3
        IF (NSTP .EQ. 1) THEN
          D2        = DS/2.
          D6        = DS/6.
          D12       = DS/12.
          D24       = DS/24.
          YP(I,1)   = YP(I,4)
          YOLD(I)   = Y(I)
          YAPX(I,1) = Y(I)
          Y(I)      = YOLD(I) + DS*YP(I,1)

        ELSE IF (NSTP .EQ. 2) THEN
          YP(I,2) = YP(I,4)
          Y(I)    = YOLD(I) + D2*(YP(I,2)+YP(I,1))

        ELSE IF (NSTP .EQ. 3) THEN
          Y(I) = YOLD(I) + D6*(2.*YP(I,4)+YP(I,2)+3.*YP(I,1))

        ELSE IF (NSTP .EQ. 4) THEN
          YP(I,2)   = YP(I,4)
          YAPX(I,2) = Y(I)
          YOLD(I)   = Y(I)
          Y(I)      = YOLD(I) + D2*(3.*YP(I,2)-YP(I,1))

        ELSE IF (NSTP .EQ. 5) THEN
          Y(I) = YOLD(I) + D12*(5.*YP(I,4)+8.*YP(I,2)-YP(I,1))

        ELSE IF (NSTP .EQ. 6) THEN
          YP(I,3)   = YP(I,4)
          YOLD(I)   = Y(I)
          YAPX(I,3) = Y(I)
          Y(I)      = YOLD(I) + D12*(23.*YP(I,3)-16.*YP(I,2)+5.*YP(I,1))

        ELSE IF (NSTP .EQ. 7) THEN
          YAPX(I,1) = YAPX(I, 2)
          YAPX(I,2) = YAPX(I, 3)
          Y(I)      = YOLD(I) + D24*(9.*YP(I,4) + 19.*YP(I,3) -
     +                               5.*YP(I,2) +     YP(I,1))
          YAPX(I,3) = Y(I)
        ENDIF
   10   CONTINUE
        IF (NSTP .EQ. 6 .OR. NSTP .EQ. 7) THEN        ! signal if apex passed
          RC = RDUS (YAPX(1,3), YAPX(2,3), YAPX(3,3))
          RP = RDUS (YAPX(1,2), YAPX(2,2), YAPX(3,2))
          IF (RC .LT. RP) IAPX = 2
        ENDIF

      ELSE                 ! NSTP > 7

        DO 30 I=1,3
        YAPX(I,1) = YAPX(I,2)
        YAPX(I,2) = Y(I)
        YOLD(I)   = Y(I)
        Y(I)      = YOLD(I) + D24*(55.*YP(I,4) - 59.*YP(I,3) +
     +                             37.*YP(I,2) -  9.*YP(I,1))
        YAPX(I,3) = Y(I)

        DO 20 J=1,3
   20   YP(I,J) = YP(I,J+1)
   30   CONTINUE
        RC = RDUS (   Y(1),    Y(2),    Y(3))
        RP = RDUS (YOLD(1), YOLD(2), YOLD(3))
        IF (RC .LT. RP) IAPX = 2
      ENDIF

      RETURN
      END

       SUBROUTINE FNDAPX (ALT,ZMAG,A,ALAT,ALON)

C          Find apex coordinates once tracing (in subroutine ITRACE) has
C          signalled that the apex has been passed.
C          INPUTS:
C            ALT  = Altitude of starting point
C            ZMAG = Downward component of geomagnetic field at starting point
C          OUTPUT
C            A    = Apex radius, defined as (Apex height + Req)/Req, where
C                   Req = equatorial Earth radius.
C                   A is analogous to the L value in invariant coordinates.
C            ALAT = Apex Lat. (deg)
C            ALON = Apex Lon. (deg)
C
C          COMMON BLOCKS:
C            COMMON /APXIN/  YAPX(3,3)
C            COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP
C
C          APXIN has step locations determined in ITRACE:
C            YAPX  = Matrix of cartesian coordinates (loaded columnwise) of the
C                    three points about the apex.  Set in subroutine ITRACE.
C
C          DIPOLE has IGRF variables obtained from routines in magfld.f:
C            COLAT = Geocentric colatitude of geomagnetic dipole north pole (deg)
C            ELON  = East longitude of geomagnetic dipole north pole (deg)
C            VP    = Magnitude (T-m) of dipole component of magnetic potential at
C                    geomagnetic pole and geocentric radius of 6371.0088 km
C            CTP   = cosine of COLAT
C            STP   = sine   of COLAT
C
C          EXTERNALS:
C            FINT = Second degree interpolation routine
C------------------------------------------------------------------------------
C          HISTORY:
C          Oct 1973: Initial version completed on the 23rd by Clark, W., NOAA
C                    Boulder.
C          Aug 1994: Revision on the 3rd by A.D. Richmond, NCAR
C          Apr 2004: Repair problem noted by Dan Weimer where the apex location
C                    produced by FINT may still have a non-zero vertical magnetic
C                    field component.

      PARAMETER (RTOD = 57.2957795130823,
     +           DTOR = .01745329251994330, REQ=6378.137)
      COMMON /APXIN/  YAPX(3,3)
      COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP
      DIMENSION BD(3), Y(3)

C          Get geodetic height and vertical (downward) component of the magnetic
C          field at last three points found by ITRACE
      DO 10 I=1,3
      RHO  = SQRT (YAPX(1,I)**2 + YAPX(2,I)**2)
      CALL CONVRT (3,GDLT,HT, RHO,YAPX(3,I))
      GDLN = RTOD*ATAN2 (YAPX(2,I),YAPX(1,I))
   10 CALL FELDG (1,GDLT,GDLN,HT, BN,BE,BD(I),BMAG)

C          Interpolate to where Bdown=0 to find cartesian coordinates at dip equator
      NITR = 0
   20 Y(1) = FINT (BD(1),BD(2),BD(3),YAPX(1,1),YAPX(1,2),YAPX(1,3), 0.)
      Y(2) = FINT (BD(1),BD(2),BD(3),YAPX(2,1),YAPX(2,2),YAPX(2,3), 0.)
      Y(3) = FINT (BD(1),BD(2),BD(3),YAPX(3,1),YAPX(3,2),YAPX(3,3), 0.)

C          Insure negligible Bdown or
C
C            |Bdown/Btot| < 2.E-6
C
C          For instance, Bdown must be less than 0.1 nT at low altitudes where
C          Btot ~ 50000 nT.  This ratio can be exceeded when interpolation is
C          not accurate; i.e., when the middle of the three points interpolated
C          is too far from the dip equator.  The three points were initially
C          defined with equal spacing by ITRACE, so replacing point 2 with the
C          most recently fit location will reduce the interpolation span.
      RHO  = SQRT (Y(1)**2 + Y(2)**2)
      GDLN = RTOD*ATAN2 (Y(2),Y(1))
      CALL CONVRT (3,GDLT,HTA, RHO,Y(3))
      CALL FELDG (1,GDLT,GDLN,HTA, BNA,BEA,BDA,BA)
      ABDOB = ABS(BDA/BA)

      IF (ABDOB .GT. 2.E-6) THEN
        IF (NITR .LT. 4) THEN        ! 4 was chosen because tests rarely required 2 iterations
          NITR      = NITR + 1
          YAPX(1,2) = Y(1)
          YAPX(2,2) = Y(2)
          YAPX(3,2) = Y(3)
          BD(2)     = BDA
          GO TO 20
        ELSE
         WRITE (0,'(''APEX: Imprecise fit of apex: |Bdown/B| ='',1PE7.1
     +    )') ABDOB
        ENDIF
      ENDIF

C          Ensure altitude of the Apex is at least the initial altitude when
C          defining the Apex radius then use it to define the Apex latitude whose
C          hemisphere (sign) is inferred from the sign of the dip angle at the
C          starting point
      A = (REQ + AMAX1(ALT,HTA)) / REQ
      IF (A .LT. 1.) THEN
        WRITE (0,'(''APEX: A can not be less than 1; A, REQ, HTA: '',1P3
     +E15.7)') A,REQ,HTA
        CALL EXIT (1)
      ENDIF
      RASQ = ACOS (SQRT(1./A))*RTOD
      ALAT = SIGN (RASQ,ZMAG)

C          ALON is the dipole longitude of the apex and is defined using
C          spherical coordinates where
C            GP   = geographic pole.
C            GM   = geomagnetic pole (colatitude COLAT, east longitude ELON).
C            XLON = longitude of apex.
C            TE   = colatitude of apex.
C            ANG  = longitude angle from GM to apex.
C            TP   = colatitude of GM.
C            TF   = arc length between GM and apex.
C            PA   = ALON be geomagnetic longitude, i.e., Pi minus angle measured
C                   counterclockwise from arc GM-apex to arc GM-GP.
C          then, spherical-trigonometry formulas for the functions of the angles
C          are as shown below.  Notation uses C=cos, S=sin and STFCPA = sin(TF) * cos(PA),
C                                                              STFSPA = sin(TF) * sin(PA)
      XLON = ATAN2 (Y(2),Y(1))
      ANG  = XLON-ELON*DTOR
      CANG = COS (ANG)
      SANG = SIN (ANG)
      R    = SQRT (Y(1)**2 + Y(2)**2 + Y(3)**2)
      CTE  = Y(3)/R
      STE  = SQRT (1.-CTE*CTE)
      STFCPA = STE*CTP*CANG - CTE*STP
      STFSPA = SANG*STE
      ALON = ATAN2 (STFSPA,STFCPA)*RTOD
      RETURN
      END

      SUBROUTINE DIPAPX (GDLAT,GDLON,ALT,BNORTH,BEAST,BDOWN, A,ALON)

C          Compute A, ALON from local magnetic field using dipole and spherical
C          approximation.
C
C          INPUTS:
C            GDLAT  = geodetic latitude, degrees
C            GDLON  = geodetic longitude, degrees
C            ALT    = altitude, km
C            BNORTH = geodetic northward magnetic field component (any units)
C            BEAST  = eastward magnetic field component
C            BDOWN  = geodetic downward magnetic field component
C          OUTPUTS:
C            A      = apex radius, 1 + h_A/R_eq
C            ALON   = apex longitude, degrees
C
C          Use spherical coordinates and define:
C            GP    = geographic pole.
C            GM    = geomagnetic pole (colatitude COLAT, east longitude ELON).
C            G     = point at GDLAT,GDLON.
C            E     = point on sphere below apex of dipolar field line passing
C                    through G.
C            TD    = dipole colatitude of point G, found by applying dipole
C                    formula for dip angle to actual dip angle.
C            B     = Pi plus local declination angle.  B is in the direction
C                    from G to E.
C            TG    = colatitude of G.
C            ANG   = longitude angle from GM to G.
C            TE    = colatitude of E.
C            TP    = colatitude of GM.
C            A     = longitude angle from G to E.
C            APANG = A + ANG
C            PA    = geomagnetic longitude, i.e., Pi minus angle measured
C                    counterclockwise from arc GM-E to arc GM-GP.
C            TF    = arc length between GM and E.
C          Then, using notation C=cos, S=sin, COT=cot, spherical-trigonometry
C          formulas for the functions of the angles are as shown below.  Note:
C            STFCPA = sin(TF) * cos(PA)
C            STFSPA = sin(TF) * sin(PA)
C
C          COMMON BLOCKS:
C            COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP
C
C          DIPOLE has IGRF variables obtained from routines in magfld.f:
C            COLAT = Geocentric colatitude of geomagnetic dipole north pole (deg)
C            ELON  = East longitude of geomagnetic dipole north pole (deg)
C            VP    = Magnitude (T-m) of dipole component of magnetic potential at
C                    geomagnetic pole and geocentric radius of 6371.0088 km
C            CTP   = cosine of COLAT
C            STP   = sine   of COLAT
C------------------------------------------------------------------------------
C          HISTORY:
C          May 1994:  Completed on the 1st by A. D. Richmond
C          Nov 2009: Change definition of earth's mean radius (RE) from 6371.2
C                    to the WGS84 value (6371.0088), by J.T. Emmert, NRL.

      PARAMETER (RTOD = 57.2957795130823,   RE =6371.0088,
     +           DTOR = .01745329251994330, REQ=6378.137)
      COMMON /DIPOLE/ COLAT,ELON,VP,CTP,STP

      BHOR = SQRT(BNORTH*BNORTH + BEAST*BEAST)
      IF (BHOR .EQ. 0.) THEN
        ALON = 0.
        A    = 1.E34
        RETURN
      ENDIF
      COTTD  = BDOWN*.5/BHOR
      STD    = 1./SQRT(1.+COTTD*COTTD)
      CTD    = COTTD*STD
      SB     = -BEAST /BHOR
      CB     = -BNORTH/BHOR
      CTG    = SIN (GDLAT*DTOR)
      STG    = COS (GDLAT*DTOR)
      ANG    = (GDLON-ELON)*DTOR
      SANG   = SIN(ANG)
      CANG   = COS(ANG)
      CTE    = CTG*STD + STG*CTD*CB
      STE    = SQRT(1. - CTE*CTE)
      SA     = SB*CTD/STE
      CA     = (STD*STG - CTD*CTG*CB)/STE
      CAPANG = CA*CANG - SA*SANG
      SAPANG = CA*SANG + SA*CANG
      STFCPA = STE*CTP*CAPANG - CTE*STP
      STFSPA = SAPANG*STE
      ALON = ATAN2 (STFSPA,STFCPA)*RTOD
      R    = ALT + RE
      HA   = ALT + R*COTTD*COTTD
      A    = 1. + HA/REQ
      RETURN
      END

      FUNCTION FINT (X1,X2,X3,Y1,Y2,Y3, XFIT)
C          Second degree interpolation used by FNDAPX
C          INPUTS:
C            X1   = point 1 ordinate value
C            X2   = point 2 ordinate value
C            X3   = point 3 ordinate value
C            Y1   = point 1 abscissa value
C            Y2   = point 2 abscissa value
C            Y3   = point 3 abscissa value
C            XFIT = ordinate value to fit
C          RETURNS:
C            YFIT = abscissa value corresponding to XFIT
C
C          MODIFICATIONS:
C          Apr 2004: Change from subroutine to function, rename variables and
C                    add intermediates which are otherwise calculated twice
      X12 = X1-X2
      X13 = X1-X3
      X23 = X2-X3
      XF1 = XFIT-X1
      XF2 = XFIT-X2
      XF3 = XFIT-X3

      FINT = (Y1*X23*XF2*XF3 - Y2*X13*XF1*XF3 + Y3*X12*XF1*XF2) /
     +                                                     (X12*X13*X23)
      RETURN
      END


***************************************************************
** The following code is for simulating the 2D flow past
*  a forward facing step using the high order accurate
*  WENO schemes, developed by Guang-Shan Jiang and Chi-Wang Shu
*  (see the paper on JCP, v126, pp. 202-228(1996)).
*
** The code is in Fortran 77 with single precision.
*  Compile with "f77 -r8" to achieve double precision.
*
** Any comments on the performance of the code and the schemes
*  are very welcome.
*
** The authors are happy to provide this code to any potential
*  users. However, any redistribution of this code should
*  carry this preamble.
*
** Please credit the authors for any work facilitated by this
*  code or the WENO schemes.
***************************************************************

      program main

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)

      call init

* Runge-Kutta time stepping:
      tnum=0.
      istop=0

        write(*,*) '4th order Runge-kutta in time'

      do 400 nt=1, 100000

      call bcx
      call enox
      call bcy
      call enoy
      dt=cfl/em/(cdx+cdy)
      if((tnum+dt).ge.tend) then
           istop=1
           dt=tend-tnum
      endif
      dt2=0.5*dt
      tnum=tnum+dt
      do 410 m=1,mn
      do 410 j=0,ny
      do 410 i=nxl(j),nxr(j)
        u0(i,j,m)=u(i,j,m)
         u(i,j,m)=u(i,j,m)+dt2*f(i,j,m)
410     continue

      call bcx
      call enox
      call bcy
      call enoy
      do 420 m=1,mn
      do 420 j=0,ny
      do 420 i=nxl(j),nxr(j)
        uc(i,j,m)=-u0(i,j,m)+u(i,j,m)
         u(i,j,m)= u0(i,j,m)+dt2*f(i,j,m)
420     continue

      call bcx
      call enox
      call bcy
      call enoy
      do 430 m=1,mn
      do 430 j=0,ny
      do 430 i=nxl(j),nxr(j)
        uc(i,j,m)=uc(i,j,m)+2.*u(i,j,m)
         u(i,j,m)=u0(i,j,m)+dt*f(i,j,m)
430     continue

      call bcx
      call enox
      call bcy
      call enoy
        do 440 m=1,mn
      do 440 j=0,ny
      do 440 i=nxl(j),nxr(j)
        u(i,j,m)=(1./3.)*(uc(i,j,m)+u(i,j,m)+dt2*f(i,j,m))
440      continue

      if(istop.eq.1) goto 999
400     continue

999    continue

       write(*,*) '  nt=',nt,'  t=', tnum

       call save

1      format(1x,'CPU time=',f12.4)

       stop
       end

      subroutine init

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)

* Setup parameters:

* Ratio of specific heats:
      gamma = 1.4
      gm1   = gamma - 1.0
* WENO constant
      epweno = 1.e-6
* Final time
      tend = 4.0
* CFL number
      cfl = 0.6

      xleft=0.0
      xright=3.0
      yleft=0.0
      yright=1.0
      xmid=0.6
      ymid=0.2

      write(*,*) ' '
      write(*,*) 'Flow past a forward facing step'
      write(*,*) ' '
      write(*,*) 'xleft=',xleft, '  xright=', xright
      write(*,*) 'yleft=',yleft, '  yright=', yright
      write(*,*) 'tend=', tend,  '  cfl=', cfl
      write(*,*) ' '
      write(*,*) 'constant initial condition'
      write(*,*) 'density x-velocity y-velocity pressure'
      write(*,*) '  1.4       3          0         1'
      write(*,*) '    '

      dx=(xright-xleft)/(nx+0.5)
      dy=(yright-yleft)/(ny+1)
      ii=int((xmid-xleft)/dx+1.e-4)
      jj=int((ymid-yleft)/dy+1.e-4)-1
      nxmid=ii
      nymid=jj
      cdx=1./dx
      cdy=1./dy

      do 2 i=-md,nxm
        x(i)=xleft+i*dx
2     continue
      do 3 i=-md,nym
        y(i)=yleft+(i+0.5)*dy
3     continue
      do 4 j=-md,nym
      if(j.le.jj) then
        nxl(j)=0
        nxr(j)=ii
        else
        nxl(j)=0
        nxr(j)=nx
        endif
4     continue
      do 5 i=-md,nxm
      if(i.le.ii) then
        nyl(i)=0
        nyr(i)=ny
      else
        nyl(i)=jj+1
        nyr(i)=ny
      endif
5     continue

c give initial conditions

      den=1.4
      vex=3.0
      vey=0.
      pre=1.0
      do 10 j=-md,nym
      do 10 i=-md,nxm
        u(i,j,1)=den
        u(i,j,2)=den*vex
        u(i,j,3)=den*vey
        u(i,j,4)=pre/gm1+0.5*den*(vex**2+vey**2)
10    continue

      do 20 j=0,ny
        ul(j,1)=den
        ul(j,2)=den*vex
        ul(j,3)=den*vey
        ul(j,4)=pre/gm1+0.5*den*(vex**2+vey**2)
        ur(j,1)=den
        ur(j,2)=den*vex
        ur(j,3)=den*vey
        ur(j,4)=pre/gm1+0.5*den*(vex**2+vey**2)
20     continue

      return
      end

      subroutine bcy

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)

c bottom boundary(reflective)

      do 3 j=1,md
      do 3 i=0,nxmid
        u(i,-j,1)= u(i,j-1,1)
        u(i,-j,2)= u(i,j-1,2)
        u(i,-j,3)=-u(i,j-1,3)
        u(i,-j,4)= u(i,j-1,4)
3     continue
      do 5 j=1,md
      do 5 i=nxmid+1,nx
        u(i,nymid+1-j,1)= u(i,nymid+j,1)
        u(i,nymid+1-j,2)= u(i,nymid+j,2)
        u(i,nymid+1-j,3)=-u(i,nymid+j,3)
        u(i,nymid+1-j,4)= u(i,nymid+j,4)
5     continue

c top boundary(reflective)

      do 4 j=1,md
      do 4 i=0,nx
        u(i,ny+j,1)= u(i,ny+1-j,1)
        u(i,ny+j,2)= u(i,ny+1-j,2)
        u(i,ny+j,3)=-u(i,ny+1-j,3)
        u(i,ny+j,4)= u(i,ny+1-j,4)
4     continue

      return
      end

      subroutine bcx

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)
      real utmp(-md:ndm,4)

c treat the singularity at the corner

      den=u(nxmid,nymid,1)
      vex=u(nxmid,nymid,2)/den
      vey=u(nxmid,nymid,3)/den
      q2=vex*vex+vey*vey
      pre=gm1*(u(nxmid,nymid,4)-0.5*den*q2)
      enth=(u(nxmid,nymid,4)+pre)/den
      ent=pre/abs(den)**gamma

      do 10 j=0,1
      do 10 i=nxmid+1,nxmid+4-2*j

        jj=j+nymid+1

        den=u(i,jj,1)
        vex=u(i,jj,2)/den
        vey=u(i,jj,3)/den
        q2=vex*vex+vey*vey
        pre=gm1*(u(i,jj,4)-0.5*den*q2)

        den=(abs(pre/ent))**(1./gamma)
        qq2=abs(2.*(enth-gamma*pre/den/gm1))
        t0=sqrt(qq2/q2)
        vex=vex*t0
        vey=vey*t0
        u(i,jj,1)=den
        u(i,jj,2)=den*vex
        u(i,jj,3)=den*vey
        u(i,jj,4)=pre/gm1+0.5*den*qq2
10    continue

c left boundary(osher inflow b.c.)

      do 1 m=1,4
      do 1 j=0,ny
        utmp(j,m)=u(0,j,m)
1     continue

      call osher(0,ny,ul,utmp)

      do 7 m=1,4
      do 7 i=0,md
      do 7 j=0,ny
        u(-i,j,m)=um(j,m)
7     continue

c right boundary(part reflective, part osher outflow b.c.)

      do 6 i=1,md
      do 6 j=0,nymid
        u(nxmid+i,j,1)= u(nxmid+1-i,j,1)
        u(nxmid+i,j,2)=-u(nxmid+1-i,j,2)
        u(nxmid+i,j,3)= u(nxmid+1-i,j,3)
        u(nxmid+i,j,4)= u(nxmid+1-i,j,4)
6     continue

      do 2 m=1,4
      do 2 j=nymid+1,ny
        utmp(j,m)=u(nx,j,m)
2     continue

      call osher(nymid+1,ny,utmp,ur)

      do 8 m=1,4
      do 8 i=0,md
      do 8 j=nymid+1,ny
        u(nx+i,j,m)=um(j,m)
8     continue

      return
      end

      subroutine osher(loops,loope,vl,vr)

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)

      dimension vl(-md:ndm,4),vr(-md:ndm,4),um2(4),um3(4)

      do 10 j=loops,loope

      rho4=vl(j,1)
      u4=vl(j,2)/rho4
      v4=vl(j,3)/rho4
      p4=gm1*(vl(j,4)-0.5*rho4*(u4*u4+v4*v4))
      c4=sqrt(gamma*p4/rho4)

      rho1=vr(j,1)
      u1=vr(j,2)/rho1
      v1=vr(j,3)/rho1
      p1=gm1*(vr(j,4)-0.5*rho1*(u1*u1+v1*v1))
      c1=sqrt(gamma*p1/rho1)

      c2=c1*(gm1/2.*(u4-u1)+(c4+c1))/(c1+c4*(p1/p4)**(gm1/2./gamma))
      p2=p1*(c2/c1)**(2.*gamma/gm1)
      p3=p2
      c3=c4*(p3/p4)**(gm1/2./gamma)
      u2=u1+2.*(c2-c1)/gm1
      u3=u2

      rho3=gamma*p3/c3**2
      rho2=gamma*p2/c2**2

      v3=v4
      v2=v1

      um3(1)=rho3
      um3(2)=rho3*u3
      um3(3)=rho3*v3
      um3(4)=p3/gm1+0.5*rho3*(u3*u3+v3*v3)

      um2(1)=rho2
      um2(2)=rho2*u2
      um2(3)=rho2*v2
      um2(4)=p2/gm1+0.5*rho2*(u2*u2+v2*v2)

      if(u4-c4.gt.0.) then
       um(j,1)=vl(j,1)
       um(j,2)=vl(j,2)
       um(j,3)=vl(j,3)
       um(j,4)=vl(j,4)
      else if(u2.gt.0.) then
       um(j,1)=um3(1)
       um(j,2)=um3(2)
       um(j,3)=um3(3)
       um(j,4)=um3(4)
      else if(u1+c1.gt.0.) then
       um(j,1)=um2(1)
       um(j,2)=um2(2)
       um(j,3)=um2(3)
       um(j,4)=um2(4)
      else
       um(j,1)=vr(j,1)
       um(j,2)=vr(j,2)
       um(j,3)=vr(j,3)
       um(j,4)=vr(j,4)
      end if

   10 continue

      return
      end

      subroutine save

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)

c save the solution for graphing with Tecplot

      open(10,file='data')

      write(10,*)'   TITLE = "Flow Past a Forward Facing Step" '
      write(10,13)
      write(10,14) nxmid+1,nymid+2
13    format(3x,'VARIABLES = "X","Y","DENSITY","X-VELOCITY",'
     &                      ,'"Y-VELOCITY","PRESSURE","ENTROPY"')
14    format(3x,'ZONE T="Small Rect", I=',I3,' J=',I3)
      do 2 j=0,nymid+1
      do 2 i=0,nxmid
        den=u(i,j,1)
        xmt=u(i,j,2)
        ymt=u(i,j,3)
        vex=xmt/den
        vey=ymt/den
        pre=gm1*(u(i,j,4)-0.5*(xmt*vex+ymt*vey))
        ent=alog(abs(pre/abs(den)**gamma))
        write(10,12) x(i),y(j),den,vex,vey,pre,ent
2     continue
      write(10,15) nx+1,(ny-nymid)
15    format(3x,'ZONE T="Large Rect", I=',I3,' J=',I3)
      do 3 j=nymid+1,ny
      do 3 i=0,nx
        den=u(i,j,1)
        xmt=u(i,j,2)
        ymt=u(i,j,3)
        vex=xmt/den
        vey=ymt/den
        pre=gm1*(u(i,j,4)-0.5*(xmt*vex+ymt*vey))
        ent=alog(abs(pre/abs(den)**gamma))
        write(10,12) x(i),y(j),den,vex,vey,pre,ent
3     continue

      close(91)

12    format(7f11.6)

      return
      end

      subroutine enox

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)
      real w(-md:nxm),h(-md:nxm),vx(-md:nxm),vy(-md:nxm)
     &    ,fp(-md:nxm,mn),uk(-md:nxm,mn),fh(-md:nxm,mn),am(mn)
     &    ,evl(-md:nxm,mn,mn),evr(-md:nxm,mn,mn)
     &    ,tf(-md:nxm,mn),tu(-md:nxm,mn)
     &    ,ff(-md:nxm,mn),gg(-md:nxm,mn,2),hh(-md:nxm,4,2)

* Use global Lax-Friedriches flux splitting:

*  Compute  f_x :

              em=1.e-15

      do 100 j=0,ny

       am(1) = 1.e-15
       am(2) = 1.e-15
       am(4) = 1.e-15
       do 110 i=-md+nxl(j), nxr(j)+md
         den=u(i,j,1)
         xmt=u(i,j,2)
         ymt=u(i,j,3)
         eng=u(i,j,4)
         t0=1./den
         vex=xmt*t0
         vey=ymt*t0
         pre=gm1*(eng-0.5*(xmt*vex+ymt*vey))
         cvel=sqrt(abs(gamma*pre*t0))
         fp(i,1)=xmt
         fp(i,2)=pre+xmt*vex
         fp(i,3)=xmt*vey
         fp(i,4)=vex*(pre+eng)
         uk(i,1)=den
         uk(i,2)=xmt
         uk(i,3)=ymt
         uk(i,4)=eng
         w(i)=sqrt(abs(den))
         vx(i)=vex
         vy(i)=vey
         h(i)=(pre+eng)*t0
         am(1)=max(am(1),abs(vex-cvel))
         am(2)=max(am(2),abs(vex))
         am(4)=max(am(4),abs(vex+cvel))

110    continue
         am(1)=am(1)*1.1
         am(2)=am(2)*1.1
         am(3)=am(2)
         am(4)=am(4)*1.1
         em=max(em, max(am(1),am(4)))

       do 115 i=-1+nxl(j),nxr(j)
* Compute e'vectors using Roe's average:
         ip=i+1
         t0=w(i)/(w(i)+w(ip)+1.e-15)
         t1=1.-t0
         vxm=t0*vx(i)+t1*vx(ip)
         vym=t0*vy(i)+t1*vy(ip)
         hm=t0*h(i)+t1*h(ip)
         qm=0.5*(vxm*vxm+vym*vym)
         cm=sqrt(abs(gm1*(hm-qm)))+1.e-15
         t0=vxm*cm
         evr(i,1,1)=1.0
         evr(i,1,2)=0.0
         evr(i,1,3)=1.0
         evr(i,1,4)=1.0
         evr(i,2,1)=vxm-cm
         evr(i,2,2)=0.0
         evr(i,2,3)=vxm
         evr(i,2,4)=vxm+cm
         evr(i,3,1)=vym
         evr(i,3,2)=1.0
         evr(i,3,3)=vym
         evr(i,3,4)=vym
         evr(i,4,1)=hm-t0
         evr(i,4,2)=vym
         evr(i,4,3)=qm
         evr(i,4,4)=hm+t0
         rcm=1./cm
         b1=gm1*rcm*rcm
         b2=qm*b1
         t0=vxm*rcm
         t1=b1*vxm
         t2=0.5*b1
         t3=b1*vym
         evl(i,1,1)=0.5*(b2+t0)
         evl(i,1,2)=-0.5*(t1+rcm)
         evl(i,1,3)=-0.5*t3
         evl(i,1,4)=t2
         evl(i,2,1)=-vym
         evl(i,2,2)=0.0
         evl(i,2,3)=1.0
         evl(i,2,4)=0.0
         evl(i,3,1)=1.-b2
         evl(i,3,2)=t1
         evl(i,3,3)=t3
         evl(i,3,4)=-b1
         evl(i,4,1)=0.5*(b2-t0)
         evl(i,4,2)=-0.5*(t1-rcm)
         evl(i,4,3)=-0.5*t3
         evl(i,4,4)=t2
115    continue

       do 120 m=1,mn
       do 120 i=-md+nxl(j),nxr(j)+md-1
        tf(i,m)=fp(i+1,m)-fp(i,m)
        tu(i,m)=uk(i+1,m)-uk(i,m)
120     continue

*  begin of the big loop

       do 125 m=1,mn
       do 125 i = -1, nx
125      ff(i,m) = 0.0

       do 160 m=1,mn

* Project the relevant first undivided differences into the
* 'm'th characteristic field
       do 130 m1=1,mn
       do 130 i=-md+nxl(j),nxr(j)+md-1
       gg(i,m1,1)=0.5*(tf(i,m1)+am(m)*tu(i,m1))
       gg(i,m1,2)=gg(i,m1,1)-tf(i,m1)
130    continue

       do 140 m1=1,4
       k0=m1-3
       k1=3-m1
       do 140 i=-1+nxl(j),nxr(j)
         hh(i,m1,1)=evl(i,m,1)*gg(i+k0,1,1)+evl(i,m,2)*gg(i+k0,2,1)
     &             +evl(i,m,3)*gg(i+k0,3,1)+evl(i,m,4)*gg(i+k0,4,1)
       hh(i,m1,2)=evl(i,m,1)*gg(i+k1,1,2)+evl(i,m,2)*gg(i+k1,2,2)
     &             +evl(i,m,3)*gg(i+k1,3,2)+evl(i,m,4)*gg(i+k1,4,2)
140    continue

* Compute numerical flux in each characteristic field:

       do 150 m1=1,2
       do 150 i=-1+nxl(j),nxr(j)
           t1 = hh(i,1,m1) - hh(i,2,m1)
           t2 = hh(i,2,m1) - hh(i,3,m1)
           t3 = hh(i,3,m1) - hh(i,4,m1)
          tt1 = 13. * t1**2 + 3. * (   hh(i,1,m1) - 3*hh(i,2,m1) )**2
          tt2 = 13. * t2**2 + 3. * (   hh(i,2,m1) +   hh(i,3,m1) )**2
          tt3 = 13. * t3**2 + 3. * ( 3*hh(i,3,m1) -   hh(i,4,m1) )**2
           s1 =  1.0 / ( epweno + tt1 )**2
           s2 =  6.0 / ( epweno + tt2 )**2
           s3 =  3.0 / ( epweno + tt3 )**2
           t0 = 1. / ( s1 + s2 + s3 )
           s1 = s1 * t0
           s3 = s3 * t0
         ff(i,m) = ff(i,m) + ( s1*(t2-t1) + (0.5*s3-0.25)*(t3-t2) ) /3.
150    continue

160    continue

*  end of the big loop

* Project the numerical flux to the physical space:

        do 162 m=1,mn
        do 162 i=-1+nxl(j),nxr(j)
       fh(i,m)=(-fp(i-1,m)+7*(fp(i,m)+fp(i+1,m))-fp(i+2,m))/12.
     &          +evr(i,m,1)*ff(i,1)+evr(i,m,2)*ff(i,2)
     &          +evr(i,m,3)*ff(i,3)+evr(i,m,4)*ff(i,4)
162     continue

       do 166 m=1,mn
       do 166 i=nxl(j),nxr(j)
        f(i,j,m)=(fh(i-1,m)-fh(i,m))*cdx
166    continue
100    continue

      return
      end

      subroutine enoy

      parameter(md=4,mn=4,nx=122,ny=39,nd=122)
      parameter(nxm=nx+md,nym=ny+md,ndm=nd+md)
      common/const/tend,cfl,epweno,gamma,gm1
      common/grid/dx,cdx,x(-md:nxm),dy,cdy,y(-md:nym),dt,em,tnum
      common/sol/ u(-md:nxm,-md:nym,mn),f(-md:nxm,-md:nym,mn)
     &           ,u0(-md:nxm,-md:nym,mn),uc(-md:nxm,-md:nym,mn)
      common/zerod/ul(-md:ndm,mn),ur(-md:ndm,mn)
     &            ,ut(-md:ndm,mn),ub(-md:ndm,mn),um(-md:ndm,mn)
      common/step/nxmid,nxl(-md:nym),nxr(-md:nym)
     &           ,nymid,nyl(-md:nxm),nyr(-md:nxm)
      real w(-md:nym),h(-md:nym),vx(-md:nym),vy(-md:nym)
     &    ,fp(-md:nym,mn),uk(-md:nym,mn),fh(-md:nym,mn),am(mn)
     &    ,evl(-md:nym,mn,mn),evr(-md:nym,mn,mn)
     &    ,tf(-md:nym,mn),tu(-md:nym,mn)
     &    ,ff(-md:nym,mn),gg(-md:nym,mn,2),hh(-md:nym,4,2)

* Use global Lax-Friedriches flux splitting:

*  Compute  g_y :

      do 200 j=0,nx

       am(1) = 1.e-15
       am(2) = 1.e-15
       am(4) = 1.e-15
       do 210 i=-md+nyl(j), nyr(j)+md
          den=u(j,i,1)
          xmt=u(j,i,2)
          ymt=u(j,i,3)
          eng=u(j,i,4)
          t0=1./den
         vex=xmt*t0
         vey=ymt*t0
         pre=gm1*(eng-0.5*(xmt*vex+ymt*vey))
         cvel=sqrt(abs(gamma*pre*t0))
           fp(i,1)=ymt
           fp(i,2)=xmt*vey
           fp(i,3)=pre+ymt*vey
           fp(i,4)=vey*(pre+eng)
           uk(i,1)=den
           uk(i,2)=xmt
           uk(i,3)=ymt
           uk(i,4)=eng
         w(i)=sqrt(abs(den))
         vx(i)=vex
         vy(i)=vey
         h(i)=(pre+eng)*t0
           am(1)=max(am(1),abs(vey-cvel))
           am(2)=max(am(2),abs(vey))
           am(4)=max(am(4),abs(vey+cvel))
210     continue
           am(1)=am(1)*1.1
           am(2)=am(2)*1.1
           am(3)=am(2)
           am(4)=am(4)*1.1
           em=max(em,max(am(1),am(4)))

       do 215 i=-1+nyl(j),nyr(j)
* Compute e'vectors using Roe's average:
          ip=i+1
          t0=w(i)/(w(i)+w(ip)+1.e-15)
          t1=1.-t0
         vxm=t0*vx(i)+t1*vx(ip)
         vym=t0*vy(i)+t1*vy(ip)
         hm=t0*h(i)+t1*h(ip)
         qm=0.5*(vxm*vxm+vym*vym)
         cm=sqrt(abs(gm1*(hm-qm)))+1.e-15
          t0=vym*cm
         evr(i,1,1)=1.0
         evr(i,1,2)=0.0
         evr(i,1,3)=1.0
         evr(i,1,4)=1.0
         evr(i,2,1)=vxm
         evr(i,2,2)=1.0
         evr(i,2,3)=vxm
         evr(i,2,4)=vxm
         evr(i,3,1)=vym-cm
         evr(i,3,2)=0.0
         evr(i,3,3)=vym
         evr(i,3,4)=vym+cm
         evr(i,4,1)=hm-t0
         evr(i,4,2)=vxm
         evr(i,4,3)=qm
         evr(i,4,4)=hm+t0
          rcm=1./cm
          b1=gm1*rcm*rcm
          b2=qm*b1
          t0=vym*rcm
          t1=b1*vym
          t2=0.5*b1
          t3=b1*vxm
         evl(i,1,1)=0.5*(b2+t0)
         evl(i,1,2)=-0.5*t3
         evl(i,1,3)=-0.5*(t1+rcm)
         evl(i,1,4)=t2
         evl(i,2,1)=-vxm
         evl(i,2,2)=1.0
         evl(i,2,3)=0.0
         evl(i,2,4)=0.0
         evl(i,3,1)=1.-b2
       evl(i,3,2)=t3
       evl(i,3,3)=t1
       evl(i,3,4)=-b1
       evl(i,4,1)=0.5*(b2-t0)
       evl(i,4,2)=-0.5*t3
       evl(i,4,3)=-0.5*(t1-rcm)
       evl(i,4,4)=t2
215    continue

       do 220 m=1,mn
       do 220 i=-md+nyl(j),nyr(j)+md-1
        tf(i,m)=fp(i+1,m)-fp(i,m)
        tu(i,m)=uk(i+1,m)-uk(i,m)
220     continue

*  begin of the big loop

       do 225 m=1,mn
       do 225 i = -1, ny
225      ff(i,m) = 0.0

       do 260 m=1,mn

* Project the relevant first undivided differences into the
* 'm'th characteristic field
       do 230 m1=1,mn
       do 230 i=-md+nyl(j),nyr(j)+md-1
         gg(i,m1,1)=0.5*(tf(i,m1)+am(m)*tu(i,m1))
         gg(i,m1,2)=gg(i,m1,1)-tf(i,m1)
230    continue

       do 240 m1=1,4
         k0=m1-3
         k1=3-m1
       do 240 i=-1+nyl(j),nyr(j)
         hh(i,m1,1)=evl(i,m,1)*gg(i+k0,1,1)+evl(i,m,2)*gg(i+k0,2,1)
     &             +evl(i,m,3)*gg(i+k0,3,1)+evl(i,m,4)*gg(i+k0,4,1)
         hh(i,m1,2)=evl(i,m,1)*gg(i+k1,1,2)+evl(i,m,2)*gg(i+k1,2,2)
     &             +evl(i,m,3)*gg(i+k1,3,2)+evl(i,m,4)*gg(i+k1,4,2)
240    continue

* Compute numerical flux in each characteristic field:

       do 250 m1=1,2
       do 250 i=-1+nyl(j),nyr(j)
           t1 = hh(i,1,m1) - hh(i,2,m1)
           t2 = hh(i,2,m1) - hh(i,3,m1)
           t3 = hh(i,3,m1) - hh(i,4,m1)
          tt1 = 13. * t1**2 + 3. * (   hh(i,1,m1) - 3*hh(i,2,m1) )**2
          tt2 = 13. * t2**2 + 3. * (   hh(i,2,m1) +   hh(i,3,m1) )**2
          tt3 = 13. * t3**2 + 3. * ( 3*hh(i,3,m1) -   hh(i,4,m1) )**2
           s1 =  1.0 / ( epweno + tt1 )**2
           s2 =  6.0 / ( epweno + tt2 )**2
           s3 =  3.0 / ( epweno + tt3 )**2
            t0 = 1. / ( s1 + s2 + s3 )
            s1 = s1 * t0
            s3 = s3 * t0
         ff(i,m) = ff(i,m) + ( s1*(t2-t1) + (0.5*s3-0.25)*(t3-t2) ) /3.
250    continue

260    continue

*  end of the big loop

* Project the numerical flux to the physical space:

        do 262 m=1,mn
        do 262 i=-1+nyl(j),nyr(j)
       fh(i,m)=(-fp(i-1,m)+7*(fp(i,m)+fp(i+1,m))-fp(i+2,m))/12.
     &          +evr(i,m,1)*ff(i,1)+evr(i,m,2)*ff(i,2)
     &          +evr(i,m,3)*ff(i,3)+evr(i,m,4)*ff(i,4)
262     continue

       do 266 m=1,mn
       do 266 i=nyl(j),nyr(j)
        f(j,i,m)=f(j,i,m)+(fh(i-1,m)-fh(i,m))*cdy
266     continue
200   continue

      return
      end


c demonstration paradigme decembre 1994
c
c MAIN
c
      program hpftest66
      integer n, m
      parameter(n=100, m=77)
      integer compute
      external compute
      integer iter, again, last
      print *, 'HPFTEST66 RUNNING'
c
c number of iterations
c
 10   print *, 'PLEASE ENTER THE NUMBER OF ITERATIONS (1-', n, ')'
      read *, iter
      if (iter.lt.1.or.iter.gt.n) goto 10
c
c procedure calls
c
      call init
      last = compute(iter)
      call output(last)
c
c again ?
c
      print *, 'AGAIN (0/1) ?'
      read *, again
      if (again.eq.1) goto 10
      print *, 'HPFTEST66 ENDING'
      end
c
c INIT
c
      subroutine init
      integer n, m
      parameter(n=100, m=77)
      common /arrays/ a(n,m,2), b(n), avm
      real*8 a, b, avm
chpf$ template t(n,m)
chpf$ processors p(2,2)
chpf$ align a(i,j,*) with t(i,j)
chpf$ align b(i) with t(i,1)
chpf$ distribute t(block,block) onto p
      integer i,j
      real*8 tmp
      print *, 'INITIALIZING ARRAY A'
chpf$ independent(j), new(tmp)
      do j=1, m
         tmp = 7.84*j
chpf$ independent(i)
         do i=1, n
            a(i,j,1) = tmp + (3.14/4.2*i)
         enddo
      enddo
chpf$ independent(i)
      do i=1, n
         b(i)=78.0/i
      enddo
      end
c
c COMPUTE
c
      integer function compute(it)
      integer it
      integer n, m
      parameter(n=100, m=77)
      common /arrays/ a(n,m,2), b(n), avm
      real*8 a, b, avm
chpf$ template t(n,m)
chpf$ processors p(2,2)
chpf$ align a(i,j,*) with t(i,j)
chpf$ align b(i) with t(i,1)
chpf$ distribute t(block,block) onto p
      real*8 redmin3
      external redmin3
      integer i,j,time,new,old
      real*8 amin
      print *, 'COMPUTING ', it, ' ITERATIONS'
      new=2
      old=1
      avm = 0.0
      do time=1, it
chpf$ independent(j,i)
         do j=2,m-1
            do i=3,n
               a(i,j,new) = 0.25*
     $              (a(i,j,old) +
     $               a(i-1,j,old) +
     $               a(i-1,j-1,old) +
     $               a(i-2,j+1,old))
            enddo
         enddo
         amin = redmin3(a(1,1,1),3,n,2,m-1,new,new)
         avm = avm + amin
         old=new
         new=3-new
      enddo
      avm = avm/it
      compute=old
      end
c
c OUTPUT
c
      subroutine output(last)
      integer last
      integer n, m
      parameter(n=100, m=77)
      common /arrays/ a(n,m,2), b(n), avm
      real*8 a, b, avm
chpf$ template t(n,m)
chpf$ processors p(2,2)
chpf$ align a(i,j,*) with t(i,j)
chpf$ align b(i) with t(i,1)
chpf$ distribute t(block,block) onto p
      integer i, up
      up=min(n,m)
      print *, 'average min is ', avm
      print *, (a(i,i,last), i=1, up)
      end
c
c REDUCTION MIN 3D
c
      real*8 function redmin3(t,l1,u1,l2,u2,l3,u3)
      integer n, m
      parameter(n=100, m=77)
      integer l1,u1,l2,u2,l3,u3
      real*8 t(n,m,2)
      integer k,j,i
      real*8 result
      result=t(l1,l2,l3)
      do k=l3,u3
         do j=l2,u2
            do i=l1,u1
               if (result.gt.t(i,j,k)) result=t(i,j,k)
            enddo
         enddo
      enddo
      redmin3=result
      end
c
c END
c


program hip_dger

  use iso_c_binding
  use hipfort
  use hipfort_check
  use hipfort_hipblas

  implicit none

  integer, parameter ::  m = 100, n = 100
  double precision, parameter ::  alpha = 1.1d0

  double precision, allocatable, target, dimension(:)   :: hx, hy
  double precision, allocatable, target, dimension(:,:) :: hA

  type(c_ptr) :: handle = c_null_ptr

  double precision, pointer, dimension(:)   :: dx, dy
  double precision, pointer, dimension(:,:) :: dA

  integer :: i,j
  double precision :: error

  write(*,"(a)",advance="no") "-- Running test 'dger' (Fortran 2008 interfaces) - "

  call hipblasCheck(hipblasCreate(handle))

  allocate(hx(m))
  allocate(hy(n))
  allocate(ha(m,n))

  hx(:)   = 1.d0
  hy(:)   = 1.d0
  hA(:,:) = 1.d0

  ! Allocate device memory
  call hipCheck(hipMalloc(dx,m))
  call hipCheck(hipMalloc(dy,n))
  call hipCheck(hipMalloc(dA,m,n))

  !Transfer from host to device
  call hipCheck(hipMemcpy(dx, hx, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dy, hy, hipMemcpyHostToDevice))
  call hipCheck(hipMemcpy(dA, hA, hipMemcpyHostToDevice))

  call hipblasCheck(hipblasDger(handle,m,n,alpha,dx,1,dy,1,dA,m))

  call hipCheck(hipDeviceSynchronize())

  ! Transfer data back to host memory
  call hipCheck(hipMemcpy(hA, dA, hipMemcpyDeviceToHost))

  do j = 1,n
    do i = 1,m
     error = abs(2.1d0 - hA(i,j))
     if( error > 10*epsilon(error) )then
        write(*,*) "FAILED! Error bigger than max! Error = ", error, "hA(i,j) = ", hA(i,j)
        call exit(1)
     end if
   end do
  end do

  call hipCheck(hipFree(dx))
  call hipCheck(hipFree(dy))
  call hipCheck(hipFree(dA))

  call hipblasCheck(hipblasDestroy(handle))

  deallocate(hx,hy,hA)

  write(*,*) "PASSED!"

end program hip_dger


      SUBROUTINE  SGBCO( ABD, LDA, N, ML, MU, IPVT, RCOND, Z )
C
C         FACTORS A REAL BAND MATRIX BY GAUSSIAN ELIMINATION
C         AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C     IF  RCOND  IS NOT NEEDED, SGBFA IS SLIGHTLY FASTER.
C     TO SOLVE  A*X = B , FOLLOW SBGCO BY SGBSL.
C
C     INPUT:
C
C        ABD     REAL(LDA, N)
C                CONTAINS THE MATRIX IN BAND STORAGE.  THE COLUMNS
C                OF THE MATRIX ARE STORED IN THE COLUMNS OF  ABD  AND
C                THE DIAGONALS OF THE MATRIX ARE STORED IN ROWS
C                ML+1 THROUGH 2*ML+MU+1 OF  ABD .
C                SEE THE COMMENTS BELOW FOR DETAILS.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C                LDA MUST BE .GE. 2*ML + MU + 1 .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C                0 .LE. ML .LT. N .
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C                0 .LE. MU .LT. N .
C                MORE EFFICIENT IF  ML .LE. MU .
C
C     ON RETURN
C
C        ABD     AN UPPER TRIANGULAR MATRIX IN BAND STORAGE AND
C                THE MULTIPLIERS WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U  WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     BAND STORAGE
C
C           IF  A  IS A BAND MATRIX, THE FOLLOWING PROGRAM SEGMENT
C           WILL SET UP THE INPUT.
C
C                   ML = (BAND WIDTH BELOW THE DIAGONAL)
C                   MU = (BAND WIDTH ABOVE THE DIAGONAL)
C                   M = ML + MU + 1
C                   DO 20 J = 1, N
C                      I1 = MAX0(1, J-MU)
C                      I2 = MIN0(N, J+ML)
C                      DO 10 I = I1, I2
C                         K = I - J + M
C                         ABD(K,J) = A(I,J)
C                10    CONTINUE
C                20 CONTINUE
C
C           THIS USES ROWS  ML+1  THROUGH  2*ML+MU+1  OF  ABD .
C           IN ADDITION, THE FIRST  ML  ROWS IN  ABD  ARE USED FOR
C           ELEMENTS GENERATED DURING THE TRIANGULARIZATION.
C           THE TOTAL NUMBER OF ROWS NEEDED IN  ABD  IS  2*ML+MU+1 .
C           THE  ML+MU BY ML+MU  UPPER LEFT TRIANGLE AND THE
C           ML BY ML  LOWER RIGHT TRIANGLE ARE NOT REFERENCED.
C
C     EXAMPLE:  IF THE ORIGINAL MATRIX IS
C
C           11 12 13  0  0  0
C           21 22 23 24  0  0
C            0 32 33 34 35  0
C            0  0 43 44 45 46
C            0  0  0 54 55 56
C            0  0  0  0 65 66
C
C      THEN  N = 6, ML = 1, MU = 2, LDA .GE. 5  AND ABD SHOULD CONTAIN
C
C            *  *  *  +  +  +  , * = NOT USED
C            *  * 13 24 35 46  , + = USED FOR PIVOTING
C            * 12 23 34 45 56
C           11 22 33 44 55 66
C           21 32 43 54 65  *
C
C
C     ROUTINES CALLED:  FROM LINPACK: SGBFA
C                       FROM BLAS:    SAXPY, SDOT, SSCAL, SASUM
C                       FROM FORTRAN: ABS, AMAX1, MAX0, MIN0, SIGN
C
      INTEGER  LDA, N, ML, MU, IPVT(*)
      REAL     ABD(LDA,*), Z(*)
      REAL     RCOND
C
      REAL     SDOT, EK, T, WK, WKM
      REAL     ANORM, S, SASUM, SM, YNORM
      INTEGER  IS, INFO, J, JU, K, KB, KP1, L, LA, LM, LZ, M, MM
C
C
C                       ** COMPUTE 1-NORM OF A
      ANORM = 0.0E0
      L = ML + 1
      IS = L + MU
      DO 10 J = 1, N
         ANORM = AMAX1(ANORM, SASUM(L,ABD(IS,J), 1))
         IF (IS .GT. ML + 1) IS = IS - 1
         IF (J .LE. MU) L = L + 1
         IF (J .GE. N - ML) L = L - 1
   10 CONTINUE
C                                               ** FACTOR
      CALL SGBFA(ABD, LDA, N, ML, MU, IPVT, INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C                     ** SOLVE TRANS(U)*W = E
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
C
      M = ML + MU + 1
      JU = 0
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK, -Z(K))
         IF (ABS(EK-Z(K)) .GT. ABS(ABD(M,K))) THEN
            S = ABS(ABD(M,K))/ABS(EK-Z(K))
            CALL SSCAL(N, S, Z, 1)
            EK = S*EK
         ENDIF
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (ABD(M,K) .NE. 0.0E0) THEN
            WK  = WK /ABD(M,K)
            WKM = WKM/ABD(M,K)
         ELSE
            WK  = 1.0E0
            WKM = 1.0E0
         ENDIF
         KP1 = K + 1
         JU = MIN0(MAX0(JU, MU+IPVT(K)), N)
         MM = M
         IF (KP1 .LE. JU) THEN
            DO 60 J = KP1, JU
               MM = MM - 1
               SM = SM + ABS(Z(J)+WKM*ABD(MM,J))
               Z(J) = Z(J) + WK*ABD(MM,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .LT. SM) THEN
               T = WKM - WK
               WK = WKM
               MM = M
               DO 70 J = KP1, JU
                  MM = MM - 1
                  Z(J) = Z(J) + T*ABD(MM,J)
   70          CONTINUE
            ENDIF
         ENDIF
         Z(K) = WK
  100 CONTINUE
C
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
C
C                         ** SOLVE TRANS(L)*Y = W
      DO 120 KB = 1, N
         K = N + 1 - KB
         LM = MIN0(ML, N-K)
         IF (K .LT. N) Z(K) = Z(K) + SDOT(LM, ABD(M+1,K), 1, Z(K+1), 1)
         IF (ABS(Z(K)) .GT. 1.0E0) THEN
            S = 1.0E0 / ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
         ENDIF
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
C
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
C
      YNORM = 1.0E0
C                         ** SOLVE L*V = Y
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         LM = MIN0(ML, N-K)
         IF (K .LT. N) CALL SAXPY(LM, T, ABD(M+1,K), 1, Z(K+1), 1)
         IF (ABS(Z(K)) .GT. 1.0E0) THEN
            S = 1.0E0 / ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
            YNORM = S*YNORM
         ENDIF
  140 CONTINUE
C
      S = 1.0E0/SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
      YNORM = S*YNORM
C                           ** SOLVE  U*Z = W
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .GT. ABS(ABD(M,K))) THEN
            S = ABS(ABD(M,K)) / ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
            YNORM = S*YNORM
         ENDIF
         IF (ABD(M,K) .NE. 0.0E0) Z(K) = Z(K)/ABD(M,K)
         IF (ABD(M,K) .EQ. 0.0E0) Z(K) = 1.0E0
         LM = MIN0(K, M) - 1
         LA = M - LM
         LZ = K - LM
         T = -Z(K)
         CALL SAXPY(LM, T, ABD(LA,K), 1, Z(LZ), 1)
  160 CONTINUE
C                              ** MAKE ZNORM = 1.0
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE  SGBFA( ABD, LDA, N, ML, MU, IPVT, INFO )
C
C         FACTORS A REAL BAND MATRIX BY ELIMINATION.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C     SGBFA IS USUALLY CALLED BY SBGCO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C
C     INPUT:  SAME AS 'SGBCO'
C
C     ON RETURN:
C
C        ABD,IPVT    SAME AS 'SGBCO'
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT SGBSL WILL DIVIDE BY ZERO IF
C                     CALLED.  USE  RCOND  IN SBGCO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     (SEE 'SGBCO' FOR DESCRIPTION OF BAND STORAGE MODE)
C
C     ROUTINES CALLED:  FROM BLAS:    SAXPY, SSCAL, ISAMAX
C                       FROM FORTRAN: MAX0, MIN0
C
      INTEGER  LDA, N, ML, MU, IPVT(*), INFO
      REAL     ABD(LDA,*)
C
      REAL     T
      INTEGER  I,ISAMAX,I0,J,JU,JZ,J0,J1,K,KP1,L,LM,M,MM,NM1
C
C
      M = ML + MU + 1
      INFO = 0
C                        ** ZERO INITIAL FILL-IN COLUMNS
      J0 = MU + 2
      J1 = MIN0(N, M) - 1
      DO 20 JZ = J0, J1
         I0 = M + 1 - JZ
         DO 10 I = I0, ML
            ABD(I,JZ) = 0.0E0
   10    CONTINUE
   20 CONTINUE
      JZ = J1
      JU = 0
C
C                       ** GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
      NM1 = N - 1
      DO 120 K = 1, NM1
         KP1 = K + 1
C                                  ** ZERO NEXT FILL-IN COLUMN
         JZ = JZ + 1
         IF (JZ .LE. N) THEN
            DO 40 I = 1, ML
               ABD(I,JZ) = 0.0E0
   40       CONTINUE
         ENDIF
C                                  ** FIND L = PIVOT INDEX
         LM = MIN0(ML, N-K)
         L = ISAMAX(LM+1, ABD(M,K), 1) + M - 1
         IPVT(K) = L + K - M
C
         IF (ABD(L,K) .EQ. 0.0E0) THEN
C                                      ** ZERO PIVOT IMPLIES THIS COLUMN
C                                      ** ALREADY TRIANGULARIZED
            INFO = K
         ELSE
C                                ** INTERCHANGE IF NECESSARY
            IF (L .NE. M) THEN
               T = ABD(L,K)
               ABD(L,K) = ABD(M,K)
               ABD(M,K) = T
            ENDIF
C                                   ** COMPUTE MULTIPLIERS
            T = -1.0E0 / ABD(M,K)
            CALL SSCAL(LM, T, ABD(M+1,K), 1)
C
C                               ** ROW ELIMINATION WITH COLUMN INDEXING
C
            JU = MIN0(MAX0(JU, MU+IPVT(K)), N)
            MM = M
            DO 80 J = KP1, JU
               L = L - 1
               MM = MM - 1
               T = ABD(L,J)
               IF (L .NE. MM) THEN
                  ABD(L,J) = ABD(MM,J)
                  ABD(MM,J) = T
               ENDIF
               CALL SAXPY(LM, T, ABD(M+1,K), 1, ABD(MM+1,J), 1)
   80       CONTINUE
C
         ENDIF
C
  120 CONTINUE
C
      IPVT(N) = N
      IF (ABD(M,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE  SGBSL( ABD, LDA, N, ML, MU, IPVT, B, JOB )
C
C         SOLVES THE REAL BAND SYSTEM
C            A * X = B  OR  TRANSPOSE(A) * X = B
C         USING THE FACTORS COMPUTED BY SBGCO OR SGBFA.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C     INPUT:
C
C        ABD     REAL(LDA, N)
C                THE OUTPUT FROM SBGCO OR SGBFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  ABD .
C
C        N       INTEGER
C                THE ORDER OF THE ORIGINAL MATRIX.
C
C        ML      INTEGER
C                NUMBER OF DIAGONALS BELOW THE MAIN DIAGONAL.
C
C        MU      INTEGER
C                NUMBER OF DIAGONALS ABOVE THE MAIN DIAGONAL.
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SBGCO OR SGBFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B , WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY, THIS INDICATES SINGULARITY,
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF SBGCO HAS SET RCOND .GT. 0.0
C        OR SGBFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SGBCO(ABD,LDA,N,ML,MU,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL SGBSL(ABD,LDA,N,ML,MU,IPVT,C(1,J),0)
C        10 CONTINUE
C
C     ROUTINES CALLED:  FROM BLAS:    SAXPY, SDOT
C                       FROM FORTRAN: MIN0
C
      INTEGER  LDA, N, ML, MU, IPVT(*), JOB
      REAL     ABD(LDA,*), B(*)
C
      REAL     SDOT,T
      INTEGER  K,KB,L,LA,LB,LM,M,NM1
C
C
      M = MU + ML + 1
      NM1 = N - 1
      IF (JOB .EQ. 0) THEN
C                               ** JOB = 0 , SOLVE  A * X = B
C                               ** FIRST SOLVE L*Y = B
         IF (ML .NE. 0) THEN
            DO 20 K = 1, NM1
               LM = MIN0(ML, N-K)
               L = IPVT(K)
               T = B(L)
               IF (L .NE. K) THEN
                  B(L) = B(K)
                  B(K) = T
               ENDIF
               CALL SAXPY( LM, T, ABD(M+1,K), 1, B(K+1), 1 )
   20       CONTINUE
         ENDIF
C                           ** NOW SOLVE  U*X = Y
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K) / ABD(M,K)
            LM = MIN0(K, M) - 1
            LA = M - LM
            LB = K - LM
            T = -B(K)
            CALL SAXPY(LM, T, ABD(LA,K), 1, B(LB), 1)
   40    CONTINUE
C
      ELSE
C                          ** JOB = NONZERO, SOLVE  TRANS(A) * X = B
C                                  ** FIRST SOLVE  TRANS(U)*Y = B
         DO 60 K = 1, N
            LM = MIN0(K, M) - 1
            LA = M - LM
            LB = K - LM
            T = SDOT(LM, ABD(LA,K), 1, B(LB), 1)
            B(K) = (B(K) - T)/ABD(M,K)
   60    CONTINUE
C                                  ** NOW SOLVE TRANS(L)*X = Y
         IF (ML .NE. 0) THEN
            DO 80 KB = 1, NM1
               K = N - KB
               LM = MIN0(ML, N-K)
               B(K) = B(K) + SDOT(LM, ABD(M+1,K), 1, B(K+1), 1)
               L = IPVT(K)
               IF (L .NE. K) THEN
                  T = B(L)
                  B(L) = B(K)
                  B(K) = T
               ENDIF
   80       CONTINUE
         ENDIF
C
      ENDIF
C
      RETURN
      END
      SUBROUTINE  SGECO( A, LDA, N,IPVT, RCOND, Z )
C
C         FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION
C         AND ESTIMATES THE CONDITION OF THE MATRIX.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C         IF  RCOND  IS NOT NEEDED, SGEFA IS SLIGHTLY FASTER.
C         TO SOLVE  A*X = B , FOLLOW SGECO BY SGESL.
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE MATRIX TO BE FACTORED.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C     ON RETURN
C
C        A       AN UPPER TRIANGULAR MATRIX AND THE MULTIPLIERS
C                WHICH WERE USED TO OBTAIN IT.
C                THE FACTORIZATION CAN BE WRITTEN  A = L*U , WHERE
C                L  IS A PRODUCT OF PERMUTATION AND UNIT LOWER
C                TRIANGULAR MATRICES AND  U  IS UPPER TRIANGULAR.
C
C        IPVT    INTEGER(N)
C                AN INTEGER VECTOR OF PIVOT INDICES.
C
C        RCOND   REAL
C                AN ESTIMATE OF THE RECIPROCAL CONDITION OF  A .
C                FOR THE SYSTEM  A*X = B , RELATIVE PERTURBATIONS
C                IN  A  AND  B  OF SIZE  EPSILON  MAY CAUSE
C                RELATIVE PERTURBATIONS IN  X  OF SIZE  EPSILON/RCOND .
C                IF  RCOND  IS SO SMALL THAT THE LOGICAL EXPRESSION
C                           1.0 + RCOND .EQ. 1.0
C                IS TRUE, THEN  A  MAY BE SINGULAR TO WORKING
C                PRECISION.  IN PARTICULAR,  RCOND  IS ZERO  IF
C                EXACT SINGULARITY IS DETECTED OR THE ESTIMATE
C                UNDERFLOWS.
C
C        Z       REAL(N)
C                A WORK VECTOR WHOSE CONTENTS ARE USUALLY UNIMPORTANT.
C                IF  A  IS CLOSE TO A SINGULAR MATRIX, THEN  Z  IS
C                AN APPROXIMATE NULL VECTOR IN THE SENSE THAT
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     ROUTINES CALLED:  FROM LINPACK: SGEFA
C                       FROM BLAS:    SAXPY, SDOT, SSCAL, SASUM
C                       FROM FORTRAN: ABS, AMAX1, SIGN
C
      INTEGER  LDA, N, IPVT(*)
      REAL     A(LDA,*), Z(*)
      REAL     RCOND
C
      REAL     SDOT,EK,T,WK,WKM
      REAL     ANORM,S,SASUM,SM,YNORM
      INTEGER  INFO,J,K,KB,KP1,L
C
C
C                        ** COMPUTE 1-NORM OF A
      ANORM = 0.0E0
      DO 10 J = 1, N
         ANORM = AMAX1( ANORM, SASUM(N,A(1,J),1) )
   10 CONTINUE
C                                      ** FACTOR
      CALL SGEFA(A,LDA,N,IPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  TRANS(A)*Y = E .
C     TRANS(A)  IS THE TRANSPOSE OF A .  THE COMPONENTS OF  E  ARE
C     CHOSEN TO CAUSE MAXIMUM LOCAL GROWTH IN THE ELEMENTS OF W  WHERE
C     TRANS(U)*W = E .  THE VECTORS ARE FREQUENTLY RESCALED TO AVOID
C     OVERFLOW.
C
C                        ** SOLVE TRANS(U)*W = E
      EK = 1.0E0
      DO 20 J = 1, N
         Z(J) = 0.0E0
   20 CONTINUE
C
      DO 100 K = 1, N
         IF (Z(K) .NE. 0.0E0) EK = SIGN(EK, -Z(K))
         IF (ABS(EK-Z(K)) .GT. ABS(A(K,K))) THEN
            S = ABS(A(K,K)) / ABS(EK-Z(K))
            CALL SSCAL(N, S, Z, 1)
            EK = S*EK
         ENDIF
         WK = EK - Z(K)
         WKM = -EK - Z(K)
         S = ABS(WK)
         SM = ABS(WKM)
         IF (A(K,K) .NE. 0.0E0) THEN
            WK  = WK  / A(K,K)
            WKM = WKM / A(K,K)
         ELSE
            WK  = 1.0E0
            WKM = 1.0E0
         ENDIF
         KP1 = K + 1
         IF (KP1 .LE. N) THEN
            DO 60 J = KP1, N
               SM = SM + ABS(Z(J)+WKM*A(K,J))
               Z(J) = Z(J) + WK*A(K,J)
               S = S + ABS(Z(J))
   60       CONTINUE
            IF (S .LT. SM) THEN
               T = WKM - WK
               WK = WKM
               DO 70 J = KP1, N
                  Z(J) = Z(J) + T*A(K,J)
   70          CONTINUE
            ENDIF
         ENDIF
         Z(K) = WK
  100 CONTINUE
C
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
C                                ** SOLVE TRANS(L)*Y = W
      DO 120 KB = 1, N
         K = N + 1 - KB
         IF (K .LT. N) Z(K) = Z(K) + SDOT(N-K, A(K+1,K), 1, Z(K+1), 1)
         IF (ABS(Z(K)) .GT. 1.0E0) THEN
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
         ENDIF
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
  120 CONTINUE
C
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
C                                 ** SOLVE L*V = Y
      YNORM = 1.0E0
      DO 140 K = 1, N
         L = IPVT(K)
         T = Z(L)
         Z(L) = Z(K)
         Z(K) = T
         IF (K .LT. N) CALL SAXPY(N-K, T, A(K+1,K), 1, Z(K+1), 1)
         IF (ABS(Z(K)) .GT. 1.0E0) THEN
            S = 1.0E0/ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
            YNORM = S*YNORM
         ENDIF
  140 CONTINUE
C
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
C                                  ** SOLVE  U*Z = V
      YNORM = S*YNORM
      DO 160 KB = 1, N
         K = N + 1 - KB
         IF (ABS(Z(K)) .GT. ABS(A(K,K))) THEN
            S = ABS(A(K,K))/ABS(Z(K))
            CALL SSCAL(N, S, Z, 1)
            YNORM = S*YNORM
         ENDIF
         IF (A(K,K) .NE. 0.0E0) Z(K) = Z(K)/A(K,K)
         IF (A(K,K) .EQ. 0.0E0) Z(K) = 1.0E0
         T = -Z(K)
         CALL SAXPY(K-1, T, A(1,K), 1, Z(1), 1)
  160 CONTINUE
C                                   ** MAKE ZNORM = 1.0
      S = 1.0E0 / SASUM(N, Z, 1)
      CALL SSCAL(N, S, Z, 1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0E0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0E0) RCOND = 0.0E0
      RETURN
      END
      SUBROUTINE  SGEFA( A, LDA, N, IPVT, INFO )
C
C         FACTORS A REAL MATRIX BY GAUSSIAN ELIMINATION.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C     SGEFA IS USUALLY CALLED BY SGECO, BUT IT CAN BE CALLED
C     DIRECTLY WITH A SAVING IN TIME IF  RCOND  IS NOT NEEDED.
C     (TIME FOR SGECO) = (1 + 9/N)*(TIME FOR SGEFA) .
C
C     INPUT:  SAME AS 'SGECO'
C
C     ON RETURN:
C
C        A,IPVT  SAME AS 'SGECO'
C
C        INFO    INTEGER
C                = 0  NORMAL VALUE.
C                = K  IF  U(K,K) .EQ. 0.0 .  THIS IS NOT AN ERROR
C                     CONDITION FOR THIS SUBROUTINE, BUT IT DOES
C                     INDICATE THAT SGESL OR SGEDI WILL DIVIDE BY ZERO
C                     IF CALLED.  USE  RCOND  IN SGECO FOR A RELIABLE
C                     INDICATION OF SINGULARITY.
C
C     ROUTINES CALLED:  FROM BLAS:    SAXPY, SSCAL, ISAMAX
C
      INTEGER  LDA, N, IPVT(*), INFO
      REAL     A(LDA,*)
C
      REAL     T
      INTEGER  ISAMAX,J,K,KP1,L,NM1
C
C
C                      ** GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
      INFO = 0
      NM1 = N - 1
      DO 60 K = 1, NM1
         KP1 = K + 1
C                                            ** FIND L = PIVOT INDEX
         L = ISAMAX( N-K+1, A(K,K), 1) + K-1
         IPVT(K) = L
C
         IF (A(L,K) .EQ. 0.0E0) THEN
C                                     ** ZERO PIVOT IMPLIES THIS COLUMN
C                                     ** ALREADY TRIANGULARIZED
            INFO = K
         ELSE
C                                     ** INTERCHANGE IF NECESSARY
            IF (L .NE. K) THEN
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
            ENDIF
C                                     ** COMPUTE MULTIPLIERS
            T = -1.0E0 / A(K,K)
            CALL SSCAL( N-K, T, A(K+1,K), 1 )
C
C                              ** ROW ELIMINATION WITH COLUMN INDEXING
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .NE. K) THEN
                  A(L,J) = A(K,J)
                  A(K,J) = T
               ENDIF
               CALL SAXPY( N-K, T, A(K+1,K), 1, A(K+1,J), 1 )
   30       CONTINUE
C
         ENDIF
C
   60 CONTINUE
C
      IPVT(N) = N
      IF (A(N,N) .EQ. 0.0E0) INFO = N
      RETURN
      END
      SUBROUTINE  SGESL( A, LDA, N,IPVT, B, JOB )
C
C         SOLVES THE REAL SYSTEM
C            A * X = B  OR  TRANS(A) * X = B
C         USING THE FACTORS COMPUTED BY SGECO OR SGEFA.
C
C         REVISION DATE:  8/1/82
C         AUTHOR:  MOLER, C. B., (U. OF NEW MEXICO)
C
C     ON ENTRY
C
C        A       REAL(LDA, N)
C                THE OUTPUT FROM SGECO OR SGEFA.
C
C        LDA     INTEGER
C                THE LEADING DIMENSION OF THE ARRAY  A .
C
C        N       INTEGER
C                THE ORDER OF THE MATRIX  A .
C
C        IPVT    INTEGER(N)
C                THE PIVOT VECTOR FROM SGECO OR SGEFA.
C
C        B       REAL(N)
C                THE RIGHT HAND SIDE VECTOR.
C
C        JOB     INTEGER
C                = 0         TO SOLVE  A*X = B ,
C                = NONZERO   TO SOLVE  TRANS(A)*X = B  WHERE
C                            TRANS(A)  IS THE TRANSPOSE.
C
C     ON RETURN
C
C        B       THE SOLUTION VECTOR  X .
C
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY, THIS INDICATES SINGULARITY,
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        SETTING OF LDA .  IT WILL NOT OCCUR IF THE SUBROUTINES ARE
C        CALLED CORRECTLY AND IF SGECO HAS SET RCOND .GT. 0.0
C        OR SGEFA HAS SET INFO .EQ. 0 .
C
C     TO COMPUTE  INVERSE(A) * C  WHERE  C  IS A MATRIX
C     WITH  P  COLUMNS
C           CALL SGECO(A,LDA,N,IPVT,RCOND,Z)
C           IF (RCOND IS TOO SMALL) GO TO ...
C           DO 10 J = 1, P
C              CALL SGESL(A,LDA,N,IPVT,C(1,J),0)
C        10 CONTINUE
C
C
C     ROUTINES CALLED:  FROM BLAS:    SAXPY, SDOT
C
      INTEGER  LDA, N, IPVT(*), JOB
      REAL     A(LDA,*), B(*)
C
      REAL     SDOT,T
      INTEGER  K,KB,L,NM1
C
C
      NM1 = N - 1
      IF (JOB .EQ. 0) THEN
C                                 ** JOB = 0 , SOLVE  A * X = B
C                                     ** FIRST SOLVE  L*Y = B
         DO 20 K = 1, NM1
            L = IPVT(K)
            T = B(L)
            IF (L .NE. K) THEN
               B(L) = B(K)
               B(K) = T
            ENDIF
            CALL SAXPY( N-K, T, A(K+1,K), 1, B(K+1), 1 )
   20    CONTINUE
C                                    ** NOW SOLVE  U*X = Y
         DO 40 KB = 1, N
            K = N + 1 - KB
            B(K) = B(K) / A(K,K)
            T = -B(K)
            CALL SAXPY( K-1, T, A(1,K), 1, B(1), 1 )
   40    CONTINUE
C
      ELSE
C                         ** JOB = NONZERO, SOLVE  TRANS(A) * X = B
C                                    ** FIRST SOLVE  TRANS(U)*Y = B
         DO 60 K = 1, N
            T = SDOT( K-1, A(1,K), 1, B(1), 1 )
            B(K) = (B(K) - T) / A(K,K)
   60    CONTINUE
C                                    ** NOW SOLVE  TRANS(L)*X = Y
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + SDOT( N-K, A(K+1,K), 1, B(K+1), 1 )
            L = IPVT(K)
            IF (L .NE. K) THEN
               T = B(L)
               B(L) = B(K)
               B(K) = T
            ENDIF
   80    CONTINUE
C
      ENDIF
C
      RETURN
      END
      REAL FUNCTION  SASUM( N, SX, INCX )
C
C  --INPUT--  N  NUMBER OF ELEMENTS IN VECTOR TO BE SUMMED
C            SX  SING-PREC ARRAY, LENGTH 1+(N-1)*INCX, CONTAINING VECTOR
C          INCX  SPACING OF VECTOR ELEMENTS IN 'SX'
C
C --OUTPUT-- SASUM   SUM FROM 0 TO N-1 OF  ABS(SX(1+I*INCX))
C
      REAL SX(*)
C
C
      SASUM = 0.0
      IF( N.LE.0 )  RETURN
      IF( INCX.NE.1 ) THEN
C                                          ** NON-UNIT INCREMENTS
          DO 10 I = 1, 1+(N-1)*INCX, INCX
             SASUM = SASUM + ABS(SX(I))
   10     CONTINUE
      ELSE
C                                          ** UNIT INCREMENTS
         M = MOD(N,6)
         IF( M.NE.0 ) THEN
C                             ** CLEAN-UP LOOP SO REMAINING VECTOR
C                             ** LENGTH IS A MULTIPLE OF 6.
            DO 30  I = 1, M
              SASUM = SASUM + ABS(SX(I))
   30       CONTINUE
         ENDIF
C                              ** UNROLL LOOP FOR SPEED
         DO 50  I = M+1, N, 6
           SASUM = SASUM + ABS(SX(I))   + ABS(SX(I+1)) + ABS(SX(I+2))
     $                   + ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5))
   50    CONTINUE
      ENDIF
C
      RETURN
      END
      SUBROUTINE     SAXPY( N, SA, SX, INCX, SY, INCY )
C
C          Y = A*X + Y  (X, Y = VECTORS, A = SCALAR)
C
C  --INPUT--
C        N  NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
C       SA  SINGLE PRECISION SCALAR MULTIPLIER 'A'
C       SX  SING-PREC ARRAY CONTAINING VECTOR 'X'
C     INCX  SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
C       SY  SING-PREC ARRAY CONTAINING VECTOR 'Y'
C     INCY  SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
C
C --OUTPUT--
C       SY   FOR I = 0 TO N-1, OVERWRITE  SY(LY+I*INCY) WITH
C                 SA*SX(LX+I*INCX) + SY(LY+I*INCY),
C            WHERE LX = 1          IF INCX .GE. 0,
C                     = (-INCX)*N  IF INCX .LT. 0
C            AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
C
      REAL SX(*), SY(*), SA
C
C
      IF( N.LE.0 .OR. SA.EQ.0.0 ) RETURN
C
      IF ( INCX.EQ.INCY .AND. INCX.GT.1 )  THEN
C
          DO 10  I = 1, 1+(N-1)*INCX, INCX
             SY(I) = SY(I) + SA * SX(I)
   10     CONTINUE
C
      ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 )  THEN
C
C                                        ** EQUAL, UNIT INCREMENTS
         M = MOD(N,4)
         IF( M .NE. 0 ) THEN
C                            ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C                            ** IS A MULTIPLE OF 4.
            DO 20  I = 1, M
              SY(I) = SY(I) + SA * SX(I)
   20       CONTINUE
         ENDIF
C                              ** UNROLL LOOP FOR SPEED
         DO 30  I = M+1, N, 4
            SY(I)   = SY(I)   + SA * SX(I)
            SY(I+1) = SY(I+1) + SA * SX(I+1)
            SY(I+2) = SY(I+2) + SA * SX(I+2)
            SY(I+3) = SY(I+3) + SA * SX(I+3)
   30    CONTINUE
C
      ELSE
C               ** NONEQUAL OR NONPOSITIVE INCREMENTS.
         IX = 1
         IY = 1
         IF( INCX.LT.0 )  IX = 1 + (N-1)*(-INCX)
         IF( INCY.LT.0 )  IY = 1 + (N-1)*(-INCY)
         DO 40  I = 1, N
            SY(IY) = SY(IY) + SA*SX(IX)
            IX = IX + INCX
            IY = IY + INCY
   40    CONTINUE
C
      ENDIF
C
      RETURN
      END
      REAL FUNCTION  SDOT( N, SX, INCX, SY, INCY )
C
C          S.P. DOT PRODUCT OF VECTORS  'X'  AND  'Y'
C
C  --INPUT--
C        N  NUMBER OF ELEMENTS IN INPUT VECTORS 'X' AND 'Y'
C       SX  SING-PREC ARRAY CONTAINING VECTOR 'X'
C     INCX  SPACING OF ELEMENTS OF VECTOR 'X' IN 'SX'
C       SY  SING-PREC ARRAY CONTAINING VECTOR 'Y'
C     INCY  SPACING OF ELEMENTS OF VECTOR 'Y' IN 'SY'
C
C --OUTPUT--
C     SDOT   SUM FOR I = 0 TO N-1 OF  SX(LX+I*INCX) * SY(LY+I*INCY),
C            WHERE  LX = 1          IF INCX .GE. 0,
C                      = (-INCX)*N  IF INCX .LT. 0,
C            AND LY IS DEFINED IN A SIMILAR WAY USING INCY.
C
      REAL SX(*), SY(*)
C
C
      SDOT = 0.0
      IF( N.LE.0 )  RETURN
C
      IF ( INCX.EQ.INCY .AND. INCX.GT.1 )  THEN
C
          DO 10  I = 1, 1+(N-1)*INCX, INCX
             SDOT = SDOT + SX(I) * SY(I)
   10     CONTINUE
C
      ELSE IF ( INCX.EQ.INCY .AND. INCX.EQ.1 )  THEN
C
C                                        ** EQUAL, UNIT INCREMENTS
         M = MOD(N,5)
         IF( M .NE. 0 ) THEN
C                            ** CLEAN-UP LOOP SO REMAINING VECTOR LENGTH
C                            ** IS A MULTIPLE OF 4.
            DO 20  I = 1, M
               SDOT = SDOT + SX(I) * SY(I)
   20       CONTINUE
         ENDIF
C                              ** UNROLL LOOP FOR SPEED
         DO 30  I = M+1, N, 5
            SDOT = SDOT + SX(I)*SY(I)     + SX(I+1)*SY(I+1)
     $                  + SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3)
     $                  + SX(I+4)*SY(I+4)
   30    CONTINUE
C
      ELSE
C               ** NONEQUAL OR NONPOSITIVE INCREMENTS.
         IX = 1
         IY = 1
         IF( INCX.LT.0 )  IX = 1 + (N-1)*(-INCX)
         IF( INCY.LT.0 )  IY = 1 + (N-1)*(-INCY)
         DO 40  I = 1, N
            SDOT = SDOT + SX(IX) * SY(IY)
            IX = IX + INCX
            IY = IY + INCY
   40    CONTINUE
C
      ENDIF
C
      RETURN
      END
      LOGICAL FUNCTION  WRTBADQ ( quiet, VARNAM )
C
C          WRITE NAMES OF ERRONEOUS VARIABLES AND RETURN 'TRUE'
C
C      INPUT :   VARNAM = NAME OF ERRONEOUS VARIABLE TO BE WRITTEN
C                         ( CHARACTER, ANY LENGTH )
C ----------------------------------------------------------------------
      CHARACTER*(*)  VARNAM
      INTEGER        MAXMSG, NUMMSG
      LOGICAL quiet
      SAVE  NUMMSG, MAXMSG
      DATA  NUMMSG / 0 /,  MAXMSG / 50 /
C
C
      WRTBADQ = .TRUE.
      NUMMSG = NUMMSG + 1
      WRITE ( *, '(3A)' )  ' ****  INPUT VARIABLE  ', VARNAM,
     $     '  IN ERROR  ****'
      IF ( NUMMSG.EQ.MAXMSG  .AND. .NOT. quiet )
     $ CALL  ERRMSG( 'TOO MANY INPUT ERRORS.  ABORTING...$', .TRUE. )
      RETURN
      END
      LOGICAL FUNCTION  WRTDIMQ ( quiet, DIMNAM, MINVAL )
C
C          WRITE NAME OF TOO-SMALL SYMBOLIC DIMENSION AND
C          THE VALUE IT SHOULD BE INCREASED TO;  RETURN 'TRUE'
C
C      INPUT :  DIMNAM = NAME OF SYMBOLIC DIMENSION WHICH IS TOO SMALL
C                        ( CHARACTER, ANY LENGTH )
C               MINVAL = VALUE TO WHICH THAT DIMENSION SHOULD BE
C                        INCREASED (AT LEAST)
C ----------------------------------------------------------------------
      CHARACTER*(*)  DIMNAM
      INTEGER        MINVAL
      LOGICAL quiet
C
C
      WRITE ( *, '(3A,I7)' )  ' ****  SYMBOLIC DIMENSION  ',
     $     DIMNAM, '  SHOULD BE INCREASED TO AT LEAST ', MINVAL
      WRTDIMQ = .TRUE.
      RETURN
      END


! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test that PRIVATE/PUBLIC can be used on names that aren't defined until later

module m1
 real max,min
 public:: max
 private:: min
 public:: sin, setmin
contains
 subroutine setmin(i)
  real i
  min = i
!print *,'min=',min
 end subroutine
 real function sin(x)
  real x
  sin = min*max*x
!print *,'sin=',sin
 end function
end module

program p
 use m1
 real t, u, v
 real expect(3), result(3)
 data expect/5.0,90.0,5.0/
 max = 9.0
 call setmin(2.0)
 t = 5.0
 u = sin(t)
 v = min(t,u)
 result(1) = t
 result(2) = u
 result(3) = v
! print *,t,u,v
 call check(result,expect,3)
end program


PROGRAM test_output
INTEGER, PARAMETER :: minval = 0, maxval = 3
INTEGER, DIMENSION(minval:maxval,minval:maxval) :: my_data
my_data(0,:) = (/  1,  2,  3,  4 /)
my_data(1,:) = (/  5,  6,  7,  8 /)
my_data(2,:) = (/  9, 10, 11, 12 /)
my_data(3,:) = (/ 13, 14, 15, 16 /)

WRITE (*,100) my_data
100 FORMAT (/,(4(1X,I4)))
WRITE (*,110) my_data
110 FORMAT (/,(6(1X,I4)))
WRITE (*,120) ((my_data(I,J), J=minval,maxval), I=minval,maxval)
120 FORMAT (/,(6(1X,I4)))
WRITE (*,130) ((my_data(I,J), J=minval,maxval), I=minval,maxval)
130 FORMAT (/,(4(1X,I4)))
WRITE (*,140) (my_data(I,:), I=minval,maxval)
140 FORMAT (/,(4(1X,I4)))
WRITE (*,150) ' '
150 FORMAT (A)
DO I = minval, maxval
   WRITE (*,160) (my_data(I,J), J=minval,maxval)
   160 FORMAT (6(1X,I4))
END DO
END PROGRAM


      ! -------------------------------------------------------------
      !
      ! Copyright (C) 2022 The Simons Foundation
      !
      ! Author: Jason Kaye
      !
      ! -------------------------------------------------------------
      !
      ! libdlr is licensed under the Apache License, Version 2.0 (the
      ! "License"); you may not use this file except in compliance with
      ! the License.  You may obtain a copy of the License at
      !
      !     http://www.apache.org/licenses/LICENSE-2.0
      !
      ! Unless required by applicable law or agreed to in writing,
      ! software distributed under the License is distributed on an "AS
      ! IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either
      ! express or implied.  See the License for the specific language
      ! governing permissions and limitations under the License.
      !
      ! -------------------------------------------------------------

      program dyson_mat

      ! Solve 2x2 matrix-valued Dyson equation in imaginary time
      !
      ! To obtain an exact solution for testing, we begin with a 3x3
      ! Hamiltonian h and zero self-energy. The corresponding Green's
      ! function G_ij can be obtained by diagonalization. It can then be
      ! shown that the upper left 2x2 block of G_ij can also be obtained
      ! by solving the Dyson equation with single-particle Hamiltonian
      ! given by h(1:2,1:2), and self-energy given by
      ! h(1:2,3)*G0*h(3,1:2), where G0 is the free-particle Green's
      ! function with energy h(3,3). By comparing the Green's function
      ! obtained by this approach with the known exact solution, we can
      ! test a matrix-valued Dyson solver.

      implicit none
      integer ntst
      real *8 lambda,eps,beta,h(3,3)

      ! Input parameters

      lambda = 200.0d0  ! DLR high energy cutoff
      eps = 1.0d-14     ! DLR error tolerance

      beta = 20.0d0     ! Inverse temperature

      h(1,1) = -3.0d0   ! 3x3 Hamiltonian matrix
      h(2,2) = -1.0d0
      h(3,3) = 1.0d0
      h(2,1) = 0.3d0
      h(1,2) = 0.3d0
      h(3,1) = -0.2d0
      h(1,3) = -0.2d0
      h(3,2) = 0.1d0
      h(2,3) = 0.1d0

      ntst = 101        ! # output points

      ! Main test subroutine

      call dyson_mat_main(lambda,eps,ntst,beta,h)

      end program dyson_mat

      subroutine dyson_mat_main(lambda,eps,ntst,beta,h)

      ! Main driver routine for matrix-valued Dyson solver test

      implicit none
      integer ntst
      real *8 lambda,eps,beta,h(3,3)

      integer i,j,k,r
      integer, allocatable :: dlrmf(:),it2cfp(:)
      real *8 err
      real *8, allocatable :: it2cf(:,:),dlrit(:),dlrrf(:)
      real *8, allocatable :: phi(:,:),g0it(:,:,:),g0mat(:,:)
      real *8, allocatable :: g(:,:,:),gc(:,:,:),g02it(:),sig(:,:,:)
      real *8, allocatable :: gtrue(:,:,:),gctrue(:,:,:)
      real *8, allocatable :: it_tst(:),gtst(:,:,:),gtruetst(:,:,:)

      ! Get DLR frequencies, imaginary time grid

      r = 500 ! Upper bound on DLR rank

      allocate(dlrrf(r),dlrit(r))

      call dlr_it_build(lambda,eps,r,dlrrf,dlrit)

      ! Get imaginary time values -> DLR coefficients matrix (LU form)

      allocate(it2cf(r,r),it2cfp(r))

      call dlr_it2cf_init(r,dlrrf,dlrit,it2cf,it2cfp)

      ! Get convolution tensor

      allocate(phi(r*r,r))

      call dlr_convtens(beta,-1,r,dlrrf,dlrit,it2cf,it2cfp,phi)

      ! Get free particle Green's function for upper-left 2x2 block of
      ! Hamiltonian

      allocate(g0it(r,2,2))

      call getg0_it(beta,r,2,dlrit,h(1:2,1:2),0.0d0,g0it)

      ! Get matrix of convolution by free particle Green's function

      allocate(g0mat(2*r,2*r))

      call dlr_convmat(r,2,it2cf,it2cfp,phi,g0it,g0mat)

      ! Get self-energy from free particle Green's function for
      ! lower-right entry of Hamiltonian

      allocate(g02it(r),sig(r,2,2))

      call getg0_it(beta,r,1,dlrit,h(3,3),0.0d0,g02it)

      sig(:,1,1) = g02it*h(1,3)*h(3,1)
      sig(:,2,1) = g02it*h(2,3)*h(3,1)
      sig(:,1,2) = g02it*h(1,3)*h(3,2)
      sig(:,2,2) = g02it*h(2,3)*h(3,2)

      ! Solve Dyson equation

      allocate(g(r,2,2),gc(r,2,2))

      call dyson_it(r,2,it2cf,it2cfp,phi,g0it,g0mat,sig,g)

      ! Get DLR coefficients of solution

      call dlr_it2cf(r,2,it2cf,it2cfp,g,gc)

      ! Get exact 3x3 Green's function on imaginary time grid by
      ! diagonalization

      allocate(gtrue(r,3,3),gctrue(r,2,2))

      call getg0_it(beta,r,3,dlrit,h,0.0d0,gtrue)

      ! Get DLR coefficients of upper left 2x2 block of exact Green's
      ! function

      call dlr_it2cf(r,2,it2cf,it2cfp,gtrue(:,1:2,1:2),gctrue)

      ! Get test points in relative format

      allocate(it_tst(ntst))

      call eqpts_rel(ntst,it_tst)

      ! Evaluate solutions on test grid

      allocate(gtst(ntst,2,2),gtruetst(ntst,2,2))

      do k=1,ntst

        call dlr_it_eval(r,2,dlrrf,gc,it_tst(k),gtst(k,:,:))
        call dlr_it_eval(r,2,dlrrf,gctrue,it_tst(k),gtruetst(k,:,:))

      enddo

      err = maxval(abs(gtst-gtruetst))

      write(6,*) 'Max L^inf error = ',err

      ! Return failed status if error is not sufficiently small

      if (err.gt.1.0d-13) then
        call exit(1)
      endif

      end subroutine dyson_mat_main

      subroutine getg0_it(beta,r,n,dlrit,h,mu,g0)

      ! Obtain nxn single-particle Green's function with Hamiltonian h
      ! on DLR imaginary time grid

      implicit none
      integer r,n
      real *8 beta,dlrit(r),h(n,n),mu,g0(r,n,n)

      integer i,j,lwork,info
      real *8, allocatable :: eval(:),evec(:,:),d(:),e(:),tau(:),work(:)
      real *8, external :: kfunf_rel

      ! Get eigenvalues and eigenvectors of Hamiltonian matrix h

      lwork = n*n
      allocate(eval(n),evec(n,n),e(n-1),tau(n-1),work(lwork))

      evec = h

      call dsytrd('U',n,evec,n,eval,e,tau,work,lwork,info)
      call dorgtr('U',n,evec,n,tau,work,lwork,info)
      call dsteqr('V',n,eval,e,evec,n,work,info)

      ! Get free particle Green's function

      g0 = 0
      do i=1,r
        do j=1,n
          g0(i,j,j) = -kfunf_rel(dlrit(i),beta*(eval(j)-mu))
        enddo
          g0(i,:,:) = matmul(evec,matmul(g0(i,:,:),transpose(evec)))
      enddo

      end subroutine getg0_it


      subroutine compute_a2(n_A,n_psi,Nx,res)
      implicit none
      integer i
      integer Nx
      real*8 n_A(Nx)
      real*8 n_psi(Nx)
      real*8 res(Nx)
      real*8 qb
      do i=1, Nx, 1
      qb = n_psi(i) ** 4 * n_A(i)
      res(i)=qb
      end do
      END