!        Generated by TAPENADE     (INRIA, Ecuador team)
!  tapenade 3.x
!
!  Differentiation of ftheta in reverse (adjoint) mode (with options noISIZE i8):
!   gradient     of useful results: tlocal theta dtheta
!   with respect to varying inputs: tlocal
! MIT License
!
! Copyright (c) 2020 SHEMAT-Suite
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.
!>    @brief calculates the fluid/ice partition function
!>    @param[in] tlocal = temperature
!>    @param[in] tliq = phase boundary temperature
!>    @param[in] wmushy =  scaling factor for "mushy" region = Tsolidus-tliqidus
!>    @param[in] ismpl local sample index
!>    @param[out] theta = value of partition function  (0<Theta<1)
!>    @param[out] dtheta = value of derivative of partition function with respect to temperature
!#>   returns the fluid/ice partition function theta and its derivative dtheta
!>    @details
!>calculates the fluid/ice partition function used for the \n
!>apparent heat capacity approach to phase change.\n
SUBROUTINE FTHETA_AD(tlocal, tlocal_ad, tliq, wmushy, theta, theta_ad, &
& dtheta, dtheta_ad, ismpl)
  use arrays

  USE ARRAYS_AD

  USE ICE
  IMPLICIT NONE
  INTEGER :: ismpl
  DOUBLE PRECISION :: tlocal, theta, dtheta, val, tliq, wmushy
  DOUBLE PRECISION :: tlocal_ad, theta_ad, dtheta_ad, val_ad
  INTRINSIC EXP
  DOUBLE PRECISION :: temporary_ad
  IF (tlocal .LT. tliq) THEN
    val = (tlocal-tliq)/wmushy
!         Theta=exp((-(T-Tf)/w)^2)
    theta = EXP(-(val*val))
!         dTheta=-2*(T-Tf)/w^2*Theta;
!       IF (theta.lt.liqmin) THEN
!         theta  =  liqmin
!         dtheta =  0.
!       END IF
    temporary_ad = -(2.d0*dtheta_ad/wmushy)
    theta_ad = theta_ad + val*temporary_ad
    val_ad = theta*temporary_ad - 2*val*EXP(-(val**2))*theta_ad
    tlocal_ad = tlocal_ad + val_ad/wmushy
  END IF
END SUBROUTINE FTHETA_AD


C++--------------------------------------------------------------------
C Program BACKGROUND
C to fit a polynomial to the background of an image.
C Options :
C -  2-D Polynomial fitting on a subsample of points (excluding 2 boxes)
C -  Compression (with local histograms) and extension with pseudo-cubic
C    splines (From A. Bijaoui)
C
C JLP Version of 09-05-94
C--------------------------------------------------------------------
	PROGRAM BACKGROUND
	PARAMETER (NCHEBY=100)
	PARAMETER (IDIM1=6000,IDIM_GRID=200)
	REAL*4 GRID(IDIM_GRID,IDIM_GRID)
        REAL*8 XMIN0,XMAX0,YMIN0,YMAX0
        REAL*8 CHEBY(NCHEBY)
	REAL*8 XX(IDIM1),YY(IDIM1),ZZ(IDIM1)
	CHARACTER IN_NAME*60,NAME*60,COMMENTS*80
        INTEGER*4 KKX1,KKY1
	INTEGER*4 NPOINT(IDIM1)
	LOGICAL HOLE
	CHARACTER ANS*1
        INTEGER PNTR_IN,PNTR_OUT,MADRID(1)
        COMMON/VMR/MADRID
	COMMON/SURFIT/CHEBY,KKX1,KKY1,XMIN0,XMAX0,YMIN0,YMAX0

10	FORMAT(A)
	PRINT 5
5	FORMAT(' Program BACKGROUND to compute the background of an'
     1	' image',/)

	CALL JLP_BEGIN
C Inquire the format :
	CALL JLP_INQUIFMT

80	PRINT 88
88	FORMAT(' MENU :',/,
     1	' 1. Surface fitting with a 2-D polynomial',/,
     1	' 2. Spline interpolation on a grid (for patched images)',/,
C     1	' 3. Surface fitting with cubic splines',/,
     1	' 10. Exit',/,
     1	' Enter your choice : ',$)
	READ(5,*) IOPT

C	PRINT 70
C70	FORMAT(' SECOND MENU : ',/,
C     1	' 1. Subtraction of the background',/,
C     1	' 2. Division by the background',/,
C     1	' Enter the option :',$)
C	READ(5,*) IOPT1
	IOPT1=1
	PRINT 71
71	FORMAT('OK: subtraction of the background')

C Input of the image :
	WRITE(6,*) 'Input image: '
        READ(5,10) IN_NAME
	CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,IN_NAME,COMMENTS)
        IDIM=NX

C Memory allocation for output image:
        ISIZE=NX*NY*4
        CALL JLP_GETVM(PNTR_OUT,ISIZE)

C--------------------------------------------------------------------
C Option 1 : 2-D polynomial fit
C---------------------------------------------------------------------

	IF(IOPT.EQ.1)THEN
C KKX and KKY :
	PRINT *,' Order of the polynomial in X and Y :'
	READ(5,*) KKX,KKY

	PRINT *,' Size of the cells in X and Y ?'
	READ(5,*) IXSIZE,IYSIZE

	PRINT 104
104	FORMAT(' Generating the grid',/)
	HOLE=.TRUE.
	CALL GENE_GRID(MADRID(PNTR_IN),NX,NY,IDIM,GRID,NXCELL,NYCELL,
     1	IDIM_GRID,IXSIZE,IYSIZE,HOLE)

	PRINT 105
105	FORMAT(' Loading the arrays',/)

	CALL PREPARE_E02CAF(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,
     1	IYSIZE,XX,YY,ZZ,NPTX,NPTY,NPOINT,KKX)

C Output of the grid :
	PRINT *,' Output of the grid :'
        READ(5,10) NAME
	 CALL JLP_WRITEIMAG(GRID,NXCELL,NYCELL,IDIM_GRID,NAME,COMMENTS)

	PRINT 106
106	FORMAT(' Fitting a 2-D polynomial ',/)
	CALL SURFACEFIT_POLY(XX,YY,ZZ,NPTX,NPTY,NPOINT,KKX,KKY)

	PRINT *,' Subtracting the background'
	CALL FLATTEN_1(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX,NY,IDIM,IOPT1)
	PRINT *,' Background subtracted'

	ENDIF

C--------------------------------------------------------------------
C OPTION 2
C Two steps :
C  - Compression of the patched image with sky determination from the
C     shape of local histograms.
C  - Pseudo-spline extension of this grid
C
C---------------------------------------------------------------------

	IF(IOPT.EQ.2)THEN

	PRINT 204
204	FORMAT(' Generating the grid with local histograms',/)
	PRINT *,' Compression factor of the image ?'
	READ(5,*) IFACT

	PRINT *,' Lower and upper thresholds for the histogram ?'
	READ(5,*) ZMIN,ZMAX
	PRINT *,' Noise estimate ?'
	READ(5,*) ZNOISE

C NTERM = Number of terms for the fit of the histograms
C (NTERM > 30 for a good fit according to A. Bijaoui
	NTERM=34
	CALL COMPRES_HISTO(MADRID(PNTR_IN),NX,NY,IDIM,GRID,NXCELL,
     1	NYCELL,IDIM_GRID,IFACT,NTERM,ZMIN,ZMAX,ZNOISE)

	PRINT 211
211	FORMAT(/,' Transfer of the knots of the grid ',
     1	' (Necessary for the next step)')
	CALL TRANSFER_KNOTS(GRID,NXCELL,NYCELL,IDIM_GRID)

	PRINT 206
206	FORMAT(/,' Extension of the grid and subtraction ',/)

	CALL EXTEN_SPLINE1(GRID,NXCELL,NYCELL,IDIM_GRID,IFACT,
     1                     MADRID(PNTR_OUT),IDIM)

	NX1=NXCELL*IFACT
	NY1=NYCELL*IFACT

	PRINT 207
207	FORMAT(' Do you want to subtract the background ',/,
     1	' from the original image (not patched) ? (Y)')
	READ(5,10) ANS

	IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
C Entering the image :
         WRITE(6,*) 'Input file: '
         READ(5,10) IN_NAME
	 CALL JLP_VM_READIMAG(PNTR_IN,NX,NY,IN_NAME,COMMENTS)
         IDIM=NX
	ENDIF

C Subtracting the background :
        CALL SUBTRACT(MADRID(PNTR_IN),MADRID(PNTR_OUT),NX1,NY1,IDIM)

	ENDIF

C--------------------------------------------------------------------
C OPTION 3 : 2-D fit of cubic splines
C Does not work : E02ZAF is limited at PX=12 and PY=12 !!!!!
C---------------------------------------------------------------------

	IF(IOPT.EQ.3)THEN

	PRINT 304
304	FORMAT(' I. Generating the grid',/)
	PRINT *,'     Size of the cells in X and Y ?'
	READ(5,*) IXSIZE,IYSIZE

	HOLE=.TRUE.
	CALL GENE_GRID(MADRID(MADRID_IN),NX,NY,IDIM,GRID,NXCELL,NYCELL,
     1	IDIM_GRID,IXSIZE,IYSIZE,HOLE)

C--------------------
C Filling the holes of the grid :
	PRINT 305
305	FORMAT(/,' II. Filling the holes of the grid ',
     1	'(polynomial fitting)',/)

C KKX and KKY :
	PRINT *,'    Order of the polynomial in X and Y :'
	READ(5,*) KKX,KKY

	PRINT 306
306	FORMAT(' II. a) Loading the arrays',/)

	CALL PREPARE_E02CAF(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,
     1	IYSIZE,XX,YY,ZZ,NPTX,NPTY,NPOINT,KKX)

	PRINT 307
307	FORMAT(' II. b) Fitting a 2-D polynomial ',/)
	CALL SURFACEFIT_POLY(XX,YY,ZZ,NPTX,NPTY,NPOINT,KKX,KKY)

	PRINT 308
308	FORMAT(' II. c) Filling the holes, now',/)
	CALL FILL_3(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,IYSIZE)

C Output of the grid :
C	PRINT *,' Output of the grid :'
C        READ(5,10) NAME
C	 CALL JLP_WRITEIMAG(GRID,NXCELL,NYCELL,IDIM_GRID,IDIM2,NAME,COMMENTS)

C-------------------
C Fitting cubic splines :
	PRINT 309
309	FORMAT(' II. d) Fitting cubic splines ',/)
	CALL SURFACEFIT_SPLINE(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,IYSIZE)

C	PRINT 310
C310	FORMAT(/,' III. Subtraction : calling "FLATTEN_3',/)
C	CALL FLATTEN_3(GRID,NXCELL,NYCELL,IDIM_GRID,
C     1                 MADRID(PNTR_IN),MADRID(PNTR_OUT),
C     1	NX,NY,IDIM,IXSIZE,IYSIZE,IOPT1)

	ENDIF

C----------------------------------------------------------------------
C Output
C----------------------------------------------------------------------
         WRITE(6,37)
37       FORMAT(' Output image:')
         READ(5,10) NAME
         WRITE(COMMENTS,33) IN_NAME(1:20)
33       FORMAT('Background subtr. from: ',A20)
	 CALL JLP_WRITEIMAG(MADRID(PNTR_OUT),NX,NY,IDIM,NAME,COMMENTS)

        CALL JLP_END
	STOP
	END
C*************************************************************
C	Subroutine MEAN_SIGMA to compute the mean and sigma
C	of an area defined by IMIN, IMAX JMIN and JMAX
C
C IFLAG : Detection of 0 (Outside of the mask)
C*************************************************************
	SUBROUTINE MEAN_SIGMA(IMAGE,IMIN,IMAX,JMIN,
     1	JMAX,XMEAN,SIGMA,IDIM,IFLAG)
	REAL*4 IMAGE(IDIM,*)
	REAL*8 TOTSUM,TOT2,XMEAN1,WORK

	IFLAG=1
C First passage to calculate the mean
	IT=0
        NSUM=0
        TOTSUM=0.0D0
        TOT2=TOTSUM

        DO 18 J=JMIN,JMAX
        DO 18 I=IMIN,IMAX
        AIJ=IMAGE(I,J)
	  IF(AIJ.EQ.0.0)THEN
	  IFLAG=0
	  RETURN
	  ENDIF
	NSUM=NSUM+1
        TOTSUM=TOTSUM+AIJ
        TOT2=TOT2+AIJ**2
18      CONTINUE

C TOTSUM : first mean
	TOTSUM=TOTSUM/DFLOAT(NSUM)

C TOT2 : first standard deviation
        TOT2=(TOT2/DFLOAT(NSUM))-TOTSUM**2
        TOT2=DSQRT(TOT2)

30	XMEAN1=TOTSUM

C ZUL: upper level
	ZUL=TOTSUM+3.*TOT2

C ZLL: low level
        ZLL=TOTSUM-3.*TOT2

C Second passage to calculate the standard deviation (discarding
C some points)
        NSUM=0
        TOTSUM=0.0D0
        TOT2=TOTSUM

        DO 19 J=JMIN,JMAX
        DO 19 I=IMIN,IMAX
        AIJ=IMAGE(I,J)
        IF((AIJ.NE.0.0).OR.(AIJ.LE.ZUL).OR.(AIJ.GE.ZLL))THEN
        NSUM=NSUM+1
        TOTSUM=TOTSUM+AIJ
        TOT2=TOT2+AIJ**2
	ENDIF
19      CONTINUE

C TOTSUM : second mean (without extreme values)
        TOTSUM=TOTSUM/DFLOAT(NSUM)

C TOT2 : second standard deviation (in intensity)
        TOT2=(TOT2/DFLOAT(NSUM))-TOTSUM**2
        TOT2=DSQRT(TOT2)
	   IF(XMEAN1.NE.0)THEN
	   WORK=DABS((TOTSUM-XMEAN1)/XMEAN1)
	   ELSE
	   WORK=DABS(TOTSUM-XMEAN1)
	   ENDIF

C Loop until the mean is stable ...
	IF(WORK.GT.0.1E-09)THEN
	IT=IT+1
	PRINT *,' IT =',IT
	GO TO 30
	ENDIF

	XMEAN=TOTSUM
	SIGMA=TOT2

	RETURN
	END
C-------------------------------------------------------------
C Subroutine to fit a 2-D polynomial :
C Input arrays :
C XX all points on Y=Y(1) followed by
C    all points on Y=Y(2) followed by ...
C (Size of XX = NPTX)
C
C NPOINT(K)= Number of points XX in line K
C
C YY values of the lines Y=Y(K) in strictly increasing order.
C (Size of YY = NPTY)
C
C ZZ in the same order as XX
C (Size of ZZ = NPTX)
C
C NCHEBY > (KKX+1)*(KKY+1)   (KKX and KKY : orders of the polynomials)
C NWORK > NPTX + 2 * MAX(NPTX,NPTY) + 2*NPTY*(KKX+2) + 5*(1+MAX(KKX,KKY))
C--------------------------------------------------------------
	SUBROUTINE SURFACEFIT_POLY(XX,YY,ZZ,NPTX,NPTY,NPOINT,
     1	KKX,KKY)
	PARAMETER (NCHEBY=100)
	PARAMETER (IDIM1=6000)
	REAL*8 XX(NPTX),YY(NPTY),ZZ(NPTX)
	REAL*8 CHEBY(NCHEBY),W(IDIM1),XMIN(IDIM1),XMAX(IDIM1)
	REAL*8 NUX(IDIM1),NUY(IDIM1),WORK(IDIM1)
        REAL*8 XMIN0,XMAX0,YMIN0,YMAX0
	INTEGER*4 NPOINT(NPTY)
        INTEGER*4 KKX1,KKY1

	COMMON/SURFIT/CHEBY,KKX1,KKY1,XMIN0,XMAX0,YMIN0,YMAX0
C Initiallization of polynomial order in common block:
	KKX1=KKX
	KKY1=KKY

C Lower and upper limits :
	XMIN0=XX(1)
	XMAX0=XX(NPTX)
	  DO I=1,NPTX
	  IF(XX(I).LT.XMIN0)XMIN0=XX(I)
	  IF(XX(I).GT.XMAX0)XMAX0=XX(I)
	  END DO
	YMIN0=YY(1)
	YMAX0=YY(NPTY)
	  DO J=1,NPTY
	  IF(YY(J).LT.YMIN0)YMIN0=YY(J)
	  IF(YY(J).GT.YMAX0)YMAX0=YY(J)
	  END DO
	WRITE(6,39) XMIN0,XMAX0,YMIN0,YMAX0
39      FORMAT('xmin,xmax,ymin,ymax',4(1X,F9.2))
        IF(XMIN0.EQ.XMAX0.OR.YMIN0.EQ.YMAX0)THEN
          WRITE(6,8)
8         FORMAT('Fatal error: null dynamical range in X or Y')
          CALL JLP_END
          STOP
        ENDIF

C Sets the weights to 1.
	DO I=1,NPTX
	 W(I)=1.D0
	END DO

C Defines the min and max values in each line
	DO I=1,NPTX
	  XMIN(I)=XMIN0
	  XMAX(I)=XMAX0
	END DO

C No constraints on the fit :
	INUXP1=1
	INUYP1=1

C Calling NAG routine E02CAF to fit a polynomial in X, and in Y
	IFAIL=1
	NWORK=IDIM1
	PRINT *,' NPTX,NPTY,KKX,KKY',NPTX,NPTY,KKX,KKY

	CALL E02CAF(NPOINT,NPTY,KKX,KKY,XX,YY,ZZ,W,NPTX,
     1	CHEBY,NCHEBY,XMIN,XMAX,
     1	NUX,INUXP1,NUY,INUYP1,WORK,NWORK,IFAIL)

	IF(IFAIL.NE.0)THEN
	  PRINT 30,IFAIL
30	  FORMAT(' SURFACEFIT_POLY/Error in E02CAF   IFAIL=',I4)
	ENDIF

	RETURN
	END
C******************************************************************
C Subroutine to generate the array GRID for further interpolation
C GRID(NXCELL,NYCELL) : output array
C IXSIZE : lenth of the cells in X
C IYSIZE : lenth of the cells in Y
C
C If HOLE=.true. possibility of excluding some areas
C-------------------------------------------------------------------
	SUBROUTINE GENE_GRID(INPUT,NX,NY,IDIM,GRID,NXCELL,NYCELL,
     1	IDIM_GRID,IXSIZE,IYSIZE,HOLE)
	REAL*4 INPUT(IDIM,*),GRID(IDIM_GRID,*)
	LOGICAL HOLE

	NXCELL=(NX/IXSIZE)
	NYCELL=(NY/IYSIZE)
c	HALFXSIZE=IXSIZE/2
c	HALFYSIZE=IYSIZE/2
	PRINT *,' SIZE OF "GRID" : NXCELL, NYCELL',NXCELL,NYCELL

C If HOLE=.true. possibility of excluding some areas
	IF(HOLE)THEN

	PRINT *,' Exclusion of 2 rectangular areas :'
	PRINT *,' Enter the limits IXMIN,IXMAX,IYMIN,IYMAX for box 1 '
	READ(5,*) IXMIN1,IXMAX1,IYMIN1,IYMAX1
	PRINT *,' Enter the limits IXMIN,IXMAX,IYMIN,IYMAX for box 2 '
	READ(5,*) IXMIN2,IXMAX2,IYMIN2,IYMAX2

	ENDIF

	DO KY=1,NYCELL

	JMIN=(KY-1)*IYSIZE +1
	JMAX=KY*IYSIZE
C	YY(NPTY)=FLOAT(JMIN)+HALFYSIZE

	DO KX=1,NXCELL

	IMIN=(KX-1)*IXSIZE +1
	IMAX=KX*IXSIZE

C Removing pixels inside of the exclusion boxes :
	IF(HOLE)THEN

C Box 1 :
	IF(((IMIN.GT.IXMIN1.AND.IMIN.LT.IXMAX1).OR.
     1	(IMAX.GT.IXMIN1.AND.IMAX.LT.IXMAX1)).AND.
     1	((JMIN.GT.IYMIN1.AND.JMIN.LT.IYMAX1).OR.
     1	(JMAX.GT.IYMIN1.AND.JMAX.LT.IYMAX1)))THEN
	GRID(KX,KY)=-1.
	GO TO 20
	ENDIF

C Box 2:
	IF(((IMIN.GT.IXMIN2.AND.IMIN.LT.IXMAX2).OR.
     1	(IMAX.GT.IXMIN2.AND.IMAX.LT.IXMAX2)).AND.
     1	((JMIN.GT.IYMIN2.AND.JMIN.LT.IYMAX2).OR.
     1	(JMAX.GT.IYMIN2.AND.JMAX.LT.IYMAX2)))THEN
	GRID(KX,KY)=-1.
	GO TO 20
	ENDIF

	ENDIF

C Computing the mean :
	CALL MEAN_SIGMA(INPUT,IMIN,IMAX,JMIN,JMAX,
     1	XMEAN,SIGMA,IDIM,IFLAG)
C	PRINT *,' KX,IMIN,IMAX,JMIN,JMAX,XMEAN',
C     1            KX,IMIN,IMAX,JMIN,JMAX,XMEAN

C Possibility of multiplying by a mask (0 when outside of the frame) :
C Therefore discarding all these values :
	IF(IFLAG.NE.0)THEN
C	XX(NPTX)=FLOAT(IMIN)+HALFXSIZE
	GRID(KX,KY)=XMEAN
	ENDIF

20	END DO

	END DO

	RETURN
	END
C-------------------------------------------------------------
C Subroutine to flatten the input image with option 1
C  i.e., surface fitting with a 2-D polynomial
C--------------------------------------------------------------
	SUBROUTINE FLATTEN_1(INPUT,OUTPUT,NX,NY,IDIM,IOPT)
	PARAMETER (NCHEBY=100)
C IDIM1: Max size of the lines:
	PARAMETER (IDIM1=6000)
	REAL*4 INPUT(IDIM,*),OUTPUT(IDIM,*)
	REAL*8 CHEBY(NCHEBY),W(IDIM1),WORK(IDIM1)
	REAL*8 XX(IDIM1),ZZ(IDIM1),YY
        REAL*8 XMIN0,XMAX0,YMIN0,YMAX0
        INTEGER*4 NX,NY,KKX1,KKY1

	COMMON/SURFIT/CHEBY,KKX,KKY,XMIN0,XMAX0,YMIN0,YMAX0

	IMIN=NINT(XMIN0)+1
	IMAX=NINT(XMAX0)-1
	JMIN=NINT(YMIN0)+1
	JMAX=NINT(YMAX0)-1
	PRINT *,'FLATTEN_1/imin,imax,jmin,jmax',IMIN,IMAX,JMIN,JMAX

C JLP97: I erase the output array:
        DO J=1,NY
         DO I=1,NX
          OUTPUT(I,J)=0.
         END DO
        END DO

	DO J=JMIN,JMAX
	JJ=J-JMIN+1
	YY=FLOAT(J)

	DO I=IMIN,IMAX
	II=I-IMIN+1
	XX(II)=FLOAT(I)
	END DO

C Calling NAG routine E02CBF (to compute the value of the background for the
C current line)
	IFAIL=1
	NWORK=IDIM1
	MFIRST=1
	MLAST=IMAX-IMIN+1

	CALL E02CBF(MFIRST,MLAST,KKX,KKY,XX,XMIN0,XMAX0,
     1	YY,YMIN0,YMAX0,ZZ,CHEBY,NCHEBY,WORK,NWORK,IFAIL)

	IF(IFAIL.NE.0)THEN
	PRINT 30,IFAIL
30	FORMAT(' FLATTEN_1/Error in E02CBF (Computing back. value) IFAIL=',I4)
C If IFAIL=2: Y is not in [YMIN,YMAX[ intervall...
	  IF(IFAIL.EQ.2)THEN
             PRINT *,'IFAIL=2:   YMIN,YY,YMAX',YMIN0,YY,YMAX0
          ENDIF
        ELSE
C        PRINT 32,J
32      FORMAT('Line #',I4,' of the grid: successful fit')
	ENDIF

	IF(IOPT.EQ.1)THEN
	  DO I=IMIN,IMAX
	   II=I-IMIN+1
	   IF(INPUT(I,J).NE.0.)OUTPUT(I,J)=INPUT(I,J)-ZZ(II)
	  END DO
	ELSE
	  DO I=IMIN,IMAX
	    II=I-IMIN+1
	    IF(ZZ(II).EQ.0.)THEN
	     PRINT *,' WARNING ZZ(II)=0. !!'
	     OUTPUT(I,J)=0.
	    ELSE
	     OUTPUT(I,J)=INPUT(I,J)/ZZ(II)
	    ENDIF
	  END DO
	ENDIF

	END DO

	RETURN
	END
C******************************************************************
C Subroutine to generate the arrays XX YY and ZZ for the fit with E02CAF
C from a grid
C XX,YY : Coordinates of the centre
C ZZ : Mean intensity of the cell
C-------------------------------------------------------------------
	SUBROUTINE PREPARE_E02CAF(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,
     1	IYSIZE,XX,YY,ZZ,NPTX,NPTY,NPOINT,KKX)
	PARAMETER (IDIM1=6000)
	REAL*4 GRID(IDIM_GRID,*)
	REAL*8 XX(IDIM1),YY(IDIM1),ZZ(IDIM1)
	INTEGER*4 NPOINT(IDIM1)

	HALFXSIZE=FLOAT(IXSIZE)/2.
	HALFYSIZE=FLOAT(IYSIZE)/2.

	NPTX=0
	NPTY=0

	DO KY=1,NYCELL

C NPTY : "Index" for the current "line" of cells.
	NPTY=NPTY+1
	NPOINT(NPTY)=0
	JMIN=(KY-1)*IYSIZE +1
	JMAX=KY*IYSIZE
	YY(NPTY)=FLOAT(JMIN)+HALFYSIZE

	DO KX=1,NXCELL

	IMIN=(KX-1)*IXSIZE +1
	IMAX=KX*IXSIZE

C Therefore discarding bad values (0. and -1.) :
	IF(GRID(KX,KY).NE.0..AND.GRID(KX,KY).NE.-1.)THEN
	NPTX=NPTX+1
	NPOINT(NPTY)=NPOINT(NPTY)+1
	XX(NPTX)=FLOAT(IMIN)+HALFXSIZE
	ZZ(NPTX)=GRID(KX,KY)
	ENDIF

	END DO

C If less than KKX+1 points on the current line, we forget the current line
C for the fit. (For NAG routine)
	IF(NPOINT(NPTY).LT.KKX+1)THEN
	NPTX=NPTX-NPOINT(NPTY)
	NPTY=NPTY-1
	ENDIF

	END DO

	RETURN
	END
C-------------------------------------------------------------
C Subroutine to flatten the input image with option 1
C--------------------------------------------------------------
	SUBROUTINE FILL_3(GRID,NXCELL,NYCELL,IDIM_GRID,IXSIZE,IYSIZE)
	PARAMETER (IDIM2=200)
	PARAMETER (IDIM1=6000)
	REAL*4 GRID(IDIM_GRID,*)
	REAL*8 CHEBY(IDIM2),W(IDIM1),WORK(IDIM1)
	REAL*8 XX(IDIM1),ZZ(IDIM1),YY
        REAL*8 XMIN0,XMAX0,YMIN0,YMAX0
        INTEGER*4 KKX1,KKY1

	COMMON/SURFIT/CHEBY,KKX,KKY,XMIN0,XMAX0,YMIN0,YMAX0

C Main loop on the lines :
	DO J=1,NYCELL
	YY=IYSIZE*FLOAT(J)

	DO I=1,NXCELL

C When GRID(I,J)=-1 it is sustituted by the polynomial approximation :
	   IF(GRID(I,J).EQ.-1)THEN
	   XX(1)=IXSIZE*FLOAT(I)

C Calling NAG routine E02CBF (to compute the value of the background for the
C current point)
	   IFAIL=1
	   NWORK=IDIM1
	   MFIRST=1
	   MLAST=1
	   NCHEBY=IDIM2

	   CALL E02CBF(MFIRST,MLAST,KKX,KKY,XX,XMIN0,XMAX0,
     1	YY,YMIN0,YMAX0,ZZ,CHEBY,NCHEBY,WORK,NWORK,IFAIL)

	   IF(IFAIL.NE.0)THEN
	   PRINT 30,IFAIL
30	   FORMAT(' FILL_3/Error in E02CBF (computing back. value) IFAIL=',I4)
	   PRINT 31,XX(1),YY
31	   FORMAT(' Pb at point : X,Y :',F7.1,2X,F7.1)
	   ZZ(1)=0.
	   ENDIF

C Substitution :
	   GRID(I,J)=ZZ(1)

	   ENDIF

	END DO
	END DO

	RETURN
	END
C-------------------------------------------------------------
C Subroutine to fit 2-D cubic splines :
C Input array : GRID(NXCELL,NYCELL)
C
C--------------------------------------------------------------
	SUBROUTINE SURFACEFIT_SPLINE(GRID,NXCELL,NYCELL,
     1	IDIM_GRID,IXSIZE,IYSIZE)
	PARAMETER (IDIM3=2000,IDIM2=200)
	PARAMETER (IDIM1=6000)
	REAL*4 GRID(IDIM_GRID,*)
C	REAL*8 XX(IDIM1),YY(IDIM1),ZZ(IDIM1)
C	REAL*8 CHEBY(IDIM2),WEIGHT(IDIM1),LAMDA(IDIM3),MU(IDIM3)
C	REAL*8 WORK(IDIM1),DL(IDIM1),C(IDIM1)
C	REAL*8 EPS
	REAL*4 XX(IDIM1),YY(IDIM1),ZZ(IDIM1)
	REAL*4 CHEBY(IDIM2),WEIGHT(IDIM1),LAMDA(IDIM3),MU(IDIM3)
	REAL*4 WORK(IDIM1),DL(IDIM1),C(IDIM1)
	INTEGER*4 POINT(IDIM1),IADDRES(IDIM1)
        INTEGER PX, PY

C Loading the arrays XX and YY :
	MM=0
	DO J=1,NYCELL
	YWORK1=IYSIZE*FLOAT(J)
	  DO I=1,NXCELL
	  MM=MM+1
	  XX(MM)=IXSIZE*FLOAT(I)
	  YY(MM)=YWORK1
	  ZZ(MM)=GRID(I,J)
	  END DO
	END DO

C Sets the weights to 1.
	DO KK=1,MM
	WEIGHT(KK)=1.D0
	END DO

C Defines the interior knots in each line (starting at k=5)
	INCREX=4
34	PX=0
	DO I=2,NXCELL-1,INCREX
	PX=PX+1
	LAMDA(PX+4)=FLOAT(IXSIZE*I)
	END DO
	  IF(PX.LT.3)THEN
	  INCREX=MAX(INCREX-1,0)
	  PRINT *,' PX =', PX,' WARNING : NOT ENOUGH KNOTS IN X (!)'
	  GO TO 34
	  ENDIF
C Sets PX to PX+8 which is imposed by NAG E02ZAF and E02DAF :
	PX=PX+8

C Defines the interior knots in each column (starting at k=5)
	INCREY=4
35	PY=0
	DO J=2,NYCELL-1,INCREY
	PY=PY+1
	MU(PY+4)=FLOAT(IYSIZE*J)
	END DO
	  IF(PY.LT.3)THEN
	  INCREY=MAX(INCREY-1,0)
	  PRINT *,' PY =', PY,' WARNING : NOT ENOUGH KNOTS IN Y (!)'
	  GO TO 35
	  ENDIF
C Sets PY to PY+8 which is imposed by NAG E02ZAF and E02DAF :
	PY=PY+8

	PRINT *,' MM,PX,PY : ',MM,PX,PY

C Sorting the arrays to improve the efficiency of the algorithm
C for E02DAF (NAG): (Generating the array POINT of the indices)
C	IFAIL=1

	NADDRES=(PX-7)*(PY-7)
	NPOINT=MM+NADDRES
	PRINT *,' PX,PY,MM,XX(10),YY(10)',PX,PY,MM,XX(10),YY(10)
	PRINT *,' NPOINT,NADDRES',NPOINT,NADDRES
C	DO I=1,PX
CC	PRINT *,' LAMDA, I',LAMDA(I),I
C	END DO
C	DO I=1,PY
CC	PRINT *,' MU, I',MU(I),I
C	END DO

C Sorting the arrays with E02ZAF (NAG)
	CALL E02ZAF(PX,PY,LAMDA,MU,MM,XX,YY,
     1	POINT,NPOINT,IADDRES,NADDRES,IFAIL)
C	CALL NEW_E02ZAF(PX,PY,LAMDA,MU,MM,XX,YY,
C     1	POINT,NPOINT,IADDRES,NADDRES,IFAIL)
	  IF(IFAIL.NE.0)THEN
	  PRINT 30,IFAIL
30	  FORMAT(' SURFACEFIT_SPLINE/Error in E02ZAF, IFAIL=',I4)
	  ENDIF
	PRINT *,' POINT(1),POINT(MM+1)',POINT(1),POINT(MM+1)
	PRINT *,' POINT(2),POINT(MM+2)',POINT(2),POINT(MM+2)
	PRINT *,' POINT(3),POINT(MM+3)',POINT(3),POINT(MM+3)

C Calling NAG routine E02DAF to fit 2-D cubic splines :
	IFAIL=1
	NWORK=IDIM1
C   Threshold to define 0 for the inversion of the matrix :
	EPS=1.D-08
C
	NC=(PX-4)*(PY-4)

	CALL E02DAF(MM,PX,PY,XX,YY,ZZ,WEIGHT,LAMDA,
     1	MU,POINT,NPOINT,DL,C,NC,WORK,NWORK,
     1	EPS,SIGMA,IRANK,IFAIL)

	IF(IFAIL.NE.0)THEN
	PRINT 31,IFAIL
31	FORMAT(' SURFACEFIT_SPLINE/Error in E02DAF   IFAIL=',I4)
	ENDIF

	PRINT 38,NC,IRANK,SIGMA
38	FORMAT(' Number of knots : ',I6,/,
     1	' Rank of the system :',I6,/,
     1	' Sigma for the fit :',E10.3)

	RETURN
	END
C---------------------------------------------------------------------------
	SUBROUTINE NEW_E02ZAF(PX,PY,LAMDA,MU,MM,XX,YY,
     1	POINT,NPOINT,IADDRES,NADDRES,IFAIL)
	REAL*8 XX(*),YY(*)
	REAL*8 MU(*),LAMDA(*)
	INTEGER*4 IADDRES(*),POINT(*)
        INTEGER*4 PPX,PPY,PX,PY,MM,NPOINT,NADDRES,IFAIL

	PPX=PX-8
	PPY=PY-8

C Present address for the panel IPANEL  (NADDRES=(PX-7)*(PX-7) because of
C the upper edges ...
	DO IPANEL=1,NADDRES
	IADDRES(IPANEL)=MM+IPANEL
	END DO

C--------------------------------------
C Loop on the points :
	DO 11 I=1,MM

C Classification in column :
	DO IX=1,PPX
	ILAM=IX+4
	WORKX=XX(I)-LAMDA(ILAM)
	  IF(WORKX.LT.0.)GO TO 12
	END DO

C Last column :
	IX=PPX+1
C???	GO TO 12

11	CONTINUE

	RETURN
C---------------------------------------------
C Classification in  row :

C Loop on MU :
12	DO 13 IY=1,PPY
	IMU=IY+4
	WORKY=YY(I)-MU(IMU)
	   IF(WORKY.LT.0.)THEN
	   IPANEL=(IX-1)*PPY+IY
	   POINT(IADDRES(IPANEL))=I
	   IADDRES(IPANEL)=I
           RETURN
	   ENDIF
13	CONTINUE

C Last row :
	IPANEL=(IX-1)*PPY+(PPY+1)
	POINT(IADDRES(IPANEL))=I
	IADDRES(IPANEL)=I
        RETURN

	END
C-----------------------------------------------------------------------
C Subroutine EXTEN_SPLINE1
C From AMTENB A.BIJAOUI 27 FEVRIER 1979
C      EXTENSION A L'AIDE DES B-SPLINES
C Version of April 6th 1987
C
C Input :
C GRID(NPL1,NL1)
C IFACT = Extension factor  (integer < 128 )
C
C Output :
C OUTPUT(NPL,NL)
C-----------------------------------------------------------------------
	SUBROUTINE EXTEN_SPLINE1(GRID,NPL1,NL1,IDIM_GRID,IFACT,OUTPUT,IDIM)
	PARAMETER(IDIM3=2000)
	REAL*4 GRID(IDIM_GRID,*),OUTPUT(IDIM,*)
 	REAL*4 AMES(4,IDIM3),PSI(128,4),DENS(IDIM3)

	NPL=NPL1*IFACT
	NL=NL1*IFACT
	PRINT *,' NPL,NL,IFACT',NPL,NL,IFACT

C Loading the array PSI for the extension
	DO K=1,IFACT
	  DO L=1,4
	  X=FLOAT(K-1)/FLOAT(IFACT)
	  PSI(K,L)=PHI(X,L)
	  END DO
	END DO

C Reads line 1
	IY=1
 	CALL EXTEN(PSI,IFACT,GRID,IDIM_GRID,IY,NPL1,DENS,NPL)

C Loading AMES(1,*) and AMES(2,*):
 	DO IPL=1,NPL
 	AMES(1,IPL)=DENS(IPL)
	AMES(2,IPL)=DENS(IPL)
	END DO

C Reads line 2
	IY=2
 	CALL EXTEN(PSI,IFACT,GRID,IDIM_GRID,IY,NPL1,DENS,NPL)

C Loading AMES(3,*):
 	DO IPL=1,NPL
	AMES(3,IPL)=DENS(IPL)
	END DO

 	DO 25 IL=1,NL1-1
 	IL1=IL+2
 	IF(IL1.GT.NL1) GO TO 26
C Reads line IL1
	IY=IL1
 	CALL EXTEN(PSI,IFACT,GRID,IDIM_GRID,IY,NPL1,DENS,NPL)

C Loading AMES(4,*):
 	DO IPL=1,NPL
	AMES(4,IPL)=DENS(IPL)
	END DO

26	DO 28 K=1,IFACT
 	IL2=(IL-1)*IFACT+K

 	DO 29 IPL=1,NPL
 	S=0.
	  DO L=1,4
	  S=S+AMES(L,IPL)*PSI(K,L)
	  END DO
	OUTPUT(IPL,IL2)=S
29	CONTINUE

28	CONTINUE

C Rotation on the lines :
	   DO IPL=1,NPL
	   AMES(1,IPL)=AMES(2,IPL)
	   AMES(2,IPL)=AMES(3,IPL)
	   AMES(3,IPL)=AMES(4,IPL)
	   END DO

25	CONTINUE

	RETURN
 	END
C-----------------------------------------------------------------------
C Function PHI
C-----------------------------------------------------------------------
	REAL FUNCTION PHI(X,L)
 	GO TO (1,2,3,4),L
 1	PHI=((1.-X)**3)/6.
 	GO TO 5
 2	PHI=0.5*(X**3)-(X**2)+2./3.
 	GO TO 5
 3	PHI=-0.5*(X**3)+0.5*(X**2)+0.5*X+1./6.
 	GO TO 5
 4	PHI=(X**3)/6.
 5	RETURN
 	END
C--------------------------------------------------------------------------
C Subroutine EXTEN : Extension along a line.
C Input :
C GRID(NPL1,NL1)
C IY : Line index
C
C Output :
C DENS(NPL)		!NPL=NPL1*IFACT
C-----------------------------------------------------------------------
	SUBROUTINE EXTEN(PSI,IFACT,GRID,IDIM_GRID,IY,NPL1,DENS,NPL)
	REAL*4 GRID(IDIM_GRID,*)
 	REAL*4 DENS(1),PSI(128,4)
 	INTEGER*4 IL(4)

 	DO 1 IP=1,NPL1-1
 	   DO L=1,4
 	   IL(L)=IP+L-2
 	   IF(IL(L).LT.1) IL(L)=1
 	   IF(IL(L).GT.NPL1) IL(L)=NPL1
	   END DO

	DO 3 K=1,IFACT
 	IPL=K+(IP-1)*IFACT
 	S=0.
 	   DO L=1,4
 	   S= S + PSI(K,L)*GRID(IL(L),IY)
	   END DO
	DENS(IPL)=S
3	CONTINUE

1	CONTINUE

 	RETURN
 	END
C----------------------------------------------------------------------
C Subroutine COMPRES_HISTO
C
C From "AMCFC.FOR" A.BIJAOUI 25 JUIN 1980
C Generates a compressed map of the background
C
C Input :
C IFACT = Compression factor
C NTERM = Number of points taken into account to fit
C 	  the histogram (at least 30)
C ZMIN,ZMAX = Lower and upper limits for the background determination
C
C Output :
C
C----------------------------------------------------------------------
	SUBROUTINE COMPRES_HISTO(INPUT,NPL,NL,IDIM,GRID,NXCELL,
     1	NYCELL,IDIM_GRID,IFACT,NTERM,ZMIN,ZMAX,ZNOISE)
	REAL*4 INPUT(IDIM,*),GRID(IDIM_GRID,*)
 	INTEGER*4 ISTO(1024)

 	NXCELL=(NPL-1)/IFACT+1
 	NYCELL=(NL-1)/IFACT+1
C Unit for one step in the histogram :
	WORK1=(ZMAX-ZMIN)/800.
	WORK2=ZNOISE/4.
	ZSCALE=AMAX1(WORK1,WORK2)
	PRINT *,' STEP FOR THE HISTOGRAM : ',ZSCALE

C Main loop on the lines :
 	DO 1 IBL=1,NYCELL
 	NL1=1+(IBL-1)*IFACT
 	NL2=MIN(IBL*IFACT,NL)

C Loop on the columns :
 	DO 100 IBP=1,NXCELL
 	NP1=1+(IBP-1)*IFACT
 	NP2=MIN(IBP*IFACT,NPL)

C Erasing the histogram :
 	 DO K=1,1024
	 ISTO(K)=0
	 END DO

C Loading the histogram (values from 10 to 800 in "Zcale" units)
 	DO 3 IL=NL1,NL2
 	DO 3 IPL=NP1,NP2
	WORK=(INPUT(IPL,IL)-ZMIN)/ZSCALE
 	K=NINT(WORK)+1
 	IF(K.LE.10.OR.K.GT.800) GO TO 3
 	ISTO(K)=ISTO(K)+1
 3	CONTINUE

C Looking for the maximum ISTOMAX and KMAX (Peak in the distribution)
 	KMAX=11
 	ISTOMAX=ISTO(11)

 	DO 4 K=12,800
 	IF(ISTO(K).LE.ISTOMAX) GO TO 4
 	KMAX=K
 	ISTOMAX=ISTO(K)
4	CONTINUE

C	PRINT *,' @ KMAX ,ISTOMAX :',KMAX,ISTOMAX

C Preparing the data for the fit of the histogram :
 	NPL1=KMAX-NTERM
 	IF(NPL1.LE.0) NPL1=1
 	NPL2=KMAX+NTERM
 	IF(NPL2.GT.800) NPL2=800
 	NPL3=NPL2-NPL1+1
 	S0=0.
 	S1=0.
 	S2=0.
 	S3=0.

C Shifting the values of (-NPL1) :
	 DO IPL=NPL1,NPL2
	 ISTO(IPL-NPL1+1)=ISTO(IPL)
	 END DO

C Computing the sum of the centred momentum : S0, S1, S2, S3
	DO 5 IPL=1,NPL3
 	  X=ISTO(IPL)
 	  PL=IPL
 	  S0=S0+X
 	  X=X*PL
 	  S1=S1+X
 	  X=X*PL
 	  S2=S2+X
 	  X=X*PL
	  S3=S3+X
5	CONTINUE

C Computing the value of the background (approximation with the shape of the
C peak)
	  IF(S0.EQ.0.)THEN
	   GRID(IBP,IBL)=0.
	  ELSE
	   AM=S1/S0
 	   SIG=S2/S0-AM**2
 	   CURT=S3/S0-3.*AM*S2/S0+2.*(AM**3)
 	   IF(CURT.LE.0.) CURT=0.
 	   AX=(CURT/2.)**0.33333333
 	   FC=AM-AX+FLOAT(NPL1)-2.
 	   GRID(IBP,IBL)=(FC*ZSCALE)+ZMIN
	  ENDIF

100	CONTINUE

1	CONTINUE

	RETURN
 	END
C------------------------------------------------------------------------
C Subroutine TRANSFER_KNOTS
C To transfer the values of a grid from the centre of the cells to the top
C of the cells (Necessary for AMTENB or EXTEN_SPLINE)
C From AMEXP1,	A. Bijaoui 26th Feb 1979
C
C Version 8th April 1987
C
C Input :
C GRIDIN(NPL,NL)
C NPL,NL
C
C Output :
C NPL=(NPL+1)
C NL=(NL+1)
C GRIDIN(NPL,NL)
C-------------------------------------------------------------------------
	SUBROUTINE TRANSFER_KNOTS(GRIDIN,NPL,NL,IDIM_GRID)
	PARAMETER (IDIM2=200)
	REAL*4 GRIDIN(IDIM_GRID,*),GRIDOUT(IDIM2,IDIM2)
	REAL*4 MES1(IDIM2),MES2(IDIM2),MES3(IDIM2),MES4(IDIM2)

 	NPL1=NPL+1
 	NL1=NL+1

 	A1=-1./16.
 	A2=9./16.
 	A3=A2
 	A4=A1

C Loop on the pixels of the first line
C (to fill the arrays MES1, MES2, MES3)
	DO 1 IPL=1,NPL1
C Boundaries :
	IPL0=IPL-2
 	IPL0=MAX(1,IPL0)
 	IPL1=IPL-1
 	IPL1=MAX(1,IPL1)
 	IPL2=IPL
 	IPL2=MIN(NPL,IPL2)
 	IPL3=IPL+1
 	IPL3=MIN(NPL,IPL3)

C Computing the top value from the centre values in the current line
 	X=A1*GRIDIN(IPL0,1)+A2*GRIDIN(IPL1,1)
     1	+A3*GRIDIN(IPL2,1)+A4*GRIDIN(IPL3,1)
 	MES1(IPL)=X
 	MES2(IPL)=MES1(IPL)
 	MES3(IPL)=MES2(IPL)
 1	CONTINUE

C Main loop on the lines :
 	DO 2 IL=1,NL1
 	IL1=IL+1
 	IF(IL1.GT.NL) GO TO 3

 	DO 4 IPL=1,NPL1
C Boundaries :
	IPL0=IPL-2
 	IPL0=MAX(1,IPL0)
 	IPL1=IPL-1
 	IPL1=MAX(1,IPL1)
 	IPL2=IPL
 	IPL2=MIN(NPL,IPL2)
 	IPL3=IPL+1
 	IPL3=MIN(NPL,IPL3)

C Computing the top value from the centre values in the current line
 	X=A1*GRIDIN(IPL0,IL1)+A2*GRIDIN(IPL1,IL1)
     1	+A3*GRIDIN(IPL2,IL1)+A4*GRIDIN(IPL3,IL1)
	MES4(IPL)=X
4	CONTINUE

C Computing output :
3	DO 5 IPL=1,NPL1
 	X=A1*MES1(IPL)+A2*MES2(IPL)+A3*MES3(IPL)+A4*MES4(IPL)
	GRIDOUT(IPL,IL)=X
5	CONTINUE

C Rotation on the lines :
 	DO 6 IPL=1,NPL1
 	MES1(IPL)=MES2(IPL)
 	MES2(IPL)=MES3(IPL)
 	MES3(IPL)=MES4(IPL)
6	CONTINUE

2	CONTINUE

C Transfer back to the input array :
 	NPL=NPL+1
 	NL=NL+1

	DO J=1,NL
	DO I=1,NPL
	GRIDIN(I,J)=GRIDOUT(I,J)
	END DO
	END DO

	RETURN
 	END
C******************************************************************
C Subtraction of the background
C******************************************************************
        SUBROUTINE SUBTRACT(INPUT,OUTPUT,NX1,NY1,IDIM)
        REAL*4 INPUT(IDIM,*),OUTPUT(IDIM,*)
        DO J=1,NY1
          DO I=1,NX1
           OUTPUT(I,J)=INPUT(I,J)-OUTPUT(I,J)
          END DO
        END DO
        RETURN
        END


module solver

use mpi
use schemes
use boundaryConditions
use communicator

implicit none

contains

    subroutine PressureSolver_MPI(P,E_rms,NITS_final,u,v)
        use settings, only: nx, ny, dx, dy, dt, rho, nit, omega_P, tol

        double precision, dimension(ny,0:m+1) :: u,v,P
        double precision :: E_rms, E_sqr_loc, E_sqr
        integer :: NITS_final

        double precision, dimension(ny-2,1:m) :: DIVU, b
        double precision, dimension(ny,1:m) :: E
        double precision, dimension(ny,0:m+1) :: P_new
        double precision :: ap,ae,aw,an,as,P_max
        integer :: i,n

        integer :: ierr

        call DIV(DIVU,u,v)

		ap = 2/dx**2 + 2/dy**2
		ae = 1/dx**2;
		aw = 1/dx**2;
		an = 1/dy**2;
		as = 1/dy**2;
		b = -rho*(DIVU)/dt; ! dt affects possibility of convergence

		n = nx*ny

		!P_new = P

		do i=1,nit
			!print*, i
			P_new(2:ny-1,1:m) = (an*P(3:ny,1:m)+as*P(1:ny-2,1:m) &
				+ae*P(2:ny-1,2:m+1)+aw*P(2:ny-1,0:m-1) + b)/ap

			call setPressureBC_MPI(P_new)

            ! COMMUNICATE(P)
            call communicate(P_new)

			if (mod(i,50)==0) then

				E = P_new(:,1:m) - P(:,1:m)
				E_sqr_loc = sum(E**2)

                call mpi_allreduce(E_sqr_loc,E_sqr,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
                E_rms = sqrt(E_sqr/n)

				if (E_rms<tol) then
					exit
				end if

			end if

            ! MPI_Barrier ??

			P = P + omega_P * (P_new - P)

			call communicate(P)

		end do

		NITS_final = i

		! R = ap*P(2:nz-1,2:ny-1,2:nx-1)-(an*P(2:nz-1,3:ny,2:nx-1)+as*P(2:nz-1,1:ny-2,2:nx-1) &
		!	+ae*P(2:nz-1,2:ny-1,3:nx)+aw*P(2:nz-1,2:ny-1,1:nx-2) &
		!	+at*P(3:nz,2:ny-1,2:nx-1)+ab*P(1:nz-2,2:ny-1,2:nx-1)+b);
		! R_rms = sqrt(sum(R**2)/n)

    end subroutine PressureSolver_MPI

    !----------------------------------------------
    ! PressureSolver_MPI_BiCGStab
    !----------------------------------------------
	subroutine PressureSolver_MPI_BiCGStab(X,E_rms,NITS_final,u,v)
        use settings, only: nx, ny, dx, dy, dt, rho, nit, tol
        double precision, dimension(ny,0:m+1) :: u,v,X
        double precision :: E_rms, E_sqr_loc, E_sqr
        integer :: NITS_final

        double precision, dimension(ny,0:m+1) :: DIVU, b ! includes boundary nodes and flaps
        double precision, dimension(ny,1:m) :: E
        double precision, dimension(ny,0:m+1) :: X_new
        double precision :: ap,ae,aw,an,as,X_max
        integer :: i,n

        ! BiCGStab Variables
        double precision, dimension(ny,0:m+1) :: r, r0_star, p, s, r_new, p_new,  AX_temp
        double precision :: temp_loc, temp1, temp2
        double precision :: alpha, beta, omega

        integer :: id, Nproc, ierr

        call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
        call mpi_comm_size(MPI_COMM_WORLD, Nproc, ierr)

		!call setPressureBC_MPI(X)
        !call communicate(X)
        call DIV_All(DIVU,u,v)

		!ap = 2/dx**2 + 2/dy**2
		!ae = 1/dx**2;
		!aw = 1/dx**2;
		!an = 1/dy**2;
		!as = 1/dy**2;
		b = -rho*(DIVU)/dt; ! dt affects possibility of convergence

        ! for BC's
        b(1,:) = 0; b(ny,:) = 0 ! top and bottom
        ! for cavity, left and right boundaries
        !if (id==0) b(:,1) = 0
        !if (id==Nproc-1) b(:,m) = 0

		n = nx*ny

		!P_new = P

        r = b - AX(X)
        r0_star = r
        p = r
		do i=1,nit
			!print*, i

            AX_temp = AX(p)
            temp_loc = dot_product(pack(r(:,1:m),.true.),pack(r0_star(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp1, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            temp_loc = dot_product(pack(AX_temp(:,1:m),.true.),pack(r0_star(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp2, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            alpha = temp1/temp2

            !print*, temp_loc, temp1, temp2, alpha
            !if(i==50) stop

            s = r - alpha * AX(p)
            call communicate(s)

            AX_temp = AX(s)
            temp_loc = dot_product(pack(AX_temp(:,1:m),.true.),pack(s(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp1, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            temp_loc = dot_product(pack(AX_temp(:,1:m),.true.),pack(AX_temp(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp2, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            omega = temp1/temp2

            ! update X
            X_new = X + alpha*p + omega*s
            call communicate(X_new)

            ! update r
            r_new = s - omega*AX(s)
            call communicate(r_new)

            temp_loc = dot_product(pack(r_new(:,1:m),.true.),pack(r0_star(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp1, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            temp_loc = dot_product(pack(r(:,1:m),.true.),pack(r0_star(:,1:m),.true.))
            call mpi_allreduce(temp_loc, temp2, 1, MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, ierr)
            beta = (temp1/temp2)*(alpha/omega)

            ! update p
            p_new = r_new + beta * (p-omega*AX(p))
            call communicate(p_new)

            ! COMMUNICATE(P)
            !call communicate(X_new)

			!call setPressureBC_MPI(X_new)

			if (mod(i,1)==0) then

				E = X_new(:,1:m) - X(:,1:m)
				E_sqr_loc = sum(E**2)

                call mpi_allreduce(E_sqr_loc,E_sqr,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
                E_rms = sqrt(E_sqr/n)

                !print*, 'Pressure Error:',E_rms

				if (E_rms<tol) then
					exit
				end if

			end if

            ! MPI_Barrier ??

			!X = X_new
            !r = r_new
            !p = p_new

			X = X + omega_P*(X_new-X)
			r = r + omega_P*(r_new-r)
			p = p + omega_P*(p_new-p)

		end do

		NITS_final = i

		! R = ap*P(2:nz-1,2:ny-1,2:nx-1)-(an*P(2:nz-1,3:ny,2:nx-1)+as*P(2:nz-1,1:ny-2,2:nx-1) &
		!	+ae*P(2:nz-1,2:ny-1,3:nx)+aw*P(2:nz-1,2:ny-1,1:nx-2) &
		!	+at*P(3:nz,2:ny-1,2:nx-1)+ab*P(1:nz-2,2:ny-1,2:nx-1)+b);
		! R_rms = sqrt(sum(R**2)/n)

    end subroutine PressureSolver_MPI_BiCGStab

    function AX(X)
        use settings, only: nx, ny, dx, dy, dt

        double precision, dimension(ny,0:m+1) :: X
        double precision, dimension(ny,0:m+1) :: AX
        double precision :: ap, ae, aw, an, as

        integer :: id, Nproc, ierr

        call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
        call mpi_comm_size(MPI_COMM_WORLD, Nproc, ierr)

        ap = 2/dx**2 + 2/dy**2
		ae = 1/dx**2;
		aw = 1/dx**2;
		an = 1/dy**2;
		as = 1/dy**2;

        AX(2:ny-1,1:m) = ap*X(2:ny-1,1:m) - ( an*X(3:ny,1:m) + as*X(1:ny-2,1:m) + aw*X(2:ny-1,0:m-1) + ae*X(2:ny-1,2:m+1) )
         AX(1,1:m) = X(1,1:m) - X(2,1:m)
        AX(ny,1:m) = X(ny,1:m) - X(ny-1,1:m)

		AX(1,:) = X(1,:) - X(2,:)
        AX(ny,:) = X(ny,:) - X(ny-1,:)

        ! for cavity case, bc at left and right edges
        !if (id==0) AX(:,1) = X(:,1) - X(:,2)
        !if (id==Nproc-1) AX(:,m) = X(:,m) - X(:,m-1)

        call communicate(AX)

    end function AX

    subroutine calcUstar_AB(u_star,v_star,u,v,u_last,v_last)
        use settings, only: nx, ny, dx, dy, dt, rho, nit, tol

        double precision, dimension(ny,0:m+1) :: u,v,u_star,v_star,u_last,v_last
        double precision, dimension(2:ny-1,1:m) :: SU,SV,SU_last,SV_last

        double precision, dimension(2:ny-1,1:m) :: D_CONV_U,D_CONV_V,D_CONV_U_last, D_CONV_V_last
        double precision, dimension(2:ny-1,1:m) :: DEL2U,DEL2V,DEL2U_last, DEL2V_last

        call CONV_U_UPWIND(D_CONV_U,u,v)
        call CONV_V_UPWIND(D_CONV_V,u,v)
        call CONV_U_UPWIND(D_CONV_U_last,u_last,v_last)
        call CONV_V_UPWIND(D_CONV_V_last,u_last,v_last)

        call DEL2(DEL2U,u)
        call DEL2(DEL2V,v)
        call DEL2(DEL2U_last,u_last)
        call DEL2(DEL2V_last,v_last)

        SU = -D_CONV_U + nu*DEL2U
        SV = -D_CONV_V + nu*DEL2V
        SU_last = -D_CONV_U_last + nu*DEL2U_last
        SV_last = -D_CONV_V_last + nu*DEL2V_last

        u_star(2:ny-1,1:m) = u(2:ny-1,1:m) + dt * (1.5*SU-0.5*SU_last)
        v_star(2:ny-1,1:m) = v(2:ny-1,1:m) + dt * (1.5*SV-0.5*SV_last)

        call setVelocityBC_MPI(u,v)

    end subroutine

	subroutine calcUstar_Implicit(u_star,v_star,E_rms,NITS_final,u,v,Bx,By)

		double precision, dimension(ny,0:m+1) :: u, v, u_star,v_star
		double precision, dimension(ny,0:m+1) :: u_star_new,v_star_new

		double precision ,dimension(ny-2,1:m) :: D_CONV_U, D_CONV_V, DEL2U, DEL2V

		double precision ,dimension(ny,1:m) :: Bx, By

		double precision, dimension(ny,1:m) :: E
		double precision :: E_rms, E_sqr_loc, E_sqr
        integer :: NITS_final
		integer :: i, n, Nproc, ierr, id

		call mpi_comm_rank(MPI_COMM_WORLD, id, ierr)
        call mpi_comm_size(MPI_COMM_WORLD, Nproc, ierr)

		n = ny*nx

		u_star = u
		v_star = v

		u_star_new = 0
		v_star_new = 0

		do i=1,nit
			call CONV_U_UPWIND(D_CONV_U,u_star,v_star)
			call CONV_V_UPWIND(D_CONV_V,u_star,v_star)

			call DEL2(DEL2U,u_star)
			call DEL2(DEL2V,v_star)

			u_star_new(2:ny-1,1:m) = u(2:ny-1,1:m) + dt*(-D_CONV_U + nu*DEL2U + Bx(2:ny-1,:))
			v_star_new(2:ny-1,1:m) = v(2:ny-1,1:m) + dt*(-D_CONV_V + nu*DEL2V + By(2:ny-1,:))

			call setVelocityBC_MPI(u_star_new,v_star_new)

			!if (id==0) print*, id, v_star_new(1:5,0)
			!if (id==3) print*, id, v_star_new(1:5,m)

			! COMMUNICATE (u_star)
			call communicate(u_star_new)
			call communicate(v_star_new)

			!if (id==0) print*, id, v_star_new(1:5,0)
			!if (id==3) print*, id, v_star_new(1:5,m)

			!if (id==0) read(*,*)

			E = u_star_new(:,1:m) - u_star(:,1:m)
			E_sqr_loc = sum(E**2)

			call mpi_allreduce(E_sqr_loc,E_sqr,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
			E_rms = sqrt(E_sqr/n)

			!if (id==0) print*, 'U_star error:', E_rms

			if (E_rms<tol) then
				exit
			end if

			u_star = u_star + omega_U * (u_star_new - u_star)
			v_star = v_star + omega_V * (v_star_new - v_star)

			call communicate(u_star)
			call communicate(v_star)

		end do

		NITS_final = i

	end subroutine calcUstar_Implicit

end module solver


!
!     ------------------------------------------------------------------
!     P A M T M T
!     ------------------------------------------------------------------
!
      SUBROUTINE PAMTMT(X, T, WORK, NORB)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
!
! GENERATE PER AKE'S T MATRIX FROM A
! ORBITAL ROTATION MATRIX X
!
! T IS OBTAINED AS A STRICTLY LOWER TRIANGULAR
! MATRIX TL AND AN UPPER TRIANGULAR MATRIX TU
!
!         TL = 1 - L
!         TU = U ** -1
!
! WHERE L AND U ARISES FROM A LU DECOMPOSITION OF
! X :
!         X = L * U
! WITH L BEING A LOWER TRIANGULAR MATRIX WITH UNIT ON THE
! DIAGONAL AND U IS AN UPPER TRIANGULAR MATRIX
!
! JEPPE OLSEN OCTOBER 1988
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  14:43:44  11/20/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE lulu_I
      USE setvec_I
      USE wrtmat_I
      USE invmat_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: NORB
      REAL(DOUBLE)  :: X(NORB,NORB)
      REAL(DOUBLE)  :: T(NORB,NORB)
      REAL(DOUBLE)  :: WORK(*)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NTEST, KLFREE, KLL, KLU, I, J
!-----------------------------------------------
! DIMENSION OF WORK : NORB ** 2 + NORB*(NORB+1) / 2
!
      NTEST = 0
!. Allocate local memory
      KLFREE = 1
!     KLL = KFLREE
      KLL = KLFREE
      KLFREE = KLL + NORB*(NORB + 1)/2
      KLU = KLFREE
      KLFREE = KLU + NORB**2
!.LU factorize X
      CALL LULU (X, WORK(KLL), WORK(KLU), NORB)
!.Expand U to full matrix
      CALL SETVEC (T, 0.0D0, NORB**2)
      DO I = 1, NORB
         DO J = I, NORB
            T(I,J) = WORK(KLU-1+J*(J-1)/2+I)
         END DO
      END DO
      IF (NTEST >= 10) THEN
         WRITE (6, *) ' MATRIX TO BE INVERTED '
         CALL WRTMAT (T, NORB, NORB, NORB, NORB)
      ENDIF
!.Invert U
      CALL INVMAT (T, WORK(KLU), NORB, NORB)
      IF (NTEST >= 10) THEN
         WRITE (6, *) ' INVERTED MATRIX '
         CALL WRTMAT (T, NORB, NORB, NORB, NORB)
      ENDIF
!.Subtract L
      DO I = 1, NORB
         T(I,:I-1) = -WORK(KLL+I*(I-1)/2:I-2+KLL+I*(I-1)/2)
      END DO
!
      IF (NTEST /= 0) THEN
         WRITE (6, *) ' INPUT X MATRIX '
         CALL WRTMAT (X, NORB, NORB, NORB, NORB)
         WRITE (6, *) ' T MATRIX '
         CALL WRTMAT (T, NORB, NORB, NORB, NORB)
      ENDIF
!
      RETURN
      END SUBROUTINE PAMTMT


C
C $Id: curvpsdp.f,v 1.3 2008-07-27 03:10:10 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
C NOTE: If you make any changes to this software, please remember to
C make the same changes to the corresponding single precision routine.
C
      SUBROUTINE CURVPSDP(N,X,Y,P,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP,IERR)
c
      INTEGER N,ISW,IERR
      DOUBLE PRECISION X(N),Y(N),P,D(N),S,EPS,YS(N),YSP(N),SIGMA,
     +                 TEMP(N,11)
c
c                                 coded by alan kaylor cline
c                              from fitpack -- april 8, 1991
c                        a curve and surface fitting package
c                      a product of pleasant valley software
c                  8603 altus cove, austin, texas 78759, usa
c
c this subroutine determines the parameters necessary to
c compute a periodic smoothing spline under tension. for a
c given increasing sequence of abscissae (x(i)), i = 1,...,n
c and associated ordinates (y(i)), i = 1,...,n, letting p be
c the period, x(n+1) = x(1)+p, and y(n+1) = y(1), the
c function determined minimizes the summation from i = 1 to
c n of the square of the second derivative of f plus sigma
c squared times the difference of the first derivative of f
c and (f(x(i+1))-f(x(i)))/(x(i+1)-x(i)) squared, over all
c functions f with period p and two continuous derivatives
c such that the summation of the square of
c (f(x(i))-y(i))/d(i) is less than or equal to a given
c constant s, where (d(i)), i = 1,...,n are a given set of
c observation weights. the function determined is a periodic
c spline under tension with third derivative discontinuities
c at (x(i)) i = 1,...,n (and all periodic translations of
c these values). for actual computation of points on the
c curve it is necessary to call the function curvp2dp. the
c determination of the curve is performed by subroutine
c curvpp, the subroutin curvps only decomposes the workspace
c for curvpp.
c
c on input--
c
c   n is the number of values to be smoothed (n.ge.2).
c
c   x is an array of the n increasing abscissae of the
c   values to be smoothed.
c
c   y is an array of the n ordinates of the values to be
c   smoothed, (i. e. y(k) is the functional value
c   corresponding to x(k) ).
c
c   p is the period (p .gt. x(n)-x(1)).
c
c   d is a parameter containing the observation weights.
c   this may either be an array of length n or a scalar
c   (interpreted as a constant). the value of d
c   corresponding to the observation (x(k),y(k)) should
c   be an approximation to the standard deviation of error.
c
c   isw contains a switch indicating whether the parameter
c   d is to be considered a vector or a scalar,
c          = 0 if d is an array of length n,
c          = 1 if d is a scalar.
c
c   s contains the value controlling the smoothing. this
c   must be non-negative. for s equal to zero, the
c   subroutine does interpolation, larger values lead to
c   smoother funtions. if parameter d contains standard
c   deviation estimates, a reasonable value for s is
c   float(n).
c
c   eps contains a tolerance on the relative precision to
c   which s is to be interpreted. this must be greater than
c   or equal to zero and less than or equal to one. a
c   reasonable value for eps is sqrt(2./float(n)).
c
c   ys is an array of length at least n.
c
c   ysp is an array of length at least n.
c
c   sigma contains the tension factor. this value indicates
c   the degree to which the first derivative part of the
c   smoothing functional is emphasized. if sigma is nearly
c   zero (e. g. .001) the resulting curve is approximately a
c   cubic spline. if sigma is large (e. g. 50.) the
c   resulting curve is nearly a polygonal line. if sigma
c   equals zero a cubic spline results. a standard value for
c   sigma is approximately 1.
c
c and
c
c   temp is an array of length at least 11*n which is used
c   for scratch storage.
c
c on output--
c
c   ys contains the smoothed ordinate values.
c
c   ysp contains the values of the second derivative of the
c   smoothed curve at the given nodes.
c
c   ierr contains an error flag,
c        = 0 for normal return,
c        = 1 if n is less than 2,
c        = 2 if s is negative,
c        = 3 if eps is negative or greater than one,
c        = 4 if x-values are not strictly increasing,
c        = 5 if a d-value is non-positive,
c        = 6 if p is less than or equal to x(n)-x(1).
c
c and
c
c   n, x, y, p, d, isw, s, eps, and sigma are unaltered.
c
c this subroutine references package modules curvpp, terms,
c and snhcsh.
c
c-----------------------------------------------------------
c
c decompose temp into eleven arrays and call curvpp
c
c
      CALL CURVPPDP(N,X,Y,P,D,ISW,S,EPS,YS,YSP,SIGMA,TEMP(1,1),
     +  TEMP(1,2),TEMP(1,3),TEMP(1,4),TEMP(1,5),TEMP(1,6),TEMP(1,7),
     +            TEMP(1,8),TEMP(1,9),TEMP(1,10),TEMP(1,11),IERR)
      RETURN
      END


c
c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine madsum(lastkn,lastrs,ibegin,aij,
     >                  rslatmd,knlat_x,knlat_y,knlat_z,knlatsq,
     >                  eta,tau,madmat,
     >                  pi4,iprint,istop)
c     ================================================================
c
c     ****************************************************************
c     performs ewald summation for Madelung constant.
c     requires 'lastkn,lastrs,eta,knlat,aij'
c     returns 'madelung sum': madmat
c     ****************************************************************
      implicit   none
c
      character  istop*32
      character  sname*32
      parameter (sname='madsum')
c
      integer    lastkn
      integer    lastrs
      integer    ibegin
      integer    iprint
      integer    i
c
      real*8     knlat_x(lastkn)
      real*8     knlat_y(lastkn)
      real*8     knlat_z(lastkn)
      real*8     knlatsq(lastkn)
      real*8     rslatmd(lastrs)
      real*8     aij(3)
      real*8     eta
      real*8     tau
      real*8     madmat
      real*8     pi4
      real*8     fac
      real*8     zero
      real*8     four
      real*8     erfc
      real*8     erf
c
      parameter (zero=0.0d0)
      parameter (four=4.0d0)
c
c     ================================================================
c                                     2   2       -> ->
c              4*pi          1    -eta *Kq /4 - i*Kq*aij
c     term1 =  ---- * sum  ----- e
c              tau    q<>0    2
c                           Kq
c
c     note sum starts at 2 since kn=0.0 of 1/(rs-aij) is
c     canceled by kn=0.0 of the 1/rs sum.
c     ================================================================
      madmat = zero
      fac=eta*eta/four
      do i = 2,lastkn
         madmat=madmat+exp(-fac*knlatsq(i))/knlatsq(i)
     >                *cos( knlat_x(i)*aij(1)+knlat_y(i)*aij(2)
     >                     +knlat_z(i)*aij(3) )
c if(i.le.5)write(6,'(''i,a,k,f,m'',i5,10f10.4)')
c     >   i,aij(1),aij(2),aij(3),knlat_x(i),knlat_y(i)
c     >   ,knlat_z(i),exp(-fac*knlatsq(i))/knlatsq(i)*pi4/tau
c     >        ,madmat*pi4/tau*6./3.5449077d0
      enddo
      madmat = pi4/tau*madmat
c     ================================================================
c
c                           ->   ->
c                  1 - erf(|Rn + aij|/eta)
c     term2 = sum -------------------------
c              n         ->   ->
c                       |Rn + aij|
c
c     note for calculation of aij=0.0 term ibegin=2.
c     ================================================================
      do i=ibegin,lastrs
c     do i=ibegin,1
	 erf=erfc(rslatmd(i)/eta)/rslatmd(i)
         madmat = madmat + erf
c     if(i.lt.20.and.iprint.ge.0)write(6,'('' i,erf'',i5,3f15.7)')i,
c    >rslatmd(i),eta,erf
      enddo
c
      return
      end


       module trigd

	  implicit none

	  contains

	    function sind(x)
	      real*4 sind, x, pi180_sp
              pi180_sp=2.0e0 * asin(1.0e0) / 180.0e0
	      sind = sin(pi180_sp * x)
	    end function sind

	    function dsind(x)
	      real*8 dsind, x, pi180_dp
              pi180_dp=2.0d0 * asin(1.0d0) / 180.0d0
	      dsind = sin(pi180_dp * x)
	    end function dsind

	    function dasind(x)
	      real*8 dasind, x, pi180_dp
              pi180_dp=2.0d0 * asin(1.0d0) / 180.0d0
	      dasind = asin(x) / pi180_dp
	    end function dasind

	    function cosd(x)
	      real*4 cosd, x, pi180_sp
              pi180_sp=2.0e0 * asin(1.0e0) / 180.0e0
              print *,pi180_sp, x
	      cosd = cos(pi180_sp * x)
	    end function cosd

	    function dcosd(x)
	      real*8 dcosd, x, pi180_dp
              pi180_dp=2.0d0 * asin(1.0d0) / 180.0d0
	      dcosd = cos(pi180_dp * x)
	    end function dcosd

	    function dacosd(x)
	      real*8 dacosd, x, pi180_dp
              pi180_dp=2.0d0 * asin(1.0d0) / 180.0d0
	      dacosd = acos(x) / pi180_dp
	    end function dacosd

	    function atan2d(x,y)
	      real*4 atan2d, x, y, pi180_sp
              pi180_sp=2.0e0 * asin(1.0e0) / 180.0e0
	      atan2d = atan2(x,y) / pi180_sp
	    end function atan2d

	    function datan2d(x,y)
	      real*8 datan2d, x, y, pi180_dp
              pi180_dp=2.0d0 * asin(1.0d0) / 180.0d0
	      datan2d = atan2(x,y) / pi180_dp
	    end function datan2d

	end module trigd


PROGRAM PRINTQS
IMPLICIT NONE

INTERFACE
  FUNCTION Heus2010(T, qs, qt)
    REAL, INTENT(IN) :: T   ! [K] temperature to evalute at (Tl)
    REAL, INTENT(IN) :: qs  ! []  qsat at this temperature T
    REAL, INTENT(IN) :: qt  ! []  total liquid water
  END FUNCTION Heus2010

  FUNCTION dales_formula(T)
    REAL :: dales_formula
    REAL, INTENT(IN) :: T
  END FUNCTION dales_formula

  FUNCTION dales_formula_ice(T)
    REAL :: dales_formula_ice
    REAL, INTENT(IN) :: T
  END FUNCTION dales_formula_ice

  FUNCTION Huang(T)
    REAL :: Huang
    REAL, INTENT(IN) :: T
  END FUNCTION Huang

  FUNCTION Huang_Ice(T)
    REAL :: Huang_Ice
    REAL, INTENT(IN) :: T
  END FUNCTION Huang_Ice

  FUNCTION WagnerPruss(T)
    REAL ::  WagnerPruss
    REAL, INTENT(IN) :: T
  END FUNCTION WagnerPruss

  FUNCTION WagnerPruss_Ice(T)
    REAL ::  WagnerPruss_Ice
    REAL, INTENT(IN) :: T
  END FUNCTION WagnerPruss_Ice

  FUNCTION Improved_Magnus(T)
    REAL ::  Improved_Magnus
    REAL, INTENT(IN) :: T
  END FUNCTION Improved_Magnus

  FUNCTION Improved_Magnus_Ice(T)
    REAL ::  Improved_Magnus_Ice
    REAL, INTENT(IN) :: T
  END FUNCTION Improved_Magnus_Ice
END INTERFACE

INTEGER :: n
REAL :: T, T_prev, T0  ! temperature [K]
REAL :: qt, qc, qc_prev  ! [g/kg]
REAL :: qs
REAL :: esat  ! Saturation vapour pressure [Pa]
REAL :: rlvt
REAL :: beta
REAL :: p
REAL :: qsat ! Saturation specific humidity [g/kg]

REAL, PARAMETER :: eps0 = 0.622
REAL, PARAMETER :: rd = 287.05
REAL, PARAMETER :: cp = 1005.0
REAL, PARAMETER :: rv = 461.5

! WRITE (*,*) "Over water"
! WRITE (*,*) "n, WagnerPruss(T), Improved_Magnus(T), Huang(T), dales_formula"
! DO n=-40,40 ! in degC
!   T = n + 273.15 ! from degC to K
!   WRITE (*,*) n, WagnerPruss(T), Improved_Magnus(T), Huang(T), dales_formula(T) !, WagnerPruss_Ice(T), Improved_Magnus_Ice(T)
! END DO

! WRITE (*,*) "Over Ice"
! WRITE (*,*) "n, WagnerPruss(T), Improved_Magnus(T), Huang(T), dales_formula"
! DO n=-40,40 ! in degC
!   T = n + 273.15  ! from degC to K
!   WRITE (*,*) n, WagnerPruss_Ice(T), Improved_Magnus_Ice(T), Huang_Ice(T), dales_formula_ice(T)
! END DO

! Starting point: oversaturated at ~20 degC and 1 bar
T0 = 275.0  ! [K]
p = 1.0E5  ! [Pa]
qt = (eps0/p) * WagnerPruss(290.0) + 1.E-6

! start
T = T0
qc = 0.0
write(*,*) 'n, T, qc, deltaT, delatQc'

! NOTE: From Heus2010: To calculate q_s~ an implicit equation needs to be solved, because T~ is not directly available
! and has to be diagnosed from the prognostic variables θl and qt .

! TODO: for the above note, it seems we have an (implicit?) constraint on T via theta_l.
! that is currently not there,
DO n=1,30
  ! store previous steps
  T_prev = T
  qc_prev = qc

  ! condens water
  rlvt = 3151378 - 2386*T  ! TODO: independent from T
  beta = eps0*rlvt**2/(rd*cp*T*T)
  esat  = Improved_Magnus(T)
  qsat = eps0*esat/(p-(1.-rd/rv)*esat)
  qs = qsat*(1+beta*qt)/(1+beta*qsat)

  ! Eq. (53) in Heus2010: "all or nothing" cloud adjustment
  qc = max(qt - qs, 0.)

  ! adjust T
  T = T_prev + (qc - qc_prev)*rlvt/cp

  write(*,*) n, T, qc, (T-T_prev), (qc - qc_prev)
ENDDO

END PROGRAM

! A single step in the iterative procedure from Heus2010 eq (59)
FUNCTION Heus2010(T, qs, qt)
  IMPLICIT NONE
  REAL :: Heus2010
  REAL, INTENT(IN) :: T   ! [K] temperature to evalute at (Tl)
  REAL, INTENT(IN) :: qs  ! []  qsat at this temperature T
  REAL, INTENT(IN) :: qt  ! []  total liquid water

  REAL, PARAMETER :: L = 2.5e6      ! [J/kg] the latent heat of vaporization
  REAL, PARAMETER :: Rv = 461.5     ! [J/kgK] the gas constant for water vapor
  REAL, PARAMETER :: c_pd = 1004.0  ! [J/kgK] the heat capacity of dry air
  REAL, PARAMETER :: c = Rv * c_pd / L**2

  ! Heus2010 = qs * &
  !   (1. + L**2 * qt / (Rv * c_pd * T**2)) / &
  !   (1. + L**2 * qs / (Rv * c_pd * T**2))

  ! Heus2010 = qs * (c * T*T + qt) / (c * T*T + qs)
  Heus2010 = qs * (1 + qt/(c*T*T)) / (1 + qs/(c*T*T))
END FUNCTION Heus2010

! Improved_Magnus [Pa] saturation vapor pressure over water
! T [K] temperature
FUNCTION Improved_Magnus(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL  :: Improved_Magnus

Improved_Magnus = 610.94 * EXP((17.625 * (T-273.15)) / (T + 243.04 - 273.15))
END FUNCTION

! Improved_Magnus [Pa] saturation vapor pressure over ice
! T [K] temperature
FUNCTION Improved_Magnus_Ice(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL  :: Improved_Magnus_Ice

Improved_Magnus_Ice = 611.21 * EXP((22.587 * (T-273.15)) / (T + 273.86 - 273.15))
END FUNCTION Improved_Magnus_Ice

! WagnerPruss [Pa] saturation vapor pressure of water
! T [K] temperature
FUNCTION WagnerPruss(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL :: WagnerPruss  ! saturation water vapour pressure [Pa]

REAL, PARAMETER :: TC = 647.096 ! critical point temperature [K]

REAL :: x

x = (1 - (T/TC))
WagnerPruss = 22064000.0 * EXP( (TC/T) * ( &
  - 7.85951783 * x &
  + 1.84408259 * x**1.5 &
  - 11.7866497 * x**3 &
  + 22.6807411 * x**3.5 &
  - 15.9618719 * x**4 &
  + 1.80122502 * x**7.5 &
  ))

END FUNCTION WagnerPruss

! WagnerPrussIce [Pa] saturation vapor pressure over ice
! T [K] temperature
! NOTE: those values are all wrong.. check formula!
FUNCTION WagnerPruss_Ice(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL :: WagnerPruss_Ice

REAL, PARAMETER :: TT = 273.16 ! Triple point temperature of water [K]

WagnerPruss_Ice = 611.657 * EXP( &
  (TT/T) * ( &
    + 21.2144006 * (T/TT)**0.00333333333 &
    + 27.3203819 * (T/TT)**1.20666667 &
    +  6.1059813 * (T/TT)**1.70333333 &
  ))

END FUNCTION WagnerPruss_Ice

! Huang [Pa] saturation vapor pressure over water
! T [K] temperature
FUNCTION Huang(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL  :: Huang

REAL :: TC

TC = T - 273.15  !  TC [degC]

Huang = EXP(34.494 - 4924.99 / (TC + 237.1)) /  (TC + 105)**1.57

END FUNCTION Huang

! Huang [Pa] saturation vapor pressure over water
! T [K] temperature
FUNCTION Huang_Ice(T)

IMPLICIT NONE
REAL, INTENT(IN) :: T
REAL  :: Huang_Ice

REAL :: TC

TC = T - 273.15  !  TC [degC]

Huang_Ice = EXP(43.494 -  6545.8 / (TC + 278)) / (TC + 868)**2

END FUNCTION Huang_Ice

! Current implementation in DALES
FUNCTION dales_formula(T)
  IMPLICIT NONE
  INTERFACE
    FUNCTION sattab_l(m)
      REAL :: sattab_l
      INTEGER, INTENT(IN) :: m
    END FUNCTION sattab_l

    FUNCTION sattab_i(m)
      REAL :: sattab_i
      INTEGER, INTENT(IN) :: m
    END FUNCTION sattab_i
  END INTERFACE

  real,parameter :: rd      = 287.04           !<    * gas constant for dry air.
  real,parameter :: rv      = 461.5            !<    * gas constant for water vapor.
  real,parameter :: tup     = 268.             !<    * Temperature range over which mixed phase occurs (high)
  real,parameter :: tdn     = 253.             !<    * Temperature range over which mixed phase occurs (low)

  real, intent(in) :: T
  real :: dales_formula
  real :: esl, qvsl, qvsi

  real :: ilratio
  real :: esi, thi, tlo
  integer :: tlonr, thinr

  tlonr=int(T*5.)
  tlo = tlonr - T*5.
  esl=(tlo + 1.0)*sattab_l(tlonr - 750)-tlo*sattab_l(tlonr - 750 + 1)
  esi=(tlo + 1.0)*sattab_i(tlonr - 750)-tlo*sattab_i(tlonr - 750 + 1)
  dales_formula = esl
end function dales_formula

FUNCTION dales_formula_ice(T)
  IMPLICIT NONE
  INTERFACE
    FUNCTION sattab_l(m)
      REAL :: sattab_l
      INTEGER, INTENT(IN) :: m
    END FUNCTION sattab_l

    FUNCTION sattab_i(m)
      REAL :: sattab_i
      INTEGER, INTENT(IN) :: m
    END FUNCTION sattab_i
  END INTERFACE

  real,parameter :: rd      = 287.04           !<    * gas constant for dry air.
  real,parameter :: rv      = 461.5            !<    * gas constant for water vapor.
  real,parameter :: tup     = 268.             !<    * Temperature range over which mixed phase occurs (high)
  real,parameter :: tdn     = 253.             !<    * Temperature range over which mixed phase occurs (low)

  real, intent(in) :: T
  real :: dales_formula_ice
  real :: esl, qvsl, qvsi

  real :: ilratio
  real :: esi, thi, tlo
  integer :: tlonr, thinr

  tlonr=int(T*5.)
  tlo = tlonr - T*5.
  esl=(tlo + 1.0)*sattab_l(tlonr - 750)-tlo*sattab_l(tlonr - 750 + 1)
  esi=(tlo + 1.0)*sattab_i(tlonr - 750)-tlo*sattab_i(tlonr - 750 + 1)
  dales_formula_ice = esl
END FUNCTION dales_formula_ice

FUNCTION sattab_l(m)
  implicit none
  integer, intent(in) :: m
  real :: sattab_l, t

  t = 150.+0.2*m
  sattab_l = exp(54.842763-6763.22/t-4.21*log(t)+0.000367*t+&
       tanh(0.0415*(t-218.8))*(53.878-1331.22/t-9.44523*log(t)+ 0.014025*t))
END FUNCTION sattab_l

FUNCTION sattab_i(m)
  implicit none
  integer, intent(in) :: m
  real :: sattab_i, t

  t = 150.+0.2*m
  sattab_i = exp(9.550426-5723.265/t+3.53068*log(t)-0.00728332*t)
END FUNCTION sattab_i


      SUBROUTINE pade(cof,n,resid)
      INTEGER n,NMAX
      REAL resid,BIG
      DOUBLE PRECISION cof(2*n+1)
      PARAMETER (NMAX=20,BIG=1.E30)
CU    USES lubksb,ludcmp,mprove
      INTEGER j,k,indx(NMAX)
      REAL d,rr,rrold,sum,q(NMAX,NMAX),qlu(NMAX,NMAX),x(NMAX),y(NMAX),
     *z(NMAX)
      do 12 j=1,n
        x(j)=cof(n+j+1)
        y(j)=x(j)
        do 11 k=1,n
          q(j,k)=cof(j-k+n+1)
          qlu(j,k)=q(j,k)
11      continue
12    continue
      call ludcmp(qlu,n,NMAX,indx,d)
      call lubksb(qlu,n,NMAX,indx,x)
      rr=BIG
1     continue
        rrold=rr
        do 13 j=1,n
          z(j)=x(j)
13      continue
        call mprove(q,qlu,n,NMAX,indx,y,x)
        rr=0.
        do 14 j=1,n
          rr=rr+(z(j)-x(j))**2
14      continue
      if(rr.lt.rrold)goto 1
      resid=sqrt(rr)
      do 16 k=1,n
        sum=cof(k+1)
        do 15 j=1,k
          sum=sum-x(j)*cof(k-j+1)
15      continue
        y(k)=sum
16    continue
      do 17 j=1,n
        cof(j+1)=y(j)
        cof(j+n+1)=-x(j)
17    continue
      return
      END

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


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c Detrend the window centered at B(ii,jj) and output to W.

      subroutine detrend_window(B,ib,jb,ii,jj,W,ia,ja,rsw,csw)
      implicit none
c Inputs...
      integer ib,jb
      integer*2 B(-ib:ib,-jb:jb)	!search area
      integer ia,ja
      integer ii,jj			!center window at B(ii,jj)
c Output...
      integer*2 W(-ia:ia,-ja:ja)	!detrended window
c Scratch space...
      integer rsw(-ja:ja)	!row sums of w(i,j)
      integer csw(-ia:ia)	!column sums of w(i,j)

      common/cd/npixels,sii,sjj
      real npixels,sii,sjj

c Local variables...
      integer i,j		!w(i,j) = b(i+ii,j+jj)
      integer rsumw
      integer sumw,sumwi,sumwj
      real*8 c1,c2,c3		!plane constants

c Fit window W to a brightness plane D, where

c	d(i,j) = c1*i + c2*j + c3

c solving for the coefficients c1, c2, and c3 that minimize the
c least-squares error.

      sumw = 0
      do i=-ia,ia
         csw(i) = 0
      enddo

      do j=-ja,ja
         rsumw = 0
         do i=-ia,ia
            w(i,j) = b(i+ii,j+jj)	!copy window from B to W
            rsumw = rsumw + w(i,j)
            csw(i) = csw(i) + w(i,j)
         enddo
         sumw = sumw + rsumw
         rsw(j) = rsumw
      enddo

      sumwi = 0
      do i=-ia,ia
         sumwi = sumwi + csw(i)*i
      enddo

      sumwj = 0
      do j=-ja,ja
         sumwj = sumwj + rsw(j)*j
      enddo

      c1 = sumwi/sii
      c2 = sumwj/sjj
      c3 = sumw/npixels

c Detrend the window...

      do j=-ja,ja
         do i=-ia,ia
            w(i,j) = w(i,j) - (c1*i+c2*j+c3)
         enddo
      enddo

      return
      end


      SUBROUTINE MC01SW( A, B, M, E )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To find the mantissa M and the exponent E of a real number A such
C     that
C        A = M * B**E
C        1 <= ABS( M ) < B
C     if A is non-zero. If A is zero, then M and E are set to 0.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     A       (input) DOUBLE PRECISION
C             The number whose mantissa and exponent are required.
C
C     B       (input) INTEGER
C             The base of the floating-point arithmetic.
C
C     M       (output) DOUBLE PRECISION
C             The mantissa of the floating-point representation of A.
C
C     E       (output) INTEGER
C             The exponent of the floating-point representation of A.
C
C     NUMERICAL ASPECTS
C
C     None.
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Mar. 1997.
C     Supersedes Release 2.0 routine MC01GZ by A.J. Geurts.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           B, E
      DOUBLE PRECISION  A, M
C     .. Local Scalars ..
      DOUBLE PRECISION  DB
C     .. Intrinsic Functions ..
      INTRINSIC         ABS, DBLE
C     .. Executable Statements ..
C
C     Quick return if possible.
C
      IF ( A.EQ.ZERO ) THEN
         M = ZERO
         E = 0
         RETURN
      END IF
C
C     A non-zero.
C
      DB = DBLE( B )
      M = ABS( A )
      E = 0
C     WHILE ( M >= B ) DO
   20 IF ( M.GE.DB ) THEN
         M = M/DB
         E = E + 1
         GO TO 20
      END IF
C     END WHILE 20
C     WHILE ( M < 1 ) DO
   40 IF ( M.LT.ONE ) THEN
         M = M*DB
         E = E - 1
         GO TO 40
      END IF
C     END WHILE 40
C
      IF ( A.LT.ZERO ) M = -M
C
      RETURN
C *** Last line of MC01SW ***
      END


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

  if (improveN .eq. 0) then
     w0_N = 1.D0
     w1_N = 1.D0
     w2_N = 0.D0
     w3_N = 0.D0
  elseif (improveN .eq. 1) then
     w0_N = 5.D0/4.D0
     w1_N = 4.D0/3.D0
     w2_N = 1.D0/12.D0
     w3_N = 0.D0
  elseif (improveN .eq. 2) then
     w0_N = 49.D0/36.D0
     w1_N = 3.D0/2.D0
     w2_N = 3.D0/20.D0
     w3_N = 1.D0/90.D0
  else
     if (myid .eq. 0) then
        write(*,*)'error in improveN'
     endif
     stop
  endif

  if (improveP .eq. 0) then
     w0_P = 1.D0
     w1_P = 1.D0
     w2_P = 0.D0
     w3_P = 0.D0
  elseif (improveP .eq. 1) then
     w0_P = 5.D0/4.D0
     w1_P = 4.D0/3.D0
     w2_P = 1.D0/12.D0
     w3_P = 0.D0
  elseif (improveP .eq. 2) then
     w0_P = 49.D0/36.D0
     w1_P = 3.D0/2.D0
     w2_P = 3.D0/20.D0
     w3_P = 1.D0/90.D0
  else
     if (myid .eq. 0) then
        write(*,*)'error in improveP'
     endif
     stop
  endif

  if (improveD .eq. 0) then
     o1 = 1.D0
     o2 = 0.D0
     o3 = 0.D0
  elseif (improveD .eq. 1) then
     o1 = 4.D0/3.D0
     o2 = 1.D0/6.D0
     o3 = 0.D0
  elseif (improveD .eq. 2) then
     o1 = 3.D0/2.D0
     o2 = 3.D0/10.D0
     o3 = 1.D0/30.D0
  else
     if (myid .eq. 0) then
        write(*,*)'error in improveD'
     endif
     stop
  endif

  !     parameter for renormalizing the pion field

  qpi3 = atovera*(ampi3**2+6.D0*w0_P)

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


program pgm
integer :: a(2:3,2:3,2:3), i , j, k, c

c = 1
do i = 2, 3
do j = 2, 3
do k = 2, 3
 a(j,i,k) = c
 c = c + 1
enddo
enddo
enddo

do k = 2, 3
do j = 2, 3
do i = 2, 3
 if (a(k,j,i) <= a(i,j,k)) then
  print *, a(k,j,i)
 endif
enddo
enddo
enddo
end


!---------------------------------------------------!
! Copyright (c) 2016 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
!-------10--------20--------30--------40--------50--------60--------70--------80--------90
subroutine mesh
  use global_variables
  implicit none
  integer :: ix, iy

  write(*,'(A)')'===== Making mesh ================================================================'
  write(*,'(A)')
  write(*,'(A)')

  allocate(xn(0:Nx),Rn(0:NR),xRn(0:Nx,0:NR))
  dx = length_x/dble(Nx)
  dr = length_R/dble(NR)

  do ix = 0,Nx
     xn(ix) = dx*dble(ix) - 0.5d0*length_x
  end do

  do ix = 0,NR
    Rn(ix) = dr*dble(ix)
  end do

  write(*,'(A)')'===== Complete Making mesh ========================================================'
  return
end subroutine mesh


    Program dpftrf_example

!     DPFTRF Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dpftrf, dtfttr
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer :: i, ifail, info, k, lar1, lda, lenar, n, q
      Character (1) :: transr, uplo
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), ar(:)
!     .. Executable Statements ..
      Write (nout, *) 'DPFTRF Example Program Results'
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, uplo, transr

      lenar = n*(n+1)/2
      lda = n
      Allocate (ar(lenar), a(lda,n))

!     Setup notional dimensions of RFP matrix AR
      k = n/2
      q = n - k
      If (transr=='N' .Or. transr=='n') Then
        lar1 = 2*k + 1
      Else
        lar1 = q
      End If

!     Read an RFP matrix into array AR
      Do i = 1, lar1
        Read (nin, *) ar(i:lenar:lar1)
      End Do

!     Factorize A
      Call dpftrf(transr, uplo, n, ar, info)

      Write (nout, *)
      Flush (nout)
      If (info==0) Then

!       Convert factor to full array form, and print it
        Call dtfttr(transr, uplo, n, ar, a, lda, info)
        ifail = 0
        Call nagf_file_print_matrix_real_gen(uplo, 'Nonunit', n, n, a, lda, &
          'Factor', ifail)

      Else
        Write (nout, *) 'A is not positive definite'
      End If

    End Program


program bits_02
use iso_fortran_env, only: block_kind => int64, bits_kind  => int32
implicit none

    integer(bits_kind), parameter :: block_size  = bit_size(0_block_kind)
    integer(block_kind), parameter :: all_zeros  = 0_block_kind
    integer(block_kind), parameter :: all_ones   = not(all_zeros)

    print *, block_size
    print *, all_zeros
    print *, all_ones

end program


!
! Numeric vector sort
!
program perf
    implicit none
    integer, parameter :: N = 10000000
    real*8 d(N)
    integer*8 t0, t1
    integer*8 hz

    call random_number(d)
    call system_clock(t0)
    call quicksort(d, 1, N)
    call system_clock(t1)

    call system_clock(count_rate=hz)
    print "('size = ', i0, ', msec = ', f0.1)", N, (t1 - t0) * 1000.0 / hz

contains

    recursive subroutine quicksort(a, lo0, hi)
        real*8 a(:)
        integer lo0, hi
        integer i, j, lo
        real*8 pivot, t

        lo = lo0
        i = lo
        j = hi
        do while (i < hi)
            pivot = a((lo+hi)/2)
            do while (i <= j)
                do while (a(i) < pivot)
                    i = i + 1
                end do
                do while (a(j) > pivot)
                    j = j - 1
                end do
                if (i <= j) then
                    t = a(i)
                    a(i) = a(j)
                    a(j) = t
                    i = i + 1
                    j = j - 1
                end if
            end do
            if (lo < j) call quicksort(a, lo, j)
            lo = i
            j = hi
        end do
    end subroutine

end program


MODULE FDM_Grid2D
    USE precision
    IMPLICIT NONE
    INTEGER :: nx, ny
    REAL(dp) :: xmin, xmax, ymin, ymax
    REAL(dp) :: delta_x, delta_y
    REAL(dp), DIMENSION(:), ALLOCATABLE :: x, y

    CONTAINS
    	SUBROUTINE SetFDMGrid
        	IMPLICIT NONE
            INTEGER :: i

            xmin = 0.0d0
            xmax = 1.0d0

            ymin = 0.0d0
            ymax = 2.0d0

            nx = 20
            ny = 40

            delta_x = (xmax - xmin) / (nx - 1)
            delta_y = (ymax - ymin) / (ny - 1)

            IF (.NOT. ALLOCATED(x)) ALLOCATE(x(1:nx))
            IF (.NOT. ALLOCATED(y)) ALLOCATE(y(1:ny))

            x(1) = xmin
            y(1) = ymin

            DO i = 2, nx
              x(i) = x(i-1) + delta_x
            ENDDO

            DO i = 2, ny
              y(i) = y(i-1) + delta_y
            ENDDO

        END SUBROUTINE SetFDMGrid
END MODULE


      REAL             FUNCTION SCPVAL (P,NDEGP,X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1994-10-20 SCPVAL Krogh  Changes to use M77CON
C>> 1994-04-20 SCPVAL CLL Edited to make DP & SP files similar.
C>> 1987-12-09 SCPVAL Lawson  Initial code.
c--S replaces "?": ?CPVAL
C
C     C.L.LAWSON,JPL, 1969 DEC 17   MODIFIED 1973 JULY 24
C
C     MODIFIED 1974 NOV 19
C
C     EVALUATE A POLYNOMIAL OF DEGREE NDEGP GIVEN TRANSFORMATION
C     PARAMETERS, P(1) AND P(2), AND COEFFICIENTS RELATIVE TO THE
C     CHEBYSHEV BASIS.
C
C     NDEGP               DEGREE OF POLYNOMIAL
C     (P(I),I=1,NDEGP+3)  PARAMETERS DEFINING THE POLYNOMIAL
C     X                  INPUT ARGUMENT
C             THE POLYNOMIAL'S VALUE AT X IS DEFINED AS FOLLOWS.
C
C                             S = ( X - P(1) ) / P(2)
C
C                SCPVAL=SUM OF P(I+3)*T(I,S) FOR I=0,1,...NDEGP
C
C                             WHERE T(I,S) DENOTES THE CHEBYSHEV
C                             POLYNOMIAL OF DEGREE I EVALUATED AT S .
C
      integer J, NDEGP
      REAL             P(*),W(3),S,S2,X
      W(1)=0.0E0
      W(2)=0.0E0
C                             TRANSFORM X TO S
      S=(X-P(1))/P(2)
      S2=S+S
C
C                             EVALUATE POLYNOMIAL USING RECURSION
C
      do 30 J = NDEGP+3, 4, -1
          W(3)=W(2)
          W(2)=W(1)
          W(1)=(S2*W(2)-W(3))+P(J)
   30 continue
      SCPVAL=(S*W(1)-W(2))+P(3)
      RETURN
      END


      REAL*8 FUNCTION OBLIQ(TSEC50)
      IMPLICIT REAL*8 (A-H,O-Z)
C
C  THIS ROUTINE COMPUTES THE MEAN OBLIQUITY OF THE ECLIPTIC AT A
C  GIVEN TIME. THAT IS, IT COMPUTES THE ANGLE BETWEEN THE
C  ECLIPTIC PLANE AND THE MEAN EQUATOR OF DATE(DATE REFERS TO
C  THE INPUT TIME).
C
C VARIABLE  DIM  TYPE I/O DESCRIPTION
C --------  ---  ---- --- -----------
C
C TSEC50     1   R*8   I  TIME AT WHICH THE MEAN OBLIQUITY IS WANTED.
C                         IN SECONDS SINCE 1/1/50,0.0 HRS, ET.
C                         ACCURACY IS NOT HIGH ENOUGH TO WARRANT DOING
C                         AN ET-UT CORRECTION. USE UT IF IT IS MORE
C                         CONVENIENT.
C
C OBLIQ      1   R*8   O  FUNCTION VALUE RETURNED. IN RADIANS.
C
C***********************************************************************
C
C  BY C PETRUZZO. 12/82.
C  MODIFIED... 7/83. CJP. COMMENT MOD. NO CODE CHANGED.
C
C***********************************************************************
C
C  NOTE -- THE CONSTANTS AND FORMULA ARE FROM THE EXPLANATORY SUPPLEMENT
C          TO THE ASTRONOMICAL ALMANAC AND THE AMERICAN EPHEMERIS AND
C          NAUTICAL ALMANAC, 1974(=1961+AMMENDMENTS), PAGE 98. THE
C          GSFC LIBRARY NUMBER IS QB8.U5, E96.
C
      REAL*8 C0/23.452294D0/, C1/-0.0130125D0/, C2/-0.164D-5/,
     1       C3/0.0503D-5/
C
      REAL*8 HAFCENT/18262.5D0/,CENT/36525.D0/,SECDAY/86400.D0/
      REAL*8 DEGRAD/ 57.29577951308232D0 /
C
C   GET INPUT TIME AS JULIAN CENTURIES SINCE JAN 0.5,1900, E.T.
      TFRAC=(HAFCENT+TSEC50/SECDAY)/CENT
C
      T1 = TFRAC
      T2 = T1*T1
      T3 = T2*T1
      TILT = C0 + C1*T1 + C2*T2 + C3*T3
C
      OBLIQ = TILT/DEGRAD
      RETURN
      END