C compile: gfortran polrgdeh.for multr.for minv.for order.for gdata.for -o polrgdeh

C        SAMPLE MAIN PROGRAM FOR POLYNOMIAL REGRESSION - POLRG
        IMPLICIT DOUBLE PRECISION (A - H)
        IMPLICIT DOUBLE PRECISION (O - Z)
C  THE FOLLOWING ROUTINES ARE USED: GDATA,ORDER,MINV,MULTR
C       AND AN OPTIONAL PLOTTING SUBROUTINE COULD BE ADDED
C
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C       PRODUCT OF N*(M+1) WHERE N IS THE NUMBER OF OBSERVATIONS AND
C       M IS THE HIGHEST DEGREE POLYNOMIAL SPECIFIED.
C	N = 100 observations; M = 6
        DIMENSION X(15000)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO THE
C       PRODUCT OF M*M.
        DIMENSION DI(100)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO
C       (M+2)*(M+1)/2.
        DIMENSION D(100)
C       THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO M.
        DIMENSION B(6),SB(6),T(6),E(6)
C       THE FOLLOWING DIMENSIONS MUST BE GREATER THAN OR EQUAL TO
C       (M+1).
        DIMENSION XBAR(7),STD(7),COE(7),SUMSQ(7),ISAVE(7)
C       THE FOLLOWING DIMENSION MUST BE GREATER THAN OR EQUAL TO 10.
        DIMENSION ANS(20)
C
	CHARACTER P*6
	CHARACTER FILEI*20
	CHARACTER FILEO*20
C       OUTPUT CHANNEL = IOUT, INPUT CHANNEL = IN
C	RULER FOR COLUMNS 1-72
CCCCCCCCCC..........//////////..........//////////..........//////////ZZ
C		LOGICAL DEVICE FOR READ, WRITE

C	WRITE (*,92)
C92	FORMAT (' Enter input file name'/)
C	READ (*,*) FILEI
	IN = 10
C	OPEN (unit=IN,file=FILEI,status='old')
	OPEN (unit=IN,file='polgdegA.dat',status='old')

	WRITE (*,93)
93	FORMAT (' Enter 6 char output file name'/)
	READ (*,*) FILEO
	IOUT = 2
	OPEN (unit=IOUT,file=FILEO,status='new')

C	Read format for input data
C       READ PARAMETER CARD
100     READ(IN,*) P,N,M
C       P=PROBLEM NUMBER (MAY BE ALPHAMERIC)
C       N=NUMBER OF OBSERVATIONS
C       M=HIGHEST DEGREE POLYNOMIAL SPECIFIED
C
        IF(N.EQ.0) STOP
C
C       PRINT PROBLEM NUMBER AND N.
        WRITE(IOUT,3) P
3       FORMAT(//27H POLYNOMIAL REGRESSION.....,A6)
        WRITE(IOUT,4) N,M
4       FORMAT(/23H NUMBER OF OBSERVATION,I4/' HIGHEST DEGREE',I4)
C
C       READ INPUT DATA
        L=N*M
        DO 110 I=1,N
        J=L+I
C       X(I) IS THE INDEPENDENT VARIABLE, AND X(J) IS THE DEPENDENT
C       VARIABLE.
        READ(IN,*) X(I),X(J)
	WRITE (IOUT,*) X(I),X(J)
  110   CONTINUE
        CALL GDATA(N,M,X,XBAR,STD,D,SUMSQ)
        MM=M+1
        SUM=0.0
        NT=N-1
        DO 200 I=1,M
        ISAVE(I)=I
C       FORM SUBSET OF CORRELATION COEFFICIENT MATRIX
        CALL ORDER(M,D,MM,I,ISAVE,DI,E)
C       INVERT THE SUBMATRIX OF CORRELATION COEFFICIENTS
        CALL MINV(DI,I,DET,B,T)
232     CALL MULTR(N,I,XBAR,STD,SUMSQ,DI,E,ISAVE,B,SB,T,ANS)
C
C       PRINT THE RESULT OF CALCULATION
        WRITE(IOUT,5) I
5       FORMAT(/32H POLYNOMIAL REGRESSION OF DEGREE,I3)
        IF(ANS(7)) 140,130,130
130     SUMIP=ANS(4)-SUM
        IF(SUMIP) 140,140,150
140     WRITE(IOUT,13)
13      FORMAT(/17H  NO IMPROVEMENT )
        GO TO 100
150     WRITE(IOUT,6) ANS(1)
6       FORMAT(/'C-----   INTERCEPT'/'      DATA RCPT/',D26.16,'/')
        WRITE(IOUT,7) (J,B(J),J=1,I)
7       FORMAT(/'C-----   REGRESSION COEFFICIENTS'/
     1 ('      DATA D(',I1,') /',D26.16,'/'))
        WRITE(IOUT,8) I
8         FORMAT(/8X,24HANALYSIS OF VARIANCE FOR,I4,19H  DEGREE POLYNOMI
     1AL/)
        WRITE(IOUT,9)
9         FORMAT(/' SOURCE OF VARIATION  DEGREE'6X'SUM OF'8X'MEAN'
     110X'F    IMPROVEMENT'/24X'OF'8X'SQUARES'7X'SQUARE'6X
     2'VALUE  IN TERMS OF'/21X'FREEDOM'39X'SUM OF SQUARE')
        SUM=ANS(4)
        WRITE(IOUT,10) I,ANS(4),ANS(6),ANS(10),SUMIP
10      FORMAT(/' DUE TO REGRESSION',I6,4X,4F13.5)
        NI=ANS(8)
        WRITE(IOUT,11) NI,ANS(7),ANS(9)
11      FORMAT(' DEVIATION ABOUT'/8X'REGRESSION',I6,4X,2F13.5)
        WRITE(IOUT,12) NT,SUMSQ(MM)
12      FORMAT(' TOTAL',12X,I6,4X,F13.5///)
200     CONTINUE
        END


	SUBROUTINE MHOR
     .	(ALPHA,POWER,T,N,C,M,PI,CORRECTED, OR1, OR2)
	USE MSIMSL
	IMPLICIT NONE
!
!  Calculate detectable odds ratio for the Mantel-Haenszel test.
!  OR is derived by interating to find the zero of the mhpowerfcn
!  routine.
!
!   input:
!       alpha=type I error
!       power=power for the uncorrected or corrected M-H chi-square
!       t=number of 2X2 tables
!       n=sample size
!       c(i)=proportion of cases in table i
!       m(i)=number of controls per case in table i
!       pi(i,2)=proportion of successes among controls in table i
!       corrected=uncorrected or corrected result (0 or 1)
!

	REAL POWER, T, C(20), M(20), PI(20), N, ALPHA
	INTEGER CORRECTED

	REAL CPOWER, CT, CC(20), CM(20), CPI(20), CN, CALPHA
	INTEGER CCORRECTED
	COMMON /MHORCOMM/ CPOWER, CT, CC, CM, CPI, CN,
     .		 CALPHA, CCORRECTED

	INTEGER I
	INTEGER    ITMAX, NROOT
	REAL       EPS, ERRABS, ERRREL, ETA
	PARAMETER  (NROOT=2)
!	INTEGER    INFO(NROOT)
	REAL       BPOWERFCN
!	REAL THETA(NROOT)
!	REAL THETAGUESS(NROOT)
	EXTERNAL BPOWERFCN

	REAL OR1, OR2
	real a, b

!	DATA THETAGUESS/100/
!	DATA THETAGUESS/.01,1.01/
!
!  Code:
!
	if (power.lt.alpha) then
		or1=-999
		or2=-999
		return
	end	if
!
!
!  Load input for mhpowerfcn function into common.
!
	CPOWER=POWER
	CT=T
	DO I=1,T
		CC(I)=C(I)
		CM(I)=M(I)
		CPI(I)=PI(I)
	END DO
	CN=N
	CALPHA=ALPHA
	CCORRECTED=CORRECTED
!
!  Set zero finding parameters.
!
	EPS    = 1.0E-4
	ERRABS = 1.0E-4
	ERRREL = 1.0E-4
	ETA    = .01
!
!  Iterate for the detectable odds ratio.
!
	ITMAX  = 100
	a=.01
	b=.99
	CALL ZBREN (bpowerfcn, ERRABS, ERRREL, A, B, ITMAX)
	OR1=b

	ITMAX  = 100
	a=1.01
	b=10
	CALL ZBREN (bpowerfcn, ERRABS, ERRREL, A, B, ITMAX)
	OR2=b

!	CALL ZREAL (BPOWERFCN, ERRABS, ERRREL, EPS, ETA, NROOT,
!     .		ITMAX, THETAGUESS, THETA, INFO)
!
!	OR1=THETA(1)
!	OR2=THETA(2)

!	if (or1.lt.0) or1=-999
!	if (or2.lt.0) or2=-999

	RETURN
	END

	REAL FUNCTION BPOWERFCN(THETA)
!
!  This is function to find the zero when determining the
!  M-H detectable odds ratio.
!
!  i.e., bpowerfcn=power-mhpowerfcn(...,theta,...)
!
	IMPLICIT NONE
	REAL MHPOWERFCN
	REAL THETA

	REAL CPOWER, CT, CC(20), CM(20), CPI(20), CN, CALPHA
	INTEGER CCORRECTED
	COMMON /MHORCOMM/ CPOWER, CT, CC, CM, CPI, CN,
     .		 CALPHA, CCORRECTED
     	REAL LOCALPOWER
!
!  Code.
!
!	write(*,*)" trying THETA=",THETA
!
!
!	IF (THETA.LT.1) THETA=1
!	BPOWERFCN=CPOWER-
!     .	MHPOWERFCN(CALPHA,CN,CT,THETA,CC,CM,CPI,CCORRECTED)
!	BPOWERFCN=CPOWER-
!    .	MHPOWERFCN(CN,CT,CC,CM,THETA,CPI,CALPHA,CCORRECTED)

	LOCALPOWER=MHPOWERFCN(CN,CT,CC,CM,THETA,CPI,CALPHA,CCORRECTED)
	BPOWERFCN=CPOWER-LOCALPOWER
	RETURN
	END


      SUBROUTINE HFTI (A,MDA,M,N,B,MDB,NB,TAU,KRANK,RNORM,H,G,IP)
C
C  SOLVE LEAST SQUARES PROBLEM USING ALGORITHM, HFTI.
C  Householder Forward Triangulation with column Interchanges.
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1973 JUN 12, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
      integer I, II, IP1, J, JB, JJ, K, KP1, KRANK
      integer L, LDIAG, LMAX, M, MDA, MDB, N, NB
C     integer IP(N)
C     double precision A(MDA,N),B(MDB,NB),H(N),G(N),RNORM(NB)
      integer IP(*)
      double precision A(MDA,*),B(MDB, *),H(*),G(*),RNORM( *)
      double precision DIFF, FACTOR, HMAX, SM, TAU, TMP, ZERO
      parameter(FACTOR = 0.001d0, ZERO = 0.0d0)
C     ------------------------------------------------------------------
C
      K=0
      LDIAG=min(M,N)
      IF (LDIAG.LE.0) GO TO 270
          DO 80 J=1,LDIAG
          IF (J.EQ.1) GO TO 20
C
C     UPDATE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
          LMAX=J
              DO 10 L=J,N
              H(L)=H(L)-A(J-1,L)**2
              IF (H(L).GT.H(LMAX)) LMAX=L
   10         CONTINUE
          IF(DIFF(HMAX+FACTOR*H(LMAX),HMAX)) 20,20,50
C
C     COMPUTE SQUARED COLUMN LENGTHS AND FIND LMAX
C    ..
   20     LMAX=J
              DO 40 L=J,N
              H(L)=0.
                  DO 30 I=J,M
   30             H(L)=H(L)+A(I,L)**2
              IF (H(L).GT.H(LMAX)) LMAX=L
   40         CONTINUE
          HMAX=H(LMAX)
C    ..
C     LMAX HAS BEEN DETERMINED
C
C     DO COLUMN INTERCHANGES IF NEEDED.
C    ..
   50     CONTINUE
          IP(J)=LMAX
          IF (IP(J).EQ.J) GO TO 70
              DO 60 I=1,M
              TMP=A(I,J)
              A(I,J)=A(I,LMAX)
   60         A(I,LMAX)=TMP
          H(LMAX)=H(J)
C
C     COMPUTE THE J-TH TRANSFORMATION AND APPLY IT TO A AND B.
C    ..
   70     CALL H12 (1,J,J+1,M,A(1,J),1,H(J),A(1,J+1),1,MDA,N-J)
   80     CALL H12 (2,J,J+1,M,A(1,J),1,H(J),B,1,MDB,NB)
C
C     DETERMINE THE PSEUDORANK, K, USING THE TOLERANCE, TAU.
C    ..
          DO 90 J=1,LDIAG
          IF (ABS(A(J,J)).LE.TAU) GO TO 100
   90     CONTINUE
      K=LDIAG
      GO TO 110
  100 K=J-1
  110 KP1=K+1
C
C     COMPUTE THE NORMS OF THE RESIDUAL VECTORS.
C
      IF (NB.LE.0) GO TO 140
          DO 130 JB=1,NB
          TMP=ZERO
          IF (KP1.GT.M) GO TO 130
              DO 120 I=KP1,M
  120         TMP=TMP+B(I,JB)**2
  130     RNORM(JB)=SQRT(TMP)
  140 CONTINUE
C                                           SPECIAL FOR PSEUDORANK = 0
      IF (K.GT.0) GO TO 160
      IF (NB.LE.0) GO TO 270
          DO 150 JB=1,NB
              DO 150 I=1,N
  150         B(I,JB)=ZERO
      GO TO 270
C
C     IF THE PSEUDORANK IS LESS THAN N COMPUTE HOUSEHOLDER
C     DECOMPOSITION OF FIRST K ROWS.
C    ..
  160 IF (K.EQ.N) GO TO 180
          DO 170 II=1,K
          I=KP1-II
  170     CALL H12 (1,I,KP1,N,A(I,1),MDA,G(I),A,MDA,1,I-1)
  180 CONTINUE
C
C
      IF (NB.LE.0) GO TO 270
          DO 260 JB=1,NB
C
C     SOLVE THE K BY K TRIANGULAR SYSTEM.
C    ..
              DO 210 L=1,K
              SM=ZERO
              I=KP1-L
              IF (I.EQ.K) GO TO 200
              IP1=I+1
                  DO 190 J=IP1,K
  190             SM=SM+A(I,J)*B(J,JB)
  200         continue
  210         B(I,JB)=(B(I,JB)-SM)/A(I,I)
C
C     COMPLETE COMPUTATION OF SOLUTION VECTOR.
C    ..
          IF (K.EQ.N) GO TO 240
              DO 220 J=KP1,N
  220         B(J,JB)=ZERO
              DO 230 I=1,K
  230         CALL H12 (2,I,KP1,N,A(I,1),MDA,G(I),B(1,JB),1,MDB,1)
C
C      RE-ORDER THE SOLUTION VECTOR TO COMPENSATE FOR THE
C      COLUMN INTERCHANGES.
C    ..
  240         DO 250 JJ=1,LDIAG
              J=LDIAG+1-JJ
              IF (IP(J).EQ.J) GO TO 250
              L=IP(J)
              TMP=B(L,JB)
              B(L,JB)=B(J,JB)
              B(J,JB)=TMP
  250         CONTINUE
  260     CONTINUE
C    ..
C     THE SOLUTION VECTORS, X, ARE NOW
C     IN THE FIRST  N  ROWS OF THE ARRAY B(,).
C
  270 KRANK=K
      RETURN
      END


C
C**************************  NUDWT  ************************************
C
C  calculate temporal weighting function W(t) for nudging
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION NUDWT(WFLAG,TT,TTO,TAU)
C
      IMPLICIT NONE
      INTEGER  WFLAG
      REAL*8   TD,TAU2
      REAL*8   TT,TTO,TAU
C
      IF (WFLAG .EQ. 0) THEN
         TD=DABS(TT-TTO)
         TAU2=0.5D0*TAU
         IF (TD .LT. TAU2) THEN
            NUDWT=1.0D0
         ELSE IF (TD .GE. TAU2  .AND.  TD .LE. TAU) THEN
            NUDWT=(TAU - TD)/TAU2
         ELSE
            NUDWT=0.0D0
         END IF
      ELSE
         TD=TT-TTO
         IF (TD .LT. 0.0D0) THEN
            NUDWT=0.0D0
         ELSE
            NUDWT=DEXP(-TD/TAU)
         END IF
      END IF
C
      RETURN
      END


C ******************************************************************
      SUBROUTINE SPLSET(X,Y,M,C)                                        00006970
C ***** CALCULATES TABLE OF COEFFICIENTS FOR SPLINE INTERPOLATION ***
C***** X = INDEPENDENT VARIABLE                                         00006980
C***** Y = DEPENDENT VARIABLE                                           00006990
C***** M = NUMBER OF DATA POINTS IN THE X AND Y ARRAYS                  00007000
C***** C = COEFFICENTS OF THE CUBIC THAT IS FIT BETWEEN ADJACENT DATA PO00007010
C***** THE FOLLOWING DIMENSIONS MUST BE .GE. M                          00007020
      DIMENSION D(81), P(81), E(81), A(81,3), B(81), Z(81)
      DIMENSION X(m),Y(m),C(4,m)
      MM=M-1                                                            00007050
      DO 2 K=1,MM                                                       00007060
      D(K)=X(K+1)-X(K)                                                  00007070
      P(K)=D(K)/6.                                                      00007080
  2   E(K)=(Y(K+1)-Y(K))/D(K)                                           00007090
      DO 3 K=2,MM                                                       00007100
  3   B(K)=E(K)-E(K-1)                                                  00007110
      A(1,2)=-1.-D(1)/D(2)                                              00007120
      A(1,3)=D(1)/D(2)                                                  00007130
      A(2,3)=P(2)-P(1)*A(1,3)                                           00007140
      A(2,2)=2.*(P(1)+P(2))-P(1)*A(1,2)                                 00007150
      A(2,3)=A(2,3)/A(2,2)                                              00007160
      B(2)=B(2)/A(2,2)                                                  00007170
      DO 4  K=3,MM                                                      00007180
      A(K,2)=2.*(P(K-1)+P(K))-P(K-1)*A(K-1,3)                           00007190
      B(K)=B(K)-P(K-1)*B(K-1)                                           00007200
      A(K,3)=P(K)/A(K,2)                                                00007210
  4   B(K)=B(K)/A(K,2)                                                  00007220
      Q=D(M-2)/D(M-1)                                                   00007230
      A(M,1)=1.+Q+A(M-2,3)                                              00007240
      A(M,2)=-Q-A(M,1)*A(M-1,3)                                         00007250
      B(M)=B(M-2)-A(M,1)*B(M-1)                                         00007260
      Z(M)=B(M)/A(M,2)                                                  00007270
      MN=M-2                                                            00007280
      DO 6 I=1,MN                                                       00007290
      K=M-I                                                             00007300
  6   Z(K)=B(K)-A(K,3)*Z(K+1)                                           00007310
      Z(1)=-A(1,2)*Z(2)-A(1,3)*Z(3)                                     00007320
      DO 7 K=1,MM                                                       00007330
      Q=1./(6.*D(K))                                                    00007340
      C(1,K)=Z(K)*Q                                                     00007350
      C(2,K)=Z(K+1)*Q                                                   00007360
      C(3,K)=Y(K)/D(K)-Z(K)*P(K)                                        00007370
  7   C(4,K)=Y(K+1)/D(K)-Z(K+1)*P(K)                                    00007380
      RETURN                                                            00007390
      END                                                               00007400
C
      SUBROUTINE SPLINE (N,X,Y,M,A,B)                                   00006760
C ***** PERFORMS SPLINE INTERPOLATION USING ROUTINE SPLSET **********
      DIMENSION C(4,81),X(n),Y(n),A(m),B(m)
      CALL SPLSET (X,Y,N,C)                                             00006780
      NM=N-1                                                            00006790
      J=1                                                               00006800
      XD=A(1)                                                           00006810
      DO 20 I=1,NM                                                      00006820
      IP=I+1                                                            00006830
      IF (XD.GT.X(IP)) GO TO 20                                         00006840
   10 DA=X(IP)-XD                                                       00006850
      DB=XD-X(I)                                                        00006860
      B(J)=DA*(C(1,I)*DA**2+C(3,I)) + DB*(C(2,I)*DB**2+C(4,I))          00006870
      J=J+1                                                             00006880
      IF (J.GT.M) GO TO 30                                              00006890
      XD=A(J)                                                           00006900
      IF (XD.GT.X(I) .AND. XD.LE.X(IP)) GO TO 10                        00006910
      IF (XD.LE.X(1)) GO TO 10                                          00006920
   20 CONTINUE                                                          00006930
   30 CONTINUE                                                          00006940
      RETURN                                                            00006950
      END                                                               00006960


!*==zgelss.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief  ZGELSS solves overdetermined or underdetermined systems for GE matrices
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download ZGELSS + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE ZGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
!                          WORK, LWORK, RWORK, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
!       DOUBLE PRECISION   RCOND
!       ..
!       .. Array Arguments ..
!       DOUBLE PRECISION   RWORK( * ), S( * )
!       COMPLEX*16         A( LDA, * ), B( LDB, * ), WORK( * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> ZGELSS computes the minimum norm solution to a complex linear
!> least squares problem:
!>
!> Minimize 2-norm(| b - A*x |).
!>
!> using the singular value decomposition (SVD) of A. A is an M-by-N
!> matrix which may be rank-deficient.
!>
!> Several right hand side vectors b and solution vectors x can be
!> handled in a single call; they are stored as the columns of the
!> M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
!> X.
!>
!> The effective rank of A is determined by treating as zero those
!> singular values which are less than RCOND times the largest singular
!> value.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A. M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A. N >= 0.
!> \endverbatim
!>
!> \param[in] NRHS
!> \verbatim
!>          NRHS is INTEGER
!>          The number of right hand sides, i.e., the number of columns
!>          of the matrices B and X. NRHS >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is COMPLEX*16 array, dimension (LDA,N)
!>          On entry, the M-by-N matrix A.
!>          On exit, the first min(m,n) rows of A are overwritten with
!>          its right singular vectors, stored rowwise.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A. LDA >= max(1,M).
!> \endverbatim
!>
!> \param[in,out] B
!> \verbatim
!>          B is COMPLEX*16 array, dimension (LDB,NRHS)
!>          On entry, the M-by-NRHS right hand side matrix B.
!>          On exit, B is overwritten by the N-by-NRHS solution matrix X.
!>          If m >= n and RANK = n, the residual sum-of-squares for
!>          the solution in the i-th column is given by the sum of
!>          squares of the modulus of elements n+1:m in that column.
!> \endverbatim
!>
!> \param[in] LDB
!> \verbatim
!>          LDB is INTEGER
!>          The leading dimension of the array B.  LDB >= max(1,M,N).
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!>          S is DOUBLE PRECISION array, dimension (min(M,N))
!>          The singular values of A in decreasing order.
!>          The condition number of A in the 2-norm = S(1)/S(min(m,n)).
!> \endverbatim
!>
!> \param[in] RCOND
!> \verbatim
!>          RCOND is DOUBLE PRECISION
!>          RCOND is used to determine the effective rank of A.
!>          Singular values S(i) <= RCOND*S(1) are treated as zero.
!>          If RCOND < 0, machine precision is used instead.
!> \endverbatim
!>
!> \param[out] RANK
!> \verbatim
!>          RANK is INTEGER
!>          The effective rank of A, i.e., the number of singular values
!>          which are greater than RCOND*S(1).
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is COMPLEX*16 array, dimension (MAX(1,LWORK))
!>          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
!> \endverbatim
!>
!> \param[in] LWORK
!> \verbatim
!>          LWORK is INTEGER
!>          The dimension of the array WORK. LWORK >= 1, and also:
!>          LWORK >=  2*min(M,N) + max(M,N,NRHS)
!>          For good performance, LWORK should generally be larger.
!>
!>          If LWORK = -1, then a workspace query is assumed; the routine
!>          only calculates the optimal size of the WORK array, returns
!>          this value as the first entry of the WORK array, and no error
!>          message related to LWORK is issued by XERBLA.
!> \endverbatim
!>
!> \param[out] RWORK
!> \verbatim
!>          RWORK is DOUBLE PRECISION array, dimension (5*min(M,N))
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0:  successful exit
!>          < 0:  if INFO = -i, the i-th argument had an illegal value.
!>          > 0:  the algorithm for computing the SVD failed to converge;
!>                if INFO = i, i off-diagonal elements of an intermediate
!>                bidiagonal form did not converge to zero.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date June 2016
!
!> \ingroup complex16GEsolve
!
!  =====================================================================
      SUBROUTINE ZGELSS(M,N,Nrhs,A,Lda,B,Ldb,S,Rcond,Rank,Work,Lwork,   &
     &                  Rwork,Info)
      IMPLICIT NONE
!*--ZGELSS182
!
!  -- LAPACK driver routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     June 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , Ldb , Lwork , M , N , Nrhs , Rank
      DOUBLE PRECISION Rcond
!     ..
!     .. Array Arguments ..
      DOUBLE PRECISION Rwork(*) , S(*)
      COMPLEX*16 A(Lda,*) , B(Ldb,*) , Work(*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      DOUBLE PRECISION ZERO , ONE
      PARAMETER (ZERO=0.0D+0,ONE=1.0D+0)
      COMPLEX*16 CZERO , CONE
      PARAMETER (CZERO=(0.0D+0,0.0D+0),CONE=(1.0D+0,0.0D+0))
!     ..
!     .. Local Scalars ..
      LOGICAL lquery
      INTEGER bl , chunk , i , iascl , ibscl , ie , il , irwork , itau ,&
     &        itaup , itauq , iwork , ldwork , maxmn , maxwrk , minmn , &
     &        minwrk , mm , mnthr
      INTEGER lwork_zgeqrf , lwork_zunmqr , lwork_zgebrd ,              &
     &        lwork_zunmbr , lwork_zungbr , lwork_zunmlq , lwork_zgelqf
      DOUBLE PRECISION anrm , bignum , bnrm , eps , sfmin , smlnum , thr
!     ..
!     .. Local Arrays ..
      COMPLEX*16 dum(1)
!     ..
!     .. External Subroutines ..
      EXTERNAL DLABAD , DLASCL , DLASET , XERBLA , ZBDSQR , ZCOPY ,     &
     &         ZDRSCL , ZGEBRD , ZGELQF , ZGEMM , ZGEMV , ZGEQRF ,      &
     &         ZLACPY , ZLASCL , ZLASET , ZUNGBR , ZUNMBR , ZUNMLQ ,    &
     &         ZUNMQR
!     ..
!     .. External Functions ..
      INTEGER ILAENV
      DOUBLE PRECISION DLAMCH , ZLANGE
      EXTERNAL ILAENV , DLAMCH , ZLANGE
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input arguments
!
      Info = 0
      minmn = MIN(M,N)
      maxmn = MAX(M,N)
      lquery = (Lwork==-1)
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Nrhs<0 ) THEN
         Info = -3
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -5
      ELSEIF ( Ldb<MAX(1,maxmn) ) THEN
         Info = -7
      ENDIF
!
!     Compute workspace
!      (Note: Comments in the code beginning "Workspace:" describe the
!       minimal amount of workspace needed at that point in the code,
!       as well as the preferred amount for good performance.
!       CWorkspace refers to complex workspace, and RWorkspace refers
!       to real workspace. NB refers to the optimal block size for the
!       immediately following subroutine, as returned by ILAENV.)
!
      IF ( Info==0 ) THEN
         minwrk = 1
         maxwrk = 1
         IF ( minmn>0 ) THEN
            mm = M
            mnthr = ILAENV(6,'ZGELSS',' ',M,N,Nrhs,-1)
            IF ( M>=N .AND. M>=mnthr ) THEN
!
!              Path 1a - overdetermined, with many more rows than
!                        columns
!
!              Compute space needed for ZGEQRF
               CALL ZGEQRF(M,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_zgeqrf = dum(1)
!              Compute space needed for ZUNMQR
               CALL ZUNMQR('L','C',M,Nrhs,N,A,Lda,dum(1),B,Ldb,dum(1),  &
     &                     -1,Info)
               lwork_zunmqr = dum(1)
               mm = N
               maxwrk = MAX(maxwrk,N+N*ILAENV(1,'ZGEQRF',' ',M,N,-1,-1))
               maxwrk = MAX(maxwrk,                                     &
     &                  N+Nrhs*ILAENV(1,'ZUNMQR','LC',M,Nrhs,N,-1))
            ENDIF
            IF ( M>=N ) THEN
!
!              Path 1 - overdetermined or exactly determined
!
!              Compute space needed for ZGEBRD
               CALL ZGEBRD(mm,N,A,Lda,S,S,dum(1),dum(1),dum(1),-1,Info)
               lwork_zgebrd = dum(1)
!              Compute space needed for ZUNMBR
               CALL ZUNMBR('Q','L','C',mm,Nrhs,N,A,Lda,dum(1),B,Ldb,    &
     &                     dum(1),-1,Info)
               lwork_zunmbr = dum(1)
!              Compute space needed for ZUNGBR
               CALL ZUNGBR('P',N,N,N,A,Lda,dum(1),dum(1),-1,Info)
               lwork_zungbr = dum(1)
!              Compute total workspace needed
               maxwrk = MAX(maxwrk,2*N+lwork_zgebrd)
               maxwrk = MAX(maxwrk,2*N+lwork_zunmbr)
               maxwrk = MAX(maxwrk,2*N+lwork_zungbr)
               maxwrk = MAX(maxwrk,N*Nrhs)
               minwrk = 2*N + MAX(Nrhs,M)
            ENDIF
            IF ( N>M ) THEN
               minwrk = 2*M + MAX(Nrhs,N)
               IF ( N>=mnthr ) THEN
!
!                 Path 2a - underdetermined, with many more columns
!                 than rows
!
!                 Compute space needed for ZGELQF
                  CALL ZGELQF(M,N,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_zgelqf = dum(1)
!                 Compute space needed for ZGEBRD
                  CALL ZGEBRD(M,M,A,Lda,S,S,dum(1),dum(1),dum(1),-1,    &
     &                        Info)
                  lwork_zgebrd = dum(1)
!                 Compute space needed for ZUNMBR
                  CALL ZUNMBR('Q','L','C',M,Nrhs,N,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_zunmbr = dum(1)
!                 Compute space needed for ZUNGBR
                  CALL ZUNGBR('P',M,M,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_zungbr = dum(1)
!                 Compute space needed for ZUNMLQ
                  CALL ZUNMLQ('L','C',N,Nrhs,M,A,Lda,dum(1),B,Ldb,dum(1)&
     &                        ,-1,Info)
                  lwork_zunmlq = dum(1)
!                 Compute total workspace needed
                  maxwrk = M + lwork_zgelqf
                  maxwrk = MAX(maxwrk,3*M+M*M+lwork_zgebrd)
                  maxwrk = MAX(maxwrk,3*M+M*M+lwork_zunmbr)
                  maxwrk = MAX(maxwrk,3*M+M*M+lwork_zungbr)
                  IF ( Nrhs>1 ) THEN
                     maxwrk = MAX(maxwrk,M*M+M+M*Nrhs)
                  ELSE
                     maxwrk = MAX(maxwrk,M*M+2*M)
                  ENDIF
                  maxwrk = MAX(maxwrk,M+lwork_zunmlq)
               ELSE
!
!                 Path 2 - underdetermined
!
!                 Compute space needed for ZGEBRD
                  CALL ZGEBRD(M,N,A,Lda,S,S,dum(1),dum(1),dum(1),-1,    &
     &                        Info)
                  lwork_zgebrd = dum(1)
!                 Compute space needed for ZUNMBR
                  CALL ZUNMBR('Q','L','C',M,Nrhs,M,A,Lda,dum(1),B,Ldb,  &
     &                        dum(1),-1,Info)
                  lwork_zunmbr = dum(1)
!                 Compute space needed for ZUNGBR
                  CALL ZUNGBR('P',M,N,M,A,Lda,dum(1),dum(1),-1,Info)
                  lwork_zungbr = dum(1)
                  maxwrk = 2*M + lwork_zgebrd
                  maxwrk = MAX(maxwrk,2*M+lwork_zunmbr)
                  maxwrk = MAX(maxwrk,2*M+lwork_zungbr)
                  maxwrk = MAX(maxwrk,N*Nrhs)
               ENDIF
            ENDIF
            maxwrk = MAX(minwrk,maxwrk)
         ENDIF
         Work(1) = maxwrk
!
         IF ( Lwork<minwrk .AND. .NOT.lquery ) Info = -12
      ENDIF
!
      IF ( Info/=0 ) THEN
         CALL XERBLA('ZGELSS',-Info)
         RETURN
      ELSEIF ( lquery ) THEN
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) THEN
         Rank = 0
         RETURN
      ENDIF
!
!     Get machine parameters
!
      eps = DLAMCH('P')
      sfmin = DLAMCH('S')
      smlnum = sfmin/eps
      bignum = ONE/smlnum
      CALL DLABAD(smlnum,bignum)
!
!     Scale A if max element outside range [SMLNUM,BIGNUM]
!
      anrm = ZLANGE('M',M,N,A,Lda,Rwork)
      iascl = 0
      IF ( anrm>ZERO .AND. anrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL ZLASCL('G',0,0,anrm,smlnum,M,N,A,Lda,Info)
         iascl = 1
      ELSEIF ( anrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL ZLASCL('G',0,0,anrm,bignum,M,N,A,Lda,Info)
         iascl = 2
      ELSEIF ( anrm==ZERO ) THEN
!
!        Matrix all zero. Return zero solution.
!
         CALL ZLASET('F',MAX(M,N),Nrhs,CZERO,CZERO,B,Ldb)
         CALL DLASET('F',minmn,1,ZERO,ZERO,S,minmn)
         Rank = 0
         GOTO 100
      ENDIF
!
!     Scale B if max element outside range [SMLNUM,BIGNUM]
!
      bnrm = ZLANGE('M',M,Nrhs,B,Ldb,Rwork)
      ibscl = 0
      IF ( bnrm>ZERO .AND. bnrm<smlnum ) THEN
!
!        Scale matrix norm up to SMLNUM
!
         CALL ZLASCL('G',0,0,bnrm,smlnum,M,Nrhs,B,Ldb,Info)
         ibscl = 1
      ELSEIF ( bnrm>bignum ) THEN
!
!        Scale matrix norm down to BIGNUM
!
         CALL ZLASCL('G',0,0,bnrm,bignum,M,Nrhs,B,Ldb,Info)
         ibscl = 2
      ENDIF
!
!     Overdetermined case
!
      IF ( M>=N ) THEN
!
!        Path 1 - overdetermined or exactly determined
!
         mm = M
         IF ( M>=mnthr ) THEN
!
!           Path 1a - overdetermined, with many more rows than columns
!
            mm = N
            itau = 1
            iwork = itau + N
!
!           Compute A=Q*R
!           (CWorkspace: need 2*N, prefer N+N*NB)
!           (RWorkspace: none)
!
            CALL ZGEQRF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1, &
     &                  Info)
!
!           Multiply B by transpose(Q)
!           (CWorkspace: need N+NRHS, prefer N+NRHS*NB)
!           (RWorkspace: none)
!
            CALL ZUNMQR('L','C',M,Nrhs,N,A,Lda,Work(itau),B,Ldb,        &
     &                  Work(iwork),Lwork-iwork+1,Info)
!
!           Zero out below R
!
            IF ( N>1 ) CALL ZLASET('L',N-1,N-1,CZERO,CZERO,A(2,1),Lda)
         ENDIF
!
         ie = 1
         itauq = 1
         itaup = itauq + N
         iwork = itaup + N
!
!        Bidiagonalize R in A
!        (CWorkspace: need 2*N+MM, prefer 2*N+(MM+N)*NB)
!        (RWorkspace: need N)
!
         CALL ZGEBRD(mm,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),    &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of R
!        (CWorkspace: need 2*N+NRHS, prefer 2*N+NRHS*NB)
!        (RWorkspace: none)
!
         CALL ZUNMBR('Q','L','C',mm,Nrhs,N,A,Lda,Work(itauq),B,Ldb,     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in A
!        (CWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGBR('P',N,N,N,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         irwork = ie + N
!
!        Perform bidiagonal QR iteration
!          multiply B by transpose of left singular vectors
!          compute right singular vectors in A
!        (CWorkspace: none)
!        (RWorkspace: need BDSPAC)
!
         CALL ZBDSQR('U',N,N,0,Nrhs,S,Rwork(ie),A,Lda,dum,1,B,Ldb,      &
     &               Rwork(irwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , N
            IF ( S(i)>thr ) THEN
               CALL ZDRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL ZLASET('F',1,Nrhs,CZERO,CZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors
!        (CWorkspace: need N, prefer N*NRHS)
!        (RWorkspace: none)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL ZGEMM('C','N',N,Nrhs,N,CONE,A,Lda,B,Ldb,CZERO,Work,Ldb)
            CALL ZLACPY('G',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL ZGEMM('C','N',N,bl,N,CONE,A,Lda,B(1,i),Ldb,CZERO,   &
     &                    Work,N)
               CALL ZLACPY('G',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL ZGEMV('C',N,N,CONE,A,Lda,B,1,CZERO,Work,1)
            CALL ZCOPY(N,Work,1,B,1)
         ENDIF
!
      ELSEIF ( N>=mnthr .AND. Lwork>=3*M+M*M+MAX(M,Nrhs,N-2*M) ) THEN
!
!        Underdetermined case, M much less than N
!
!        Path 2a - underdetermined, with many more columns than rows
!        and sufficient workspace for an efficient algorithm
!
         ldwork = M
         IF ( Lwork>=3*M+M*Lda+MAX(M,Nrhs,N-2*M) ) ldwork = Lda
         itau = 1
         iwork = M + 1
!
!        Compute A=L*Q
!        (CWorkspace: need 2*M, prefer M+M*NB)
!        (RWorkspace: none)
!
         CALL ZGELQF(M,N,A,Lda,Work(itau),Work(iwork),Lwork-iwork+1,    &
     &               Info)
         il = iwork
!
!        Copy L to WORK(IL), zeroing out above it
!
         CALL ZLACPY('L',M,M,A,Lda,Work(il),ldwork)
         CALL ZLASET('U',M-1,M-1,CZERO,CZERO,Work(il+ldwork),ldwork)
         ie = 1
         itauq = il + ldwork*M
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize L in WORK(IL)
!        (CWorkspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
!        (RWorkspace: need M)
!
         CALL ZGEBRD(M,M,Work(il),ldwork,S,Rwork(ie),Work(itauq),       &
     &               Work(itaup),Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors of L
!        (CWorkspace: need M*M+3*M+NRHS, prefer M*M+3*M+NRHS*NB)
!        (RWorkspace: none)
!
         CALL ZUNMBR('Q','L','C',M,Nrhs,M,Work(il),ldwork,Work(itauq),B,&
     &               Ldb,Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors of R in WORK(IL)
!        (CWorkspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
!        (RWorkspace: none)
!
         CALL ZUNGBR('P',M,M,M,Work(il),ldwork,Work(itaup),Work(iwork), &
     &               Lwork-iwork+1,Info)
         irwork = ie + M
!
!        Perform bidiagonal QR iteration, computing right singular
!        vectors of L in WORK(IL) and multiplying B by transpose of
!        left singular vectors
!        (CWorkspace: need M*M)
!        (RWorkspace: need BDSPAC)
!
         CALL ZBDSQR('U',M,M,0,Nrhs,S,Rwork(ie),Work(il),ldwork,A,Lda,B,&
     &               Ldb,Rwork(irwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL ZDRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL ZLASET('F',1,Nrhs,CZERO,CZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
         iwork = il + M*ldwork
!
!        Multiply B by right singular vectors of L in WORK(IL)
!        (CWorkspace: need M*M+2*M, prefer M*M+M+M*NRHS)
!        (RWorkspace: none)
!
         IF ( Lwork>=Ldb*Nrhs+iwork-1 .AND. Nrhs>1 ) THEN
            CALL ZGEMM('C','N',M,Nrhs,M,CONE,Work(il),ldwork,B,Ldb,     &
     &                 CZERO,Work(iwork),Ldb)
            CALL ZLACPY('G',M,Nrhs,Work(iwork),Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = (Lwork-iwork+1)/M
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL ZGEMM('C','N',M,bl,M,CONE,Work(il),ldwork,B(1,i),   &
     &                    Ldb,CZERO,Work(iwork),M)
               CALL ZLACPY('G',M,bl,Work(iwork),M,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL ZGEMV('C',M,M,CONE,Work(il),ldwork,B(1,1),1,CZERO,     &
     &                 Work(iwork),1)
            CALL ZCOPY(M,Work(iwork),1,B(1,1),1)
         ENDIF
!
!        Zero out below first M rows of B
!
         CALL ZLASET('F',N-M,Nrhs,CZERO,CZERO,B(M+1,1),Ldb)
         iwork = itau + M
!
!        Multiply transpose(Q) by B
!        (CWorkspace: need M+NRHS, prefer M+NHRS*NB)
!        (RWorkspace: none)
!
         CALL ZUNMLQ('L','C',N,Nrhs,M,A,Lda,Work(itau),B,Ldb,Work(iwork)&
     &               ,Lwork-iwork+1,Info)
!
      ELSE
!
!        Path 2 - remaining underdetermined cases
!
         ie = 1
         itauq = 1
         itaup = itauq + M
         iwork = itaup + M
!
!        Bidiagonalize A
!        (CWorkspace: need 3*M, prefer 2*M+(M+N)*NB)
!        (RWorkspace: need N)
!
         CALL ZGEBRD(M,N,A,Lda,S,Rwork(ie),Work(itauq),Work(itaup),     &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Multiply B by transpose of left bidiagonalizing vectors
!        (CWorkspace: need 2*M+NRHS, prefer 2*M+NRHS*NB)
!        (RWorkspace: none)
!
         CALL ZUNMBR('Q','L','C',M,Nrhs,N,A,Lda,Work(itauq),B,Ldb,      &
     &               Work(iwork),Lwork-iwork+1,Info)
!
!        Generate right bidiagonalizing vectors in A
!        (CWorkspace: need 3*M, prefer 2*M+M*NB)
!        (RWorkspace: none)
!
         CALL ZUNGBR('P',M,N,M,A,Lda,Work(itaup),Work(iwork),           &
     &               Lwork-iwork+1,Info)
         irwork = ie + M
!
!        Perform bidiagonal QR iteration,
!           computing right singular vectors of A in A and
!           multiplying B by transpose of left singular vectors
!        (CWorkspace: none)
!        (RWorkspace: need BDSPAC)
!
         CALL ZBDSQR('L',M,N,0,Nrhs,S,Rwork(ie),A,Lda,dum,1,B,Ldb,      &
     &               Rwork(irwork),Info)
         IF ( Info/=0 ) GOTO 100
!
!        Multiply B by reciprocals of singular values
!
         thr = MAX(Rcond*S(1),sfmin)
         IF ( Rcond<ZERO ) thr = MAX(eps*S(1),sfmin)
         Rank = 0
         DO i = 1 , M
            IF ( S(i)>thr ) THEN
               CALL ZDRSCL(Nrhs,S(i),B(i,1),Ldb)
               Rank = Rank + 1
            ELSE
               CALL ZLASET('F',1,Nrhs,CZERO,CZERO,B(i,1),Ldb)
            ENDIF
         ENDDO
!
!        Multiply B by right singular vectors of A
!        (CWorkspace: need N, prefer N*NRHS)
!        (RWorkspace: none)
!
         IF ( Lwork>=Ldb*Nrhs .AND. Nrhs>1 ) THEN
            CALL ZGEMM('C','N',N,Nrhs,M,CONE,A,Lda,B,Ldb,CZERO,Work,Ldb)
            CALL ZLACPY('G',N,Nrhs,Work,Ldb,B,Ldb)
         ELSEIF ( Nrhs>1 ) THEN
            chunk = Lwork/N
            DO i = 1 , Nrhs , chunk
               bl = MIN(Nrhs-i+1,chunk)
               CALL ZGEMM('C','N',N,bl,M,CONE,A,Lda,B(1,i),Ldb,CZERO,   &
     &                    Work,N)
               CALL ZLACPY('F',N,bl,Work,N,B(1,i),Ldb)
            ENDDO
         ELSE
            CALL ZGEMV('C',M,N,CONE,A,Lda,B,1,CZERO,Work,1)
            CALL ZCOPY(N,Work,1,B,1)
         ENDIF
      ENDIF
!
!     Undo scaling
!
      IF ( iascl==1 ) THEN
         CALL ZLASCL('G',0,0,anrm,smlnum,N,Nrhs,B,Ldb,Info)
         CALL DLASCL('G',0,0,smlnum,anrm,minmn,1,S,minmn,Info)
      ELSEIF ( iascl==2 ) THEN
         CALL ZLASCL('G',0,0,anrm,bignum,N,Nrhs,B,Ldb,Info)
         CALL DLASCL('G',0,0,bignum,anrm,minmn,1,S,minmn,Info)
      ENDIF
      IF ( ibscl==1 ) THEN
         CALL ZLASCL('G',0,0,smlnum,bnrm,N,Nrhs,B,Ldb,Info)
      ELSEIF ( ibscl==2 ) THEN
         CALL ZLASCL('G',0,0,bignum,bnrm,N,Nrhs,B,Ldb,Info)
      ENDIF
 100  Work(1) = maxwrk
!
!     End of ZGELSS
!
      END SUBROUTINE ZGELSS


module wfmath_2d

  use iso_fortran_env, only: sp=>real32, dp=>real64, ip=>int32

  implicit none

  interface wfmath_2d_proj
     module procedure wfmath_2d_proj_dp
     module procedure wfmath_2d_proj_sp
  end interface wfmath_2d_proj

  interface wfmath_2d_iprod
     module procedure wfmath_2d_iprod_dp
     module procedure wfmath_2d_iprod_sp
  end interface wfmath_2d_iprod

  interface wfmath_2d_norm
     module procedure wfmath_2d_norm_dp
     module procedure wfmath_2d_norm_sp
  end interface wfmath_2d_norm

  interface wfmath_2d_normalize
     module procedure wfmath_2d_normalize_dp
     module procedure wfmath_2d_normalize_sp
  end interface wfmath_2d_normalize

  interface wfmath_2d_expec_op
     module procedure wfmath_2d_expec_op_dp
     module procedure wfmath_2d_expec_op_sp
  end interface wfmath_2d_expec_op

  interface wfmath_2d_stdev_op
     module procedure wfmath_2d_stdev_op_dp
     module procedure wfmath_2d_stdev_op_sp
  end interface wfmath_2d_stdev_op

  interface wfmath_2d_expec_grid
     module procedure wfmath_2d_expec_grid_dp
     module procedure wfmath_2d_expec_grid_sp
  end interface wfmath_2d_expec_grid

  interface wfmath_2d_stdev_grid
     module procedure wfmath_2d_stdev_grid_dp
     module procedure wfmath_2d_stdev_grid_sp
  end interface wfmath_2d_stdev_grid

contains

  complex(dp) function wfmath_2d_proj_dp(psi1_arr, psi2_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi1_arr(:,:), psi2_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/proj.src"
  end function wfmath_2d_proj_dp

  complex(sp) function wfmath_2d_proj_sp(psi1_arr, psi2_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi1_arr(:,:), psi2_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = sp

    include "./wfmath_2d_src/proj.src"
  end function wfmath_2d_proj_sp

  complex(dp) function wfmath_2d_iprod_dp(psi1_arr, func_arr, psi2_arr, &
       dgrid) result(val)
    complex(dp), intent(in) :: psi1_arr(:,:), psi2_arr(:,:), func_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/iprod.src"
  end function wfmath_2d_iprod_dp

  complex(sp) function wfmath_2d_iprod_sp(psi1_arr, func_arr, psi2_arr, &
       dgrid) result(val)
    complex(sp), intent(in) :: psi1_arr(:,:), psi2_arr(:,:), func_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/iprod.src"
  end function wfmath_2d_iprod_sp

  real(dp) function wfmath_2d_norm_dp(psi_arr, dgrid) result(val)
    complex(dp), intent(in) :: psi_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/norm.src"
  end function wfmath_2d_norm_dp

  real(sp) function wfmath_2d_norm_sp(psi_arr, dgrid) result(val)
    complex(sp), intent(in) :: psi_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = sp

    include "./wfmath_2d_src/norm.src"
  end function wfmath_2d_norm_sp

  subroutine wfmath_2d_normalize_dp(psi_arr, dgrid)
    complex(dp), intent(inout) :: psi_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/normalize.src"
  end subroutine wfmath_2d_normalize_dp

  subroutine wfmath_2d_normalize_sp(psi_arr, dgrid)
    complex(sp), intent(inout) :: psi_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = sp

    include "./wfmath_2d_src/normalize.src"
  end subroutine wfmath_2d_normalize_sp

  real(dp) function wfmath_2d_expec_op_dp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:,:), op_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/expec_op.src"
  end function wfmath_2d_expec_op_dp

  real(sp) function wfmath_2d_expec_op_sp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:,:), op_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/expec_op.src"
  end function wfmath_2d_expec_op_sp

  real(dp) function wfmath_2d_stdev_op_dp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:,:), op_arr(:,:)
    real(dp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/stdev_op.src"
  end function wfmath_2d_stdev_op_dp

  real(sp) function wfmath_2d_stdev_op_sp(psi_arr, op_arr, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:,:), op_arr(:,:)
    real(sp), intent(in) :: dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/stdev_op.src"
  end function wfmath_2d_stdev_op_sp

  real(dp) function wfmath_2d_expec_grid_dp(psi_arr, grid, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:,:)
    real(dp), intent(in) :: grid(:,:), dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/expec_grid.src"
  end function wfmath_2d_expec_grid_dp

  real(sp) function wfmath_2d_expec_grid_sp(psi_arr, grid, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:,:)
    real(sp), intent(in) :: grid(:,:), dgrid(2)

    integer(ip), parameter :: fp = sp

    include "./wfmath_2d_src/expec_grid.src"
  end function wfmath_2d_expec_grid_sp

  real(dp) function wfmath_2d_stdev_grid_dp(psi_arr, grid, dgrid) &
       result(val)
    complex(dp), intent(in) :: psi_arr(:,:)
    real(dp), intent(in) :: grid(:,:), dgrid(2)

    integer(ip), parameter :: fp = dp

    include "./wfmath_2d_src/stdev_grid.src"
  end function wfmath_2d_stdev_grid_dp

  real(sp) function wfmath_2d_stdev_grid_sp(psi_arr, grid, dgrid) &
       result(val)
    complex(sp), intent(in) :: psi_arr(:,:)
    real(sp), intent(in) :: grid(:,:), dgrid(2)

    integer(ip), parameter :: fp = sp

    include "./wfmath_2d_src/stdev_grid.src"
  end function wfmath_2d_stdev_grid_sp

end module wfmath_2d


      SUBROUTINE EXPINT(AX,AY,ANSX,ANSY)

!PURPOSE: Compute the real & imaginary components and derivatives of
!the function exp(z)E(z) where E(z) is the exponential integral function.
!Originally written by       W.I.F.David      1-SEP-84
!Minor changes by R.B. Von Dreele 1-Aug-1986

!PSEUDOCODE:

!CALLING ARGUMENTS:

      REAL*4        AX,AY               !Real & imaginary parts of argument z
      REAL*4        ANSX,ANSY           !Real & imaginary parts of result

!INCLUDE STATEMENTS:

!LOCAL VARIABLES:

      REAL*4        ZX,ZY
      REAL*4        CLNX,CLNY
      REAL*4        TEMX,TEMY
      REAL*4        SUBX,SUBY
      REAL*4        EULERX
      REAL*4        ZANSX,ZANSY
      REAL*4        DEDZX,DEDZY
      REAL*4        RATX,RATY
      REAL*4        ADDX,ADDY

!SUBROUTINES CALLED:

!FUNCTION DEFINITIONS:

!DATA STATEMENTS:

      DATA EULERX/0.5772156649/

!CODE:

      ZX = AX                              !Z=CMPLX(AX,AY)
      ZY = AY
      AYCH= -1.
      IF (AX .LT. 0.) AYCH= 0.125*AX+4.
      A= SQRT(AX*AX+AY*AY)
      IF (A .LT. 4.0 .OR. ABS(AY) .LT. AYCH) THEN
        ITER= 10 + 4*NINT(A)
        CLNX = 0.5*LOG(ZX**2+ZY**2)            !CLN=CLOG(Z)
        CLNY = ATAN2(ZY,ZX)
        TEMX = FLOAT(ITER)/FLOAT((ITER+1)*(ITER+1))
        TEMY = ZY*TEMX
        TEMX = ZX*TEMX
        SUMX = TEMX                        !SUM=TEM
        SUMY = TEMY
        DO J= ITER,2,-1
          T= 1./FLOAT(J)
          SUBX = 1.- SUMX                  !SUB=1.0-SUM
          SUBY = -SUMY
          T = (1.+T)*(1-T*T)
          TEMX = TEMX*T
          TEMY = TEMY*T
          SUMX = TEMX*SUBX-TEMY*SUBY            !SUM=TEM*SUB
          SUMY = TEMX*SUBY+TEMY*SUBX
        END DO
        TEMX = 1.0-SUMX
        TEMY = -SUMY
        SUMX = TEMX*ZX-TEMY*ZY
        SUMY = TEMX*ZY+TEMY*ZX
        SUMX = -EULERX-CLNX+SUMX
        SUMY = -CLNY+SUMY
        EX = 0.0
        IF ( ZX.GT.-75.0 ) EX = EXP(ZX)
        EY = EX*SIN(ZY)
        EX = EX*COS(ZY)
        ANSX = SUMX*EX-SUMY*EY            !ZANS=SUM*EXP(Z)
        ANSY = SUMX*EY+SUMY*EX
      ELSE
        IF (AX .LT. 0.) A = SQRT((AX+29.)*(AX+29.)/9.0+AY*AY)
        ITER = 4 + NINT(128./A)
        TEMX = FLOAT(ITER)
        ADDX = TEMX
        ADDY = 0.0
        DO I=1,ITER-1
          TEMX = TEMX - 1.
          SUMX = ZX + ADDX                  !SUM = Z+ADD
          SUMY = ZY + ADDY
          X2PY2 = SUMX**2+SUMY**2
          RATX = TEMX*SUMX/X2PY2      !RAT = TEM/SUM
          RATY = -TEMX*SUMY/X2PY2
          RATX = 1.0+RATX
          X2PY2 = RATX**2+RATY**2
          ADDX = TEMX*RATX/X2PY2      !ADD = TEM/(1.+RAT))
          ADDY = -TEMX*RATY/X2PY2
        END DO
        ZX = ZX+ADDX                        !Z=A+ADD
        ZY = ZY+ADDY
        X2PY2 = ZX**2+ZY**2
        ANSX      = ZX/X2PY2                  !ZANS= 1./Z
        ANSY = -ZY/X2PY2
      END IF

      RETURN
      END


module grad_module

  use amrex_fort_module, only : amrex_real, dim=>amrex_spacedim
  use amrex_bc_types_module
  use amrex_filcc_module

  implicit none

  public

contains

  subroutine pushvtog(lo, hi, dlo, dhi, U, U_lo, U_hi, nc) bind(c,name='pushvtog')
    implicit none
    integer, intent(in) :: nc, lo(3),  hi(3), dlo(3), dhi(3)
    integer, intent(in) :: U_lo(3), U_hi(3)
    real(amrex_real), intent(inout) :: U(U_lo(1):U_hi(1),U_lo(2):U_hi(2),U_lo(3):U_hi(3),nc)

    integer :: n
    real(amrex_real) :: xlo(3), dx(3)

    ! Make up something for these that gets what we want
    dx(1:3)  = 1._amrex_real
    xlo(1:3) = 0._amrex_real

    do n = 1,nc
       call hoextraptocc(U(:,:,:,n),U_lo(1),U_lo(2),U_lo(3),U_hi(1),U_hi(2),U_hi(3),lo,hi,dx,xlo)
    enddo

  end subroutine pushvtog

  subroutine gradient(lo, hi, U, U_lo, U_hi, G, G_lo, G_hi, dx) bind(c,name='gradient')
    implicit none
    integer, intent(in) :: lo(3),  hi(3)
    integer, intent(in) :: U_lo(3), U_hi(3), G_lo(3), G_hi(3)
    real(amrex_real), intent(in   ) :: U(U_lo(1):U_hi(1),U_lo(2):U_hi(2),U_lo(3):U_hi(3))
    real(amrex_real), intent(inout) :: G(G_lo(1):G_hi(1),G_lo(2):G_hi(2),G_lo(3):G_hi(3),dim+1)
    real(amrex_real), intent(in)    :: dx(3)
    real(amrex_real) :: dxInv(3)
    integer :: i,j,k

    dxInv(1:3) = 0.5_amrex_real / dx(1:3)
    do k = lo(3),hi(3)
       do j = lo(2),hi(2)
          do i = lo(1),hi(1)
             G(i,j,k,1) = dxInv(1)*(U(i+1,j,k) - U(i-1,j,k))
             G(i,j,k,2) = dxInv(2)*(U(i,j+1,k) - U(i,j-1,k))
             if (dim .gt. 2) then
                G(i,j,k,3) = dxInv(3)*(U(i,j,k+1) - U(i,j,k-1))
             else
                G(i,j,k,3) = 0._amrex_real
             endif
             G(i,j,k,dim+1) = SQRT(G(i,j,k,1)**2 + G(i,j,k,2)**2 + G(i,j,k,3)**2)
          enddo
       enddo
    enddo
  end subroutine gradient

end module grad_module


subroutine BAtoHilmRhoH(cilm, ba, grid, lmax, nmax, mass, r0, rho, gridtype, &
                        w, plx, zero, filter_type, filter_deg, lmax_calc, &
                        exitstatus)
!-------------------------------------------------------------------------------
!
!   This routine will compute the next estimate of Moho coefficients
!   given an initial estimate of the moho in a gridded data file. This
!   is simply Equation 18 in Wieczorek and Phillips (1998), modified to
!   take into account lateral variations in density as from eq. 30 of
!   Wieczorek (2007). Note that the degree-0 topography must be included
!   in the gridded relief. Note that the array plx is optional, and should
!   not be precomputed when memory is an issue (i.e., lmax>360).
!
!   Calling Parameters
!
!       IN
!           ba          Bouguer Anomaly spherical harmonic coefficients.
!           grid        Initial estimate of Moho refief, gridded according
!                       to a call to Makegrid.
!           lmax        Maxmimum spherical harmonic degree to compute.
!           nmax        Order of potential coefficient expansion.
!           mass        Mass of planet.
!           R0          The radius that the coefficients are referenced to.
!           rho         Laterally varying density contrast between the mantle
!                       and crust.
!           gridtype    1 = Gauss-Legendre quadrature grid corresponding
!                       to LMAX. 2 = N by N Driscoll and Healy grid
!                       corresponding to LMAX. 3 = N by 2N Driscoll and Healy
!                       grid corresponding to LMAX.
!
!       OUT
!           cilm        Estimate of Moho relief spherical harmonic coefficients,
!                       with dimensions (2, lmax+1, lmax+1).
!
!       OPTIONAL
!           w           Gauss-Legendre points used in integrations (for
!                       GRIDTYPE=1, determined from a call to SHGLQ).
!           zero        Array of dimension lmax+1 that contains the latitudinal
!                       gridpoints used in the Gauss-Legendre quadrature
!                       integration scheme (For GRIDTYPE=1). Only needed if plx
!                       is not included.
!           plx         Input array of Associated Legendre Polnomials computed
!                       at the Gauss points (for GRIDTYPE=1, determined from a
!                       call to SHGLQ). If this is not included, then the
!                       optional array zero MUST be inlcuded.
!           filter_deg  If specified, each interation will be filtered
!                       according to equation 18 in Wieczorek and Phillips
!                       (1998), where the value of filter_deg corresponds to
!                       the spherical harmonic degree where the filter is 1/2.
!           filter_type If filter_deg is specified, this must be as well.
!                       A value of (0) corresponds to none, (1) corresponds to
!                       the minimum amplitude filter in Wieczorek and Phillips
!                       (1998), whereas as value of (2) corresponds to a minimum
!                       curvature filter.
!           lmax_calc   Maximum degree to compute spherical harmonic
!                       expansions.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   All units assumed to be SI.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only:  SHExpandGLQ, SHExpandDH, DownContFilterMA, &
                        DownContFilterMC, MakeGridGLQ, MakeGridDH
    use ftypes

    implicit none

    real(dp), intent(out) :: cilm(:,:,:)
    real(dp), intent(in) :: ba(:,:,:), grid(:,:), mass, r0, rho(:,:)
    real(dp), intent(in), optional :: plx(:,:), zero(:), w(:)
    integer, intent(in) :: lmax, nmax, gridtype
    integer, intent(in), optional :: filter_type, filter_deg, lmax_calc
    integer, intent(out), optional :: exitstatus
    real(dp) :: prod, pi, d, filter(lmax+1)
    real(dp), allocatable :: cilmn(:, :, :), grid2(:,:)
    integer  :: j, l, n, nlong, nlat, astat(2), lmax_out, lmax_calc2, n_out

    if (present(exitstatus)) exitstatus = 0

    pi = acos(-1.0_dp)

    if (present(lmax_calc)) then
        if (lmax_calc > lmax .or. lmax_calc < 0) then
            print*, "Error -- BAtoHilmRhoH"
            print*, "LMAX_CALC must be less than or equal to LMAX."
            print*, "LMAX = ", lmax
            print*, "LMAX_CALC = ", lmax_calc
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        lmax_calc2 = lmax_calc

    else
        lmax_calc2 = lmax

    end if

    if (size(cilm(:,1,1)) < 2 .or. size(cilm(1,:,1)) < lmax_calc2+1 .or. &
        size(cilm(1,1,:)) < lmax_calc2+1) then
        print*, "Error --- BAtoHilmRhoH"
        print*, "CILM must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax_calc2
        print*, "Input dimension is ", size(cilm(:,1,1)), size(cilm(1,:,1)), &
                                       size(cilm(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (size(ba(:,1,1)) < 2 .or. size(ba(1,:,1)) < lmax_calc2+1 .or. &
             size(ba(1,1,:)) < lmax_calc2+1) then
        print*, "Error --- BAtoHilmRhoH"
        print*, "BA must be dimensioned as (2, LMAX+1, LMAX+1) " // &
                "where LMAX is ", lmax_calc2
        print*, "Input dimension is ", size(ba(:,1,1)), size(ba(1,:,1)), &
                                       size(ba(1,1,:))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (gridtype == 1) then
        nlat = lmax+1
        nlong = 2 * lmax + 1

    else if (gridtype == 2) then
        nlat = 2 * lmax+2
        nlong = nlat

    else if (gridtype == 3) then
        nlat = 2 * lmax+2
        nlong = 2 * nlat

    else
        print*, "Error --- BAtoHilmRhoH"
        print*, "GRIDTYPE must be 1 (Gauss-Legendre Quadrature), " // &
                "2 (Driscoll-Healy NxN) or 3 (Driscoll-Healy Nx2N)"
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    end if

    if (size(grid(1,:)) < nlong .or. size(grid(:,1)) <  nlat .or. &
        size(rho(1,:)) < nlong .or. size(rho(:,1)) <  nlat) then
        print*, "Error --- BAtoHilmRhoH"
        print*, "GRID and RHO must be dimensioned as (NLAT, NLONG) where"
        print*, "NLAT = ", nlat
        print*, "NLONG = ", nlong
        print*, "Input dimension of GRID is ", size(grid(1,:)), size(grid(:,1))
        print*, "Input dimension of RHO is ", size(rho(1,:)), size(rho(:,1))
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    end if

    if (present(w)) then
        if (gridtype /= 1) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "W can only be present when GRIDTYPE is 1 " // &
                    "(Gauss-Legendre Quadrature)"
            print*, "GRIDTYPE = ", gridtype
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        else if(size(w) < lmax+1) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "W must be dimensioned as (LMAX+1) where LMAX is ", lmax
            print*, "Input dimension is ", size(w)
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        end if

    end if

    if (present(zero)) then
        if (gridtype /= 1) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "ZERO can only be present when GRIDTYPE is 1 " //&
                    "(Gauss-Legendre Quadrature)"
            print*, "GRIDTYPE = ", gridtype
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        else if (size(zero) < lmax + 1) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "ZERO must be dimensioned as (LMAX+1) where LMAX is ", lmax
            print*, "Input dimension is ", size(zero)
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(plx)) then
        if (gridtype /= 1) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "PLX can only be present when GRIDTYPE is 1 " // &
                    "(Gauss-Legendre Quadrature)"
            print*, "GRIDTYPE = ", gridtype
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        else if (size(plx(:,1)) < lmax+1 .or. &
                    size(plx(1,:)) < (lmax+1)*(lmax+2)/2) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "PLX must be dimensioned as (LMAX+1, " // &
                    "(LMAX+1)*(LMAX+2)/2) where LMAX is ", lmax
            print*, "Input dimension is ", size(plx(:,1)), size(plx(1,:))
            if (present(exitstatus)) then
                exitstatus = 1
                return
            else
                stop
            end if

        end if

    end if

    if (present(w)) then
        if (present(plx) .and. present(zero)) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "If the optional parameter W is present, then only " // &
                    "one of PLX and ZERO must also be present."
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        end if

        if (.not. present(plx) .and. .not. present(zero)) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "If the optional parameter W is present, then one " // &
                    "of PLX or ZERO must also be present."
            if (present(exitstatus)) then
                exitstatus = 5
                return
            else
                stop
            end if

        end if

    end if

    if (present(filter_type)) then
        if (filter_type /=0 .and. filter_type /=1 .and. filter_type /=2) then
            print*, "Error --- BAtoHilmRhoH"
            print*, "FILTER_TYPE must be either 0 (none), " // &
                    "1 (minimum amplitude), or 2 (minimum curvature)"
            print*, "Input value is ", filter_type
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

        if (filter_type == 1 .or. filter_type == 2) then
            if (.not. present(filter_deg)) then
                print*, "Error --- BAtoHilmRhoH"
                print*, "If FILTER_TYPE is present and equal to 1 or 2, " // &
                        "so mush FILTER_DEG."
                if (present(exitstatus)) then
                    exitstatus = 5
                    return
                else
                    stop
                end if

            end if

        end if

    end if

    allocate (cilmn(2, lmax_calc2+1, lmax_calc2+1), stat = astat(1))
    allocate (grid2(nlat, nlong), stat = astat(2))
    if (astat(1) /= 0 .or. astat(2) /= 0) then
        print*, "Error --- BAtoHilmRhoH"
        print*, "Problem allocating arrays CILMN and GRID2", astat(1), astat(2)
        if (present(exitstatus)) then
            exitstatus = 3
            return
        else
            stop
        end if

    end if

    !--------------------------------------------------------------------------
    !
    !   Do the expansions
    !
    !--------------------------------------------------------------------------
    cilm = 0.0_dp
    cilmn = 0.0_dp

    grid2(1:nlat,1:nlong) = grid(1:nlat,1:nlong)

    if (gridtype == 1) then
        if (present(plx)) then
            if (present(exitstatus)) then
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = 0, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = 0)
            end if
        else
            if (present(exitstatus)) then
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, lmax_calc = 0, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, lmax_calc = 0)
            end if
        end if

    else if (gridtype == 2) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = 0, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, lmax_calc = 0)
        end if

    else if (gridtype == 3) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = 0, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, lmax_calc = 0)
        end if

    end if

    d = cilmn(1,1,1)

    ! calculate (rho*h)_00
    grid2(1:nlat,1:nlong) = (grid(1:nlat,1:nlong) - d) * rho(1:nlat,1:nlong)

    if (gridtype == 1) then
        if (present(plx)) then
            if (present(exitstatus)) then
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = 0, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = 0)
            end if
        else
            if (present(exitstatus)) then
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, lmax_calc = 0, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, lmax_calc = 0)
            end if
        end if

    else if (gridtype == 2) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = 0, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, lmax_calc = 0)
        end if

    else if (gridtype == 3) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = 0, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, lmax_calc = 0)
        end if

    end if

    cilm(1,1,1) = cilmn(1,1,1)

    ! Calculate first term resulting from Bouguer anomaly
    filter = 1.0_dp

    if (present(filter_type) .and. present(filter_deg)) then
        do l = 1, lmax_calc2
            if (filter_type == 1) then
                filter(l+1) = DownContFilterMA(l, filter_deg, r0, d)

            else if(filter_type == 2) then
                filter(l+1) = DownContFilterMC(l, filter_deg, r0, d)

            end if

        end do

    end if

    do l = 1, lmax_calc2
        cilm(1:2,l+1,1:l+1) = filter(l+1) * ba(1:2,l+1,1:l+1) * mass &
                              * dble(2*l+1) * ((r0 / d)**l) &
                              / (4.0_dp * pi * d**2)
    end do

    ! calculate higher order terms
    do n = 2, nmax

        grid2(1:nlat,1:nlong) = rho(1:nlat,1:nlong) &
                                * ((grid(1:nlat,1:nlong) - d) / d)**n

        if (gridtype == 1) then
            if (present(plx)) then
                if (present(exitstatus)) then
                    call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                    w(1:lmax+1), &
                                    plx=plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                    norm = 1, csphase = 1, &
                                    lmax_calc = lmax_calc2, &
                                    exitstatus = exitstatus)
                    if (exitstatus /= 0) return
                else
                    call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                    w(1:lmax+1), &
                                    plx=plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                    norm = 1, csphase = 1, &
                                    lmax_calc = lmax_calc2)
                end if
            else
                if (present(exitstatus)) then
                    call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                     w(1:lmax+1), zero = zero(1:lmax+1), &
                                     norm = 1, csphase = 1, &
                                     lmax_calc = lmax_calc2, &
                                     exitstatus = exitstatus)
                    if (exitstatus /= 0) return
                else
                    call SHExpandGLQ(cilmn, lmax, grid2(1:nlat,1:nlong), &
                                     w(1:lmax+1), zero = zero(1:lmax+1), &
                                     norm = 1, csphase = 1, &
                                     lmax_calc = lmax_calc2)
                end if
            end if

        else if (gridtype == 2) then
            if (present(exitstatus)) then
                call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                                norm = 1, sampling = 1, csphase = 1, &
                                lmax_calc = lmax_calc2, &
                                exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                                norm = 1, sampling = 1, csphase = 1, &
                                lmax_calc = lmax_calc2)
            end if

        else if (gridtype == 3) then
            if (present(exitstatus)) then
                call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                                norm = 1, sampling = 2, csphase = 1, &
                                lmax_calc = lmax_calc2, &
                                exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilmn, lmax_out, &
                                norm = 1, sampling = 2, csphase = 1, &
                                lmax_calc = lmax_calc2)
            end if

        end if

        do l = 1, lmax_calc2
            prod = 1.0_dp

            do j = 1, n
                prod = prod * dble(l+4-j)
            end do

            prod = d * prod / (dble(l+3) * fact(n))

            cilm(1:2,l+1,1:l+1) = cilm(1:2,l+1,1:l+1) &
                                  - filter(l+1)*cilmn(1:2,l+1,1:l+1) * prod

        end do

    end do

    ! make grid of (h*rho)_lm
    if (gridtype == 1) then
        if (present(plx)) then
            if (present(exitstatus)) then
                call MakeGridGLQ(grid2(1:nlat,1:nlong), cilm, lmax, &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, &
                                 lmax_calc = lmax_calc2, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call MakeGridGLQ(grid2(1:nlat,1:nlong), cilm, lmax, &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = lmax_calc2)
            end if
        else
            if (present(exitstatus)) then
                call MakeGridGLQ(grid2(1:nlat,1:nlong), cilm, lmax, &
                                 zero = zero(1:lmax+1), norm = 1, csphase = 1,&
                                 lmax_calc = lmax_calc2, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call MakeGridGLQ(grid2(1:nlat,1:nlong), cilm, lmax, &
                                 zero = zero(1:lmax+1), norm = 1, csphase = 1,&
                                 lmax_calc = lmax_calc2)
            end if
        end if

    else if (gridtype == 2) then
        if (present(exitstatus)) then
            call MakeGridDH(grid2(1:nlat,1:nlong), n_out, cilm, lmax, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = lmax_calc2, &
                            exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call MakeGridDH(grid2(1:nlat,1:nlong), n_out, cilm, lmax, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = lmax_calc2)
        end if

    else if (gridtype == 3) then
        if (present(exitstatus)) then
            call MakeGridDH(grid2(1:nlat,1:nlong), n_out, cilm, lmax, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = lmax_calc2, &
                            exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call MakeGridDH(grid2(1:nlat,1:nlong), n_out, cilm, lmax, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = lmax_calc2)
        end if

    end if

    ! convert grid
    grid2(1:nlat,1:nlong) = grid2(1:nlat,1:nlong) / rho(1:nlat,1:nlong)

    if (gridtype == 1) then
        if (present(plx)) then
            if (present(exitstatus)) then
                call SHExpandGLQ(cilm, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, &
                                 lmax_calc = lmax_calc2, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilm, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), &
                                 plx = plx(1:lmax+1, 1:(lmax+1)*(lmax+2)/2), &
                                 norm = 1, csphase = 1, lmax_calc = lmax_calc2)
            end if
        else
            if (present(exitstatus)) then
                call SHExpandGLQ(cilm, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, &
                                 lmax_calc = lmax_calc2, &
                                 exitstatus = exitstatus)
                if (exitstatus /= 0) return
            else
                call SHExpandGLQ(cilm, lmax, grid2(1:nlat,1:nlong), &
                                 w(1:lmax+1), zero = zero(1:lmax+1), &
                                 norm = 1, csphase = 1, &
                                 lmax_calc = lmax_calc2)
            end if
        end if

    else if (gridtype == 2) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilm, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = lmax_calc2, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilm, lmax_out, &
                            norm = 1, sampling = 1, csphase = 1, &
                            lmax_calc = lmax_calc2)
        end if

    else if (gridtype == 3) then
        if (present(exitstatus)) then
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilm, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = lmax_calc2, exitstatus = exitstatus)
            if (exitstatus /= 0) return
        else
            call SHExpandDH(grid2(1:nlat,1:nlong), nlat, cilm, lmax_out, &
                            norm = 1, sampling = 2, csphase = 1, &
                            lmax_calc = lmax_calc2)
        end if

    end if

    cilm(1,1,1) = d

    deallocate (cilmn)
    deallocate (grid2)

    CONTAINS

        function fact(i)
        !----------------------------------------------------------------------
        !
        !   This function computes the factorial of an integer
        !
        !----------------------------------------------------------------------
            implicit none
            integer :: i, j
            real(dp) :: fact

            if (i == 0) then
                fact = 1.0_dp

            else if (i < 0) then
                print*, "Argument to FACT must be positive"
                if (present(exitstatus)) then
                    exitstatus = 2
                    return
                else
                    stop
                end if

            else
                fact = 1.0_dp
                do j = 1, i
                    fact = fact * j
                end do

            end if

        end function fact

end subroutine BAtoHilmRhoH


module ISO
use ISO_FORTRAN_ENV

implicit none

integer(kind = int8), parameter :: is = int8, id = int16, il = int32, ix = int64
integer(kind = int8), parameter :: rs = real32, rd = real64, rl = real128
! s : Short, d : Double, l : Large, x : eXtralarge

integer(kind = int8), parameter :: wp = rd

end module ISO


subroutine multigrid_correction(u_h, e_h, nx, ny)
!use variables
use kind_parameters
implicit none

integer:: i, j, nx, ny
real(kind=dp), intent(in), dimension(nx,ny):: e_h
real(kind=dp), intent(inout), dimension(nx,ny):: u_h
real(kind=dp):: alpha

! Correct the values of u_h using e_h
! Input
! u_h   Variable in grid h
! e_h   Estimated error in grid h
! h     grid spacing
!
! Output
! u_h   Updated value of u_h

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012

do j = 2,ny-1

    do i = 2,nx-1

        u_h(i,j) = u_h(i,j) + e_h(i,j)

    end do

end do

end subroutine


SUBROUTINE dfpmin_sp(p,gtol,iter,fret,func,dfunc)
  use mo_kind,   only: i4, sp, lgt
  use mo_nrutil, only: nrerror,outerprod,unit_matrix,vabs
  use mo_nr,     only: lnsrch

  IMPLICIT NONE

  REAL(SP), DIMENSION(:), INTENT(INOUT) :: p
  REAL(SP),               INTENT(IN)    :: gtol
  INTEGER(I4),            INTENT(OUT)   :: iter
  REAL(SP),               INTENT(OUT)   :: fret

  INTERFACE
     FUNCTION func(p)
       use mo_kind, only: sp
       IMPLICIT NONE
       REAL(SP), DIMENSION(:), INTENT(IN) :: p
       REAL(SP) :: func
     END FUNCTION func
     !BL
     FUNCTION dfunc(p)
       use mo_kind, only: sp
       IMPLICIT NONE
       REAL(SP), DIMENSION(:), INTENT(IN) :: p
       REAL(SP), DIMENSION(size(p)) :: dfunc
     END FUNCTION dfunc
  END INTERFACE

  ! local variables
  INTEGER(I4), PARAMETER               :: ITMAX=200
  REAL(SP),    PARAMETER               :: STPMX=100.0_sp,EPS=epsilon(p),TOLX=4.0_sp*EPS
  INTEGER(I4)                          :: its
  LOGICAL(lgt)                         :: check
  REAL(SP)                             :: den,fac,fad,fae,fp,stpmax,sumdg,sumxi
  REAL(SP), DIMENSION(size(p))         :: dg,g,hdg,pnew,xi
  REAL(SP), DIMENSION(size(p),size(p)) :: hessin

  fp=func(p)
  g=dfunc(p)
  call unit_matrix(hessin)
  xi=-g
  stpmax=STPMX*max(vabs(p),real(size(p),sp))
  do its=1,ITMAX
     iter=its
     call lnsrch(p,fp,g,xi,pnew,fret,stpmax,check,func)
     fp=fret
     xi=pnew-p
     p=pnew
     if (maxval(abs(xi)/max(abs(p),1.0_sp)) < TOLX) RETURN
     dg=g
     g=dfunc(p)
     den=max(fret,1.0_sp)
     if (maxval(abs(g)*max(abs(p),1.0_sp)/den) < gtol) RETURN
     dg    = g-dg
     hdg   = matmul(hessin,dg)
     fac   = dot_product(dg,xi)
     fae   = dot_product(dg,hdg)
     sumdg = dot_product(dg,dg)
     sumxi = dot_product(xi,xi)
     if (fac**2 > EPS*sumdg*sumxi) then
        fac    = 1.0_sp/fac
        fad    = 1.0_sp/fae
        dg     = fac*xi-fad*hdg
        hessin = hessin+fac*outerprod(xi,xi)-&
             fad*outerprod(hdg,hdg)+fae*outerprod(dg,dg)
     end if
     xi = -matmul(hessin,g)
  end do
  call nrerror('dfpmin: too many iterations')
END SUBROUTINE dfpmin_sp

SUBROUTINE dfpmin_dp(p,gtol,iter,fret,func,dfunc)
  use mo_kind,   only: i4, dp, lgt
  use mo_nrutil, only: nrerror,outerprod,unit_matrix,vabs
  use mo_nr,     only: lnsrch

  IMPLICIT NONE

  REAL(DP), DIMENSION(:), INTENT(INOUT) :: p
  REAL(DP),               INTENT(IN)    :: gtol
  INTEGER(I4),            INTENT(OUT)   :: iter
  REAL(DP),               INTENT(OUT)   :: fret

  INTERFACE
     FUNCTION func(p)
       use mo_kind, only: dp
       IMPLICIT NONE
       REAL(DP), DIMENSION(:), INTENT(IN) :: p
       REAL(DP) :: func
     END FUNCTION func
     !BL
     FUNCTION dfunc(p)
       use mo_kind, only: dp
       IMPLICIT NONE
       REAL(DP), DIMENSION(:), INTENT(IN) :: p
       REAL(DP), DIMENSION(size(p)) :: dfunc
     END FUNCTION dfunc
  END INTERFACE

  ! local variables
  INTEGER(I4), PARAMETER               :: ITMAX=200
  REAL(DP),    PARAMETER               :: STPMX=100.0_dp,EPS=epsilon(p),TOLX=4.0_dp*EPS
  INTEGER(I4)                          :: its
  LOGICAL(lgt)                         :: check
  REAL(DP)                             :: den,fac,fad,fae,fp,stpmax,sumdg,sumxi
  REAL(DP), DIMENSION(size(p))         :: dg,g,hdg,pnew,xi
  REAL(DP), DIMENSION(size(p),size(p)) :: hessin

  fp=func(p)
  g=dfunc(p)
  call unit_matrix(hessin)
  xi=-g
  stpmax=STPMX*max(vabs(p),real(size(p),dp))
  do its=1,ITMAX
     iter=its
     call lnsrch(p,fp,g,xi,pnew,fret,stpmax,check,func)
     fp=fret
     xi=pnew-p
     p=pnew
     if (maxval(abs(xi)/max(abs(p),1.0_dp)) < TOLX) RETURN
     dg=g
     g=dfunc(p)
     den=max(fret,1.0_dp)
     if (maxval(abs(g)*max(abs(p),1.0_dp)/den) < gtol) RETURN
     dg    = g-dg
     hdg   = matmul(hessin,dg)
     fac   = dot_product(dg,xi)
     fae   = dot_product(dg,hdg)
     sumdg = dot_product(dg,dg)
     sumxi = dot_product(xi,xi)
     if (fac**2 > EPS*sumdg*sumxi) then
        fac    = 1.0_dp/fac
        fad    = 1.0_dp/fae
        dg     = fac*xi-fad*hdg
        hessin = hessin+fac*outerprod(xi,xi)-&
             fad*outerprod(hdg,hdg)+fae*outerprod(dg,dg)
     end if
     xi = -matmul(hessin,g)
  end do
  call nrerror('dfpmin: too many iterations')
END SUBROUTINE dfpmin_dp


c     ============================================
      subroutine setaux(maxmx,mbc,mx,xlower,dx,maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c     # variable coefficient acoustics
c     #  aux(i,1) = impedance Z in i'th cell
c     #  aux(i,2) = sound speed c in i'th cell
c
c
c     # rho value for i-1 < x < i is determined by rho(i)
c     # input from setprob.rho in setprob.f
c
c
      implicit double precision (a-h,o-z)
      dimension aux(1-mbc:maxmx+mbc, 2)
      common /comaux/ rho(1000)

      open(unit=31,file='fort.aux',status='unknown',form='formatted')
c

       do i=1-mbc,mx+mbc
          xcell = xlower + (i-0.5d0)*dx
c         # truncate to an integer to determine which layer xcell is in:
	  ix = xcell + 1
	  if (ix.lt.1) ix = 1
	  aux(i,2) = 1.d0
 	  aux(i,1) = rho(ix)*aux(i,2)
c         # uniform for comparison:
c	  aux(i,1) = aux(i,2)
	  enddo

	do i=1,mx
          write(31,701) aux(i,1), aux(i,2)
  701     format(2e16.6)
          enddo

       close(unit=31)
c
       return
       end


MODULE shared_constants

    !/*	setup	                */

    IMPLICIT NONE

!******************************************************************************
!******************************************************************************

    INTEGER, PARAMETER          :: our_int      = selected_int_kind(9)
    INTEGER, PARAMETER          :: our_dble     = selected_real_kind(15, 307)

    INTEGER(our_int), PARAMETER :: zero_int     = 0_our_int
    INTEGER(our_int), PARAMETER :: one_int      = 1_our_int
    INTEGER(our_int), PARAMETER :: two_int      = 2_our_int
    INTEGER(our_int), PARAMETER :: three_int    = 3_our_int

    REAL(our_dble), PARAMETER   :: zero_dble    = 0.00_our_dble
    REAL(our_dble), PARAMETER   :: half_dble    = 0.50_our_dble
    REAL(our_dble), PARAMETER   :: one_dble     = 1.00_our_dble
    REAL(our_dble), PARAMETER   :: two_dble     = 2.00_our_dble
    REAL(our_dble), PARAMETER   :: three_dble   = 3.00_our_dble

    REAL(our_dble), PARAMETER   :: pi           = 3.141592653589793238462643383279502884197_our_dble
    REAL(our_dble), PARAMETER   :: eps          = epsilon(one_dble)

    ! Variables that are part of the FORTRAN initialization file and remain unchanged during the run. These are often used to construct explicit-shape arrays. The same reasoning applied to MAX_STATES_PERIOD which is determined durint the state space creation.
    INTEGER(our_int)            :: max_states_period
    INTEGER(our_int)            :: num_points_interp
    INTEGER(our_int)            :: num_agents_est
    INTEGER(our_int)            :: num_agents_sim
    INTEGER(our_int)            :: num_draws_emax
    INTEGER(our_int)            :: num_draws_prob
    INTEGER(our_int)            :: num_periods
    INTEGER(our_int)            :: num_free
    INTEGER(our_int)            :: min_idx

    ! This variable needs to be accessible during optimization. It is defined here as it is required by the optimizers as well.
    INTEGER(our_int)            :: num_eval = zero_int

    ! Variables that need to be aligned across FORTRAN and PYTHON implementations.
    INTEGER(our_int), PARAMETER :: MISSING_INT                  = -99_our_int

    REAL(our_dble), PARAMETER   :: INADMISSIBILITY_PENALTY      = -40000.00_our_dble
    REAL(our_dble), PARAMETER   :: MISSING_FLOAT                = -99.0_our_dble
    REAL(our_dble), PARAMETER   :: SMALL_FLOAT                  = 1.0e-5_our_dble
    REAL(our_dble), PARAMETER   :: TINY_FLOAT                   = 1.0e-8_our_dble
    REAL(our_dble), PARAMETER   :: HUGE_FLOAT                   = 1.0e20_our_dble
    REAL(our_dble), PARAMETER   :: LARGE_FLOAT                  = 1.0e8_our_dble

!******************************************************************************
!******************************************************************************
END MODULE


chapter xiv, example 1. cubic smoothing spline
c  from  * a practical guide to splines *  by c. de boor
calls  bsplpp(bsplvb), ppvalu(interv), smooth(setupq,chol1d)
c     values from a cubic b-spline are rounded to  n d i g i t  places
c  after the decimal point, then smoothed via  s m o o t h  for
c  various values of the control parameter  s .
      integer i,is,j,l,lsm,ndigit,npoint,ns
      real a(61,4),bcoef(7),break(5),coef(4,4),coefsm(4,60),dely,dy(61)
     *    ,s(20),scrtch(427),sfp,t(11),tenton,x(61),y(61)
      equivalence (scrtch,coefsm)
      data t /4*0.,1.,3.,4.,4*6./
      data bcoef /3*0.,1.,3*0./
      call bsplpp(t,bcoef,7,4,scrtch,break,coef,l)
      npoint = 61
      read 500,ndigit,ns,(s(i),i=1,ns)
  500 format(2i3/(e10.4))
      print 600,ndigit
  600 format(24h exact values rounded to,i2,21h digits after decimal
     *       ,7h point./)
      tenton = 10.**ndigit
      dely = .5/tenton
      do 10 i=1,npoint
         x(i) = .1*float(i-1)
         y(i) = ppvalu(break,coef,l,4,x(i),0)
         y(i) = float(ifix(y(i)*tenton + .5))/tenton
   10    dy(i) = dely
      do 15 i=1,npoint,5
         do 15 j=1,4
   15       a(i,j) = ppvalu(break,coef,l,4,x(i),j-1)
      print 615,(i,(a(i,j),j=1,4),i=1,npoint,5)
  615 format(52h value and derivatives of noisefree function at some
     *      ,7h points/(i4,4e15.7))
      do 20 is=1,ns
         sfp = smooth ( x, y, dy, npoint, s(is), scrtch, a )
         lsm = npoint - 1
         do 16 i=1,lsm
            do 16 j=1,4
   16          coefsm(j,i) = a(i,j)
         do 18 i=1,npoint,5
            do 18 j=1,4
   18          a(i,j) = ppvalu(x,coefsm,lsm,4,x(i),j-1)
   20    print 620, s(is), sfp, (i,(a(i,j),j=1,4),i=1,npoint,5)
  620 format(15h prescribed s =,e10.3,23h, s(smoothing spline) =,e10.3/
     *       54h value and derivatives of smoothing spline at corresp.
     *      ,7h points/(i4,4e15.7))
                                        stop
      end


program l8
    use pyplot_module, only : pyplot
    use functions

    implicit none

    type(pyplot) :: plt

    ! Variables
    integer, parameter :: nx = 41, ny = 41, nt = 120, c = 1
    real(kind=8), parameter :: dx = real(2) / (nx -1 )
    real(kind=8), parameter :: dy = real(2) / (ny -1 )
    real(kind=8), parameter :: sigma = 0.0009, nu = 0.01
    real(kind=8), parameter :: dt = sigma * dx * dy / nu
    real(kind=8), dimension(nx,ny) :: u, un, v, vn
    real(kind=8), dimension(nx) :: x
    real(kind=8), dimension(ny) :: y
    integer :: i, j, n, time, istat
    character :: input
    real(kind=8) :: plotX = 2, plotY = 2

    real(kind=8) :: dtOdx, dtOdy, nudtOdx2, nudtOdy2, F1termU, S2termU, T3termU, F4termU, F1termV, S2termV, T3termV, F4termV

    ! Body of l8
10  format (i1)
15  format (f10.5,",")
20  format ("")

    !Generate values for y
    call spaceevenly(1, ny, plotY, y)
    !Generate values for x
    call spaceevenly(1, nx, plotX , x)

    ! Generate ones for entire array "u" "un" "v" "vn"
    do i=1,nx
        do j=1, ny
            u(i,j) = 1
            un(i,j) = 1
            v(i,j) = 1
            vn(i,j) = 1
        end do
    end do

    ! Set boundary conditions for "u" "v"
    do i=1,nx
        do j=1, ny
            if (i >= 0.5 / dx  .and. i <= 1 / dx + 1 .and. &
                j >= 0.5 / dy .and. j <= 1 / dy + 1) then
                u(i,j) = 2
                v(i,j) = 2
            end if
        end do
    end do

    time = nt
    do time = 1, time
            un = u
            do j=2, nx-1
                do i=2, ny-1
                    nudtOdx2 = (nu * dt) / (dx**2)
                    nudtOdy2 = (nu * dt) / (dy**2)
                    dtOdx = dt / dx
                    dtOdy = dt / dy

                    F1termU = u(j,i) * (u(j,i) - u(j-1,i))
                    S2termU = v(j,i) * (u(j,i) - u(j,i-1))
                    T3termU = u(j+1,i) - (2 * u(j,i)) + u(j-1,i)
                    F4termU = u(j,i+1) - (2 * u(j,i)) + u(j,i-1)

                    F1termV = v(j,i) * (v(j,i) - v(j-1,i))
                    S2termV = v(j,i) * (v(j,i) - v(j,i-1))
                    T3termV = v(j+1,i) - (2 * v(j,i)) + v(j-1,i)
                    F4termV = v(j,i+1) - (2 * v(j,i)) + v(j,i-1)

                    u(j,i) = un(j,i) - (dtOdx * F1termU) - &
                        (dtOdy * S2termU) + &
                        (nudtOdx2 * T3termU) + &
                        (nudtOdy2 * F4termU)

                    v(j,i) = vn(j,i) - (dtOdx * F1termV) - &
                        (dtOdy * S2termV) + &
                        (nudtOdx2 * T3termV) + &
                        (nudtOdy2 * F4termV)

                    u(1,j) = 1
                    u(nx,j) = 1
                    u(i,1) = 1
                    u(i,ny) = 1

                    u(1,1) = 1
                    u(1,nx) = 1
                    u(ny,1) = 1
                    u(ny,nx) = 1

                    v(1,j) = 1
                    v(nx,j) = 1
                    v(i,1) = 1
                    v(i,ny) = 1

                    v(1,1) = 1
                    v(1,nx) = 1
                    v(ny,1) = 1
                    v(ny,nx) = 1
                end do
            end do
        end do

        ! Write to csv
    open(unit=1, file="l8.csv")
    do i=1, nx
        do j=1, ny
            write(unit=1, fmt=15, advance="no"), u(i,j)
        end do
        write(unit=1,fmt=20)
    end do

    print*, "File written"

    call plt%initialize(grid=.true.,&
                        title='Plot of u',legend=.false.,mplot3d=.true.,use_colormap=.true.)

    call plt%plot_surface(x,y,u,label='value of u', istat=istat, &
                            cmap="cm.cividis")

    call plt%savefig('l8.png', &
                      pyfile='l88.py', &
                      dpi='200',istat=istat)

    print*, "Plotting done "
    close(unit=1)
    read*, input

end program l8


! Test intrinsic function folding edge case (both expected value and messages)
! These tests make assumptions regarding real(4) extrema.

#define TEST_ISNAN(v) logical, parameter :: test_##v =.NOT.(v.EQ.v)

module real_tests
  ! Test real(4) intrinsic folding on edge cases (inf and NaN)

  real(4), parameter :: r4_pmax = 3.4028235E38
  real(4), parameter :: r4_nmax = -3.4028235E38
  !WARN: invalid argument on division
  real(4), parameter :: r4_nan = 0._4/0._4
  !WARN: division by zero on division
  real(4), parameter :: r4_pinf = 1._4/0._4
  !WARN: division by zero on division
  real(4), parameter :: r4_ninf = -1._4/0._4

  !WARN: invalid argument on intrinsic function
  real(4), parameter :: nan_r4_acos1 = acos(1.1)
  TEST_ISNAN(nan_r4_acos1)
  !WARN: invalid argument on intrinsic function
  real(4), parameter :: nan_r4_acos2 = acos(r4_pmax)
  TEST_ISNAN(nan_r4_acos2)
  !WARN: invalid argument on intrinsic function
  real(4), parameter :: nan_r4_acos3 = acos(r4_nmax)
  TEST_ISNAN(nan_r4_acos3)
  !WARN: invalid argument on intrinsic function
  real(4), parameter :: nan_r4_acos4 = acos(r4_ninf)
  TEST_ISNAN(nan_r4_acos4)
  !WARN: invalid argument on intrinsic function
  real(4), parameter :: nan_r4_acos5 = acos(r4_pinf)
  TEST_ISNAN(nan_r4_acos5)

  !WARN: overflow on intrinsic function
  logical, parameter :: test_exp_overflow = exp(256._4).EQ.r4_pinf
end module

module parentheses
  ! Test parentheses in folding (they are kept around constants to keep the
  ! distinction between variable and expressions and require special care).
  real(4), parameter :: x_nop = 0.1_4
  real(4), parameter :: x_p = (x_nop)
  logical, parameter :: test_parentheses1 = acos(x_p).EQ.acos(x_nop)
end module


      subroutine frmspikev(stack,nx,ny,nz,nv,avg_vol,var_vol)
      real*4 stack(nx,ny,nz,nv),avg_vol(nx,ny,nz),var_vol(nx,ny,nz+1)

      do iz=1,nz
      do iy=1,ny
      do ix=1,nx
        avg_vol(ix,iy,iz)=0.
        var_vol(ix,iy,iz)=0.
      enddo
      enddo
      enddo

      do iv=1,nv
        do iz=1,nz
        do iy=1,ny
        do ix=1,nx
          avg_vol(ix,iy,iz)=avg_vol(ix,iy,iz)+stack(ix,iy,iz,iv)
          var_vol(ix,iy,iz)=var_vol(ix,iy,iz)+stack(ix,iy,iz,iv)**2
        enddo
        enddo
        enddo
      enddo

      do iz=1,nz
      do iy=1,ny
      do ix=1,nx
        avg_vol(ix,iy,iz)=avg_vol(ix,iy,iz)/float(nv)
        var_vol(ix,iy,iz)=var_vol(ix,iy,iz)/float(nv)-avg_vol(ix,iy,iz)**2
      enddo
      enddo
      enddo

      do iy=1,ny
      do ix=1,nx
        var_vol(ix,iy,nz+1)=0.
        do iz=1,nz
          var_vol(ix,iy,nz+1)=var_vol(ix,iy,nz+1)+var_vol(ix,iy,iz)
        enddo
        var_vol(ix,iy,nz+1)=var_vol(ix,iy,nz+1)/float(nz)
      enddo
      enddo

      return
      end

      subroutine frmspiker(stack,nx,ny,nz,nv,ix,iy)
      real*4 stack(nx,ny,nz,nv)

      do 1 iv=1,nv
      do 1 iz=1,nz
      t=0.25*(stack(ix-1,iy  ,iz,iv)
     &       +stack(ix  ,iy-1,iz,iv)
     &       +stack(ix+1,iy  ,iz,iv)
     &       +stack(ix  ,iy+1,iz,iv))
    1 stack(ix,iy,iz,iv)=t

      return
      end

      subroutine freorder(stack,ns,nz,nv,vol)
      real*4 stack(ns,nz,nv),vol(ns,nv)
c     reorder slices 16,8,15,7,14... => 1,2,3,4,5...

      do 1 iv=1,nv
      do 2 iz=1,16
      k=8*(1+mod(iz,2))-(iz-1)/2
      do 2 j=1,ns
    2 vol(j,iz)=stack(j,k,iv)
      do 3 iz=1,16
      do 3 j=1,ns
    3 stack(j,iz,iv)=vol(j,iz)
    1 continue

      return
      end