C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/tranhs                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE TRANHS (HS, XFORM, A,B,C,D)

C  TRANHS accepts a 3D half-space, described as a point (on the
C  boundary plane) and normal vector, applies a transform, and
C  returns the coefficients of the new boundary plane, such that
C  x,y,z is in the new half-space iff A*x + B*y + C*z + D .GE. 0

C  Input parameters:
C    HS(1,2,3)  : x,y,z coordinates of point of half-space
C    HS(4,5,6)  : x,y,z coordinates of normal vector of half-space
C    XFORM      : transformation matrix
C  Output parameters:
C    A,B,C,D    : coefficients of new boundary plane.

      REAL    HS(6), XFORM(4,4), TMPX,TMPY,TMPZ, A,B,C,D
      REAL    VECAX,VECAY,VECAZ, VECBX,VECBY,VECBZ
      REAL    OLDX(4),OLDY(4),OLDZ(4), NEWX(4),NEWY(4),NEWZ(4)

C  VECA is a unit vector orthogonal to the normal vector
      CALL PRPV1 (HS(4),HS(5),HS(6), TMPX, TMPY, TMPZ)
      CALL VEC1  (TMPX, TMPY, TMPZ,  VECAX,VECAY,VECAZ)
C  VECB is a unit vector orthogonal to the normal vector and VECA
      CALL CROSSP (VECAX,VECAY,VECAZ, HS(4),HS(5),HS(6),
     1             TMPX, TMPY, TMPZ)
      CALL VEC1 (TMPX,TMPY,TMPZ, VECBX,VECBY,VECBZ)

C  OLD-1, OLD-2, and OLD-3 are all in the (old) boundary plane,
C  forming an L-shape.
      OLDX(1) = HS(1) + VECAX
      OLDY(1) = HS(2) + VECAY
      OLDZ(1) = HS(3) + VECAZ

      OLDX(2) = HS(1) + VECBX
      OLDY(2) = HS(2) + VECBY
      OLDZ(2) = HS(3) + VECBZ

      OLDX(3) = HS(1)
      OLDY(3) = HS(2)
      OLDZ(3) = HS(3)

C  OLD-4 is a point inside the (old) half-space
      OLDX(4) = HS(1) + HS(4)
      OLDY(4) = HS(2) + HS(5)
      OLDZ(4) = HS(3) + HS(6)

C  transform 4 old points to 4 new points
      CALL ARRTP3 (4, OLDX,OLDY,OLDZ, XFORM, NEWX,NEWY,NEWZ)

C  first 3 new points define new boundary plane
      CALL PT3PL (NEWX,NEWY,NEWZ, A,B,C,D)

C  check that parity is OK - if not, negate co-efficients
      IF (A*NEWX(4) + B*NEWY(4) + C*NEWZ(4) + D .LT. 0) THEN
         A = -A
         B = -B
         C = -C
         D = -D
      ENDIF

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/comtok                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE COMTOK (EXPCOM, EXPATH)

C  COMTOK accepts an expected composite transformation and found
C  path.  It performs an incremental spatial search of structure
C  #101, using the transformed value of (3,4,5) as the SRP, and
C  issues pass or fail depending on whether the actual found path
C  matches that expected.

C  Input parameters:
C    EXPCOM : expected composite transformation
C    EXPATH : expected found path

C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

      INTEGER    IPTHSZ
      PARAMETER (IPTHSZ = 100)

      INTEGER    IDUM(2), FPATH(2,IPTHSZ), ERRIND, FPTHSZ
      INTEGER    SPATH(2,1), IEXPTH(2,IPTHSZ), IEXLEN

      REAL       EXPCOM(4,4), SRPX,SRPY,SRPZ

      CHARACTER  EXPATH*(*)

      LOGICAL    IAREQL

      DATA  SPATH / 101,0 /

C  get expected point in WC
      CALL ETP3 (3.0,4.0,5.0, EXPCOM, SRPX,SRPY,SRPZ)

C  decode expected found path
      CALL SETVS (EXPATH, IEXPTH, IEXLEN)

      CALL PISS3 (SRPX,SRPY,SRPZ, 0.03, 1, SPATH, PNCLIP, 1,
     1            0,IDUM,IDUM,IDUM,IDUM, 0,IDUM,IDUM,IDUM,IDUM,
     2            IPTHSZ, ERRIND, FPTHSZ, FPATH)

      CALL IFPF (ERRIND .EQ. 0 .AND.
     1           IAREQL (2*FPTHSZ, FPATH, IEXLEN, IEXPTH))

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/chkmcv                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE CHKMCV (STPATH, EXPTHS)

C  CHKMCV checks that the correct sequence of found paths is returned
C  by ISS as a result of the starting path.  It issues pass or fail
C  depending on whether the actual found paths match those expected.
C  It always uses a search reference point of 0,0,0 and distance of 2.

C  Input parameters:
C    STPATH : starting path for ISS
C    EXPTHS : expected found paths

C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

      CHARACTER  STPATH*(*), EXPTHS*(*)

      CALL ISPTHS (0.,0.,0., 2., 1, PCLIP, STPATH, EXPTHS)

      END

C  *********************************************************
C  *                                                       *
C  *    INTEGER FUNCTION 06.01.02/modtrn                   *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      INTEGER FUNCTION MODTRN (DIM)

C  MODTRN performs a random transformation on six line segments using
C  various modelling facilities, and marks the expected endpoints
C  with circle-polymarkers.  It returns the identifier of the line
C  segment which is marked incorrectly.
C
C  Input parameter:
C     DIM: dimensionality of the transformations to be tested (2 or 3)

      COMMON /DIALOG/ DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT,
     2                DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS
      INTEGER         DOUTYP, DINTYP, DSTDNR, DSTRID, PSTRID, DTCLIM,
     1                SCRMOD, DTXCI, SPECWT
      REAL            DSIZE, EFRAC, DYXRAT, SYXRAT, MTRPDC, WCPDC, QVIS

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

C Marker type
      INTEGER    PPOINT,   PPLUS,   PAST,   POMARK,   PXMARK
      PARAMETER (PPOINT=1, PPLUS=2, PAST=3, POMARK=4, PXMARK=5)

      REAL       PI
      PARAMETER (PI = 3.14159265)

      INTEGER DIM, LISBOX(6), THIS, IX, RNDINT, NGBOX

      REAL XSIZ, YSIZ, XWINLO(6), YWINLO(6)
      REAL IDXF(4,4), XF(4,4), TMP4(4,4), BOXF(4,4), FIXF(4,4)
      REAL ROTXF(4,4), WC1X,WC1Y,WC1Z, WC2X,WC2Y,WC2Z, XF2(3,3)
      REAL XA(2),YA(2), PX(2),PY(2),PZ(2), NGXF(4,4)
      REAL XSCF, YSCF, ZSCF, XMID, YMID, ZMID, XSHF, YSHF, ZSHF

      DATA PX / 1.0, 2.0 /, PY / 1.0, 2.0 /, PZ / 1.0, 2.0 /

C  Set up structure 106 to label 6 windows
      CALL WIN6 (106, 1, XSIZ,YSIZ, XWINLO, YWINLO)
C  Open test structure
      CALL POPST (102)
C  Set polymarker type
      CALL PSMK   (POMARK)
C  Initialize identity matrix
      CALL IDMAT (4,IDXF)

      CALL RNPERM (6,LISBOX)
C  box to be drawn incorrectly
      NGBOX = RNDINT(1,6)

      CALL PSPLCI (2)
      CALL PSPMCI (3)

      DO 100, IX = 1,6
         THIS = LISBOX(IX)

         IF (DIM .EQ. 2) THEN
C  set up for 2D
            CALL RANARY (3, XF2)
            CALL EXP34 (XF2,XF)
         ELSEIF (DIM .EQ. 3) THEN
C  set up for 3D
            CALL RANARY (4, XF)
         ELSE
            CALL UNMSG ('MODTRN called with invalid dimension.')
         ENDIF

         IF ((THIS.EQ.1) .OR. (THIS.EQ.4)) THEN
C  Rotate 90 around x axis
            CALL EROX ( PI/2., ROTXF)
         ELSE IF ((THIS.EQ.2) .OR. (THIS.EQ.5)) THEN
C  Rotate 90 around y axis
            CALL EROY ( PI/2., ROTXF)
         ELSE
C  Rotate 90 around z axis
            CALL EROZ ( PI/2., ROTXF)
         ENDIF
C
C  Compose new transformation matrix
         CALL ECOM3 (ROTXF,XF,TMP4)
C
C  Calculate transformation by ROTXF x XF of (1,1,1) and (2,2,2)
         CALL ETP3 (PX(1),PY(1),PZ(1), TMP4, WC1X,WC1Y,WC1Z)
         CALL ETP3 (PX(2),PY(2),PZ(2), TMP4, WC2X,WC2Y,WC2Z)

         XSCF = 0.8 * XSIZ / ( WC2X - WC1X )
         YSCF = 0.8 * YSIZ / ( WC2Y - WC1Y )
         ZSCF = 0.8        / ( WC2Z - WC1Z )

         XMID = XSCF * ( WC1X + WC2X )/2
         YMID = YSCF * ( WC1Y + WC2Y )/2
         ZMID = ZSCF * ( WC1Z + WC2Z )/2

         XSHF = XWINLO(IX) + XSIZ/2 - XMID
         YSHF = YWINLO(IX) + YSIZ/2 - YMID
         ZSHF = 0.5                 - ZMID

         CALL EBLTM3 (0.,0.,0., XSHF,YSHF,ZSHF, 0.,0.,0.,
     1                XSCF,YSCF,ZSCF, BOXF)
C
C  Compose new transformation matrix = BOX x ROTXF x XF
         CALL ECOM3 (BOXF,ROTXF,FIXF)
         CALL ECOM3 (FIXF,XF,TMP4)
C
C  Calculate expected positions of (1,1,1) and (2,2,2)
         CALL ETP3 (PX(1),PY(1),PZ(1), TMP4, WC1X,WC1Y,WC1Z)
         CALL ETP3 (PX(2),PY(2),PZ(2), TMP4, WC2X,WC2Y,WC2Z)

         IF ( IX .EQ. NGBOX) THEN
C  distort result - rotate by 10 degrees
            CALL EBLTM3 (XWINLO(IX) + XSIZ/2, YWINLO(IX) + YSIZ/2 , 0.5,
     1                   0.,0.,0.,  0.,0.,(2*PI*10)/360,
     2                   1.0,1.0,1.0, NGXF)
            CALL ECOM3 (NGXF,FIXF,TMP4)
            CALL CPYIAR (16,TMP4,FIXF)
         ENDIF

         IF ( THIS .LT. 3 ) THEN
            CALL PSLMT3 (FIXF,PCREPL)
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCPRE)
            ELSE
               CALL PSLMT3 (XF,PCPRE)
            ENDIF
         ELSEIF ( THIS .LT. 5 ) THEN
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCREPL)
            ELSE
               CALL PSLMT3 (XF,PCREPL)
            ENDIF
            CALL PSLMT3 (FIXF,PCPOST)
         ELSE
            IF (DIM .EQ. 2 ) THEN
               CALL PSLMT (XF2,PCREPL)
            ELSE
               CALL PSLMT3 (XF,PCREPL)
            ENDIF
            CALL PSGMT3 (FIXF)
         ENDIF

C  Draw line segment as changed by transformation matrix
         CALL PPL3 (2,PX,PY,PZ)

C  Now expected endpoints with no transformations
         CALL PSLMT3 (IDXF,PCREPL)
         CALL PSGMT3 (IDXF)

         XA(1) = WC1X
         YA(1) = WC1Y
         XA(2) = WC2X
         YA(2) = WC2Y
         CALL PPM (2, XA,YA)
100   CONTINUE
      CALL PCLST
      MODTRN = NGBOX

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/ranary                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE RANARY (SIZE,ARRAY)

C  RANARY initializes a 2D array of size x size to random values
C  between 0.5 and 1.5

      INTEGER SIZE, I,J
      REAL    ARRAY(SIZE,SIZE), RNDRL

      DO 100 I = 1, SIZE
      DO 200 J = 1, SIZE
         ARRAY(I,J) = RNDRL(0.5,1.5)
200   CONTINUE
100   CONTINUE

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/clpgon                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE CLPGON (VISCT, NUMPL, RAD)

C  CLPGON draws a set of markers some of which are just inside the
C  clipping region shaped like a regular polygon, and the rest just
C  outside it.

C  Input parameters:
C    VISCT : number of markers to be drawn inside clipping region
C    NUMPL : total number of markers to be drawn = #sides of polygon
C    RAD   : radius of polygon (distance from center to face, not vertex)

      INTEGER    VISCT, NUMPL, VISLIS(50), IX, IARFND
C maximum number of planes to be tested
      INTEGER    TSTMAX
      PARAMETER (TSTMAX = 500)

      REAL       XLOC(TSTMAX), YLOC(TSTMAX), ZLOC(TSTMAX)
      REAL       RAD, THSRAD, RNDRL, ANG, PI
      PARAMETER (PI = 3.14159265)

C  Choose visct markers to be inside
      CALL RNSET (VISCT, NUMPL, VISLIS)

C  calculate coordinates of polymarker:
      DO 100 IX = 1,NUMPL
         IF ( IARFND (IX, VISCT, VISLIS) .GT. 0) THEN
C  Inside:
            THSRAD = 0.99 * RAD
         ELSE
C  Outside:
            THSRAD = 1.01 * RAD
         ENDIF
         ANG = IX*2*PI / NUMPL
         XLOC (IX) = 0.5 + THSRAD * COS(ANG)
         YLOC (IX) = 0.5 + THSRAD * SIN(ANG)
         ZLOC (IX) = RNDRL(0.,1.0)
  100 CONTINUE
      CALL PPM3 (NUMPL, XLOC,YLOC,ZLOC)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/clpmk5                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE CLPMK5 (DIM, MCVND, XF, INXF,OUTXF)

C  CLPMK5 generates a 5x5 grid of polymarkers, some of which should be
C  clipped (X style) and some of which should be visible (+ style) and then
C  passes or fails based on operator response.

C  Input parameters:
C    DIM   : dimensionality of test (2 or 3)
C    XF    : transformation to be applied to clipping plane
C    INXF  : transformation to apply to marker to put it inside MCV
C    OUTXF : transformation to apply to marker to put it outside MCV
C    MCVND : half-space for MCV, in 3D or 2D format

C clipping indicator
C                noclip      clip
      INTEGER    PNCLIP,     PCLIP
      PARAMETER (PNCLIP = 0, PCLIP = 1)

C modelling clipping operator
C                replace     intersect
      INTEGER    PMCREP,     PMCINT
      PARAMETER (PMCREP = 1, PMCINT = 2)

C marker type
      INTEGER    PPOINT,   PPLUS,   PAST,   POMARK,   PXMARK
      PARAMETER (PPOINT=1, PPLUS=2, PAST=3, POMARK=4, PXMARK=5)

C composition type
C                preconcatenate  postconcatenate  replace
      INTEGER    PCPRE,          PCPOST,          PCREPL
      PARAMETER (PCPRE = 0,      PCPOST = 1,      PCREPL = 2)

      INTEGER    IX, VISCT, RNDINT

      REAL       XF(4,4), INXF(4,4), OUTXF(4,4), PTXVEC(6)
      REAL       A,B,C,D, XX,YY, XA(3), YA(3), ZA(3), PI, MCVND(6,1)
      PARAMETER (PI = 3.14159265)

      LOGICAL    DYN, INMCV, NCLIPD

      CHARACTER  DIM*1

C  a,b,c,d = coefficients of transformed boundary plane
      DO 100 IX=1,6
         PTXVEC(IX) = MCVND(IX,1)
100   CONTINUE

      IF (DIM .EQ. '2') THEN
C  two-dimensionalize
         PTXVEC(6) = 0.0
         PTXVEC(5) = MCVND(4,1)
         PTXVEC(4) = MCVND(3,1)
         PTXVEC(3) = 0.0
      ELSEIF (DIM .EQ. '3') THEN
C        OK as is
      ELSE
         CALL UNMSG ('CLPMK5 called with DIM = ' // DIM // '.')
      ENDIF
      CALL TRANHS (PTXVEC, XF, A,B,C,D)

C  visct = number of polymarkers which should be visible
      VISCT = 0

      DO 10 XX = 0.1, 1.0, 0.2
      DO 20 YY = 0.1, 1.0, 0.2
         INMCV  = RNDINT(1,3) .EQ. 1
         NCLIPD = RNDINT(1,2) .EQ. 1
         XA(1) = XX
         YA(1) = YY
         ZA(1) = (-A*XX - B*YY - D) / C

         IF (INMCV) THEN
            CALL PSLMT3 (INXF,PCREPL)
         ELSE
            CALL PSLMT3 (OUTXF,PCREPL)
         ENDIF

         IF (NCLIPD) THEN
            CALL PSMCLI (PNCLIP)
         ELSE
            CALL PSMCLI (PCLIP)
         ENDIF

         IF (INMCV .OR. NCLIPD) THEN
C  should be visible
            CALL PSPMCI (2)
            CALL PSMK (PPLUS)
            VISCT = VISCT + 1
         ELSE
C  should be invisible
            CALL PSPMCI (3)
            CALL PSMK (PXMARK)
         ENDIF

         CALL PPM3 (1, XA,YA,ZA)
20    CONTINUE
10    CONTINUE

      IF (DYN (DIM // 'D GEOMETRY OF CLIPPING VOLUME: Is plus (+) ' //
     1         'the type of all visible markers?')) THEN
C        OK so far
      ELSE
         CALL FAIL
         GOTO 380
      ENDIF

      CALL DCHPFV (DIM // 'D GEOMETRY OF CLIPPING VOLUME: ' //
     1             'How many markers are visible?', 100, VISCT)

380   CONTINUE
      CALL PEMST (102)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/clpair                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE CLPAIR (XWINLO,YWINLO,XSIZE,YSIZE, IWX, DELTA, ZVAL)

C  CLPAIR draws a double polymarker in the middle of the requested
C  window, one just in front and one just behind a given z-value, so
C  that exactly one of the pair will be clipped.

C  Input parameters:
C    XWINLO,YWINLO : List of locations of lower-left window corners
C    XSIZE,YSIZE   : Window size
C    IWX           : Index into window list; which window to draw in
C    DELTA         : offset in X and Z dimension from nominal window center
C    ZVAL          : nominal Z location = z-value of expected clipping plane

      INTEGER  IWX
      REAL     XWINLO(*),YWINLO(*),XSIZE,YSIZE, DELTA, ZVAL
      REAL     XA(2), YA(2), ZA(2)

      XA(1) =  XWINLO(IWX) + XSIZE/2 - DELTA
      YA(1) =  YWINLO(IWX) + YSIZE/2
      ZA(1) =  ZVAL - DELTA

      XA(2) =  XWINLO(IWX) + XSIZE/2 + DELTA
      YA(2) =  YWINLO(IWX) + YSIZE/2
      ZA(2) =  ZVAL + DELTA

      CALL PPM3 (2, XA,YA,ZA)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/locnpm                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE LOCNPM (NPPM, YPOS, XLOC)

C  LOCNPM draws a polymarker with NPPM markers at the real y-location
C  corresponding to the integer index given in YPOS.

      INTEGER  IX,YPOS, NPPM

      REAL     YLOCEL, XLOC(*), YA(5), YVAL

      YVAL = YLOCEL(YPOS)
      DO 10 IX = 1,NPPM
         YA(IX) = YVAL
10    CONTINUE
      CALL PPM (NPPM, XLOC, YA)

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/faclip                         *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE FACLIP (ACL,BCL,CCL,DCL, XCO,YCO,ZCO, MCV3)

C  FACLIP accepts the co-efficients for two given clipping planes,
C  generates a plane for a fill area primitive and computes
C  another clipping plane, perpendicular to the primitive's
C  plane, but intersecting it the same way as does the given
C  clipping plane.

C  Input parameters:
C    ACL,BCL,CCL,DCL : co-efficients of given planes (CCL usually zero)
C  Output parameters:
C    XCO,YCO         : x,y co-efficients of primitive plane
C    MCV3            : computed planes, perpendicular to primitive plane

      INTEGER JX

      REAL    AF,BF,CF,DF, ACL(3),BCL(3),CCL(3),DCL(3), XCO,YCO,ZCO
      REAL    MCV3(6,2), RNDRL

C  randomize plane of fill area (in MC): xco*x + yco*y - z + zco = 0
      XCO = RNDRL(0.0, 0.4)
      YCO = RNDRL(0.0, 0.4)
      ZCO = 0.1

C  calculate 3D MCVs perpendicular to MC fill area plane, with negative
C  x-component.
      DO 330 JX = 1,2
         CALL PL2PL (XCO,YCO,-1.0,ZCO,
     1               ACL(JX),BCL(JX),CCL(JX),DCL(JX),
     2               AF,BF,CF,DF)
         IF (AF .EQ. 0) THEN
            CALL UNMSG ('Generated invalid clipping plane.')
         ELSEIF (AF .GT. 0) THEN
            AF = -AF
            BF = -BF
            CF = -CF
            DF = -DF
         ENDIF
         MCV3(1,JX) = -DF/AF
         MCV3(2,JX) = 0.0
         MCV3(3,JX) = 0.0
         MCV3(4,JX) = AF
         MCV3(5,JX) = BF
         MCV3(6,JX) = CF
330   CONTINUE

      END

C  *********************************************************
C  *                                                       *
C  *    SUBROUTINE 06.01.02/exedv                          *
C  *                                                       *
C  *    PHIGS Validation Tests, produced by NIST           *
C  *                                                       *
C  *********************************************************

      SUBROUTINE EXEDV (VXSTR, XEXP,YEXP)

C  EXEDV draws a polyline using the indicated elements of the
C  arrays of expected vertices.

C  Input parameters:
C    VXSTR     : Positions in array to use as vertices
C    XEXP,YEXP : Array of expected vertices from which values are taken

      INTEGER   VXSIZ,VX(20),IX

      REAL      XEXP(*),YEXP(*), XA(20),YA(20)

      CHARACTER VXSTR*(*)

      CALL SETVS (VXSTR, VX, VXSIZ)
      DO 100 IX = 1,VXSIZ
         XA(IX) = XEXP(VX(IX))
         YA(IX) = YEXP(VX(IX))
100   CONTINUE

      CALL PPL (VXSIZ, XA,YA)

      END


program bitpat
! shows how bit masks "Z" and octets "O" work in Fortran
! https://gcc.gnu.org/onlinedocs/gfortran/BOZ-literal-constants.html
use, intrinsic:: iso_fortran_env, only: int64, stderr=>error_unit
implicit none

! note that if you want other than default elements of array, you must use e.g. int( , int64) on each element
! or use a DATA statement, as per
! https://groups.google.com/forum/#!topic/comp.lang.fortran/AFtpnBh6eLg

integer :: I(5)
integer, parameter :: J(5) = [  2**29      ,  2**22    , 2**15   , 2**8 , 2**1 ]

integer(int64), parameter :: hexa = int(z'80000000',int64)

integer(int64),parameter :: K = int(O"201004020100",int64)
!2**34+2**27+2**20+2**13+2**6

! while it's allowed to put BOZ at end, standard is to put BOZ at front
integer,parameter :: K1 = int(O'50147')

! non-standard (2003 or 2008) but virtually all compilers accept
I = [O"4000000000",O"20000000",O"100000",O"400",O"2"]

print '(A,5I12)','exp',j

print '(A,5I12)','BOZ',i

if (any(i /= j)) then
  write(stderr,*) 'bit pattern mismatch'
  stop 1
endif

if (i(1) /= 536870912)  then
  write(stderr,*)  'bit pattern mismatch'
  stop 1
endif

if (j(1) /= 536870912)  then
  write(stderr,*) 'bit pattern mismatch'
  stop 1
endif

if (k1 /= 20583)  then
  write(stderr,*) 'bit pattern mismatch'
  stop 1
endif

if (k /= 17315143744_int64)  then
  write(stderr,*) 'bit pattern mismatch'
  stop 1
endif

print *,'--------------'
print *,hexa

end program


      SUBROUTINE DL7VML(N, X, L, Y)
C
C  ***  COMPUTE  X = L*Y, WHERE  L  IS AN  N X N  LOWER TRIANGULAR
C  ***  MATRIX STORED COMPACTLY BY ROWS.  X AND Y MAY OCCUPY THE SAME
C  ***  STORAGE.  ***
C
      INTEGER N
      DOUBLE PRECISION X(N), L(1), Y(N)
C     DIMENSION L(N*(N+1)/2)
      INTEGER I, II, IJ, I0, J, NP1
      DOUBLE PRECISION T, ZERO
      PARAMETER (ZERO=0.D+0)
C
      NP1 = N + 1
      I0 = N*(N+1)/2
      DO 20 II = 1, N
         I = NP1 - II
         I0 = I0 - I
         T = ZERO
         DO 10 J = 1, I
              IJ = I0 + J
              T = T + L(IJ)*Y(J)
 10           CONTINUE
         X(I) = T
 20      CONTINUE
 999  RETURN
C  ***  LAST LINE OF DL7VML FOLLOWS  ***
      END


!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE AIRGSD( TX,PX,RHOX )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Calculates component density of air with the ideal gas equation
!     of state.
!
!     Reid, R.C., J.M. Prausnitz, and B.E. Poling. 1987.
!     The Properties of Gases and Liquids.
!     McGraw-Hill, New York, New York
!
!----------------------Authors-----------------------------------------!
!
!     Written by MD White, Battelle, PNL, January, 1992.
!     Last Modified by MD White, Battelle, PNL, January 14, 1992.
!     $Id: airgsd.F 1080 2017-03-14 16:22:02Z d3c002 $
!

!----------------------Fortran 90 Modules------------------------------!
!
      USE GLB_PAR
      USE SOLTN
      USE CONST
!

!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!

!
!----------------------Common Blocks-----------------------------------!
!

!
!----------------------Executable Lines--------------------------------!
!
      ISUB_LOG = ISUB_LOG+1
      SUB_LOG(ISUB_LOG) = '/AIRGSD'
      IF( INDEX(SVN_ID(5)(1:1),'$').EQ.0 ) SVN_ID(5) =
     & '$Id: airgsd.F 1080 2017-03-14 16:22:02Z d3c002 $'
      RHOX = PX/(RCA*(TX+TABS))
      ISUB_LOG = ISUB_LOG-1
!
!---  End of AIRGSD group  ---
!
      RETURN
      END


*DECK CPEVL
      SUBROUTINE CPEVL (N, M, A, Z, C, B, KBD)
C***BEGIN PROLOGUE  CPEVL
C***SUBSIDIARY
C***PURPOSE  Subsidiary to CPZERO
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (CPEVL-S)
C***AUTHOR  (UNKNOWN)
C***DESCRIPTION
C
C        Evaluate a complex polynomial and its derivatives.
C        Optionally compute error bounds for these values.
C
C   INPUT...
C        N = Degree of the polynomial
C        M = Number of derivatives to be calculated,
C            M=0 evaluates only the function
C            M=1 evaluates the function and first derivative, etc.
C             if M .GT. N+1 function and all N derivatives will be
C                calculated.
C       A = Complex vector containing the N+1 coefficients of polynomial
C               A(I)= coefficient of Z**(N+1-I)
C        Z = Complex point at which the evaluation is to take place.
C        C = Array of 2(M+1) words into which values are placed.
C        B = Array of 2(M+1) words only needed if bounds are to be
C              calculated.  It is not used otherwise.
C        KBD = A logical variable, e.g. .TRUE. or .FALSE. which is
C              to be set .TRUE. if bounds are to be computed.
C
C  OUTPUT...
C        C =  C(I+1) contains the complex value of the I-th
C              derivative at Z, I=0,...,M
C        B =  B(I) contains the bounds on the real and imaginary parts
C              of C(I) if they were requested.
C
C***SEE ALSO  CPZERO
C***ROUTINES CALLED  I1MACH
C***REVISION HISTORY  (YYMMDD)
C   810223  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  CPEVL
C
      COMPLEX A(*),C(*),Z,CI,CIM1,B(*),BI,BIM1,T,ZA,Q
      LOGICAL KBD
      SAVE D1
      DATA D1 /0.0/
      ZA(Q)=CMPLX(ABS(REAL(Q)),ABS(AIMAG(Q)))
C***FIRST EXECUTABLE STATEMENT  CPEVL
      IF (D1 .EQ. 0.0) D1 = REAL(I1MACH(10))**(1-I1MACH(11))
      NP1=N+1
      DO 1 J=1,NP1
         CI=0.0
         CIM1=A(J)
         BI=0.0
         BIM1=0.0
         MINI=MIN(M+1,N+2-J)
            DO 1 I=1,MINI
               IF(J .NE. 1) CI=C(I)
               IF(I .NE. 1) CIM1=C(I-1)
               C(I)=CIM1+Z*CI
               IF(.NOT. KBD) GO TO 1
               IF(J .NE. 1) BI=B(I)
               IF(I .NE. 1) BIM1=B(I-1)
               T=BI+(3.*D1+4.*D1*D1)*ZA(CI)
               R=REAL(ZA(Z)*CMPLX(REAL(T),-AIMAG(T)))
               S=AIMAG(ZA(Z)*T)
               B(I)=(1.+8.*D1)*(BIM1+D1*ZA(CIM1)+CMPLX(R,S))
               IF(J .EQ. 1) B(I)=0.0
    1 CONTINUE
      RETURN
      END


!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
module parameters_module
!
!
!     -----Description: sets of the run parameters for the r3 body runs
!
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------

    real (kind=8), parameter :: mass_gm = 1.98892d44 ! gm
    real (kind=8), parameter :: mass_solar = 1.98892d33 ! gm
    real (kind=8), parameter :: distance = 4.6285203749999994d22 ! cm
    real (kind=8), parameter :: time_s = 2.733342473337471d15 ! s
    real (kind=8), parameter :: vel_unit = distance / time_s  ! cm/s
    real (kind=8), parameter :: pc = 3.08568025d18 !cm
    real (kind=8), parameter :: kpc = pc * 1000.0d0
    real (kind=8), parameter :: year = 365.25d0 * 24.0d0*3600.0d0
    real (kind=8), parameter :: km = 1d5 ! cm
    real (kind=8), parameter :: vel_km_sec = vel_unit / km
    real (kind=8), parameter :: a_mss = distance / (time_s * time_s) / 100.0d0
    real (kind=8), parameter :: a0_mks = 1.2d-10
    real (kind=8), parameter :: a0 = a0_mks / a_mss
    real (kind=8), parameter :: pi = 3.141592653589793d0

    real (kind=8), parameter :: hbase = 0.001d0
    integer(kind=4) :: potential_type = 0

    integer, parameter :: ndim = 3
    real (kind=8) :: mass1
    real (kind=8) :: epsilon1
    real (kind=8) :: rin1
    real (kind=8) :: rout1
    real (kind=8), dimension(3):: rscale1
    real (kind=8) :: theta1
    real (kind=8) :: phi1
    integer (kind=4) :: opt1
    real (kind=8) :: heat1

    real (kind=8) :: mass2
    real (kind=8) :: epsilon2
    real (kind=8):: rin2
    real (kind=8) :: rout2
    real (kind=8), dimension(3):: rscale2
    real (kind=8) :: theta2
    real (kind=8) :: phi2
    integer (kind=4) :: opt2
    real (kind=8) :: heat2
    real (kind=8) :: tcurrent

    real (kind=8), dimension(:,:), allocatable :: x0, xout
    integer (kind=4) :: n, n1, n2

    real (kind=8) :: time,tstart,tend
    real (kind=8) :: inclination_degree
    real (kind=8) :: omega_degree
    real (kind=8) :: rmin
    real (kind=8) :: velocity_factor
    real (kind=8) :: mratio
    real (kind=8) :: secondary_size
    real (kind=8), dimension(6):: sec_vec
    logical :: use_sec_vec, tIsSet

    real (kind=8) :: h
    integer (kind=4) :: nstep
    integer (kind=4) :: nout

    integer (kind=4) :: iout
    integer (kind=4) :: unit
    integer (kind=4) :: istep

!
!     ----------------------------------------------------------------
!
CONTAINS
!
!     ----------------------------------------------------------------
!

!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
  subroutine standard_galaxy1(mass1, epsilon1, rin1, rout1, rscale1, theta1, &
    phi1, opt1, heat1)
!
!
!     -----Description: initializes the test parameters for the standard run
!
!
!          on input:
!
!          on output:
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------
!
  real (kind=8) :: mass1
  real (kind=8) :: epsilon1
  real (kind=8) :: rin1
  real (kind=8) :: rout1
  real (kind=8), dimension(3):: rscale1
  real (kind=8) :: theta1
  real (kind=8) :: phi1
  integer (kind=4) :: opt1
  real (kind=8) :: heat1

!
!     ----------------------------------------------------------------
!

  ! disk profile #1
  mass1 = 1.0d0
  epsilon1  = 0.3d0
  rin1 = 0.05d0
  rout1 = 1.0d0
  rscale1 = 3.0d0
  theta1 = 0.0d0
  phi1 = 0.0d0
  opt1 = 1

  heat1 = 0.0d0
!  seed1 = 0.0d0

end subroutine standard_galaxy1

!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
  subroutine standard_galaxy2(mass2, epsilon2, rin2, rout2, rscale2, theta2, &
    phi2, opt2, heat2)
!
!
!     -----Description:
!
!
!          on input:
!
!          on output:
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------
!
  real (kind=8) :: mass2
  real (kind=8) :: epsilon2
  real (kind=8):: rin2
  real (kind=8) :: rout2
  real (kind=8), dimension(3):: rscale2
  real (kind=8) :: theta2
  real (kind=8) :: phi2
  integer (kind=4) :: opt2
  real (kind=8) :: heat2

!
!     ----------------------------------------------------------------
!
  ! disk profile #2
  mass2 = 1.0d0
  epsilon2  = 0.3d0
  rin2 = 0.05d0
  rout2 = 1.0d0
  rscale2 = 3.0d0
  theta2 = 0.0d0
  phi2 = 0.0d0
  opt2 = 1

  heat2 = 0.0d0
!  seed2 = 0.0d0

  return

  end subroutine standard_galaxy2

!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
  subroutine test_collision(n, n1, n2, time, inclination_degree, omega_degree, &
    rmin, velocity_factor, h, nstep, nout)
!
!
!     -----Description:
!
!
!          on input:
!
!          on output:
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------
!
  integer (kind=4) :: n, n1, n2
  real (kind=8) :: time
  real (kind=8) :: inclination_degree
  real (kind=8) :: omega_degree
  real (kind=8) :: rmin
  real (kind=8) :: velocity_factor

  real (kind=8) :: h
  integer (kind=4) :: nstep
  integer (kind=4) :: nout

!  real (kind=8) :: lnl
!
!     ----------------------------------------------------------------
!

  ! collision parameters
  inclination_degree = 90.0d0
  omega_degree = 0.0d0
  rmin = 1.0d0
  velocity_factor = 1.0d0
  time = -3.0

  ! time step parameters
  h = hbase
  nout = 5
  nstep = 500

  ! particle numbers for the total and each disk
  n1 = 1000
  n2 = 1000
  n = n1 + n2

  return

end subroutine test_collision

!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
  subroutine unrotate_frame(x_in, y_in, z_in, stheta, ctheta, sphi, cphi, xn, yn, zn)
!
!
!     -----Description: rotates the frame using input angles
!          phi and theta
!
!
!          on input:
!
!          on output:
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------
!
    real (kind=8), intent(in) :: x_in, y_in, z_in
    real (kind=8), intent(in) :: stheta, ctheta, sphi, cphi
    real (kind=8), intent(out) :: xn, yn, zn

    real (kind=8) :: x1, y1, z1
    real (kind=8) :: x2, y2, z2
!
!     ----------------------------------------------------------------
!

    x1 = x_in
    y1 = y_in
    z1 = z_in

    x2  =   x1 * ctheta +  z1 * stheta
    y2  =   y1
    z2  =  -x1 * stheta +  z1 * ctheta

    xn  =   x2  * cphi -  y2 * sphi
    yn  =   x2  * sphi +  y2 * cphi
    zn  =   z2

    return

  end subroutine unrotate_frame

!
!     ----------------------------------------------------------------
!     ----------------------------------------------------------------
!
  subroutine rotate_frame(x_in, y_in, z_in, stheta, ctheta, sphi, cphi, xn, yn, zn)
!
!
!     -----Description: rotates the frame using input angles
!          phi and theta
!
!
!          on input:
!
!          on output:
!
!
!     ----------------------------------------------------------------
!
    implicit none
!
!     -----Variable declarations
!          ---------------------
!
    real (kind=8), intent(in) :: x_in, y_in, z_in
    real (kind=8), intent(in) :: stheta, ctheta, sphi, cphi
    real (kind=8), intent(out) :: xn, yn, zn

    real (kind=8) :: x1, y1, z1
    real (kind=8) :: x2, y2, z2
!
!     ----------------------------------------------------------------
!
    x1 = x_in
    y1 = y_in
    z1 = z_in

    x2  =   x1  * cphi+  y1 * sphi
    y2  =  -x1  * sphi+  y1 * cphi
    z2  =   z1

    xn  =   x2 * ctheta -  z2 * stheta
    yn  =   y2
    zn  =   x2 * stheta +  z2 * ctheta

    return

  end subroutine rotate_frame

end module parameters_module


	SUBROUTINE mrqmin_sp(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda)
	use mo_kind
        use mo_nrutil, ONLY : assert_eq,diagmult
	use mo_nr, ONLY : covsrt,gaussj
	IMPLICIT NONE
	REAL(SP), DIMENSION(:), INTENT(IN) :: x,y,sig
	REAL(SP), DIMENSION(:), INTENT(INOUT) :: a
	REAL(SP), DIMENSION(:,:), INTENT(OUT) :: covar,alpha
	REAL(SP), INTENT(OUT) :: chisq
	REAL(SP), INTENT(INOUT) :: alamda
	LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
	INTERFACE
		SUBROUTINE funcs(x,a,yfit,dyda)
		use mo_kind
		REAL(SP), DIMENSION(:), INTENT(IN) :: x,a
		REAL(SP), DIMENSION(:), INTENT(OUT) :: yfit
		REAL(SP), DIMENSION(:,:), INTENT(OUT) :: dyda
		END SUBROUTINE funcs
	END INTERFACE
	INTEGER(I4) :: ma,ndata
	INTEGER(I4), SAVE :: mfit
	call mrqmin_private
	CONTAINS
!BL
	SUBROUTINE mrqmin_private
	REAL(SP), SAVE :: ochisq
	REAL(SP), DIMENSION(:), ALLOCATABLE, SAVE :: atry,beta
	REAL(SP), DIMENSION(:,:), ALLOCATABLE, SAVE :: da
	ndata=assert_eq(size(x),size(y),size(sig),'mrqmin: ndata')
	ma=assert_eq((/size(a),size(maska),size(covar,1),size(covar,2),&
		size(alpha,1),size(alpha,2)/),'mrqmin: ma')
	mfit=count(maska)
	if (alamda < 0.0) then
		allocate(atry(ma),beta(ma),da(ma,1))
		alamda=0.001_sp
		call mrqcof(a,alpha,beta)
		ochisq=chisq
		atry=a
	end if
	covar(1:mfit,1:mfit)=alpha(1:mfit,1:mfit)
	call diagmult(covar(1:mfit,1:mfit),1.0_sp+alamda)
	da(1:mfit,1)=beta(1:mfit)
	call gaussj(covar(1:mfit,1:mfit),da(1:mfit,1:1))
	if (alamda == 0.0) then
		call covsrt(covar,maska)
		deallocate(atry,beta,da)
		RETURN
	end if
	atry=a+unpack(da(1:mfit,1),maska,0.0_sp)
	call mrqcof(atry,covar,da(1:mfit,1))
	if (chisq < ochisq) then
		alamda=0.1_sp*alamda
		ochisq=chisq
		alpha(1:mfit,1:mfit)=covar(1:mfit,1:mfit)
		beta(1:mfit)=da(1:mfit,1)
		a=atry
	else
		alamda=10.0_sp*alamda
		chisq=ochisq
	end if
	END SUBROUTINE mrqmin_private
!BL
	SUBROUTINE mrqcof(a,alpha,beta)
	REAL(SP), DIMENSION(:), INTENT(IN) :: a
	REAL(SP), DIMENSION(:), INTENT(OUT) :: beta
	REAL(SP), DIMENSION(:,:), INTENT(OUT) :: alpha
	INTEGER(I4) :: j,k,l,m
	REAL(SP), DIMENSION(size(x),size(a)) :: dyda
	REAL(SP), DIMENSION(size(x)) :: dy,sig2i,wt,ymod
	call funcs(x,a,ymod,dyda)
	sig2i=1.0_sp/(sig**2)
	dy=y-ymod
	j=0
	do l=1,ma
		if (maska(l)) then
			j=j+1
			wt=dyda(:,l)*sig2i
			k=0
			do m=1,l
				if (maska(m)) then
					k=k+1
					alpha(j,k)=dot_product(wt,dyda(:,m))
					alpha(k,j)=alpha(j,k)
				end if
			end do
			beta(j)=dot_product(dy,wt)
		end if
	end do
	chisq=dot_product(dy**2,sig2i)
	END SUBROUTINE mrqcof
	END SUBROUTINE mrqmin_sp

	SUBROUTINE mrqmin_dp(x,y,sig,a,maska,covar,alpha,chisq,funcs,alamda)
	use mo_kind
        use mo_nrutil, ONLY : assert_eq,diagmult
	use mo_nr, ONLY : covsrt,gaussj
	IMPLICIT NONE
	REAL(dp), DIMENSION(:), INTENT(IN) :: x,y,sig
	REAL(dp), DIMENSION(:), INTENT(INOUT) :: a
	REAL(dp), DIMENSION(:,:), INTENT(OUT) :: covar,alpha
	REAL(dp), INTENT(OUT) :: chisq
	REAL(dp), INTENT(INOUT) :: alamda
	LOGICAL(LGT), DIMENSION(:), INTENT(IN) :: maska
	INTERFACE
		SUBROUTINE funcs(x,a,yfit,dyda)
		use mo_kind
		REAL(dp), DIMENSION(:), INTENT(IN) :: x,a
		REAL(dp), DIMENSION(:), INTENT(OUT) :: yfit
		REAL(dp), DIMENSION(:,:), INTENT(OUT) :: dyda
		END SUBROUTINE funcs
	END INTERFACE
	INTEGER(I4) :: ma,ndata
	INTEGER(I4), SAVE :: mfit
	call mrqmin_private
	CONTAINS
!BL
	SUBROUTINE mrqmin_private
	REAL(dp), SAVE :: ochisq
	REAL(dp), DIMENSION(:), ALLOCATABLE, SAVE :: atry,beta
	REAL(dp), DIMENSION(:,:), ALLOCATABLE, SAVE :: da
	ndata=assert_eq(size(x),size(y),size(sig),'mrqmin: ndata')
	ma=assert_eq((/size(a),size(maska),size(covar,1),size(covar,2),&
		size(alpha,1),size(alpha,2)/),'mrqmin: ma')
	mfit=count(maska)
	if (alamda < 0.0) then
		allocate(atry(ma),beta(ma),da(ma,1))
		alamda=0.001_dp
		call mrqcof(a,alpha,beta)
		ochisq=chisq
		atry=a
	end if
	covar(1:mfit,1:mfit)=alpha(1:mfit,1:mfit)
	call diagmult(covar(1:mfit,1:mfit),1.0_dp+alamda)
	da(1:mfit,1)=beta(1:mfit)
	call gaussj(covar(1:mfit,1:mfit),da(1:mfit,1:1))
	if (alamda == 0.0) then
		call covsrt(covar,maska)
		deallocate(atry,beta,da)
		RETURN
	end if
	atry=a+unpack(da(1:mfit,1),maska,0.0_dp)
	call mrqcof(atry,covar,da(1:mfit,1))
	if (chisq < ochisq) then
		alamda=0.1_dp*alamda
		ochisq=chisq
		alpha(1:mfit,1:mfit)=covar(1:mfit,1:mfit)
		beta(1:mfit)=da(1:mfit,1)
		a=atry
	else
		alamda=10.0_dp*alamda
		chisq=ochisq
	end if
	END SUBROUTINE mrqmin_private
!BL
	SUBROUTINE mrqcof(a,alpha,beta)
	REAL(dp), DIMENSION(:), INTENT(IN) :: a
	REAL(dp), DIMENSION(:), INTENT(OUT) :: beta
	REAL(dp), DIMENSION(:,:), INTENT(OUT) :: alpha
	INTEGER(I4) :: j,k,l,m
	REAL(dp), DIMENSION(size(x),size(a)) :: dyda
	REAL(dp), DIMENSION(size(x)) :: dy,sig2i,wt,ymod
	call funcs(x,a,ymod,dyda)
	sig2i=1.0_dp/(sig**2)
	dy=y-ymod
	j=0
	do l=1,ma
		if (maska(l)) then
			j=j+1
			wt=dyda(:,l)*sig2i
			k=0
			do m=1,l
				if (maska(m)) then
					k=k+1
					alpha(j,k)=dot_product(wt,dyda(:,m))
					alpha(k,j)=alpha(j,k)
				end if
			end do
			beta(j)=dot_product(dy,wt)
		end if
	end do
	chisq=dot_product(dy**2,sig2i)
	END SUBROUTINE mrqcof
	END SUBROUTINE mrqmin_dp


module looptests

  use ISO_C_BINDING

  implicit none

  contains

    subroutine gemm_mnk(C, A, B, M, K, N) BIND(C, name="gemm_mnk")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(mm = 1:M, nn = 1:N, kk = 1:K)
          C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_mnk
    subroutine gemm_mkn(C, A, B, M, K, N) BIND(C, name="gemm_mkn")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(mm = 1:M, kk = 1:K, nn = 1:N)
          C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_mkn
    subroutine gemm_nmk(C, A, B, M, K, N) BIND(C, name="gemm_nmk")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(nn = 1:N, mm = 1:M, kk = 1:K)
          C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_nmk
    subroutine gemm_nkm(C, A, B, M, K, N) BIND(C, name="gemm_nkm")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K, nn = 1:N, mm = 1:M)
          C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_nkm
    subroutine gemm_kmn(C, A, B, M, K, N) BIND(C, name="gemm_kmn")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K, mm = 1:M, nn = 1:N)
          C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_kmn
    subroutine gemm_knm(C, A, B, M, K, N) BIND(C, name="gemm_knm")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(kk = 1:K, nn = 1:N, mm = 1:M)
         C(mm,nn) = C(mm,nn) + A(mm,kk) * B(kk,nn)
      end do
    end subroutine gemm_knm
    subroutine gemmbuiltin(C, A, B, M, K, N) BIND(C, name="gemmbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      C = matmul(A, B)
    end subroutine gemmbuiltin
    subroutine AtmulB(C, A, B, M, K, N) BIND(C, name="AtmulB")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0
      do concurrent(nn = 1:N, mm = 1:M, kk = 1:K)
          C(mm,nn) = C(mm,nn) + A(kk,mm) * B(kk,nn)
      end do
    end subroutine AtmulB
    subroutine AtmulBbuiltin(C, A, B, M, K, N) BIND(C, name="AtmulBbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(K, N), intent(in) :: B
      C = matmul(transpose(A), B)
    end subroutine AtmulBbuiltin
    subroutine AmulBt(C, A, B, M, K, N) BIND(C, name="AmulBt")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(N, K), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0d0
      do concurrent(kk = 1:K, nn = 1:N, mm = 1:M)
         C(mm,nn) = C(mm,nn) + A(mm,kk) * B(nn,kk)
      end do
    end subroutine AmulBt
    subroutine AmulBtbuiltin(C, A, B, M, K, N) BIND(C, name="AmulBtbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(M, K), intent(in) :: A
      real(C_double), dimension(N, K), intent(in) :: B
      C = matmul(A, transpose(B))
    end subroutine AmulBtbuiltin
    subroutine AtmulBt(C, A, B, M, K, N) BIND(C, name="AtmulBt")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(N, K), intent(in) :: B
      integer(C_long) :: mm, kk, nn
      C = 0.0d0
      do concurrent(nn = 1:N, kk = 1:K, mm = 1:M)
         C(mm,nn) = C(mm,nn) + A(kk,mm) * B(nn,kk)
      end do
    end subroutine AtmulBt
    subroutine AtmulBtbuiltin(C, A, B, M, K, N) BIND(C, name="AtmulBtbuiltin")
      integer(C_long), intent(in) :: M, K, N
      real(C_double), dimension(M, N), intent(out) :: C
      real(C_double), dimension(K, M), intent(in) :: A
      real(C_double), dimension(N, K), intent(in) :: B
      C = transpose(matmul(B, A))
    end subroutine AtmulBtbuiltin
    real(C_double) function dot(a, b, N) BIND(C, name="dot")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a, b
      integer(C_long) :: i
      dot = 0d0
      do concurrent(i = 1:N)
         dot = dot + a(i) * b(i)
      end do
    end function dot
    real(C_double) function selfdot(a, N) BIND(C, name="selfdot")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      integer(C_long) :: i
      selfdot = 0d0
      do concurrent(i = 1:N)
         selfdot = selfdot + a(i) * a(i)
      end do
    end function selfdot
    real(C_double) function dot3v2(x, A, y, M, N) BIND(C, name="dot3v2")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: x(M), A(M,N), y(N)
      real(C_double) :: t
      integer(C_long) :: mm, nn
      dot3v2 = 0.0d0
      do concurrent(nn = 1:N, mm = 1:M)
         dot3v2 = dot3v2 + x(mm) * A(mm, nn) * y(nn)
      end do
    end function dot3v2
    real(C_double) function dot3(x, A, y, M, N) BIND(C, name="dot3")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: x(M), A(M,N), y(N)
      real(C_double) :: t
      integer(C_long) :: mm, nn
      dot3 = 0.0d0
      do concurrent(nn = 1:N)
         t = 0.0d0
         do concurrent(mm = 1:M)
            t = t + x(mm) * A(mm, nn)
         end do
         dot3 = dot3 + t * y(nn)
      end do
    end function dot3
    real(C_double) function dot3builtin(x, A, y, M, N) BIND(C, name="dot3builtin")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: x(M), A(M,N), y(N)
      dot3builtin = dot_product(x, matmul(A, y))
    end function dot3builtin
    !GCC$ builtin (exp) attributes simd (notinbranch) if('x86_64')
    subroutine vexp(b, a, N) BIND(C, name="vexp")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      real(C_double), dimension(N), intent(out) :: b
      integer(C_long) :: i
      do concurrent(i = 1:N)
         b(i) = exp(a(i))
      end do
    end subroutine vexp
    real(C_double) function svexp(a, N) BIND(C, name="svexp")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N), intent(in) :: a
      integer(C_long) :: i
      svexp = 0
      do concurrent(i = 1:N)
         svexp = svexp + exp(a(i))
      end do
    end function svexp
    subroutine gemv(y, A, x, M, K) BIND(C, name="gemv")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(M,K), x(K)
      real(C_double), dimension(M), intent(out) :: y
      integer(C_long) :: mm, kk
      y = 0.0
      do concurrent(kk = 1:K, mm = 1:M)
         y(mm) = y(mm) + A(mm,kk) * x(kk)
      end do
    end subroutine gemv
    subroutine gemvbuiltin(y, A, x, M, K) BIND(C, name="gemvbuiltin")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(M,K), x(K)
      real(C_double), dimension(M), intent(out) :: y
      y = matmul(A, x)
    end subroutine gemvbuiltin
    subroutine Atmulvb(y, A, x, M, K) BIND(C, name="Atmulvb")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(K,M), x(K)
      real(C_double), dimension(M), intent(out) :: y
      integer(C_long) :: mm, kk
      real(C_double) :: ymm
      y = 0
      do concurrent(mm = 1:M, kk = 1:K)
          y(mm) = y(mm) + A(kk,mm) * x(kk)
      end do
    end subroutine Atmulvb
    subroutine Atmulvbbuiltin(y, A, x, M, K) BIND(C, name="Atmulvbbuiltin")
      integer(C_long), intent(in) :: M, K
      real(C_double), intent(in) :: A(K,M), x(1,K)
      real(C_double), dimension(1,M), intent(out) :: y
      ! y = matmul(transpose(A), x)
      y = matmul(x, A)
    end subroutine Atmulvbbuiltin
    subroutine unscaledvar(s, A, x, M, N) BIND(C, name="unscaledvar")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: A(M,N), x(M)
      real(C_double), dimension(M), intent(out) :: s
      integer(C_long) :: mm, nn
      real(C_double) :: d
      s = 0.0
      do concurrent(nn = 1:N, mm = 1:M)
         d = A(mm,nn) - x(mm)
         s(mm) = s(mm) + d * d
      end do
    end subroutine unscaledvar
    subroutine aplusBc(D, a, B, c, M, N) BIND(C, name="aplusBc")
      integer(C_long), intent(in) :: M, N
      real(C_double), intent(in) :: a(M), B(M,N), c(N)
      real(C_double), dimension(M,N), intent(out) :: D
      integer(C_long) :: mm, nn
      do concurrent(nn = 1:N, mm = 1:M)
         D(mm,nn) = a(mm) + B(mm,nn) * c(nn)
      end do
    end subroutine aplusBc
    real(C_double) function OLSlp(y, X, b, N, P) BIND(C, name="OLSlp")
      integer(C_long), intent(in) :: N, P
      real(C_double), intent(in) :: y(N), X(N, P), b(P)
      integer(C_long) :: nn, pp
      real(C_double) :: d
      OLSlp = 0
      do concurrent(nn = 1:N)
         d = y(nn)
         do concurrent(pp = 1:P)
            d = d - X(nn,pp) * b(pp)
         end do
         OLSlp = OLSlp + d*d
      end do
    end function OLSlp
    real(C_double) function OLSlpsplit(y, X, b, N, P) BIND(C, name="OLSlpsplit")
      integer(C_long), intent(in) :: N, P
      real(C_double), intent(in) :: y(N), X(N, P), b(P)
      integer(C_long) :: nn, pp
      real(C_double) :: d(N)
      d = y - matmul(X, b)
      OLSlpsplit = dot_product(d, d)
    end function OLSlpsplit
    subroutine AplusAt(B, A, N) BIND(C, name="AplusAt")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N,N), intent(out) :: B
      real(C_double), dimension(N,N), intent(in) :: A
      integer(C_long) :: i, j
      do concurrent(i = 1:N, j = 1:N)
         B(j,i) = A(j,i) + A(i,j)
      end do
    end subroutine AplusAt
    subroutine AplusAtbuiltin(B, A, N) BIND(C, name="AplusAtbuiltin")
      integer(C_long), intent(in) :: N
      real(C_double), dimension(N,N), intent(out) :: B
      real(C_double), dimension(N,N), intent(in) :: A
      B = A + transpose(A)
    end subroutine AplusAtbuiltin
    real(C_double) function randomaccess(P, basis, coefs, A, C) BIND(C, name="randomaccess")
      integer(C_long), intent(in) :: A, C, basis(A,C)
      real(C_double), intent(in) :: P(A,C), coefs(C)
      real(C_double) :: pc
      integer(C_long) :: aa, cc
      randomaccess = 0
      do cc = 1,C
         pc = coefs(cc)
         do aa = 1,A
            pc = pc * P(aa, basis(aa, cc))
         end do
         randomaccess = randomaccess + pc
      end do
    end function randomaccess
    !GCC$ builtin (log) attributes simd (notinbranch) if('x86_64')
    real(C_double) function logdettriangle(T, N) BIND(C, name="logdettriangle")
      integer(C_long), intent(in) :: N
      real(C_double), intent(in) :: T(N,N)
      integer(C_long) :: nn
      logdettriangle = 0
      do concurrent(nn = 1:N)
         logdettriangle = logdettriangle + log(T(nn,nn))
      end do
    end function logdettriangle

  subroutine filter2d(B, A, K, Ma, Na, offset) BIND(C, name="filter2d")
      integer(C_long), intent(in) :: Ma, Na, offset
      real(C_double), intent(in) :: A(Ma,Na), K(-offset:offset,-offset:offset)
      real(C_double), intent(out) :: B(1+offset:Ma-offset,1+offset:Na-offset)
      integer(C_long) :: mma, nna, mmk, nnk
      real(C_double) :: tmp
      do concurrent(mma = 1+offset:Ma-offset, nna = 1+offset:Na-offset)
         tmp = 0
         do concurrent(mmk = -offset:offset, nnk = -offset:offset)
            tmp = tmp + A(mma + mmk, nna + nnk) * K(mmk, nnk)
         end do
         B(mma,nna) = tmp
      end do
    end subroutine filter2d

    subroutine filter2d3x3(B, A, K, Ma, Na) BIND(C, name="filter2d3x3")
      integer(C_long), parameter :: offset = 1
      integer(C_long), intent(in) :: Ma, Na
      real(C_double), intent(in) :: A(Ma,Na), K(-offset:offset,-offset:offset)
      real(C_double), intent(out) :: B(1+offset:Ma-offset,1+offset:Na-offset)
      integer(C_long) :: mma, nna, mmk, nnk
      real(C_double) :: tmp
      do concurrent(mma = 1+offset:Ma-offset, nna = 1+offset:Na-offset)
         tmp = 0
         do concurrent(mmk = -offset:offset, nnk = -offset:offset)
            tmp = tmp + A(mma + mmk, nna + nnk) * K(mmk, nnk)
         end do
         B(mma,nna) = tmp
      end do
    end subroutine filter2d3x3

    subroutine filter2d3x3unrolled(B, A, K, Ma, Na) BIND(C, name="filter2d3x3unrolled")
      integer(C_long), intent(in) :: Ma, Na
      real(C_double), intent(in) :: A(Ma,Na), K(-1:1,-1:1)
      real(C_double), intent(out) :: B(2:Ma-1,2:Na-1)
      integer(C_long) :: mma, nna, mmk, nnk
      real(C_double) :: tmp
      do concurrent(mma = 2:Ma-1, nna = 2:Na-1)
         tmp =       A(mma - 1, nna - 1) * K(-1, -1)
         tmp = tmp + A(mma    , nna - 1) * K( 0, -1)
         tmp = tmp + A(mma + 1, nna - 1) * K( 1, -1)
         tmp = tmp + A(mma - 1, nna    ) * K(-1,  0)
         tmp = tmp + A(mma    , nna    ) * K( 0,  0)
         tmp = tmp + A(mma + 1, nna    ) * K( 1,  0)
         tmp = tmp + A(mma - 1, nna + 1) * K(-1,  1)
         tmp = tmp + A(mma    , nna + 1) * K( 0,  1)
         tmp = tmp + A(mma + 1, nna + 1) * K( 1,  1)
         B(mma,nna) = tmp
      end do
    end subroutine filter2d3x3unrolled

  end module looptests


      SUBROUTINE TOKEPL(U,R,V,ELEM,TFROMP,TRANOM)
      IMPLICIT REAL*8(A-H,O-Z)
C
C THIS ROUTINE WAS ORIGINALLY CALLED RECEL. MINOR MODS WERE MADE AND
C THE ROUTINE NAMED TOKEPL.
C
C  THE PURPOSE OF TOKEPL IS TO TRANSFORM THE CARTESIAN COORDINATES
C  OF A VEHICLE IN A CIRCULAR, ELLIPTIC, OR HYPERBOLIC ORBIT INTO
C  KEPLERIAN ELEMENTS.
C
C
C  INPUT:    (U AND R/V HAVE SAME UNITS. OTHERWISE NO UNIT REQMT.)
C
C  VAR   DIM   TYPE   I/O   DESCRIPTION
C  ---   ---   ----   ---   -----------
C
C  U      1    R*8    I     CENTRAL BODY GRAVITATIONAL COEFFICIENT
C                           IN SAME UNITS AS POSITION AND VELOCITY.
C                           EX: U=398601.2D0 KM**3/SEC**2
C
C  R      3    R*8    I     CARTESIAN POSITION VECTOR.
C
C  V      3    R*8    I     CARTESIAN VELOCITY VECTOR.
C
C  ELEM   6    R*8    O     KEPLERIAN ELEMENTS. LENGTH UNITS ARE THE
C                           SAME AS FOR U, R, AND V. ANGLE UNITS ARE
C                           RADIANS. ORDER IS: SMA, ECC, INCL, NODE,
C                           ARGP, MEANANOM.
C
C  TFROMP 1    R*8    O     TIME FROM PERIAPSIS. SAME TIME UNITS AS
C                           FOR U AND V.
C
C  TRANOM 1    R*8    O     TRUE ANOMALY. RADIANS.
C
C
C*******************************************************************
C
C  MODIFIED:  C PETRUZZO. 9/81. WAS RECEL BEFORE MODS.
C             CJP. 7/83. WHEN FINDING ELEM(5), DID CHECK FOR
C                        DNUL/(XNUM*XLM) > 1.D0
C
C********************************************************************
C
C
      DIMENSION R(3),V(3),WW(3),XL(3)
      DIMENSION ELEM(6),XNU(2),XNUP(3)
      REAL*8 TWOPI/ 6.283185307179586D0 /
      REAL*8 DEGRAD/ 57.29577951308232D0 /
      REAL*8 ONE/1.D0/,TWO/2.D0/
C
      EPSINC=1.D-6/DEGRAD
      WW(1)=R(2)*V(3)-R(3)*V(2)
      WW(2)=R(3)*V(1)-R(1)*V(3)
      WW(3)=R(1)*V(2)-R(2)*V(1)
      C=DSQRT(WW(1)**2+WW(2)**2+WW(3)**2)
      WW(1)=WW(1)/C
      WW(2)=WW(2)/C
      WW(3)=WW(3)/C
      XNU(1)=-WW(2)
      XNU(2)=WW(1)
      XNUM=DSQRT(WW(2)**2+WW(1)**2)
      P=C*C/U
      RM=DSQRT(R(1)**2+R(2)**2+R(3)**2)
      VM=DSQRT(V(1)**2+V(2)**2+V(3)**2)
      RD=(R(1)*V(1)+R(2)*V(2)+R(3)*V(3))
C********SOLVE FOR ELEM(1)
      ELEM(1)=RM/(TWO-RM*VM*VM/U)
C********SOLVE FOR ELEM(2)
      ELEM(2)=DSQRT(DABS(ONE-P/ELEM(1)))
C********SOLVE FOR ELEM(3)
      ELEM(3)=DACOS(WW(3))
C********SOLVE FOR ELEM(6)
      IF(ELEM(2).LT.1.D-06) GO TO 11
      CTA=(P-RM)/(ELEM(2)*RM)
      STA=RD*C/(ELEM(2)*U*RM)
      GO TO 8
   11 ELEM(2)=0.D0
      IF(DABS(ELEM(3)).LT.EPSINC) GO TO 9
      XNUP(1)=-WW(3)*WW(1)
      XNUP(2)=-WW(3)*WW(2)
      XNUP(3)=WW(1)**2+WW(2)**2
      XNUPM=DSQRT(XNUP(1)**2+XNUP(2)**2+XNUP(3)**2)
      CTA=(R(1)*XNU(1)+R(2)*XNU(2))/(RM*XNUM)
      STA=(R(1)*XNUP(1)+R(2)*XNUP(2)+R(3)*XNUP(3))/(RM*XNUPM)
      GO TO 8
    9 CTA=R(1)/RM
      STA=R(2)/RM
    8 ELEM(6)=DATAN2(STA,CTA)
      IF(ELEM(6).LT.0.D0) ELEM(6)=ELEM(6)+TWOPI
C
C********SOLVE FOR ELEM(4)
C********IF ELEM(3)=0, ELEM(4)=0
C
      ELEM(4)=0.D0
      IF(DABS(ELEM(3)).LT.EPSINC) GO TO 4
      ELEM(4)=DATAN2(WW(1),-WW(2))
      IF(ELEM(4).LT.0.D0) ELEM(4)=ELEM(4)+TWOPI
C
C********SOLVE FOR ELEM(5)
C********IF ELEM(2)=0, ELEM(5)=0
C
    4 ELEM(5)=0.D0
      IF(ELEM(2).LT.1.D-06) GO TO 7
      F=VM**2-U/RM
      DO 10 I=1,3
   10 XL(I)=F*R(I)-RD*V(I)
      DNUL=XNU(1)*XL(1)+XNU(2)*XL(2)
      XLM=DSQRT(XL(1)**2+XL(2)**2+XL(3)**2)
      IF(DABS(ELEM(3)).LT.EPSINC) GO TO 5
      TEMP=DNUL/(XNUM*XLM)
      IF(DABS(TEMP).GT.1.D0) TEMP=DSIGN(1.D0,TEMP)
      ELEM(5)=DACOS(TEMP)
      ELEM(5)=DSIGN(ELEM(5),XL(3))
      GO TO 7
    5 CW=XL(1)/XLM
      SW=XL(2)/XLM
      ELEM(5)=DATAN2(SW,CW)
    7 IF(ELEM(5).LT.0.D0) ELEM(5)=ELEM(5)+TWOPI
      Q=ELEM(6)
      IF(ELEM(1)) 110,50,50
C********SOLVE FOR TFROMP ON AN ELLIPTIC ORBIT
   50 CONTINUE
      DIV=ONE+ELEM(2)*DCOS(Q)
      COSEA=(ELEM(2)+DCOS(Q))/DIV
      SINEA=DSQRT(ONE-ELEM(2)**2)*DSIN(Q)/DIV
      EA=DATAN2(SINEA,COSEA)
      AVA=EA-ELEM(2)*DSIN(EA)
      IF(AVA.LT.0.D0) AVA=AVA+TWOPI
      XM=AVA
      TFROMP=AVA/DSQRT(U/ELEM(1)**3)
      GO TO 20
C********SOLVE FOR TFROMP ON A HYPERBOLIC ORBIT
  110 CONTINUE
      TANG=DSQRT((ELEM(2)-ONE)/(ELEM(2)+ONE))*DSIN(Q/TWO)/DCOS(Q/TWO)
      SINHF=(TWO*TANG)/(ONE-TANG*TANG)
      AUXF=DLOG(SINHF+DSQRT(SINHF*SINHF+ONE))
      Z=ELEM(2)*SINHF-AUXF
      XM=Z
      TFROMP=DSQRT(-ELEM(1)**3/U)*Z
   20 CONTINUE
C     ELEM(6) HAS BEEN CALCULATED AS TRUE ANOMALY. PUT MEAN ANOM THERE.
      TRANOM=ELEM(6)
      ELEM(6)=XM
      RETURN
      END


       subroutine phase_func_moon(phase_angle_deg,mode,area_rel,area_es,phase_corr_moon)

       include 'trigd.inc'

       Implicit real*8(a-z)

!      Traditional equation
       arg = phase_angle_deg / 100.
       phase_corr_moon = 3.05 * arg - 1.02 * arg**2 + 1.05 * arg**3

!      arg = phase_angle_deg ! Schaefer 1991
!      phase_corr = .026 * arg + 4e-9 * arg**4

!      Opposition effect
       if(phase_angle_deg .lt. 7.0)then
           arg = 0.18 / 7.
           phase_corr_moon = phase_corr_moon + (arg * (phase_angle_deg - 7.))
       endif

!      Supplementary information
       area_rel_7 = (cosd(173.) + 1.) / 2.

       area_rel = (cosd(phase_angle_deg) + 1.) / 2.

!      New formulation matches at 152 degrees / 28 degrees

!      Correct for shadowing effect
       area_rel = area_rel - (area_rel_7 * (1. - area_rel))

       area_rel = max(area_rel,0.d0)

!      Correct Earthshine using Earth's phase function
       arg = (180. - phase_angle_deg) / 100.
       phase_corr_earth = 1.30 * arg - 0.19 * arg**2 + 0.48 * arg**3
       frac_bri_earth = 10**(-phase_corr_earth * 0.4)
       area_es = 9.1201e-5 * frac_bri_earth

       surface_brightness = .073

       frac_full = area_rel * surface_brightness + area_es

       if(mode .eq. 1 .AND. phase_angle_deg .gt. 152.)then ! Modify for Crescent Moon

           phase_corr_moon = -log10(frac_full) * 2.5

       endif

       return
       end


      function fmv(pma)
!     to obtain mach number from prandtl meyer angle
      use kinddefine
      use gg, only:g2,g7,g9
!
      implicit none
      integer(kind=K4) :: i
      real(kind=K8) :: ang,fmv,one,rem,third,vm,z,zbet
      real(kind=K8),intent(in) :: pma
      one=1.d+0
      third=one/3.d+0
      vm=(dasin(one)*(pma/(g2-one))**2)**third
      z=one+.895d+0*((g7*(g2-one))**2)**third*dtan(vm)
      do i=1,100
       zbet=dsqrt(z*z-one)
       ang=g2*datan(zbet/g2)-datan(zbet)
       rem=(ang-pma)*z*(z*z+g9)/g9/zbet
       if (dabs(rem) .lt. 1.d-10) goto 2
       z=z-rem
      enddo
2     fmv=z-rem
      end function fmv


      SUBROUTINE TB01KX( N, M, P, NDIM, A, LDA, B, LDB, C, LDC, U, LDU,
     $                   V, LDV, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute an additive spectral decomposition of the transfer-
C     function matrix of the system (A,B,C) by reducing the system
C     state-matrix A to a block-diagonal form. It is assumed that A is
C     in a real Schur form, and the leading diagonal block of order NDIM
C     has eigenvalues distinct from those of the trailing diagonal
C     block. The system matrices are transformed as
C        A <-- V*A*U, B <--V*B and C <-- C*U, where V = inv(U),
C     preserving the spectra of the two diagonal blocks.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e., the
C             order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs, or of columns of B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     NDIM    (input) INTEGER
C             The dimension of the leading diagonal block of A having
C             eigenvalues distinct from those of the trailing diagonal
C             block.  0 <= NDIM <= N.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A in real Schur form.
C             On exit, the leading N-by-N part of this array contains a
C             block diagonal matrix inv(U) * A * U with two diagonal
C             blocks in real Schur form, with the elements below the
C             first subdiagonal set to zero. The leading block has
C             dimension NDIM-by-NDIM.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix inv(U) * B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * U.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= MAX(1,P).
C
C     U       (input/output) DOUBLE PRECISION array, dimension (LDU,N)
C             On entry, the leading N-by-N part of this array must
C             contain an initial transformation matrix U.
C             On exit, the leading N-by-N part of this array contains
C             the transformation matrix used to reduce A to the block-
C             diagonal form. The first NDIM columns of U span the
C             invariant subspace of A corresponding to the eigenvalues
C             of its leading diagonal block. The last N-NDIM columns of
C             U span the reducing subspace of A corresponding to the
C             eigenvalues of the trailing diagonal block of A.
C
C     LDU     INTEGER
C             The leading dimension of the array U.  LDU >= max(1,N).
C
C     V       (output) DOUBLE PRECISION array, dimension (LDV,N)
C             The leading N-by-N part of this array contains the
C             inverse of the transformation matrix U used to reduce A
C             to the block-diagonal form.
C
C     LDV     INTEGER
C             The leading dimension of the array V.  LDV >= max(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: successful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: the separation of the two diagonal blocks failed
C                  because of very close eigenvalues.
C
C     METHOD
C
C     A similarity transformation U is determined that reduces the given
C     system state-matrix A to a block-diagonal form (with two diagonal
C     blocks), so that the eigenvalues of the leading diagonal block of
C     the resulting A are preserved. The determined transformation is
C     applied to the system (A,B,C) as
C        A <-- inv(U)*A*U, B <-- inv(U)*B and C <-- C*U.
C
C     REFERENCES
C
C     [1] Safonov, M.G., Jonckheere, E.A., Verma, M., Limebeer, D.J.N.
C         Synthesis of positive real multivariable feedback systems.
C         Int. J. Control, pp. 817-842, 1987.
C
C     NUMERICAL ASPECTS
C                                   3
C     The algorithm requires about N /2 + NDIM*(N-NDIM)*(2*N+M+P)
C     floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, March 1998.
C     Based on the RASP routine SADSDC.
C
C     REVISIONS
C
C     V. Sima, Dec. 2016.
C
C     KEYWORDS
C
C     Invariant subspace, real Schur form, similarity transformation,
C     spectral factorization.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION ZERO, ONE
      PARAMETER        ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER          INFO, LDA, LDB, LDC, LDU, LDV, M, N, NDIM, P
C     .. Array Arguments ..
      DOUBLE PRECISION A(LDA,*), B(LDB,*), C(LDC,*), U(LDU,*), V(LDV,*)
C     .. Local Scalars ..
      INTEGER          NDIM1, NR
      DOUBLE PRECISION SCALE
C     .. External Subroutines ..
      EXTERNAL         DGEMM, DLASET, DTRSYL, MA02AD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC        MAX
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check input scalar arguments.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( NDIM.LT.0 .OR. NDIM.GT.N ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -10
      ELSE IF( LDU.LT.MAX( 1, N ) ) THEN
         INFO = -12
      ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
         INFO = -14
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TB01KX', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
C     Form U' in V.
C
      CALL MA02AD( 'Full', N, N, U, LDU, V, LDV )
C
      IF( NDIM.GT.0 .AND. NDIM.LT.N ) THEN
C
C        Reduce A to a block-diagonal form by a similarity
C        transformation of the form
C                 -1                  ( I -X )
C           A <- T  AT,  where    T = (      )  and X satisfies the
C                                     ( 0  I )
C        Sylvester equation
C
C           A11*X - X*A22 = A12.
C
         NR = N - NDIM
         NDIM1 = NDIM + 1
         CALL DTRSYL( 'N', 'N', -1, NDIM, NR, A, LDA, A(NDIM1,NDIM1),
     $                LDA, A(1,NDIM1), LDA, SCALE, INFO )
         IF ( INFO.NE.0 )
     $      RETURN
C                      -1                                -1
C        Compute B <- T  *B,  C <- C*T,  U <- U*T, V <- T  *V.
C
         SCALE = ONE/SCALE
         CALL DGEMM( 'N', 'N', NDIM, M, NR, SCALE, A(1,NDIM1), LDA,
     $               B(NDIM1,1), LDB, ONE, B, LDB )
         CALL DGEMM( 'N', 'N', P, NR, NDIM, -SCALE, C, LDC, A(1,NDIM1),
     $               LDA, ONE, C(1,NDIM1), LDC )
         CALL DGEMM( 'N', 'N', N, NR, NDIM, -SCALE, U, LDU, A(1,NDIM1),
     $               LDA, ONE, U(1,NDIM1), LDU )
         CALL DGEMM( 'N', 'N', NDIM, N, NR, SCALE, A(1,NDIM1), LDA,
     $               V(NDIM1,1), LDV, ONE, V, LDV )
C
C        Set A12 to zero.
C
         CALL DLASET( 'Full', NDIM, NR, ZERO, ZERO, A(1,NDIM1), LDA )
      END IF
C
C     Set to zero the lower triangular part under the first subdiagonal
C     of A.
C
      IF ( N.GT.2 )
     $   CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, A( 3, 1 ), LDA )
      RETURN
C *** Last line of TB01KX ***
      END


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------
MODULE m_doubleCounting

   USE m_constants

   IMPLICIT NONE

   CONTAINS

   FUNCTION doubleCountingPot(U,J,l,l_amf,l_spinAvg,rho,l_write) RESULT(Vdc)

      !------------------------------------------------------
      ! Calculate the Double Counting Correction in either
      ! the FLL or AMF limit
      ! If l_spinAvg is True the Double counting will be
      ! averaged over the spins
      !------------------------------------------------------

      REAL,                INTENT(IN)  :: U          !Hubbard parameters
      REAL,                INTENT(IN)  :: J
      INTEGER,             INTENT(IN)  :: l
      LOGICAL,             INTENT(IN)  :: l_amf      !Which doubleCounting is used (FLL/AMF)
      LOGICAL,             INTENT(IN)  :: l_spinAvg  !Do we want a spin averaged double counting
      REAL,                INTENT(IN)  :: rho(:)     !Trace of the density matrix for each spin
      LOGICAL, OPTIONAL,   INTENT(IN)  :: l_write

      REAL :: Vdc(SIZE(rho))
      REAL :: nup, ndn, Vdcup, Vdcdn

      nup = rho(1)
      IF(SIZE(rho) == 2) THEN
         ndn = rho(2)
      ELSE
         ndn = rho(1)
      ENDIF

      IF(l_amf) THEN
         Vdcup = U*ndn+2.0*l/(2.0*l+1)*(U-J)*nup
         Vdcdn = U*nup+2.0*l/(2.0*l+1)*(U-J)*ndn
      ELSE
         Vdcup = U*(nup+ndn - 0.5) - J*(nup - 0.5)
         Vdcdn = U*(nup+ndn - 0.5) - J*(ndn - 0.5)
      ENDIF

      IF(PRESENT(l_write)) THEN
         IF(l_write) THEN
            WRITE(oUnit,"(/,A)") 'Double counting chemical potential:'
            IF(l_amf) THEN
               WRITE(oUnit,9040) 'AMF: ','spin-up','spin-dn','(up+dn)/2','up-dn'
            ELSE
               WRITE(oUnit,9040) 'FLL: ','spin-up','spin-dn','(up+dn)/2','up-dn'
            ENDIF
9040        FORMAT(TR3,A4,TR1,A7,TR3,A7,TR3,A9,TR3,A5)
            WRITE(oUnit,9050) Vdcup,Vdcdn,(Vdcup+Vdcdn)/2.0,Vdcup-Vdcdn
9050        FORMAT(TR7,f8.4,TR2,f8.4,TR2,f8.4,TR4,f8.4)
         ENDIF
      ENDIF

      IF(l_spinAvg) THEN
         Vdc(:) = (Vdcup+Vdcdn)/2.0
      ELSE
         Vdc(1) = Vdcup
         IF(SIZE(rho) == 2) THEN
            Vdc(2) = Vdcdn
         ENDIF
      ENDIF

      IF(PRESENT(l_write)) THEN
         IF(l_write) THEN
            WRITE(oUnit,*) "Vdc = ", Vdc(:)
         ENDIF
      ENDIF

   END FUNCTION doubleCountingPot

   FUNCTION doubleCountingEnergy(U,J,l,l_amf,rho) RESULT(Edc)

      !------------------------------------------------------------
      ! Calculate the Double Counting Correction Energy in either
      ! the FLL or AMF limit
      !------------------------------------------------------------

      REAL,                INTENT(IN)  :: U          !Hubbard parameters
      REAL,                INTENT(IN)  :: J
      INTEGER,             INTENT(IN)  :: l
      LOGICAL,             INTENT(IN)  :: l_amf      !Which doubleCounting is used (FLL/AMF)
      REAL,                INTENT(IN)  :: rho(:)     !Trace of the density matrix for each spin

      REAL :: Edc
      REAL :: nup, ndn

      nup = rho(1)
      IF(SIZE(rho) == 2) THEN
         ndn = rho(2)
      ELSE
         ndn = rho(1)
      ENDIF

      IF(l_amf) THEN
         Edc = U*nup*ndn + (U-J) *l*(nup**2+ndn**2)/(2.0*l+1)
      ELSE
         Edc =   U/2.0 * (nup+ndn) * (nup+ndn - 1.0) &
               - J/2.0 * nup       * (nup     - 1.0) &
               - J/2.0 * ndn       * (ndn     - 1.0)
      ENDIF

   END FUNCTION doubleCountingEnergy

END MODULE m_doubleCounting


!>    \brief Module containing Fletcher-Reeves (non-linear Conjugate Gradient)
!!    routines including linear search algorithm
      MODULE f1dim_mod
      USE stel_kinds, ONLY: dp
      INTEGER :: ncom
      REAL(dp), DIMENSION(:), POINTER :: pcom,xicom
!      INTERFACE
!         FUNCTION func(p)
!         USE stel_kinds, ONLY: dp
!         IMPLICIT NONE
!         REAL(dp), DIMENSION(:), INTENT(IN) :: p
!         REAL(dp) :: func
!         END FUNCTION func
!      END INTERFACE

      CONTAINS

!>    \brief One-dimension function used by linmin, passed to mnbrak/brent to find minimum for line search.
      FUNCTION f1dim(x)
      IMPLICIT NONE
      REAL(dp), INTENT(IN) :: x
      REAL(dp) :: f1dim
!Used by linmin as the one-dimensional function passed to mnbrak and brent.
      REAL(dp), DIMENSION(:), ALLOCATABLE :: xt
      ALLOCATE(xt(ncom))
      xt(:)=pcom(:)+x*xicom(:)
      f1dim=wfunc(xt)
      DEALLOCATE(xt)
      END FUNCTION f1dim

!>    \brief Fletcher-Reeves-Polak-Ribiere minimization
      SUBROUTINE Fletcher_Reeves (p,ftol,iter,fret,n)
      USE stel_kinds, ONLY: dp
      IMPLICIT NONE
      INTEGER, INTENT(IN)  :: n
      INTEGER, INTENT(OUT) :: iter
      REAL(dp), INTENT(IN) :: ftol
      REAL(dp), INTENT(OUT) :: fret
      REAL(dp), DIMENSION(n), INTENT(INOUT) :: p

      INTEGER, PARAMETER :: itmax=50
      REAL(dp), PARAMETER :: eps=1.0e-10_dp

!Given a starting point p that is a vector of length N, Fletcher-Reeves-Polak-Ribiere minimization
!is performed on a function func, using its gradient as calculated by a routine
!dfunc. The convergence tolerance on the function value is input as ftol. Returned quantities
!are p (the location of the minimum), iter (the number of iterations that were
!performed), and fret (the minimum value of the function). The routine linmin is called
!to perform line minimizations.
!Parameters: ITMAX is the maximum allowed number of iterations; EPS is a small number
!to rectify the special case of converging to exactly zero function value.
      INTEGER :: its
      REAL(dp) :: dgg,fp,gam,gg
      REAL(dp), ALLOCATABLE, DIMENSION(:) :: g, h, xi
!      REAL(dp), DIMENSION(SIZE(p)) :: g,h,xi

      ALLOCATE (g(SIZE(p)), h(SIZE(p)), xi(SIZE(p)))
      fp=wfunc(p)                             !Initializations.
      xi=dfunc(p)
      g=-xi
      h=g
      xi=h
      DO its=1,itmax                          !Loop over iterations.
         iter=its
         CALL linmin(p,xi,fret)               !Next statement is the normal return:
         IF (2*ABS(fret-fp) <= ftol*(ABS(fret)+ABS(fp)+eps)) RETURN
         fp=fret
         xi=dfunc(p)
         gg=DOT_PRODUCT(g,g)
!         dgg=DOT_PRODUCT(xi,xi)                      !This statement for Fletcher-Reeves.
         dgg=DOT_PRODUCT(xi+g,xi)             !This statement for Polak-Ribiere.
         IF (gg == 0._dp) RETURN                !Unlikely. If gradient is exactly zero then we are
         gam=dgg/gg                           !already done.
         g=-xi
         h=g+gam*h
         xi=h
      END DO

      DEALLOCATE (g, h, xi)

      END SUBROUTINE Fletcher_Reeves

!>    \brief Function to compute the MHD energy used in line search
      FUNCTION wfunc(p)
      USE stel_kinds, ONLY: dp
      USE shared_functions, ONLY: getwmhd
!      USE diagnostics_mod, ONLY: getbgradp2
      IMPLICIT NONE
      REAL(dp), DIMENSION(:), INTENT(IN) :: p
      REAL(dp) :: wfunc

      wfunc = getwmhd(p)

      END FUNCTION wfunc

!>    \brief Function to compute gradient of MHD energy
      FUNCTION dfunc(p)
      USE stel_kinds, ONLY: dp
      USE shared_functions, ONLY: funct_island
      USE shared_data, ONLY: xc, gc
!      USE diagnostics_mod, ONLY: funct_fgradp, xc, gc
      IMPLICIT NONE
      REAL(dp), DIMENSION(:), INTENT(IN) :: p
      REAL(dp), DIMENSION(SIZE(p)) :: dfunc

      xc = p
      CALL funct_island
      dfunc = gc

      END FUNCTION dfunc

!>    \brief Routine to find minimum of func along a given direction xi from point p
      SUBROUTINE linmin(p,xi,fret)
      IMPLICIT NONE
      REAL(dp), INTENT(OUT) :: fret
      REAL(dp), DIMENSION(:), TARGET, INTENT(INOUT) :: p,xi
      REAL(dp), PARAMETER :: tol=1.0e-4_dp
!Given an N-dimensional point p and an N-dimensional direction xi, both vectors of length
!N, moves and resets p to where the fixed-name function func takes on a minimum along
!the direction xi from p, and replaces xi by the actual vector displacement that p was
!moved. Also returns as fret the value of func at the returned location p. This is actually
!all accomplished by calling the routines mnbrak and brent.
!Parameter TOL: Tolerance passed to brent.
      REAL(dp) :: ax,bx,fa,fb,fx,xmin,xx
!      REAL(dp), EXTERNAL :: brent

      ncom=SIZE(p)
      pcom=>p                        !Communicate the global variables to f1dim.
      xicom=>xi
      ax=0                           !Initial guess for brackets.
      xx=1
      CALL mnbrak(ax,xx,bx,fa,fx,fb,f1dim)
      fret=brent(ax,xx,bx,f1dim,tol,xmin)
      xi=xmin*xi                     !Construct the vector results to return.
      p=p+xi
      END SUBROUTINE linmin

!>    \brief Routine to bracket the minimum of func in the downhill direction
      SUBROUTINE mnbrak(ax,bx,cx,fa,fb,fc,func)
      USE stel_kinds, ONLY: dp
      IMPLICIT NONE
      REAL(dp), INTENT(INOUT) :: ax,bx
      REAL(dp), INTENT(OUT) :: cx,fa,fb,fc
      INTERFACE
         FUNCTION func(x)
         USE stel_kinds, ONLY: dp
         IMPLICIT NONE
         REAL(dp), INTENT(IN) :: x
         REAL(dp) :: func
         END FUNCTION func
      END INTERFACE
      REAL(dp), PARAMETER :: GOLD=1.618034_dp,GLIMIT=100.0_dp,TINY=1.0e-20_dp, zero=0
!Given a function func, and given distinct initial points ax and bx, this routine searches
!in the downhill direction (defined by the function as evaluated at the initial points) and
!returns new points ax, bx, cx that bracket a minimum of the function. Also returned are
!the function values at the three points, fa, fb, and fc.
!Parameters: GOLD is the default ratio by which successive intervals are magnified; GLIMIT
!is the maximum magnification allowed for a parabolic-fit step.
      REAL(dp) :: fu,q,r,u,ulim
      fa=func(ax)
 100      fb=func(bx)
      if (fb > fa) then                            !Switch roles of a and b so that we
                                                   !can go downhill in the direction from a to b.
!         bx = bx/4; goto 100
         call swap(ax,bx)
         call swap(fa,fb)
      end if
      cx=bx+GOLD*(bx-ax)                           !First guess for c.
      fc=func(cx)
      do                                           !Do-while-loop: Keep returning here
         if (fb < fc) RETURN                       !until we bracket.
!Compute u by parabolic extrapolation from a, b, c. TINY is used to prevent any possible division by zero.
         r=(bx-ax)*(fb-fc)
         q=(bx-cx)*(fb-fa)
         u=bx-((bx-cx)*q-(bx-ax)*r)/(2*sign(max(abs(q-r),TINY),q-r))
         ulim=bx+GLIMIT*(cx-bx)
!We won\92t go farther than this. Test various possibilities:
         if ((bx-u)*(u-cx) > zero) then             !Parabolic u is between b and c: try it.
            fu=func(u)
            if (fu < fc) then                      !Got a minimum between b and c.
               ax=bx
               fa=fb
               bx=u
               fb=fu
               RETURN
            else if (fu > fb) then                 !Got a minimum between a and u.
               cx=u
               fc=fu
               RETURN
            end if
            u=cx+GOLD*(cx-bx)                      !Parabolic fit was no use. Use default magnification.
            fu=func(u)
         else if ((cx-u)*(u-ulim) > zero) then      !Parabolic fit is between c and its allowed limit.
            fu=func(u)
            if (fu < fc) then
               bx=cx
               cx=u
               u=cx+GOLD*(cx-bx)
               call shft(fb,fc,fu,func(u))
            end if
         else if ((u-ulim)*(ulim-cx) >= zero) then  !Limit parabolic u to maximum allowed value.
            u=ulim
            fu=func(u)
         else                                      !Reject parabolic u, use default magnification.
            u=cx+GOLD*(cx-bx)
            fu=func(u)
         end if
         call shft(ax,bx,cx,u)
         call shft(fa,fb,fc,fu)                       !Eliminate oldest point and continue.

      end do

      END SUBROUTINE mnbrak

!>    \brief Isolates the minimum of func
      FUNCTION brent(ax,bx,cx,func,tol,xmin)
      USE stel_kinds, ONLY: dp
      IMPLICIT NONE
      REAL(dp), INTENT(IN) :: ax,bx,cx,tol
      REAL(dp), INTENT(OUT) :: xmin
      REAL(dp) :: brent
      REAL(dp), EXTERNAL :: func

      INTEGER, PARAMETER :: ITMAX=100
      REAL(dp), PARAMETER :: CGOLD=0.3819660_dp,ZEPS=1.0e-3_dp*EPSILON(ax)
!Given a function func, and given a bracketing triplet of abscissas ax, bx, cx (such that bx
!is between ax and cx, and func(bx) is less than both func(ax) and func(cx)), this
!routine isolates the minimum to a fractional precision of about tol using Brent\92s method.
!The abscissa of the minimum is returned as xmin, and the minimum function value is
!returned as brent, the returned function value.
!Parameters: ITMAX, Maximum allowed number of iterations;gol den ratio; and a small number that
!protects against trying to achieve fractional accuracy for a minimum that happens to be
!exactly zero.
      INTEGER :: iter
      REAL(dp) :: a,b,d,e,etemp,fu,fv,fw,fx,p,q,r,tol1,tol2,u,v,w,x,xm

      a=min(ax,cx)                 !a and b must be in ascending order, though
      b=max(ax,cx)                 !the input abscissas need not be.
      v=bx                         !Initializations...
      w=v
      x=v
      e=0                          !This will be the distance moved on the step before last.
      fx=func(x)
      fv=fx
      fw=fx
      do iter=1,ITMAX              !Main program loop.
         xm=0.5_dp*(a+b)
         tol1=tol*abs(x)+ZEPS
         tol2=2*tol1
         if (abs(x-xm) <= (tol2-0.5_dp*(b-a))) then    !Test for done here.
            xmin=x                                     !Arrive here ready to exit with best values.
            brent=fx
            RETURN
         end if
         if (abs(e) > tol1) then                       !Construct a trial parabolic fit.
            r=(x-w)*(fx-fv)
            q=(x-v)*(fx-fw)
            p=(x-v)*q-(x-w)*r
            q=2*(q-r)
            if (q > 0.0_dp) p=-p
            q=abs(q)
            etemp=e
            e=d
            if (abs(p) >= abs(0.5_dp*q*etemp) .or. &
            p <= q*(a-x) .or. p >= q*(b-x)) then
!The above conditions determine the acceptability of the parabolic fit. Here it is
!not o.k., so we take the golden section step into the larger of the two segments.
               e=merge(a-x,b-x, x >= xm)
               d=CGOLD*e
            else                                      !Take the parabolic step.
               d=p/q
               u=x+d
               if (u-a < tol2 .or. b-u < tol2) d=sign(tol1,xm-x)
            end if
         else                                         !Take the golden section step into the larger
            e=merge(a-x,b-x, x >= xm )                !of the two segments.
            d=CGOLD*e
         end if
         u=merge(x+d,x+sign(tol1,d), abs(d) >= tol1 )
!Arrive here with d computed either from parabolic fit, or else from golden section.
         fu=func(u)
!This is the one function evaluation per iteration.
         if (fu <= fx) then                           !Now we have to decide what to do with our
            if (u >= x) then                          !function evaluation. Housekeeping follows:
               a=x
            else
               b=x
            end if
            call shft(v,w,x,u)
            call shft(fv,fw,fx,fu)
         else
            if (u < x) then
               a=u
            else
               b=u
            end if
            if (fu <= fw .or. w == x) then
               v=w
               fv=fw
               w=u
               fw=fu
            else if (fu <= fv .or. v == x .or. v == w) then
               v=u
               fv=fu
            end if
         end if
      end do                                            !Done with housekeeping. Back for another iteration

      END FUNCTION brent

!>    \brief Swaps a,b => b,a
      SUBROUTINE swap(a,b)
      USE stel_kinds, ONLY: dp
      REAL(dp), INTENT(INOUT) :: a,b
      REAL(dp) :: dum

      dum=a
      a=b
      b=dum
      END SUBROUTINE swap

!>    \brief Shifts a=b, b=c, c=d
      SUBROUTINE shft(a,b,c,d)
      USE stel_kinds, ONLY: dp
      REAL(dp), INTENT(OUT) :: a
      REAL(dp), INTENT(INOUT) :: b,c
      REAL(dp), INTENT(IN) :: d

      a=b
      b=c
      c=d
      END SUBROUTINE shft

      END MODULE f1dim_mod


!
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!  .                                                             .
!  .                  copyright (c) 1998 by UCAR                 .
!  .                                                             .
!  .       University Corporation for Atmospheric Research       .
!  .                                                             .
!  .                      all rights reserved                    .
!  .                                                             .
!  .                                                             .
!  .                          spherepack                         .
!  .                                                             .
!  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
!
!     program advec solves the time-dependent linear advection
!     equation for geopotential phi using the spherepack software
!
!
! definitions:
!
!
!     nlat          number of gaussian latitudes excluding poles
!     nlon          number of distinct longitudes
!     omega         rotation rate of earth in radians per second
!     alpha         angle between axis of rotation and the coordinate
!                   axis
!     beta          latitude of the cosine bell
!     aa            radius of earth in meters
!     ncycle        exit number
!     time          model time in seconds
!     dt            time step
!     lambda        longitude
!     theta         latitude
!
!   the first dimension of the following two dimensional arrays
!   corresponds to the latitude index with values i=1, ..., nlat
!   where i=1 is the northern most gaussian point thetag(i)
!   and i=nlat is the southern most gaussian point thetag(nlat).
!   the second dimension is longitude with values j=1, ..., nlon
!   where j=1 corresponds to zero longitude and j=nlon corresponds
!   to 2pi minus 2pi/nlon.
!
!
!     thetag(i)           vector of gaussian points on the full sphere which
!                         have north to south orientation as i=1, ..., nlat
!
!     u(i, j)               east longitudinal velocity component
!
!     v(i, j)               latitudinal velocity component
!
!     phi(i, j)             the geopotential at t = time
!
!     phi_new(i, j)         the geopotential at t=time+dt
!
!     phi_old(i, j)         the geopotential at t=time-dt
!
!     grad_phi_lon(i, j)    the longitudinal derivative component of
!                          the gradient of phi
!
!                          grad_phi_lon = 1/(cos(theta))*d(phi)/dlambda
!
!
!     grad_phi_lat(i, j)   the latitudinal derivative component of
!                         the gradient of phi
!
!                         grad_phi_lat = d(phi)/dtheta
!
!
!   the following two dimensional arrays are nonzero in the triangle
!   n=1, ..., nlat and m less than or equal to n.
!
!     ar(m, n), br(m, n)    spectral coefficients of phi
!
program advec

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack, only: &
        wp, & ! Working precision
        ip    ! Integer precision

    use type_AdvectionSolver, only: &
        AdvectionSolver, &
        TIME_TO_CIRCUMVENT_THE_EARTH

    ! Explicit typing only
    implicit none

    ! Dictionary
    type(AdvectionSolver)             :: solver
    integer(ip), parameter            :: NLONS = 45
    integer(ip), parameter            :: NLATS = 23
    integer(ip)                       :: mprint, ncycle, ntime
    real(wp), dimension(NLATS, NLONS) :: u, v, phi, phi_old, phi_new
    real(wp), dimension(NLATS, NLONS) :: exact_phi, grad_phi, grad_phi_lon, grad_phi_lat
    real(wp)                          :: p0_l2, p0_max, time
    real(wp),         parameter       :: ZERO = 0.0_wp, HALF = 0.5_wp
    character(len=*), parameter       :: WRITE_FMT = &
        '(a, i10, a, f10.2/, a, f10.0, a, i10/, a, i10, '&
        //'a, 1pe15.6/, a, 1pe15.6, a, 0pf10.2/a, 1pe15.6, a, 1pe15.6)'

    write (stdout, '(/a)') '     advec *** TEST RUN *** '

    ! Allocate memory
    call solver%create(nlat=NLATS, nlon=NLONS)

    ! Set vector velocities and cosine bell in geopotential
    call solver%get_vector_velocities(u, v)

    ! Compute geopotential at t=-dt in phi_old and at t=0.0 in phi
    ! to start up leapfrog scheme
    associate (dt => solver%TIME_STEP)
        call solver%get_geopotential(-dt, phi_old)
        call solver%get_geopotential(ZERO, phi)
    end associate

    ! Smooth geopotential at t=-dt and t=0. by synthesizing after analysis
    call solver%perform_scalar_analysis(phi_old)
    call solver%perform_scalar_synthesis(phi_old)
    call solver%perform_scalar_analysis(phi)
    call solver%perform_scalar_synthesis(phi)

    ! Compute l2 and max norms of geopotential at t=0.
    p0_l2 = norm2(phi)
    p0_max = maxval(abs(phi))

    ! Set number of time steps for 12 days (time to circumvent the earth)
    associate (dt => solver%TIME_STEP)
        ntime = int(real(TIME_TO_CIRCUMVENT_THE_EARTH, kind=wp)/dt + HALF, kind=ip)
        mprint = ntime/12
        time = ZERO
        ncycle = 0
    end associate

    !  Start time loop
    time_loop: do while (ncycle <= ntime)

        !  Compute gradient of phi at current time
        call solver%get_gradient(phi, grad_phi_lat, grad_phi_lon)

        !  Compute the time derivative of phi, note that the sign
        !  of the last term is positive because the gradient is
        !  computed with respect to colatitude rather than latitude.
        grad_phi = -u * grad_phi_lon + v * grad_phi_lat

        ! Write variables to standard output
        if (mod(ncycle, mprint) == 0) then

            ! Compute exact solution
            call solver%get_geopotential(time, exact_phi)

            !  Compute errors
            associate (&
                htime => time/3600, &
                dt => solver%TIME_STEP, &
                nlats => solver%NUMBER_OF_LATITUDES, &
                nlons => solver%NUMBER_OF_LONGITUDES, &
                omega => solver%ROTATION_RATE_OF_EARTH, &
                hzero => solver%MAXIMUM_VALUE_OF_COSINE_BELL, &
                alphad => solver%TILT_ANGLE_IN_DEGREES, &
                errm => maxval(abs(exact_phi-phi))/p0_max, &
                err2 => norm2(exact_phi-phi)/p0_l2 &
               )

                write (stdout, '(/a)') ' advecting cosine bell, test case 2'
                write (stdout, fmt = WRITE_FMT) &
                    ' exit number              '  , ncycle, &
                    '  model time in  hours      ', htime, &
                    ' time step in seconds      ' , dt, &
                    ' number of latitudes       ' , nlats, &
                    ' number of longitudes      ' , nlons, &
                    ' rotation rate        '      , omega, &
                    ' mean height          '      , hzero, &
                    ' tilt angle                ' , alphad, &
                    ' max geopot. error    '      , errm, &
                    ' RMS geopot. error    '      , err2
            end associate
        end if

        !  Update various quantities
        associate (dt => solver%TIME_STEP)

            ! Increment
            time = time + dt
            ncycle = ncycle + 1

            ! Update phi_old, phi for next time step
            phi_new = phi_old + 2.0_wp * dt * grad_phi
            phi_old = phi
            phi = phi_new
        end associate
    end do time_loop

    !  Release memory
    call solver%destroy()

end program advec