C********************************************************************
C  EFIT fits ellipses to contours then analyses 		    *
C  the deviations of the contours from the fitted ellipses, the     *
C  way it does this is to Fourier analyse the residuals as a        *
C  function of position angle. The purpose of this is to look for   *
C  both deviations which might be artefacts, due to a poor fit of   *
C  the ellipse or to a superimposed star image, and for deviations  *
C  which might be real, caused by weak disc-bulge structure or by   *
C  box-shaped isophotes.                                            *
C
C  Call NAG routine E04HFF with second derivatives                  *
C
C  From Dave Carter
C  Possibility of free or fixed centre according to the value of NPARAM1
C
C Z(1) Major axis (pixels)
C Z(2) Minor axis (pixels)
C Z(3) Theta (radians)
C Z(4) OX (pixels)
C Z(5) OY (pixels)
C
C THEMIN, THEMAX : limiting angles in radians
C
C IFLAG ERROR FLAG (POSITIVE IF NAG ERROR CODE, NEGATIVE IF MY OWN CODE)
C CODE:
C -1 TOO FEW POINTS
C -2 TOO MANY POINTS
C -3 LARGE ERRORS
C -4 STORAGE SPACE EXHAUSTED
C
C General output in unit 6 (interactive) and unit 9 (journal).
C Output of Fourier components in unit 4 ("fitelli.fou")
C
C JLP
C Version of 05/06/92
C********************************************************************
	SUBROUTINE EFIT(NPOINT1,NPARAM1,AUTO_GUESS,AUTO_IMPROVE,
	1	FOURIER,KAMIKAZE,IFLAG,TALK)
	IMPLICIT REAL*8(A-H,P-Z)
        PARAMETER (MAXPOINTS=2000)
	REAL*8 Z(5),PI,THEMIN,THEMAX,FSUMSQ,SDEV(5),SCALE
	REAL*4 X,Y,ESTORE,FDATA,RRR,AAAA,AA
	REAL*8 FVECC(MAXPOINTS),AJAC(MAXPOINTS,5),WORK(10*MAXPOINTS)
        REAL*8 TMIN,TMAX,RMIN,RMAX,THETA
	INTEGER*4 IFLG,IWORK(10),NEE,NPARAM,NPOINT
	LOGICAL*4 FOURIER,AUTO_GUESS,AUTO_IMPROVE,KAMIKAZE,TALK

	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/BLOCKA/PI,THEMIN,THEMAX
	COMMON/BLOCKB/X(MAXPOINTS),Y(MAXPOINTS)
	COMMON/BLOCKC/SCALE
	COMMON/EPRM/SDEV
	COMMON/EDATA/ESTORE(200,10),FDATA(200,10),NEE
	COMMON/FOU1/RRR,AAAA,AA(4,2)
	COMMON/CHECKEFIT1/IILSFUN2,IILSHES2

	EXTERNAL LSFUN2,LSHES2

	PI=3.14159265358979323846D0

	IFLAG=0
	NPOINT=NPOINT1
	M=NPOINT
	NPARAM=NPARAM1
	ISTEP=1
	Z3OLD=0.0
	WRITE(9,1000) NPOINT
	IF(TALK) WRITE(6,1000) NPOINT
1000	FORMAT(/,2X,' EFIT CALLED :',2X,I8,' POINTS RECEIVED')
C
C  Doesn't try to fit the contour if there are less than 8 points
C
1111	IF(NPOINT.LT.8) THEN
	 WRITE(9,1020)
	 IF(TALK) WRITE(6,1020)
1020	 FORMAT(' TRY AGAIN WITH MORE POINTS ')
	 IFLAG=-1
	 RETURN
	ENDIF

C  Doesn't try to fit the contour if there are more than MAXPOINTS points
	IF(NPOINT.GE.MAXPOINTS) THEN
	 WRITE(9,1030)
	 IF(TALK) WRITE(6,1030)
1030	 FORMAT(' TOO MANY POINTS FOR ELLFIT')
	 IFLAG=-2
	 RETURN
	ENDIF

C  Sets up initial guess at fit on the first step :
	IF(ISTEP.LE.1.AND.AUTO_GUESS)THEN
	 IF(TALK) WRITE(6,1031)
	 WRITE(9,1031)
1031	 FORMAT(' EFIT/FIRST ATTEMPT :')
	 CALL INPARS(NPARAM)
	ENDIF

C  Calls NAG routine to minimise the residuals from
C  the fitted ellipse.
66	LIW=10
C LW>90+13*NPOINT when NPARAM=5
	LW=35000
	IILSFUN2=0
	IILSHES2=0
	IFAIL=1
	CALL E04HFF(NPOINT,NPARAM,Z,FSUMSQ,IWORK,LIW,WORK,LW,IFAIL)
	WRITE(9,1041)IILSFUN2,IILSHES2
1041	FORMAT(' ITERATIONS FOR E04HFF : IILSFUN2 =',I5,
     1          ' IILSHES2 =',I5)

C  Write to units 6 & 9 if it fails to find minimum
	IF(IFAIL.NE.0) THEN
	  WRITE(9,1040) IFAIL
	  IF(TALK) THEN
             WRITE(6,1040) IFAIL
1040	     FORMAT(' FAILURE IN E04HFF, IFAIL =',I4)
	     WRITE(9,1041)IILSFUN2,IILSHES2
C IFAIL=2: wrong starting point (more than 50 iterations)
             IF(IFAIL.EQ.2)THEN
                WRITE(6,1042)
1042	        FORMAT(' Wrong initial guess: try with another center...')
             ENDIF
          ENDIF
	  IFLAG=IFAIL
	ENDIF

C Compute new values of THEMIN,THEMAX, if center has changed (free center):
        IF(NPARAM.EQ.5)THEN
	  CALL THETA_MIN_MAX(TMIN,TMAX,RMIN,RMAX,THETA,Z(4),Z(5))
          THEMIN=TMIN
          THEMAX=TMAX
        ENDIF
C JLP99
        WRITE(6,*)' JLP99/THEMIN,THEMAX',THEMIN,THEMAX

C Return if serious problem :
	IF((IFAIL.LT.5.AND.IFAIL.GT.8).AND.(.NOT.KAMIKAZE))RETURN

C  Work out errors in the fit by inverting the Hessian matrix :
	CALL ERPARM(FSUMSQ,MFLAG,NPARAM,TALK)

	IF(MFLAG.NE.0)THEN
	  WRITE(9,1050)
	  IF(TALK) WRITE(6,1050)
1050	  FORMAT(' FAILURE TO FIND A SENSIBLE SOLUTION')
	  IFLAG=-3
C JLP99: I go on in that case.
C	  IF(.NOT.KAMIKAZE)RETURN
	ENDIF

C Display the results with "monitor" routine:
	CALL MONIT(NPARAM,FVECC,FSUMSQ,TALK)

C Possibility of removing bad points such as small stars if
C AUTO_IMPROVE=.TRUE.
	 IF(ISTEP.LT.30.AND.AUTO_IMPROVE)THEN
	    ISTEP=ISTEP+1
C Look at the variation of the position angle, and decide whether
C to do a new iteration:
	    ZDELTA=DABS(Z3OLD-Z(3))
	    Z3OLD=Z(3)
	    IF(ZDELTA.GT.0.002)THEN
C Compute the residuals FVECC with the solution :
	       LJC=MAXPOINTS
	       CALL LSFUN2(NPOINT,NPARAM,Z,FVECC,AJAC,LJC)
C Another call of E0 after elimination of points over 1.6-sigma from
C the ellipse:
	       RMS=DSQRT(FSUMSQ/FLOAT(NPOINT-NPARAM))
	       VTEST=1.6*RMS
C Eliminates only the points with positive residuals FVECC
C since most of the time the pollution comes from stars in the outskirts
	       II=0
	       DO I=1,NPOINT
	         IF(FVECC(I).LT.VTEST)THEN
	            II=II+1
	            X(II)=X(I)
	            Y(II)=Y(I)
	         ENDIF
	       END DO

	  IF(TALK) WRITE (6,857)
	  WRITE (9,857)
857	  FORMAT(' REMOVING POINTS WITH RESIDUALS OVER 1.6 SIGMA')
	  NPOINT=II
	  IF(TALK) WRITE(6,856) ISTEP,NPOINT
	  WRITE(9,856) ISTEP,NPOINT
856	  FORMAT(2X,I2,'th CALL OF E04HFF WITH :',I5,' POINTS')
	  GO TO 1111
	ENDIF

	ENDIF

C  Stores final results for later output (with ECALC)

C Return if there is more than 200 curves (!)
1300	NEE=NEE+1
	IF(NEE.GT.200) THEN
	 WRITE(9,1333)
	 IF(TALK) WRITE(6,1333)
1333	 FORMAT(' ESTORE STORAGE EXHAUSTED')
	 IFLAG=-4
	 RETURN
	ENDIF

	ESTORE(NEE,1)=Z(1)
	ESTORE(NEE,2)=Z(2)
	ESTORE(NEE,3)=Z(3)
	ESTORE(NEE,4)=Z(4)
	ESTORE(NEE,5)=Z(5)
	ESTORE(NEE,6)=SDEV(1)
	ESTORE(NEE,7)=SDEV(2)
	ESTORE(NEE,8)=SDEV(3)
	ESTORE(NEE,9)=SDEV(4)
	ESTORE(NEE,10)=SDEV(5)

C  Call the subroutine which Fourier analyses the residuals
C  of the contour from the fitted ellipse
C  and store the Fourier output for later output (with FFCALC)
	IF(FOURIER)THEN
	  CALL RECSER
	  FDATA(NEE,1)=RRR
	  FDATA(NEE,2)=AAAA
	  FDATA(NEE,3)=AA(1,1)
	  FDATA(NEE,4)=AA(1,2)
	  FDATA(NEE,5)=AA(2,1)
	  FDATA(NEE,6)=AA(2,2)
	  FDATA(NEE,7)=AA(3,1)
	  FDATA(NEE,8)=AA(3,2)
	  FDATA(NEE,9)=AA(4,1)
	  FDATA(NEE,10)=AA(4,2)
	ENDIF

	RETURN
	END
C**********************************************************
C SUBROUTINE LSFUN2(NPOINT,NPARAM,Z,FVECC,FJACC,LJC)
C This routine is called by E04HFF to work out all of the
C residuals and the Jacobian matrix
C
C**********************************************************
	SUBROUTINE LSFUN2(NPOINT,NPARAM,Z,FVECC,FJACC,LJC)
	IMPLICIT REAL*8(A-H,P-Z)
        PARAMETER (MAXPOINTS=2000)
	REAL*8 PI,THEMIN,THEMAX,X0,Y0
	REAL*4 X,Y
	REAL*8 Z(5),FVECC(NPOINT),FJACC(LJC,NPARAM)
	REAL*8 AJAC(MAXPOINTS,5)
	COMMON/BLOCKA/PI,THEMIN,THEMAX
	COMMON/BLOCKB/X(MAXPOINTS),Y(MAXPOINTS)
	COMMON/CHECKEFIT1/IILSFUN2,IILSHES2
	COMMON/FIXED_CENT/X0,Y0
	IILSFUN2=IILSFUN2+1

	TCS=DCOS(Z(3))
	TSN=DSIN(Z(3))
	TCS2=TCS*TCS
	TSN2=TSN*TSN
	Z1=Z(1)
	Z2=Z(2)
C To avoid division by 0 :
	IF(DABS(Z1).LT.1.0D-10)Z1=1.0D-10
	IF(DABS(Z2).LT.1.0D-10)Z2=1.0D-10
	DENA=Z1*Z1
	DENB=Z2*Z2

C  Residuals in array FVECC :
	DO 30 I=1,NPOINT
	TDX=X(I)-Z(4)
	TDY=Y(I)-Z(5)
	TDX2=TDX*TDX
	TDY2=TDY*TDY
	  F1=((TDX2*TCS2)+(TDY2*TSN2)+
	1	2.0*(TDX*TDY*TCS*TSN))/DENA
	  F2=((TDX2*TSN2)+(TDY2*TCS2)-
	1	2.0*(TDX*TDY*TCS*TSN))/DENB
	  FVECC(I)=F1+F2-1.0D0

C  Jacobian matrix in two dimensional array AJAC. This bit is
C  right, don't change it!
	  AJAC(I,1)=-2.0*F1/Z1
	  AJAC(I,2)=-2.0*F2/Z2
	  AJAC(I,4)=(-2.0*TDX*TCS2-2.0*TDY*TCS*TSN)/DENA+
	1	(-2.0*TDX*TSN2+2.0*TDY*TCS*TSN)/DENB
	  AJAC(I,5)=(-2.0*TDY*TSN2-2.0*TDX*TCS*TSN)/DENA+
	1	(-2.0*TDY*TCS2+2.0*TDX*TCS*TSN)/DENB
	  AJAC(I,3)=(2.0*(TDY2-TDX2)*TCS*TSN+
	1	2.0*TDX*TDY*(TCS2-TSN2))/DENA+
	1	(2.0*(TDX2-TDY2)*TCS*TSN-
	1	2.0*TDX*TDY*(TCS2-TSN2))/DENB
30	CONTINUE

	DO I=1,NPOINT
	 DO K=1,NPARAM
	  FJACC(I,K)=AJAC(I,K)
	 END DO
	END DO

	END
C**********************************************************
C SUBROUTINE LSHES2(NPOINT,NPARAM,FVECC,Z,HESS,LHES)
C  This routine is called by E04HFF to work out
C the elements of the symmetric Hessian matrix (Second derivatives)
C Here FVECC is an input array which must not be changed.
C**********************************************************
	SUBROUTINE LSHES2(NPOINT,NPARAM,FVECC,Z,HESS,LHES)
        PARAMETER (MAXPOINTS=2000)
 	IMPLICIT REAL*8(A-H,P-Z)
	REAL*8 X0,Y0,PI,THEMIN,THEMAX
	REAL*4 X,Y
	REAL*8 FHESS(15)
	REAL*8 Z(5),FVECC(NPOINT),HESS(LHES)
	COMMON/BLOCKA/PI,THEMIN,THEMAX
	COMMON/BLOCKB/X(MAXPOINTS),Y(MAXPOINTS)
	COMMON/CHECKEFIT1/IILSFUN2,IILSHES2
	COMMON/FIXED_CENT/X0,Y0
	IILSHES2=IILSHES2+1

	TCS=DCOS(Z(3))
	TSN=DSIN(Z(3))
	TCS2=TCS*TCS
	TSN2=TSN*TSN
	Z1=Z(1)
	Z2=Z(2)

C To avoid division by 0 :
	IF(DABS(Z1).LT.1.0D-10)Z1=1.0D-10
	IF(DABS(Z2).LT.1.0D-10)Z2=1.0D-10

	DENA=Z1*Z1
	DENB=Z2*Z2
	Z13=Z1*Z1*Z1
	Z23=Z2*Z2*Z2

	NMAXHESS=((NPARAM+1)*NPARAM)/2
C Initialise the array HESS
	DO K=1,NMAXHESS
	HESS(K)=0.0
	END DO

C  Residuals in array FVECC :
	DO 30 I=1,NPOINT
	TDX=X(I)-Z(4)
	TDY=Y(I)-Z(5)
	TDX2=TDX*TDX
	TDY2=TDY*TDY
	  F1=((TDX2*TCS2)+(TDY2*TSN2)+
	1	2.0*(TDX*TDY*TCS*TSN))/DENA
	  F2=((TDX2*TSN2)+(TDY2*TCS2)-
	1	2.0*(TDX*TDY*TCS*TSN))/DENB

C  Hessian matrix in one dimensional array FHESS.
C 1,1
	FHESS(1)=6.0*F1/DENA
C 2,1
	FHESS(2)=0.
C 2,2
	FHESS(3)=6.0*F2/DENB
C 3,1
	FHESS(4)=(2.0*(TDY2-TDX2)*TCS*TSN+
	1	2.0*TDX*TDY*(TCS2-TSN2))*(-2.0/Z13)
C 3,2
	FHESS(5)=(2.0*(TDX2-TDY2)*TCS*TSN-
	1	2.0*TDX*TDY*(TCS2-TSN2))*(-2.0/Z23)
C 3,3
	FHESS(6)=(2.0*TSN2*(TDX2-TDY2)-
	1	2.0*TCS2*(TDX2-TDY2)-
	1	8.0*TSN*TCS*TDX*TDY)/DENA+
	1	(2.0*TCS2*(TDX2-TDY2)-
	1	2.0*TSN2*(TDX2-TDY2)+
	1	8.0*TSN*TCS*TDX*TDY)/DENB
C 4,1
	FHESS(7)=(-2.0*TDX*TCS2-2.0*TDY*TCS*TSN)*(-2.0/Z13)
C 4,2
	FHESS(8)=(-2.0*TDX*TSN2+2.0*TDY*TCS*TSN)*(-2.0/Z23)
C 4,3
	FHESS(9)=(4.0*TCS*TSN*TDX-2.0*TDY*(TCS2-TSN2))/DENA+
	1	(-4.0*TCS*TSN*TDX+2.0*TDY*(TCS2-TSN2))/DENB
C 4,4
	FHESS(10)=2.0*TCS2/DENA+2.0*TSN2/DENB
C 5,1
	FHESS(11)=(-2.0*TDY*TSN2-2.0*TDX*TCS*TSN)*(-2.0/Z13)
C 5,2
	FHESS(12)=(-2.0*TDY*TCS2+2.0*TDX*TCS*TSN)*(-2.0/Z23)
C 5,3
	FHESS(13)=(-4.0*TCS*TSN*TDY-2.0*TDX*(TCS2-TSN2))/DENA+
	1	(4.0*TCS*TSN*TDY+2.0*TDX*(TCS2-TSN2))/DENB
C 5,4
	FHESS(14)=2.0*TCS*TSN/DENA-2.0*TCS*TSN/DENB
C 5,5
	FHESS(15)=2.0*TSN2/DENA+2.0*TCS2/DENB

	DO K=1,NMAXHESS
 	 HESS(K)=HESS(K)+FVECC(I)*FHESS(K)
	END DO

30	CONTINUE

	END
C****************************************************************
C SUBROUTINE MONIT(NPARAM,FVECC,FSUMSQ,TALK)
C
C  This routine can be called by EFIT to output how the
C  fit is going.
C
C****************************************************************
	SUBROUTINE MONIT(NPARAM,FVECC,FSUMSQ,TALK)
	IMPLICIT REAL*8(A-H,P-Z)
	REAL*8 Z(5),FVECC(NPOINT),SDEV(5),SXC,SYC
	REAL*8 PI,THEMIN,THEMAX,FSUMSQ,SCALE
        INTEGER*4 NPOINT,IFLG
	LOGICAL*4 TALK
	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/EPRM/SDEV
	COMMON/BLOCKA/PI,THEMIN,THEMAX
	COMMON/BLOCKC/SCALE

	RMS=DSQRT(FSUMSQ/FLOAT(NPOINT-NPARAM))
	WRITE(9,302) FSUMSQ,RMS
302	FORMAT(/,'  SUM OF SQUARES =',E12.5,'  RMS =',E12.5)

C Permutation of Z(1) and Z(2) when Z(1) larger than Z(2) :
	IF(Z(1).LT.Z(2))THEN
	 IF(TALK) WRITE (6,1080)
	 WRITE (9,1080)
1080	 FORMAT(' Z(1) LARGER THAN Z(2):',
	1	' PERMUTATION OF Z(1) AND Z(2) AND THETA=THETA+PI/2')
	 XZ1=Z(1)
	 XZ2=Z(2)
	 XDEV1=SDEV(1)
	 XDEV2=SDEV(2)
	 Z(1)=XZ2
	 Z(2)=XZ1
	 SDEV(1)=XDEV2
	 SDEV(2)=XDEV1
	 Z(3)=Z(3)+PI/2.0
	ENDIF

C----------------------------------------------------------------
C Output of the results :
	WRITE(9,101)
	IF(TALK) WRITE(6,101)
101	FORMAT(/,4X,'MAJOR AXIS',4X,'MEAN RADIUS',4X,'E NUMBER',6X,
	1	'XCENT',8X,'YCENT',7X,'THETA')
	WRITE(9,1088)
	IF(TALK) WRITE(6,1088)
1088	FORMAT(5X,'(ARCSEC)',57X,'(DEGREES)')

	XMAJAX=Z(1)
	XMINAX=Z(2)
	THETA=Z(3)
	SMJ=SDEV(1)
	SMN=SDEV(2)
	STH=SDEV(3)*180./PI
	IF(STH.GT.360.)STH=360.
	SXC=SDEV(4)
	SYC=SDEV(5)

	RAD=SQRT(XMAJAX*XMINAX)
	ECC=10.*(XMAJAX-XMINAX)/XMAJAX
	PCMAJ=SMJ/XMAJAX
	PCMIN=SMN/XMINAX
	PCRAD=ABS(PCMAJ)+ABS(PCMIN)
	SRAD=0.5*RAD*PCRAD
	SECC=ECC*PCRAD

C Conversion in arcseconds (Major axis and its error, Radius and its error) :
	XMAJAX=XMAJAX*SCALE
	SMAJAX=SMJ*SCALE
	RAD=RAD*SCALE
	SRAD=SRAD*SCALE

C Conversion in degrees (Theta and its error)
999	IF(THETA.LE.PI) GO TO 998
	THETA=THETA-PI
	GO TO 999
998	IF(THETA.GT.0.) GO TO 997
	THETA=THETA+PI
	GO TO 998
997	THETA=THETA*180./PI

C Output of the values :
	IF(TALK) WRITE(6,102) XMAJAX,RAD,ECC,Z(4),Z(5),THETA
	IF(TALK) WRITE(6,103) SMAJAX,SRAD,SECC,SXC,SYC,STH
	WRITE(9,102) XMAJAX,RAD,ECC,Z(4),Z(5),THETA
	WRITE(9,103) SMAJAX,SRAD,SECC,SXC,SYC,STH
102	FORMAT(2X,6(F12.4,1X))
103	FORMAT(2X,6(2X,'+/-',F8.4))

	RETURN
	END
C*******************************************************
	SUBROUTINE ERPARM(FSUMSQ,MFLAG,NPARAM,TALK)
C
C  This routine works out the formal errors on the fit by
C  inverting the Hessian matrix.
C
	IMPLICIT REAL*8(A-H,P-Z)
        PARAMETER (MAXPOINTS=2000)
	REAL*8 A(6,5),B(5,5),Z(5),WORK(5),FSUMSQ,SDEV(5)
	REAL*8 AJAC(MAXPOINTS,5),FVECC(MAXPOINTS)
	LOGICAL*4 TALK
	INTEGER*4 NPOINT,IFLG
	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/EPRM/SDEV
	MFLAG=0

C Compute the matrix AJAC :
	LJC=MAXPOINTS
	CALL LSFUN2(NPOINT,NPARAM,Z,FVECC,AJAC,LJC)

	DO 1 I=1,NPARAM
	 DO 1 J=1,NPARAM
	 SUM=0.0
	  DO K=1,NPOINT
 	  SUM=SUM+AJAC(K,I)*AJAC(K,J)
	  END DO
	 A(I,J)=SUM
1	CONTINUE

	IA=6
	IB=5
	IFAIL=1
C  Matrix inversion
	CALL F01ABF(A,IA,NPARAM,B,IB,WORK,IFAIL)
	 IF(IFAIL.NE.0)THEN
	 IF(TALK) WRITE(6,100) IFAIL
	 WRITE(9,100) IFAIL
100	 FORMAT(/,' WARNING : FAILURE WHILE INVERTING THE MATRIX'
     1	       ' TO WORK OUT THE ERRORS',/,
     1       ' ERROR IN F01ABF, IFAIL =',I5,/,
     1        '(ifail=2 means: ill-conditionned matrix)')
	 MFLAG=1
	 RETURN
	 ENDIF

	C=FSUMSQ/(NPOINT-NPARAM)
	DO I=1,NPARAM
	 DO J=1,I
	 B(I,J)=B(I,J)*C
	 END DO
	END DO

	DO I=1,5
	SDEV(I)=DSQRT(DABS(B(I,I)))
	END DO

	IF((SDEV(1).GT.10.).OR.(SDEV(2).GT.10.)
	1	.OR.(SDEV(4).GT.10.).OR.(SDEV(5).GT.10.))THEN
	 IF(TALK) WRITE(6,202)
	 WRITE(9,202)
202	FORMAT(/,' WARNING !! THE ERRORS ARE TOO HIGH TO BE '
	1	'REASONABLE ...')
	MFLAG=2
	ENDIF

C	WRITE(9,201)
C201	FORMAT(' ***********COVARIANCE MATRIX***********')
C	DO 4 I=1,NPARAM
C	WRITE(9,200) (B(I,J),J=1,I)
C4	CONTINUE
C200	FORMAT(' ',5E14.7)

	RETURN
	END
C*******************************************************************
	SUBROUTINE ECALC(KK)
C
C  This tidies up the ellipse fit output and writes it to unit 9 and 11.
C Unit 11 is used by FITELLI to generate catalogues of parameters
	REAL*4 MAJAX,MINAX,RAD,ECC,THETA
        REAL*4 SMAJAX,SRAD,SECC,SXC,SYC,STH
	REAL*8 SCALE,Z(5)
        INTEGER*4 KK,NPOINT,IFLG
	COMMON/EDATA/ ESTORE(200,10),FDATA(200,10),NEE
	COMMON/BLOCKC/SCALE
	COMMON/FIT1/Z,NPOINT,IFLG
	PI=3.14159265358979323846
	WRITE(9,100)
100	FORMAT('1',/,8X,
	1	'************* ELLIPSE FIT OUTPUT ************',/)
	WRITE(9,101)
101	FORMAT(/,4X,'MAJOR AXIS',4X,'MEAN RADIUS',4X,'E NUMBER',6X,
	1	'XCENT',8X,'YCENT',7X,'THETA')
	WRITE(9,1088)
1088	FORMAT(5X,'(ARCSEC)',57X,'(DEGREES)')

C NEE : Number of levels
	WRITE(11,*)NEE

	DO 1 I=1,NEE
          CALL CONVERT_EFIT(I,MAJAX,RAD,ECC,Z(4),Z(5),THETA,
     1                       SMAJAX,SRAD,SECC,SXC,SYC,STH)

C Output of the values :
	  WRITE(9,102) MAJAX,RAD,ECC,Z(4),Z(5),THETA
	  WRITE(9,103) SMAJAX,SRAD,SECC,SXC,SYC,STH
	  WRITE(11,102) MAJAX,RAD,ECC,Z(4),Z(5),THETA
	  WRITE(11,102) SMAJAX,SRAD,SECC,SXC,SYC,STH
1	CONTINUE
102	FORMAT(2X,6(F12.4,1X))
103	FORMAT(2X,6(2X,'+/-',F8.4))

C Last index of array ESTORE (needed by EFIT6.FOR)
        KK=NEE
        RETURN
	END
C************************************************************
	SUBROUTINE RECSER
C
C  This routine Fourier analyses the residuals of the contour
C  from the fitted ellipse.
C  Cf David Carter's thesis
C
	IMPLICIT REAL*8 (Z)
        PARAMETER (MAXPOINTS=2000)
	REAL*8 Z(5)
	INTEGER*4 NPOINT,IFLG
	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/FOU1/RRR,A,AA(4,2)
	COMMON/BLOCKB/X(MAXPOINTS),Y(MAXPOINTS)
	REAL*4 R(MAXPOINTS+1),TH(MAXPOINTS+1),DELTH(MAXPOINTS+1)
	REAL*4 AVTH(MAXPOINTS+1),AVR(MAXPOINTS+1)

	PI=3.14159265358979323846
	AAA=Z(1)
	BBB=Z(2)
	THETA=Z(3)
	TCS=COS(THETA)
	TSN=SIN(THETA)
	RRR=SQRT(AAA*BBB)
C
C First transform the coordinates of the points
C to a coordinate system in which the fitted
C ellipse is a circle of unit radius.
C
C Calculate radius of the contour as a function of azimuthal
C angle.
C
	DO 2 I=1,NPOINT
C Reset the origin to the center of the ellipse:
          XXX=X(I)-Z(4)
	  YYY=Y(I)-Z(5)
C Rotation of theta (ie new origin for the phases is the major axis):
	  XSTAR=XXX*TCS+YYY*TSN
	  YSTAR=YYY*TCS-XXX*TSN
C Normalisation to major and minor axis (ie ellipse becomes a circle):
	  XSTAR=XSTAR/AAA
	  YSTAR=YSTAR/BBB
C Here are the coordinates of the current point in
C the new system (polar coordinates)
	  R(I)=SQRT(XSTAR*XSTAR+YSTAR*YSTAR)
	  TH(I)=ANGLE0(XSTAR,YSTAR,R(I))
2	CONTINUE

	R(NPOINT+1)=R(1)
	TH(NPOINT+1)=TH(1)
	A=0.
C
C  Notice that the contour can go either way round, i.e. the
C  average DELTH can be positive or negative
C
	DO 3 I=1,NPOINT

C Check the difference in phase between two consecutive points
	DELTH(I)=TH(I+1)-TH(I)
	IF(DELTH(I).LT.-PI)THEN
	  ISWCH=1
	ELSEIF(DELTH(I).GT.PI)THEN
	  ISWCH=2
        ELSE
	  ISWCH=0
	ENDIF

C Now computes the average of the phases:
	AVTH(I)=(TH(I+1)+TH(I))/2.

C The following is simply to get the right value for the
C phases (and get rid of the dependence modulo 2*PI)
	IF(ISWCH.EQ.0) GO TO 8
	IF(ISWCH.EQ.2) GO TO 11
	DELTH(I)=DELTH(I)+2.*PI
12	IF(AVTH(I).GE.PI) GO TO 9
	IF(AVTH(I).LT.-PI) AVTH(I)=AVTH(I)+PI
	GO TO 10
11	DELTH(I)=DELTH(I)-2.*PI
	GO TO 12
9	AVTH(I)=AVTH(I)-PI
10	CONTINUE
8	AVR(I)=(R(I+1)+R(I))/2.
	A=A+DELTH(I)*AVR(I)
3       CONTINUE

	A=A/(2.*PI)
C
C  The sum for the Fourier series is formed in the arrray AA,
C  which goes from 1 to 4; Fourier components up to 4th order
C  are calculated.
C
	DO 4 J=1,2
	DO 4 K=1,4
	  AA(K,J)=0.0
4       CONTINUE

	DO 5 K=1,4
	DO 5 I=1,NPOINT
	  AA(K,1)=AA(K,1)+DELTH(I)*AVR(I)*SIN(K*AVTH(I))
	  AA(K,2)=AA(K,2)+DELTH(I)*AVR(I)*COS(K*AVTH(I))
5       CONTINUE

	DO 6 K=1,4
	DO 6 J=1,2
 	  AA(K,J)=AA(K,J)/PI
6       CONTINUE
C
C  Now if the zero order component (A) is negative (it should be
C  about +1) then all the others will be of the wrong sign too.
C  So reverse them.
C
	IF(A.LT.0.0) THEN
	  DO  K=1,4
	    DO  J=1,2
	      AA(K,J)=-AA(K,J)
	    END DO
	  END DO
	  A=-A
	END IF

	RETURN
	END
C-------------------------------------------------------------------------
	SUBROUTINE FFCALC
C
C  This routine tidies up and outputs the Fourier output.
C
	REAL*8 SCALE
	COMMON/EDATA/ ESTORE(200,10),FDATA(200,10),NEE
	COMMON/BLOCKC/SCALE
C Opens new file for Fourier output:
        OPEN(4,FILE='fitelli.fou',STATUS='UNKNOWN')
	WRITE(4,200)
200	FORMAT(/,' *******************  FOURIER COMPONENT OUTPUT  *******'
     :,'*********')
	WRITE(4,201)
201	FORMAT(/,' RADIUS ZERO ORDER  FIRST ORDER  SECOND ORDER'
     :,'   THIRD ORDER     FOURTH ORDER',/,' (ARCSEC)',6X,
     :4('MAGNITUDE PHASE '))
C
C  First write the fourier components out as amplitudes and phases.
C
	DO 1 I=1,NEE
	 RRR=FDATA(I,1)
	 A0=FDATA(I,2)
	 AA1=FDATA(I,3)
	 BB1=FDATA(I,4)
	 AA2=FDATA(I,5)
	 BB2=FDATA(I,6)
	 AA3=FDATA(I,7)
	 BB3=FDATA(I,8)
	 AA4=FDATA(I,9)
	 BB4=FDATA(I,10)
	 AMAG1=SQRT(AA1**2+BB1**2)
	 AMAG2=SQRT(AA2**2+BB2**2)
	 AMAG3=SQRT(AA3**2+BB3**2)
	 AMAG4=SQRT(AA4**2+BB4**2)
	 APH1=0.
	 APH2=0.
	 APH3=0.
	 APH4=0.
	 IF(BB1.NE.0)APH1=ATAN(AA1/BB1)
	 IF(BB2.NE.0)APH2=ATAN(AA2/BB2)
	 IF(BB3.NE.0)APH3=ATAN(AA3/BB3)
	 IF(BB4.NE.0)APH4=ATAN(AA4/BB4)

	 RRR=RRR*SCALE
	 WRITE(4,202) RRR,A0,AMAG1,APH1,AMAG2,
     1      APH2,AMAG3,APH3,AMAG4,APH4
202	FORMAT(' ',F7.2,1X,F5.3,9(1X,F7.4))
1	CONTINUE
C
	WRITE(4,203)
203	FORMAT(/,' RADIUS ZERO ORDER FIRST ORDER  SECOND ORDER'
     :,'    THIRD ORDER     FOURTH ORDER',/,' (ARCSEC)',6X,
     :4(' SINE   COSINE  '))
C
C  Then write the data out as sine and cosine components.
C
	DO 11 I=1,NEE
  	 RRR=FDATA(I,1)
	 A0=FDATA(I,2)
	 AA1=FDATA(I,3)
	 BB1=FDATA(I,4)
	 AA2=FDATA(I,5)
	 BB2=FDATA(I,6)
	 AA3=FDATA(I,7)
	 BB3=FDATA(I,8)
	 AA4=FDATA(I,9)
	 BB4=FDATA(I,10)
	 RRR=RRR*SCALE
	 WRITE(4,202) RRR,A0,AA1,BB1,AA2,BB2,AA3,BB3,AA4,BB4
11	CONTINUE

	CLOSE(4)
	RETURN
	END
C----------------------------------------------------------------------
	FUNCTION ANGLE0(X,Y,R)
C  Works out position angle given X,Y (when the centre is at the
C  origin !!). Position angles measured from the positive X axis through
C  the positive Y axis. (Radians)
C  (to compute Fourier components)
	REAL*4 ANGLE0,PI,X,Y,R
	PI=3.14159265358979323846
	IF(Y)6,2,1
1	ANGLE0=ACOS(X/R)
	RETURN
2	IF(X)5,3,4
3	WRITE(9,100)
	ANGLE0=0.0
	RETURN
4	ANGLE0=0.0
	RETURN
5	ANGLE0=PI
	RETURN
6	ANGLE0=ACOS(-X/R)+PI
	RETURN
100	FORMAT(' ANGLE0 CALLED AT CENTRE POINT')
	END
C******************************************************************
C SUBROUTINE INPARS(NPARAM)
C Set up initial parameters for first guess at the fit
C
C*******************************************************************
	SUBROUTINE INPARS(NPARAM)
        PARAMETER (MAXPOINTS=2000)
        REAL*8 Z(5),PI,THEMIN,THEMAX,X0,Y0
	REAL*8 TMIN,TMAX,RMIN,RMAX,THETA
        INTEGER*4 NPOINT,IFLG
	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/BLOCKA/ PI,THEMIN,THEMAX
	COMMON/FIXED_CENT/X0,Y0

C Take the center of the galaxy as the first guess for the
C position of the centre :
        Z(4)=X0
        Z(5)=Y0

	CALL THETA_MIN_MAX(TMIN,TMAX,RMIN,RMAX,THETA,Z(4),Z(5))

C  Initial parameters in array Z :
	Z(1)=RMAX
	Z(2)=RMIN
	Z(3)=THETA
        THEMIN=TMIN
        THEMAX=TMAX
	WRITE(9,1000) (Z(I),I=1,5)
1000    FORMAT(/,' FIRST GUESS : MAJAX (PIXELS), MINAX (PIXELS)',
	1	' THETA (RADIANS), OX, OY :',
	1	/,2X,5(E12.5,2X))

	RETURN
	END

C******************************************************************
C SUBROUTINE THETA_MIN_MAX
C Compute the limiting angles TMIN,TMAX in radians,
C given a center (XC,YC) in pixel coordinates
C
C THETA is the first guess for the position angle
C       (estimated with the maximum radius)
C
C*******************************************************************
	SUBROUTINE THETA_MIN_MAX(TMIN,TMAX,RMIN,RMAX,THETA,XC,YC)
        PARAMETER (MAXPOINTS=2000)
	REAL*8 Z(5),PI,TMIN,TMAX,XC,YC,RMIN,RMAX,THETA
        REAL*4 X1,Y1,R,DELTATHETA
	REAL*4 X,Y,TMIN1,TMAX1,TMIN2,TMAX2,THETA1,THETA2,TMID,TMAD
	INTEGER*4 NPOINT,IFLG
	COMMON/FIT1/Z,NPOINT,IFLG
	COMMON/BLOCKB/X(MAXPOINTS),Y(MAXPOINTS)

	PI=3.14159265358979323846D0
	RMIN=1.D10
	RMAX=0.D0
	TMIN1=2.1*PI
	TMIN2=TMIN1
	TMAX1=-2.1*PI
	TMAX2=TMAX1

C  Find the point on the contour which is furthest from the guess
C  at the centre.
	DO 2 I=1,NPOINT
	X1=X(I)-XC
	Y1=Y(I)-YC
	R=SQRT(X1**2+Y1**2)
	THETA1=ANGLE0(X1,Y1,R)
	TMIN1=AMIN1(THETA1,TMIN1)
	TMAX1=AMAX1(THETA1,TMAX1)

	THETA2=THETA1-PI
	IF(THETA2.LT.0.)THETA2=THETA2+2*PI

	TMIN2=AMIN1(THETA2,TMIN2)
	TMAX2=AMAX1(THETA2,TMAX2)

	IF(RMIN.GT.R)RMIN=R
	  IF(R.GT.RMAX) THEN
	    RMAX=R
	    THETA=THETA1
	  ENDIF
2	CONTINUE

C Test if  DELTATHETA is larger than 340 degrees :
	DELTATHETA=TMAX1-TMIN1
	IF(DELTATHETA.GT.5.93)THEN
	  TMIN=TMIN2-PI
	  TMAX=TMAX2-PI
	ELSE
	  TMIN=TMIN1
	  TMAX=TMAX1
	ENDIF

	TMID=TMIN*180./PI
	TMAD=TMAX*180./PI
	WRITE(9,1001)TMID,TMAD
1001	FORMAT('THETA MIN, THETA MAX :',
     1          2X,F8.3,2X,F8.3)

	RETURN
	END
C**********************************************************************
C
C ESTORE(K,1) : Major axis (pixels)
C ESTORE(K,2) : Minor axis (pixels)
C ESTORE(K,3) : Theta (radians)
C ESTORE(K,4) : XC (pixels)
C ESTORE(K,5) : YC (pixels)
C ESTORE(K,6) : Error of major axis (pixels)
C ESTORE(K,7) : Error of minor axis (pixels)
C ESTORE(K,8) : Error of theta (radians)
C ESTORE(K,9) : Error of XC (pixels)
C ESTORE(K,10) : Error of YC (pixels)
C**********************************************************************
        SUBROUTINE CONVERT_EFIT(K,MAJAX,RAD,ECC,XC,YC,THETA,
     1                       SMAJAX,SRAD,SECC,SXC,SYC,STH)
        REAL*4 ESTORE,FDATA,PI
        REAL*4 MAJAX,MINAX,RAD,ECC,XC,YC,THETA
        REAL*4 SMAJAX,SRAD,SECC,SXC,SYC,STH
        REAL*4 PCMAJ,PCMIN,PCRAD
        REAL*8 SCALE
        INTEGER*4 NEE
	COMMON/EDATA/ ESTORE(200,10),FDATA(200,10),NEE
	COMMON/BLOCKC/SCALE

	PI=3.14159265358979323846D0
	  MAJAX=ESTORE(K,1)
	  MINAX=ESTORE(K,2)
	  THETA=ESTORE(K,3)
	  XC=ESTORE(K,4)
	  YC=ESTORE(K,5)
	  SMJ=ESTORE(K,6)
	  SMN=ESTORE(K,7)
	  STH=ESTORE(K,8)*180./PI
	  SXC=ESTORE(K,9)
	  SYC=ESTORE(K,10)

	  RAD=SQRT(MAJAX*MINAX)
	  ECC=10.*(MAJAX-MINAX)/MAJAX
	  PCMAJ=SMJ/MAJAX
	  PCMIN=SMN/MINAX
	  PCRAD=ABS(PCMAJ)+ABS(PCMIN)
	  SRAD=0.5*RAD*PCRAD
	  SECC=ECC*PCRAD

C Conversion to arcseconds (Major axis and its error, Radius and its error) :
          MAJAX=MAJAX*SCALE
          SMAJAX=SMJ*SCALE
          RAD=RAD*SCALE
          SRAD=SRAD*SCALE

C Conversion to degrees (Theta and its error)
999         IF(THETA.LE.PI) GO TO 998
          THETA=THETA-PI
          GO TO 999
998         IF(THETA.GT.0.) GO TO 997
          THETA=THETA+PI
          GO TO 998
997       THETA=THETA*180./PI

         RETURN
         END


MODULE LinearSolver

    USE FloatPrecision

    IMPLICIT NONE
    REAL(fp) , ALLOCATABLE , DIMENSION(:,:) :: AMT

    CONTAINS

    SUBROUTINE solve5(jc)
        USE FloatPrecision
        IMPLICIT NONE
        INTEGER                      :: jc
        INTEGER                      :: I , J
        REAL(fp)                     :: a

        DO  I=3,jc
            a=amt(3,I-2)
            DO  J=3,6
                amt(J,I-2)=amt(J,I-2)/a
            END DO
            a=-amt(2,I-1)
            amt(3,I-1)=amt(3,I-1)+amt(4,I-2)*a
            amt(4,I-1)=amt(4,I-1)+amt(5,I-2)*a
            amt(6,I-1)=amt(6,I-1)+amt(6,I-2)*a
            a=-amt(1,I)
            amt(2,I)=amt(2,I)+amt(4,I-2)*a
            amt(3,I)=amt(3,I)+amt(5,I-2)*a
            amt(6,I)=amt(6,I)+amt(6,I-2)*a
        END DO
        a=amt(3,jc-1)
        DO  I=3,6
            amt(I,jc-1)=amt(I,jc-1)/a
        END DO
        a=-amt(2,jc)
        amt(3,jc)=amt(3,jc)+a*amt(4,jc-1)
        amt(6,jc)=(amt(6,jc)+a*amt(6,jc-1))/amt(3,jc)
        amt(6,jc-1)=amt(6,jc-1)-amt(4,jc-1)*amt(6,jc)
        DO  I=jc-2,1,-1
            amt(6,I)=amt(6,I)-amt(4,I)*amt(6,I+1)-amt(5,I)*amt(6,I+2)
        END DO

    END

    SUBROUTINE Solve3_LU(jc)

        USE FloatPrecision
        IMPLICIT NONE
        INTEGER                      :: jc
        INTEGER                      :: I , J
        REAL(fp)                     :: temp

        DO J = 2 , jc
            temp = amt(1,J) / amt(2,J-1)
            amt(1,J) = temp
            amt(2,J) = amt(2,J) - temp * amt(3,J-1)
        END DO
        DO J = 2 , jc
            amt(4,J) = amt(4,J) - amt(4,J-1) * amt(1,J)
        END DO
        amt(4,jc) = amt(4,jc) / amt(2,jc)
        DO J = jc-1 , 1 , -1
            amt(4,J) = (amt(4,J) - amt(3,J)*amt(4,J+1)) / amt(2,J)
        END DO

    END SUBROUTINE solve3_LU

    SUBROUTINE SOLVE3(JC)
        USE FloatPrecision
        IMPLICIT NONE
        INTEGER                      :: JC
        INTEGER                      :: I , J
        REAL(fp)                     :: A

        DO  I=2,JC
            A=AMT(2,I-1)
            DO  J=2,4
                AMT(J,I-1)=AMT(J,I-1)/A
            END DO
            A=-AMT(1,I)
            AMT(2,I)=AMT(2,I)+AMT(3,I-1)*A
            AMT(4,I)=AMT(4,I)+AMT(4,I-1)*A
        END DO
        A=AMT(2,JC)
        DO  J=2,4
           AMT(J,JC)=AMT(J,JC)/A
        END DO

        A=AMT(3,JC-1)
        DO  I=JC-1,1,-1
            AMT(4,I)=AMT(4,I)-AMT(3,I)*AMT(4,I+1)
        END DO

        RETURN
    END SUBROUTINE SOLVE3

END MODULE LinearSolver


    program testme_omp
    USE OMP_LIB
    use AB_matrix_fct, only : multiply, RowConvert, ColumnConvert
!   only runs with banded matrix routines to allow for larger n
    IMPLICIT NONE
    INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision
    INTEGER, PARAMETER :: n=90000 ! size of problem
    INTEGER, PARAMETER :: KU=358 ! bandwidth of matrix, KU=1 for dctsv.f90  KU>1 needs dcbsv.f90
    INTEGER, PARAMETER :: KL=0   ! for testing vs lapack version only
                                ! KL=KU to run non-periodic version of matrix KL=0 runs periodic version
    REAL(wp), ALLOCATABLE :: d(:,:),a(:),b(:),c(:),s(:,:),dd(:,:),z(:,:),zz(:,:),a_short(:) ! a_short truncated a() for dgtsv
    REAL(wp), ALLOCATABLE :: AB(:,:),CD(:,:)                ! AB(2*KU+1,n) for dcbsv; ! AB(KL+KU+1+i-j,j) for dgbsv
                                                            ! CD(KL+KU+1+i-j,j) for dgbsv
    REAL(wp) :: time_end,time_start
    INTEGER :: i,j,k,p,INFO
    INTEGER, ALLOCATABLE :: ipiv(:)
!   Copyright (c) 2021   Anthony M de Beus

!   only runs tridiagonal routines dctsv.f90, dgtsv.f90 or thomas.f90 if KU=1
!   only runs non-periodic lapack routines dgbsv and/or dgtsv if KL > 0 (and in fact KL=KU)

    allocate(AB(2*KU+1,n),CD(2*KL+KU+1,n),d(n,2),a(n),b(n),c(n),s(n,2),dd(n,2),z(n,2),zz(n,2),a_short(n-1),ipiv(n))

    AB=0
    CD=0
    p=mod(N,2*KU)
    write(*,*) 'p,KU: ',p,KU

    do i=-KU,KU                                ! generate AB in band-cyclic format
     do j=1,n
      AB(i+KU+1,j)=20.0*(i)**2 + 5.*j/(1.0*n)  ! without the second term, can be ill-conditioned, eg N=9, KU=2
      if (i == 0) then
       AB(i+KU+1,j)=AB(i+KU+1,j)+300           ! emphasize diagonal dominance
      end if
      if (i >= KU) then
       AB(i+KU+1,j)=AB(i+KU+1,j)+1.5           ! asymmetry
      end if
      if (KL == KU) then
      if ((i+j-1) /= mod(N+i+j-1,N)) then
        AB(i+KU+1,j)=0                         ! off diagonal elements zero for non-cyclic tests
      endif
      endif
     end do
    end do

    if (KL == KU .AND. KL > 0 ) then
     CD=ColumnConvert(AB)                ! for LAPACK use make a dgbsv compatible matrix
    endif

    IF (N > 100) then
     do i=1,n
      s(i,1)=57.3*cos(40.0*i)        ! solution vectors
      s(i,2)=10*sin(5.0*i)           ! i and i**2 get too ill-conditioned with large n
     end do
    else
     do i=1,n
      s(i,1)=i                       ! solution vectors
      s(i,2)=i**2
     end do
    endif

    dd=multiply(AB,s)                           ! RHS vectors
    d=dd

    IF (KU == 1) then                           ! store tridiagonal matrices in vector format
    a=AB(1,:)
    b=AB(2,:)
    c=AB(3,:)
    do i=1,n-1
     a_short(i)=a(i+1)                          !truncated "a" for dgtsv, don't have to truncate "c"
    end do

    write(*,*) 'Using dctsv.f90, O(n)'
    time_start=omp_get_wtime()                  ! have to use this to get actual time with omp
    call DCTSV( n, 2, a, b, c, d, n, INFO )     ! overwrites d into solution
    time_end=omp_get_wtime()
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    write(*,*) ' '

!    LAPACK routine for non-cyclic system
     if (KL > 0) then   ! and KL == KU == 1
      d=dd
      write(*,*) 'Using dgtsv, O(n)'
      time_start=omp_get_wtime()
      call DGTSV( n, 2, a_short, b, c, d, n, INFO )     ! overwrites d into solution
      time_end=omp_get_wtime()
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
      write(*,*) ' '

!     simple tridiagonal algorithm: should be fastest with -O3 compilation
      a=AB(1,:)
      b=AB(2,:)
      c=AB(3,:)
      d=dd
      write(*,*) 'Using thomas, O(n)'
      time_start=omp_get_wtime()
      call thomas(a,b,c,d,z,n,2)                        ! overwrites b and d, output is z
      time_end=omp_get_wtime()
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-z(:,1)),(s(:,1)-z(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-z(:,2)),(s(:,2)-z(:,2)))
      write(*,*) ' '

     endif

    ENDIF

    d=dd
    write(*,*) 'Using dcbsv.f90, O(n)'
    time_start=omp_get_wtime()
    call DCBSV( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites d
    time_end=omp_get_wtime()
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    z=multiply(AB,s(:,:))
    write(*,*) 'RHS error',dot_product(z(:,1)-dd(:,1),z(:,1)-dd(:,1))
    write(*,*) 'RHS error',dot_product(z(:,2)-dd(:,2),z(:,2)-dd(:,2))
    write(*,*) ' '

    d=dd
    write(*,*) 'Using dcbsv_f.f90, O(n)'
    time_start=omp_get_wtime()
    call DCBSV_F( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites d
    time_end=omp_get_wtime()
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    z=multiply(AB,s(:,:))
    write(*,*) 'RHS error',dot_product(z(:,1)-dd(:,1),z(:,1)-dd(:,1))
    write(*,*) 'RHS error',dot_product(z(:,2)-dd(:,2),z(:,2)-dd(:,2))
    write(*,*) ' '

    d=dd
    write(*,*) 'Using dcbsv_r.f90, O(n)'
    time_start=omp_get_wtime()
    call DCBSV_R( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites d
    time_end=omp_get_wtime()
    write(*,*) 'time: ',time_end-time_start
    write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
    write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
    z=multiply(AB,s(:,:))
    write(*,*) 'RHS error',dot_product(z(:,1)-dd(:,1),z(:,1)-dd(:,1))
    write(*,*) 'RHS error',dot_product(z(:,2)-dd(:,2),z(:,2)-dd(:,2))
    write(*,*) ' '

!    zz=d    ! save the solution
!    d=z-dd  !RHS error
!    write(*,*) 'iterative step'
!    time_start=omp_get_wtime()
!    call DCBSV( N, KU, 2, AB, 2*KU+1, d, N, INFO )      ! overwrites dd
!    time_end=omp_get_wtime()
!    write(*,*) 'time: ',time_end-time_start
!    z=zz-d
!    write(*,*) 'solution error',dot_product((s(:,1)-z(:,1)),(s(:,1)-z(:,1)))
!    write(*,*) 'solution error',dot_product((s(:,2)-z(:,2)),(s(:,2)-z(:,2)))

!    LAPACK routine for non-cyclic system
     if (KL > 0) then
      d=dd
      write(*,*) 'Using dgbsv, O(n)'
      time_start=omp_get_wtime()
      call dgbsv( N, KL, KU, 2, CD, 2*KL+KU+1, IPIV, d, N, INFO ) ! overwrites d into solution
      time_end=omp_get_wtime()
      write(*,*) 'time: ',time_end-time_start
      write(*,*) 'solution error',dot_product((s(:,1)-d(:,1)),(s(:,1)-d(:,1)))
      write(*,*) 'solution error',dot_product((s(:,2)-d(:,2)),(s(:,2)-d(:,2)))
     endif

     deallocate(AB,CD,d,a,b,c,s,dd,z,a_short,ipiv)

   END PROGRAM testme_omp


program main
	implicit none
	real(kind=8), parameter :: pi = 3.14159265358979
	real(kind=4) :: radius
	write (*,"(A)") 'Please input the radius of a circle:'
	read  (*,*) radius
	write (*,"(A, F0.8)") 'The circle''s area is ', (pi*radius**2)
	stop
end program main


!====================================================================
    MODULE MOD_VARS
!====================================================================
    INTEGER *8, PARAMETER :: MAXP = 100
    REAL*8, PARAMETER :: PI = 4*ATAN(1.D0)
    INTEGER *8 :: NOV, NTST, NSUB        ! SETTINGS
    REAL *8    :: TIME, DT, TO           ! TIME VARIABLES
    REAL *8    :: RKC1, RKC2, RKC3, RKC4 ! RK4 COEFFICIENTS
    REAL *8    :: TM, XM, YM             ! RK4 INTERIM TIME & COORDINATES
    REAL *8    :: RKV1X, RKV2X, RKV3X, RKV4X ! RK4 VALUES FOR X
    REAL *8    :: RKV1Y, RKV2Y, RKV3Y, RKV4Y ! RK4 VALUES FOR Y

    REAL *8, DIMENSION(1:MAXP)    :: POSX, XO
    REAL *8, DIMENSION(1:MAXP)    :: POSY, YO
    REAL *8, DIMENSION(1:MAXP)    :: GAM

    END MODULE MOD_VARS
!====================================================================
    PROGRAM PROJECT_ONE
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: I, M, N

    !=== READ # OF VORTICES, INITIAL POSITION, GAMMA
    !=== SET # OF STEPS AND TIMESTEP
    CALL READ()

    TIME = 0.

    CALL RKINIT()

    !=== TIME-DEPENDENT CALCULATION
    DO M = 0, NTST

        !=== WRITE POSITION & VELOCITY
        IF (MOD(M,50)==0) THEN
            CALL WRITEHISTORY(M)
        ENDIF

        CALL STEPINIT()

        ! === RK4 CALCULATION FOR EACH VORTEX
        DO I = 1, NOV
            DO N = 1, NSUB
                CALL SUBSTEPINIT(I,N)
                CALL RK4_VAL(I,N)
            ENDDO
            !=== UPDATE POSITION
            CALL RK4_UPDATE(I)
        ENDDO
        ! =========================

        TIME = TIME + DT

    ENDDO

        CALL PRINT_CURRENT_TIME()

    STOP
    END PROGRAM PROJECT_ONE
!====================================================================
    SUBROUTINE READ
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    CHARACTER*10 :: DUMMY
    INTEGER*8 :: N

    OPEN(10,FILE='input.in')
    READ(10,*) DUMMY
    READ(10,*) NOV
    READ(10,*) DUMMY
    DO N = 1, NOV
        READ(10,*) POSX(N), POSY(N), GAM(N)
    ENDDO
    READ(10,*) DUMMY
    READ(10,*) NTST, DT
    CLOSE(10)

    RETURN
    END SUBROUTINE READ
!====================================================================
    SUBROUTINE RKINIT
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE

    ! USING CLASSIC RUNGE-KUTTA 4TH ORDER (RK4) METHOD
    RKC1 = 1./6.
    RKC2 = 1./3.
    RKC3 = 1./3.
    RKC4 = 1./6.

    NSUB = 4

    RETURN
    END SUBROUTINE RKINIT
!====================================================================
   SUBROUTINE WRITEHISTORY(ST)
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: ST, I

    WRITE(*,*) 'STEP: ', ST, '  TIME: ', TIME

    OPEN(2000,FILE='history.dat',POSITION='APPEND')
    WRITE(2000,100,ADVANCE='NO') TIME
    DO I = 1, NOV
        IF (I .NE. NOV) THEN
            WRITE(2000,101,ADVANCE='NO') POSX(I), POSY(I)
        ELSE
            WRITE(2000,102) POSX(I), POSY(I)
        ENDIF
    ENDDO

100 FORMAT(F12.4, ' ')
101 FORMAT(F12.4, F12.4, ' ')
102 FORMAT(F12.4, F12.4)

    CLOSE(2000)

    RETURN
    END SUBROUTINE WRITEHISTORY
!====================================================================
    SUBROUTINE STEPINIT
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE

    TO = TIME
    XO = POSX
    YO = POSY

    RETURN
    END SUBROUTINE STEPINIT
!====================================================================
    SUBROUTINE SUBSTEPINIT(II,SS)
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: II ! VORTEX INDEX
    INTEGER *8 :: SS ! RK4 SUBSTEP FROM 1 TO 4

    IF (SS .EQ. 1) THEN
        TM = TO
        XM = XO(II)
        YM = YO(II)
    ELSE IF (SS .EQ. 2) THEN
        TM = TO + .5*DT
        XM = XO(II) + .5*DT*RKV1X
        YM = YO(II) + .5*DT*RKV1Y
    ELSE IF (SS .EQ. 3) THEN
        TM = TO + .5*DT
        XM = XO(II) + .5*DT*RKV2X
        YM = YO(II) + .5*DT*RKV2Y
    ELSE IF (SS .EQ. 4) THEN
        TM = TO + DT
        XM = XO(II) + DT*RKV3X
        YM = YO(II) + DT*RKV3Y
    ELSE
        WRITE(*,*) 'ERROR: INVALID SUBSTEP (RK4)'
        STOP
    ENDIF

    RETURN
    END SUBROUTINE SUBSTEPINIT
!====================================================================
    SUBROUTINE RK4_VAL(II, SS)
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: II ! VORTEX INDEX
    INTEGER *8 :: SS ! RK4 SUBSTEP FROM 1 TO 4
    INTEGER *8 :: I
    REAL *8    :: RKVX, RKVY

    RKVX = 0.
    RKVY = 0.
    DO I = 1, NOV
        IF (I .NE. II) THEN
            RKVX = RKVX + GAM(I)/(((XM-XO(I))**2.+(YM-YO(I))**2.)) &
                                *(-(YM-YO(I)))
            RKVY = RKVY + GAM(I)/(((XM-XO(I))**2.+(YM-YO(I))**2.)) &
                                *(XM-XO(I))
        ENDIF
    ENDDO

    IF (SS .EQ. 1) THEN
        RKV1X = RKVX
        RKV1Y = RKVY
    ELSE IF (SS .EQ. 2) THEN
        RKV2X = RKVX
        RKV2Y = RKVY
    ELSE IF (SS .EQ. 3) THEN
        RKV3X = RKVX
        RKV3Y = RKVY
    ELSE IF (SS .EQ. 4) THEN
        RKV4X = RKVX
        RKV4Y = RKVY
    ELSE
        WRITE(*,*) 'ERROR: INVALID SUBSTEP (RK4)'
        STOP
    ENDIF

    RETURN
    END SUBROUTINE RK4_VAL
!====================================================================
    SUBROUTINE RK4_UPDATE(II)
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE
    INTEGER *8 :: II ! VORTEX INDEX

    POSX(II) = POSX(II) + DT*(RKC1*RKV1X+RKC2*RKV2X+RKC3*RKV3X+RKC4*RKV4X)
    POSY(II) = POSY(II) + DT*(RKC1*RKV1Y+RKC2*RKV2Y+RKC3*RKV3Y+RKC4*RKV4Y)

    RETURN
    END SUBROUTINE RK4_UPDATE
!====================================================================
    SUBROUTINE RK4_STABILITY
!====================================================================
    USE MOD_VARS
    IMPLICIT NONE

    RETURN
    END SUBROUTINE RK4_STABILITY
!=======================================================================
      SUBROUTINE PRINT_CURRENT_TIME
!=======================================================================
    IMPLICIT NONE
    CHARACTER*8 ::  DATE
    CHARACTER*10::  NOW
    CHARACTER*5 ::  ZONE
    INTEGER*8   ::  VALS(8)

    CALL DATE_AND_TIME(DATE,NOW,ZONE,VALS)

    WRITE(*,101) VALS(1),VALS(2),VALS(3),VALS(5),VALS(6),VALS(7)
    WRITE(*,*) ''
101 FORMAT(' @ 'I0.4,'-',I0.2,'-',I0.2,' ',I0.2,':',I0.2,':',I0.2)

    RETURN
    END SUBROUTINE PRINT_CURRENT_TIME
!=======================================================================


program arrays_01_real
implicit none
integer :: i, j
real(8) :: a(3), b(4), c(2, 2)
do i = 1, 3
    a(i) = i+10
end do
if (a(1) /= 11) error stop
if (a(2) /= 12) error stop
if (a(3) /= 13) error stop

do i = 11, 14
    b(i-10) = i
end do
if (b(1) /= 11) error stop
if (b(2) /= 12) error stop
if (b(3) /= 13) error stop
if (b(4) /= 14) error stop

do i = 1, 3
    b(i) = a(i)-10
end do
if (b(1) /= 1) error stop
if (b(2) /= 2) error stop
if (b(3) /= 3) error stop

b(4) = b(1)+b(2)+b(3)+a(1)
if (b(4) /= 17) error stop

b(4) = a(1)
if (b(4) /= 11) error stop

do i = 1, 2
    do j = 1, 2
        c(i, j) = i + j + 10
    end do
end do
if (c(1, 1) /= 12) error stop
if (c(1, 2) /= 13) error stop
if (c(2, 1) /= 13) error stop
if (c(2, 2) /= 14) error stop
end


subroutine fibber(a,b,c,d)
  ! compute most significant digits, Fibonacci like.
  implicit none
  integer (kind=8), intent(in) :: a,b
  integer (kind=8), intent(out) :: c,d
  d = a + b
  if (15 .lt. log10(float(d))) then
    c = b/10
    d = d/10
  else
    c = b
  endif
end subroutine fibber

integer function leadingDigit(a)
  implicit none
  integer (kind=8), intent(in) :: a
  integer (kind=8) :: b
  b = a
  do while (9 .lt. b)
    b = b/10
  end do
  leadingDigit = transfer(b,leadingDigit)
end function leadingDigit

real function benfordsLaw(a)
  implicit none
  integer, intent(in) :: a
  benfordsLaw = log10(1.0 + 1.0 / a)
end function benfordsLaw

program benford

  implicit none

  interface

    subroutine fibber(a,b,c,d)
      implicit none
      integer (kind=8), intent(in) :: a,b
      integer (kind=8), intent(out) :: c,d
    end subroutine fibber

    integer function leadingDigit(a)
      implicit none
      integer (kind=8), intent(in) :: a
    end function leadingDigit

    real function benfordsLaw(a)
      implicit none
      integer, intent(in) :: a
    end function benfordsLaw

  end interface

  integer (kind=8) :: a, b, c, d
  integer :: i, count(10)
  data count/10*0/
  a = 1
  b = 1
  do i = 1, 1001
    count(leadingDigit(a)) = count(leadingDigit(a)) + 1
    call fibber(a,b,c,d)
    a = c
    b = d
  end do
  write(6,*) (benfordsLaw(i),i=1,9),'THE LAW'
  write(6,*) (count(i)/1000.0 ,i=1,9),'LEADING FIBONACCI DIGIT'
end program benford


c*********SUBROUTINE

      subroutine floc(lw, l1, submat, lev, nf, nprobe, nsub, nlev, rcor)
c	  input dimensions
      integer nf, nprobe, nsub, nlev
c     input
	  double precision lw(nsub), l1(nsub,nf), submat(nsub,nprobe),
     *                   lev(nlev)

c     output
      double precision rcor(nprobe,nf)
c     variables
      integer i, j, ii, jj, k
      double precision qual(nsub), poicla(nlev), z(nlev)

c     initialize rcor
      do 10, ii = 1, nprobe
         do 11 jj = 1, nf
            rcor(ii,jj)=0
11       continue
10    continue

      do 100, ii = 1, nprobe

c       initialize qual
        do 101, j = 1, nsub
           qual(j)=submat(j, ii)
101     continue

        do 110, jj = 1, nf
c          initialize and compute poicla
           do 112, k = 1, nlev
              poicla(k)=0
112	       continue

           do 120, k = 1, nlev
              do 121, i = 1, nsub
                 if(qual(i).eq.lev(k)) then
                    poicla(k)=lw(i)+poicla(k)
                 end if
121           continue
120        continue

c          initialize and compute z
           do 113, k = 1, nlev
              z(k)=0
113        continue

           do 130, k = 1, nlev
              do 131, i = 1, nsub
                 if(qual(i).eq.lev(k)) then
                    z(k)=(l1(i, jj)*lw(i)+z(k))
                 end if
131	          continue
130        continue

           do 140, k = 1, nlev
              if(poicla(k).gt.1e-12)  then
                 z(k)=z(k)/poicla(k)
              end if
140        continue

           do 150, k = 1, nlev
              rcor(ii,jj)=rcor(ii,jj)+poicla(k) * z(k) * z(k)
150        continue

110        continue
100   continue
      return
      end

c	program main

c   dimensions
c	integer nf, nprobe, nsub, nlev

c	input
c	real lw(285), l1(285,2), submat(285,830), lev(3)

c	output
c	real rcor(830,2)

c	variables
c	integer i,j

c	define dimensions
c	nf=2
c	nprobe=830
c	nsub=285
c	nlev=3

c	read input
c	open(8, file='lw.txt')
c		read(8,*) lw
c	close(8)

c	open(9, file='l1.txt')
c		read(9,*) l1
c	close(9)

c	open(10, file='submat.txt')
c		read(10,*) submat
c	close(10)

c	lev(1)=-1
c	lev(2)=0
c	lev(3)=1

c	call foc(lw, l1, submat, lev, nf, nprobe, nsub, nlev, rcor)

c	do 99, i = 1, nprobe
c		print *, (rcor(i,j),j=1,nf)
c99	continue

c	stop
c	end


       subroutine zone_setup(nx, nxmax, ny, nz)

       include 'header.h'
       include 'omp_stuff.h'

       integer nx(*), nxmax(*), ny(*), nz(*)

       integer           i,  j, zone_no
       integer           id_west, id_east, jd_south, jd_north
       double precision  x_r, y_r, x_smallest, y_smallest

       if (dabs(ratio-1.d0) .gt. 1.d-10) then

c        compute zone stretching only if the prescribed zone size ratio
c        is substantially larger than unity

         x_r   = dexp(dlog(ratio)/(x_zones-1))
         y_r   = dexp(dlog(ratio)/(y_zones-1))
         x_smallest = dble(gx_size)*(x_r-1.d0)/(x_r**x_zones-1.d0)
         y_smallest = dble(gy_size)*(y_r-1.d0)/(y_r**y_zones-1.d0)

c        compute tops of intervals, using a slightly tricked rounding
c        to make sure that the intervals are increasing monotonically
c        in size

         do i = 1, x_zones
            x_end(i) = x_smallest*(x_r**i-1.d0)/(x_r-1.d0)+0.45d0
         end do

         do j = 1, y_zones
            y_end(j) = y_smallest*(y_r**j-1.d0)/(y_r-1.d0)+0.45d0
         end do

       else

c        compute essentially equal sized zone dimensions

         do i = 1, x_zones
           x_end(i)   = (i*gx_size)/x_zones
         end do

         do j = 1, y_zones
           y_end(j)   = (j*gy_size)/y_zones
         end do

       endif

       x_start(1) = 1
       do i = 1, x_zones
          if (i .ne. x_zones) x_start(i+1) = x_end(i) + 1
          x_size(i)  = x_end(i) - x_start(i) + 1
       end do

       y_start(1) = 1
       do j = 1, y_zones
          if (j .ne. y_zones) y_start(j+1) = y_end(j) + 1
          y_size(j) = y_end(j) - y_start(j) + 1
       end do

       if (npb_verbose .gt. 1) write (*,98)
 98    format(/' Zone sizes:')

       do j = 1, y_zones
         do i = 1, x_zones
           zone_no = (i-1)+(j-1)*x_zones+1
           nx(zone_no) = x_size(i)
           nxmax(zone_no) = nx(zone_no) + 1 - mod(nx(zone_no),2)
           ny(zone_no) = y_size(j)
           nz(zone_no) = gz_size

           id_west  = mod(i-2+x_zones,x_zones)
           id_east  = mod(i,          x_zones)
           jd_south = mod(j-2+y_zones,y_zones)
           jd_north = mod(j,          y_zones)
           iz_west (zone_no) = id_west +  (j-1)*x_zones + 1
           iz_east (zone_no) = id_east +  (j-1)*x_zones + 1
           iz_south(zone_no) = (i-1) + jd_south*x_zones + 1
           iz_north(zone_no) = (i-1) + jd_north*x_zones + 1

           if (npb_verbose .gt. 1) then
             write (*,99) zone_no, nx(zone_no), ny(zone_no),
     $                    nz(zone_no)
           endif
         end do
       end do

 99    format(i5,':  ',i5,' x',i5,' x',i5)

       return
       end

       subroutine zone_starts(num_zones, nx, nxmax, ny, nz)

       include 'header.h'
       include 'omp_stuff.h'

       integer   num_zones
       integer   nx(*), nxmax(*), ny(*), nz(*)

       integer   zone, zone_size
       integer   x_face_size, y_face_size

c ... index start for u & qbc
       do zone = 1, num_zones
          zone_size = nxmax(zone)*ny(zone)*nz(zone)
          x_face_size = (ny(zone)-2)*(nz(zone)-2)*5
          y_face_size = (nx(zone)-2)*(nz(zone)-2)*5

          if (zone .eq. 1) then
             qstart_west(zone) = 1
             start1(zone) = 1
             start5(zone) = 1
          endif
          qstart_east(zone)  = qstart_west(zone) + x_face_size
          qstart_south(zone) = qstart_east(zone) + x_face_size
          qstart_north(zone) = qstart_south(zone)+ y_face_size
          if (zone .ne. num_zones) then
             qstart_west(zone+1) = qstart_north(zone) +
     $                             y_face_size
             start1(zone+1) = start1(zone) + zone_size
             start5(zone+1) = start5(zone) + zone_size*5
          else
             if (start1(zone)+zone_size-1 .gt. proc_max_size) then
                write(*,50) zone,proc_max_size,start1(zone)+zone_size-1
                stop
             endif
          endif
   50     format(' Error in size: zone',i5,' proc_max_size',i10,
     &          ' access_size',i10)
       enddo

       if (npb_verbose .gt. 1) then
          do zone = 1, num_zones
             write(*,10) zone,start1(zone),start5(zone)
          enddo
       endif
   10  format(' zone=',i5,' start1=',i10,' start5=',i10)

       return
       end


      REAL FUNCTION D2BUBF(RLAT)
C
C SPECIFIES FUNCTIONAL FORM OF 2ND DERIVATIVE OF BIG U BAR (BUBFNC)
C (USED FOR FORCED CASE ICOND = 4)
C
C CALLED BY: FORCE
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Common Blocks ----------------------------------------------------
C
C     Case 4 variables
      INCLUDE 'case4.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C LATITUDE
      REAL RLAT
C
C------ Local Variables ------------------------------------------------
C
      REAL RMU,COSLAT
C
C----- Executable Statements -------------------------------------------
C
      RMU    = SIN(RLAT)
      COSLAT = COS(RLAT)
      D2BUBF = 8.0*SU0*(2.0*RMU*COSLAT)**(NPWR-3)*RMU*
     $         (REAL((NPWR-1)*NPWR)+RMU*RMU*(REAL(NPWR-1)-
     $         REAL(2*NPWR*(2*NPWR+1))*COSLAT*COSLAT))
C
      RETURN
      END


! { dg-do run }
! { dg-require-effective-target fortran_large_real }
! Program to test the UNPACK intrinsic for large real type
program intrinsic_unpack
   implicit none
   integer,parameter :: k = selected_real_kind (precision (0.0_8) + 1)

   real(kind=k), dimension(3,3) :: ark, brk
   complex(kind=k), dimension(3,3) :: ack, bck

   logical, dimension(3, 3) :: mask
   character(len=500) line1, line2
   integer i

   mask = reshape ((/.false.,.true.,.false.,.true.,.false.,.false.,&
                    &.false.,.false.,.true./), (/3, 3/));

   ark = reshape ((/1._k, 0._k, 0._k, 0._k, 1._k, 0._k, 0._k, 0._k, 1._k/), &
         (/3, 3/));
   brk = unpack ((/2._k, 3._k, 4._k/), mask, ark)
   if (any (brk .ne. reshape ((/1._k, 2._k, 0._k, 3._k, 1._k, 0._k, &
                               0._k, 0._k, 4._k/), (/3, 3/)))) &
      STOP 1
   write (line1,'(9F9.5)') brk
   write (line2,'(9F9.5)') unpack((/2._k, 3._k, 4._k/), mask, ark)
   if (line1 .ne. line2) STOP 2
   brk = -1._k
   brk = unpack ((/2._k, 3._k, 4._k/), mask, 0._k)
   if (any (brk .ne. reshape ((/0._k, 2._k, 0._k, 3._k, 0._k, 0._k, &
      0._k, 0._k, 4._k/), (/3, 3/)))) &
      STOP 3

   ack = reshape ((/1._k, 0._k, 0._k, 0._k, 1._k, 0._k, 0._k, 0._k, 1._k/), &
        (/3, 3/));
   bck = unpack ((/(2._k, 0._k), (3._k, 0._k), (4._k,   0._k)/), mask, ack)
   if (any (real(bck) .ne. reshape ((/1._k, 2._k, 0._k, 3._k, 1._k, 0._k, &
        0._k, 0._k, 4._k/), (/3, 3/)))) &
        STOP 4
   write (line1,'(18F9.5)') bck
   write (line2,'(18F9.5)') unpack((/(2._k, 0._k), (3._k, 0._k), (4._k,0._k)/), &
        mask, ack)
   if (line1 .ne. line2) STOP 5

end program


c gmm01f
c  gxurcd0.f to compute Gaunt coefficients a(-m,n,m,v,p)
c  THIS FILE IS PART OF THE ORIGINAL GMM01F DISTRIBUTION
cu uses lnfacd.f to compute ln(z!)
      subroutine gxurcd0(m,n,v,qmax,na)
      implicit double precision (a-h,o-z)
      include 'gmm01f.par'
      parameter (ng0=np*(2*np**3+10*np**2+19*np+5)/6)
      integer v,qmax,p
      double precision lnfacd,cnv(np,np),ga0(ng0)
      common/cfnv/cnv
      common/g0/ga0
      fb(n,v,p)=dble(p-(n+v+1))*dble(p+(n+v+1))
     +           *dble(p-(n-v))*dble(p+(n-v))
     +           /(dble(2*p+1)*dble(2*p-1))
      if(iabs(m).gt.n.or.iabs(m).gt.v) then
         write(6,*) 'warning: |m|>n or v in gxurcd0'
         qmax=-1
         return
      endif
      qmax=min(n,v)
      nq=qmax+1
      if(n.le.v) then
         c1=cnv(n,v)
      else
         c1=cnv(v,n)
      endif
      c1=c1-lnfacd(dble(n-m))-lnfacd(dble(v+m))
      ga0(na+1)=dexp(c1)
      if(qmax.lt.1) return
      p=n+v
      do 8 i=2,nq
         p=p-2
         if(m.eq.0) then
            c1=fb(n,v,p+1)
            c2=fb(n,v,p+2)
            goto 2
         endif
         c1=fb(n,v,p+1)
         c2=dble(4*m*m)+fb(n,v,p+2)+fb(n,v,p+3)
         if(i.eq.2) goto 2
         c3=-fb(n,v,p+4)
         goto 4
  2	     ga0(na+i)=c2*ga0(na+i-1)/c1
         goto 8
  4	     ga0(na+i)=(c2*ga0(na+i-1)+c3*ga0(na+i-2))/c1
  8       continue
      return
      end

      subroutine gid0(nmax,m,n,iv,id)
      nt=nmax*(nmax+1)*(2*nmax+1)/3+nmax*nmax
      ns=max(1,iabs(m))
      nc0=nmax-iabs(m)
      id=nc0*(nc0+1)*(2*nc0+1)/6
      if(m) 10,11,12
 10	  id=id+(n-ns)*(nc0+1)+iv-ns+1
      return
 11	  id=id+(n-ns)*nmax+iv
      return
 12	  id=id+(nmax-n)*(nc0+1)+nmax-iv
      id=nt-id
      return
      end


module functions
    contains

subroutine spaceevenly(start, finish, number, arrayout)
    implicit none

    integer, intent(in) :: start, finish
    real(kind=8), intent(in) :: number
    real(kind=8) :: div
    real(kind=8), dimension(0:finish), intent(out) :: arrayout
    integer :: i

    div = number / ((finish-1) - (start-1))

    do i=start, finish
        arrayout(i) = div * i
    end do

end subroutine spaceevenly

subroutine diffuse(timesteps, u, nu, dt, dx, dy, nx, ny)
    implicit none
    integer, intent(in) :: nx, ny, timesteps
    real(kind=8), intent(in) :: nu, dt, dx, dy
    real(kind=8), intent(out), dimension(nx,ny) :: u
    real(kind=8), dimension(nx,ny) :: un
    integer :: i, j, time
    real(kind=8) :: Ydisip, Xdisip, Yderiv, Xderiv
    time = timesteps

    do time = 1, time
            un = u

            do j=2, nx-1
                do i=2, ny-1
                    Xderiv = (nu * dt) / (dx**2)
                    Yderiv = (nu * dt) / (dy**2)
                    Xdisip = un(j,i+1) - (2 * un(j,i)) + un(j,i-1)
                    Ydisip = un(j+1,i) - (2 * un(j,i)) + un(j-1,i)

                    u(j,i) = un(j,i) + (Xderiv * Xdisip) + (Yderiv * Ydisip)

                    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
                end do
            end do
        end do
end subroutine

end module functions


Function ftot(x)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Save
  omg = omg0(x)*(hipr1(30)+hint1(11))/hipr1(31)/2.0
  ftot = 2.0*(1.0-exp(-omg))
  Return
End Function ftot


Module Laguerre
  Use nrtype

contains

subroutine Laguerre_Fast(Temp,xl_n,xl_m,sigmaBH)

      Implicit none

      Integer(I4B)            :: NP=5
      Integer(I4B)            :: i, j, n

      Real(DP)                :: Temp,xl_n,xl_m,sigmaBH
      Real(DP)                :: u(5),w(5),x(5),func(5)
      Real(DP)                :: CMie, theta
      Intent(IN)              :: Temp,xl_n,xl_m
      Intent(OUT)             :: sigmaBH

      u(1) =  0.26356031971814109102031d0
      u(2) =  1.41340305910651679221800d0
      u(3) =  3.59642577104072208122300d0
      u(4) =  7.08581000585883755692200d0
      u(5) = 12.64080084427578265943000d0

      w(1) =  0.5217556105828086524759d0
      w(2) =  0.3986668110831759274500d0
      w(3) =  7.5942449681707595390000d-2
      w(4) =  3.6117586799220484545000d-3
      w(5) =  2.3369972385776227891000d-5

      CMie  =  (xl_n/(xl_n-xl_m))*(xl_n/xl_m)**(xl_m/(xl_n-xl_m))
      theta =  CMie / Temp

      ! roots and weights of the laguerre polynomial of order n

      ! calculation of sigmaBH using the gauss laguerre formula
      sigmaBH  =   ZERO

      do i=1,5
         x(i)     =  (theta / (u(i)+theta))**(ONE/xl_n)
         func(i)  =   x(i)*exp(theta*(ONE/x(i)**xl_m-ONE))/(u(i)+theta)

         sigmaBH  = sigmaBH + w(i)*func(i)/xl_n

      end do

      sigmaBH = ONE - sigmaBH
end subroutine Laguerre_Fast
End Module Laguerre


      FUNCTION CSEDTAUB(DENBULK,TDUM,V1,V2,V3,IOPT)
C
C CHANGE RECORD
C
C
C **  CALCULATES CRITIAL STRESS FOR BULK OR MASS EROSION OF COHESIVE
C **  SEDIMENT AS A FUNCTION OF BED BULK DENSITY
C **  IOPT=1  BASED ON
C **
C **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
C **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C **  IOPT=2  BASED ON
C **
C **  HWANG, K. N., AND A. J. MEHTA, 1989: FINE SEDIMENT DRODIBILITY
C **  IN LAKE OKEECHOBEE FLORIDA. COASTAL AND OCEANOGRAPHIC ENGINEERING
C **  DEPARTMENT, UNIVERSITY OF FLORIDA, GAINESVILLE, FL32661
C
      IF(IOPT.EQ.1)THEN
        BULKDEN=0.001*DENBULK  ! *** PMC Changed to prevent
        IF(BULKDEN.LE.1.013)THEN
          CSEDTAUB=0.0
        ELSE
          CSEDTAUB=0.001*(9.808*BULKDEN-9.934)
        ENDIF
      ELSEIF(IOPT.EQ.2)THEN
        BULKDEN=0.001*DENBULK  ! *** PMC Changed to prevent
        IF(BULKDEN.LE.1.013)THEN
          CSEDTAUB=0.0
        ELSE
          CSEDTAUB=0.001*(9.808*BULKDEN-9.934)
        ENDIF
      ELSE
        STOP 'CSEDTAUB: BAD SEDIMENT CRITICAL STRESS OPTION! STOPPING!'
      ENDIF
C
      RETURN
      END


        SUBROUTINE MOV_PROB(M1,M4,pNmin,pNmax
     $      ,A,PDF,SCALAR,qwcell,qwbin)
	integer qwcell, qwbin
        real A(qwcell), PDF(qwbin),SCALAR(qwbin)
	real pNmin, pNmax

        NBIN=60
        DO K=1,NBIN
         PDF(K)=0.
        END DO
c
c       PDFAREA: the total area of PDF
c       JJ: locate the A(K) into approciate bin #
c       pNmin: min. of scalar value
c       pNmax: max. of scalar value
c
        pNlength=pNmax-pNmin
        PDFAREA=0.
        DO K=M1,M4
          JJ=INT(NBIN*((A(K)-pNmin)/pNlength))+1
          if(jj.gt.NBIN.or. jj.le.0)then
            write(6,*)'mov_prob.f jj,a(k)=',jj,a(k)
Ccall flush(6)
            JJ=NBIN
          endif
c
c accumulate the count # at each interval of JJ
c
          PDF(JJ)=PDF(JJ)+1.
        END DO
c
c       calculate the total PDFAREA
c
        DDX=(pNlength)/float(NBIN)
        DO K=1,NBIN
        PDFAREA=PDFAREA+PDF(K)*DDX
        END DO
c
c       normlaized the PDF and calculate the real scalar
c       value at each bin#
c
        DO K=1,NBIN+1
        PDF(K)=PDF(K)/PDFAREA
        SCALAR(K)=(K-1.)*DDX+pNmin
        END DO

        RETURN
        END


C$Procedure PLTNRM ( DSK, compute outward normal of plate )

      SUBROUTINE PLTNRM ( V1, V2, V3, NORMAL )

C$ Abstract
C
C     Compute an outward normal vector of a triangular plate.
C     The vector does not necessarily have unit length.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     DSK
C
C$ Keywords
C
C     DSK
C     FILES
C     TOPOGRAPHY
C
C$ Declarations

      IMPLICIT NONE

      DOUBLE PRECISION      V1     ( 3 )
      DOUBLE PRECISION      V2     ( 3 )
      DOUBLE PRECISION      V3     ( 3 )
      DOUBLE PRECISION      NORMAL ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     V1,
C     V2,
C     V3         I   Vertices of a plate.
C     NORMAL     O   Plate's outward normal vector.
C
C$ Detailed_Input
C
C     V1,
C     V2,
C     V3             are vertices of a triangular plate.
C
C$ Detailed_Output
C
C     NORMAL         is an outward normal vector of the plate defined by
C                    the input vertices. The order of the vertices is
C                    used to determine the choice of normal direction:
C                    the normal vector is
C
C                       ( V2 - V1 ) x ( V3 - V2 )
C
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) The input plate may be degenerate: it may be a line segment
C        or a point. These are not considered to be erroneous inputs.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine saves computation time by not scaling the output
C     vector to unit length. The caller can scale the vector using
C     the routine VHAT.
C
C$ Examples
C
C
C     1) Compute an upward normal of an equilateral triangle lying
C        in the X-Y plane and centered at the origin.
C
C        Example code begins here.
C
C
C           PROGRAM EX1
C           IMPLICIT NONE
C
C           DOUBLE PRECISION      NORMAL ( 3 )
C           DOUBLE PRECISION      S
C           DOUBLE PRECISION      V1     ( 3 )
C           DOUBLE PRECISION      V2     ( 3 )
C           DOUBLE PRECISION      V3     ( 3 )
C
C
C           S = SQRT(3.D0)/2
C
C           CALL VPACK (    S,  -0.5D0,  0.D0, V1 )
C           CALL VPACK ( 0.D0,    1.D0,  0.D0, V2 )
C           CALL VPACK (   -S,  -0.5D0,  0.D0, V3 )
C
C
C           CALL PLTNRM ( V1, V2, V3, NORMAL )
C
C           WRITE (*, '(1X,A,3(3E20.12))' ) 'NORMAL = ', NORMAL
C
C           END
C
C        When run on a PC/Linux/gfortran/64-bit platform, the output
C        from this program was:
C
C
C  NORMAL =   0.000000000000E+00  0.000000000000E+00  0.259807621135E+01
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman    (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.0, 26-JAN-2016 (NJB)
C
C-&

C$ Index_Entries
C
C     compute normal vector of triangular plate from vertices
C
C-&

C
C     SPICELIB functions
C

C
C     Local variables
C
      DOUBLE PRECISION      EDGE1  ( 3 )
      DOUBLE PRECISION      EDGE2  ( 3 )

C
C     This routine is error-free.
C

C
C     Type 2 plate vertices are ordered in the positive
C     (right-handed) sense about the outward normal.
C
      CALL VSUB ( V2, V1, EDGE1 )
      CALL VSUB ( V3, V2, EDGE2 )

      CALL VCRSS ( EDGE1, EDGE2, NORMAL )

      END


      PROGRAM PGKEX18
C
C  Produce an NX x NY  CELL ARRAY based on the Mandelbrot set--color
C  the cells depending upon the speed of convergence or divergence.
C
C Define the error file, the Fortran unit number, the workstation type,
C and the workstation ID to be used in calls to GKS routines.
C
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)   ! NCGM
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=8,  IWKID=1)   ! X Windows
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=11, IWKID=1)   ! PDF
C     PARAMETER (IERRF=6, LUNIT=2, IWTYPE=20, IWKID=1)   ! PostScript
C
      PARAMETER (IERRF=6, LUNIT=2, IWTYPE=1,  IWKID=1)
      PARAMETER (NX=20, NY=20, NITER=101)
      INTEGER COLIA(NX,NY)
      COMPLEX Z
C
C  Region of interest.
C
      DATA XL,XR,YB,YT/-2.,.5,-1.25,1.25/
C
C  Open GKS, open and activate a workstation.
C
      CALL GOPKS (IERRF,IDUM)
      CALL GOPWK (IWKID,LUNIT,IWTYPE)
      CALL GACWK (IWKID)
C
C  Set up normalizaton transformation.
C
      CALL GSWN(1,XL,XR,YB,YT)
      CALL GSVP(1,.1,.9,0.,.8)
      CALL GSELNT(1)
C
C  Define color indices in a continuous spectrum.
C
      DO 11 K = 1,NITER
        H = REAL(K)/REAL(NITER)*360.
        CALL HLSRGB(H,50.,100.,RV,GV,BV)
        CALL GSCR(IWKID,K,RV,GV,BV)
   11 CONTINUE
      CALL GSCR(IWKID,NITER+1,0.,0.,1.)
C
C  Set up the cell array and call GCA.
C
      DX = (XR-XL)/NX
      DY = (YT-YB)/NY
      DO 10 J=1,NY
        Y = YB+DY*REAL(J-1)
        DO 20 I=1,NX
          X = XL+DX*REAL(I-1)
          Z = CMPLX(X,Y)
          CALL CONVG(Z,NITER,.001,10000.,ITER)
          COLIA(I,J) = ITER
   20   CONTINUE
   10 CONTINUE
      CALL GCA(XL,YB,XR,YT,NX,NY,1,1,NX,NY,COLIA)
C
C  Label the plot using Plotchar.
C
      CALL GSCLIP(0)
      CALL PCSETI('FN',25)
      CALL PCSETI('CC',NITER+1)
      CALL PLCHHQ(XL+.5*(XR-XL),YB+(YT-YB)*1.07,'Cell array',.033,0.,0.)
      CALL FRAME
C
C  Deactivate and close the workstation, close GKS.
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS
C
      STOP
      END
      SUBROUTINE CONVG(Z,NUM,TOLSM,TOLLG,ITER)
C
C  Iterate Z(N+1) = Z(N)**2+Z0 for N=1,...,NUM .  If the complex absolute
C  values get smaller than TOLSM, then set ITER equal to the number of
C  iterations and return.  If the complex absolute value gets larger than
C  TOLLG, set ITER to NUM and return.
C
      COMPLEX Z,ZS,ZN,ZO
      ZS = Z
      ZO = Z
      DO 10 I=1,NUM
        ZN = ZO*ZO+ZS
        IF (CABS(ZN-ZO) .LT. TOLSM) THEN
          ITER = I
          RETURN
        ELSE IF (CABS(ZN-ZO) .GT. TOLLG) THEN
          ITER = I
          RETURN
        ENDIF
        ZO = ZN
   10 CONTINUE
      ITER=NUM
      RETURN
      END


! Model program to compress given Gausssians
! Kernal Density Compression Algorithm
!
! Authour: Anji Babu Kapakayala
!          Dept. of Chemistry
!          IIT Kanpur, India.
!          anjibabu480@gmail.com
!
! OUTPUTS: Original_Gaus.dat
!          Compressed_Gaus.dat
!
PROGRAM kde
IMPLICIT NONE
REAL*8::x,dx0,x_min,x_max,x_width,dum,dum1,error
INTEGER::i,j,nbin=10001,ng=15000,CNG
REAL*8,ALLOCATABLE::grid(:),G(:),ht(:),sigma(:),x0(:)
REAL*8,ALLOCATABLE::C_hill(:),C_width(:),C_height(:)
!Initializing grid values
x_min=-100.d0;x_max=100.d0
x_width=(x_max-x_min)/(nbin-1)

open(10,file="Original_Gaus.dat",status='unknown')
open(11,file="Compressed_Gaus.dat",status='unknown')

ALLOCATE(grid(nbin),G(nbin))
ALLOCATE(ht(ng),sigma(ng),x0(ng))
ALLOCATE(C_hill(ng),C_width(ng),C_height(ng))

! Gridding data
do i=1,nbin
grid(i)=DFLOAT(i-1)*x_width+x_min
enddo

!Initializing Gaussian Parameters
x0(1)=-35.0;sigma(1)=0.050
ht(1)=0.20;dx0=0.0050

! Generate Gaussians centers
DO j=1,ng
ht(j)=0.50
sigma(j)=0.05
!write(*,*) x0(j),sigma(j),ht(j)
x0(j+1)=x0(j)+dx0
ENDDO

!Summing the original Gaussians
DO i=1,nbin
   dum=0.0
   DO j=1,ng
     dum=dum+ht(j)*EXP(-(((grid(i)-x0(j))**2)/2*(sigma(j)*sigma(j))))
   ENDDO
write(10,*) grid(i),dum
ENDDO

! Compressing the given Gaussians using Kernel Density Compression Algorithm
CALL Compress(ng,x0,ht,sigma,CNG,C_hill,C_width,C_height)

!Summing the Compressed Gaussians
DO i=1,nbin
   dum1=0.0
   DO j=1,CNG
    if(ng.eq.CNG)then
      dum1=dum1+C_height(j)*EXP(-(((grid(i)-C_hill(j))**2)/2*(C_width(j)*C_width(j))))
    else
      dum1=dum1+C_height(j)*EXP(-(((grid(i)-C_hill(j))**2)/2*(C_width(j))))
    endif
   ENDDO
write(11,*) grid(i),dum1
ENDDO

WRITE(*,*) "No of Original Gassians    : ",ng,"No. of Compressed Gaussians: ",CNG
WRITE(*,*) "Sum of original Gaussians  : ",dum
WRITE(*,*) "Sum of compressed Gaussians: ",dum1

! Calculating relative error
error=(abs(dum1-dum)/dum)*100
WRITE(*,*) "Relative error(%)          : ",error
close(10)
close(11)
ENDPROGRAM kde
!------------------------------------------------------------------------------------------!
!Subroutine to compress Given gasuuians using Kernel Density Compression Algorithm
SUBROUTINE Compress(NG,hill,height,width,CNG,C_hill,C_width,C_height)
IMPLICIT NONE
 INTEGER, INTENT(IN)::NG
 REAL*8,  INTENT(IN)::hill(NG),width(NG),height(NG)
 REAL*8, INTENT(OUT)::C_hill(NG),C_width(NG),C_height(NG)
 INTEGER,INTENT(OUT)::CNG
!
 integer :: i,j,n,min_j
 real*8  :: distance,cutoff=1.0,dum,new_height,new_width,new_hill,min_d
!
! Initialization of Compressed Gaussians
 C_hill(1) =hill(1)
 C_width(1)=width(1)
 C_height(1)=height(1)
 n=1

 DO i=2,NG
    min_d=sqrt(ABS(((hill(i))-C_hill(1))/C_width(1))**2)
    min_j=1
      do j=1,n
         distance=sqrt(ABS(((hill(i))-C_hill(j))/C_width(j))**2)
         if(distance.lt.min_d) then
            min_d=distance
            min_j=j
         endif
        ! print*,"Distance: ",distance
     enddo
     !print*,"Minimum Distance: ",min_d,"LOCATION: ",min_j
     !If minimun distance is less than given cutoff, it merges the both gaussinas
     ! Add as new compressed kernal otherwise.
     if(min_d.lt.cutoff)then
           new_height=height(i)+C_height(min_j)
           new_hill  =(1.0/new_height)*((height(i)*hill(i))+(C_height(min_j)*C_hill(min_j)))
           dum=(height(i)*(width(i)**2+hill(i)**2)+C_height(min_j)*(C_width(min_j)**2+C_hill(min_j)**2))
           new_width=(1.0/new_height)*dum-new_hill**2
           ! Store new variables to min_jth kernel
           C_height(min_j)=new_height
           C_width(min_j)=new_width
           C_hill(min_j)=new_hill
        else
           n=n+1
           C_height(n)=height(i)
           C_width(n)=width(i)
           C_hill(n)=hill(i)
        endif

 ENDDO
! Store n as No. of Compressed Gaussians
 CNG=n

END SUBROUTINE Compress
!------------------------------------------------------------------------------------------!
!                           Anji Babu Kapakayala, Jan, 2021			           !
!------------------------------------------------------------------------------------------!


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     PROGRAM TO ILLUSTRATE THE USE OF HSTCYL TO SOLVE THE EQUATION
C
C    (1/R)(D/DR)(R*DU/DR) + (D/DZ)(DU/DZ) = (2*R*Z)**2*(4*Z**2 + 3*R**2)
C
C     ON THE RECTANGLE 0 .LT. R .LT. 1 , 0 .LT. Z .LT. 1 WITH THE
C     BOUNDARY CONDITIONS
C
C     (DU/DR)(1,Z) = 4*Z**2  FOR  0 .LE. Z .LE. 1
C
C     AND
C
C     (DU/DZ)(R,0) = 0 AND (DU/DZ)(R,1) = 4*R**2  FOR  0 .LE. R .LE. 1 .
C
C     THE SOLUTION TO THIS PROBLEM IS NOT UNIQUE.  IT IS A
C     ONE-PARAMETER FAMILY OF SOLUTIONS GIVEN BY
C
C            U(R,Z) = (R*Z)**4 + ARBITRARY CONSTANT .
C
C     THE R-INTERVAL WILL CONTAIN 50 UNKNOWNS AND THE Z-INTERVAL WILL
C     CONTAIN 52 UNKNOWNS.
C
      DIMENSION       F(51,52)   ,BDB(52)    ,BDC(50)    ,BDD(50)    ,
     1                W(1108)    ,R(50)      ,Z(52)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF.  ALSO NOTE THAT W
C     IS DIMENSIONED (13 + INT(LOG2(N)))*M + 4*N .
C
      IDIMF = 51
      A = 0.
      B = 1.
      M = 50
      MBDCND = 6
      C = 0.
      D = 1.
      N = 52
      NBDCND = 3
      ELMBDA = 0.
C
C     GENERATE AND STORE GRID POINTS FOR THE PURPOSE OF COMPUTING
C     BOUNDARY DATA AND THE RIGHT SIDE OF THE POISSON EQUATION.
C
      DO 101 I=1,M
         R(I) = (FLOAT(I)-0.5)/50.
  101 CONTINUE
      DO 102 J=1,N
         Z(J) = (FLOAT(J)-0.5)/52.
  102 CONTINUE
C
C     GENERATE BOUNDARY DATA.
C
      DO 103 J=1,N
         BDB(J) = 4.*Z(J)**4
  103 CONTINUE
      DO 104 I=1,M
         BDC(I) = 0.
         BDD(I) = 4.*R(I)**4
  104 CONTINUE
C
C     BDA IS A DUMMY VARIABLE.
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 106 I=1,M
         DO 105 J=1,N
            F(I,J) = 4.*R(I)**2*Z(J)**2*(4.*Z(J)**2+3.*R(I)**2)
  105    CONTINUE
  106 CONTINUE
      CALL HSTCYL (A,B,M,MBDCND,BDA,BDB,C,D,N,NBDCND,BDC,BDD,ELMBDA,F,
     1             IDIMF,PERTRB,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR BY MINIMIZING OVER ALL A THE FUNCTION
C     NORM(F(I,J) - A*1 - U(R(I),Z(J))).  THE EXACT SOLUTION IS
C                U(R,Z) = (R*Z)**4 + ARBITRARY CONSTANT.
C
      X = 0.
      DO 108 I=1,M
         DO 107 J=1,N
            X = X+F(I,J)-(R(I)*Z(J))**4
  107    CONTINUE
  108 CONTINUE
      X = X/FLOAT(M*N)
      DO 110 I=1,M
         DO 109 J=1,N
            F(I,J) = F(I,J)-X
  109    CONTINUE
  110 CONTINUE
      ERR = 0.
      DO 112 I=1,M
         DO 111 J=1,N
            X = ABS(F(I,J)-(R(I)*Z(J))**4)
            IF (X .GT. ERR) ERR = X
  111    CONTINUE
  112 CONTINUE
      PRINT 1001 , IERROR,PERTRB,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE HSTCYL EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/32X,20HPERTRB =-4.43114E-04/
     3        18X,34HDISCRETIZATION ERROR = 7.52796E-05/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 958//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/32X,8HPERTRB =,E12.5/
     7        18X,22HDISCRETIZATION ERROR =,E12.5/
     8        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


    program demo_atan2
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    real(kind=sp) :: x = 1.e0_sp, y = 0.5e0_sp, z
       z = atan2(y,x)
       write(*,*)x,y,z
    end program demo_atan2


!---------------------------------------------------!
! Copyright (c) 2017 Shunsuke A. Sato               !
! Released under the MIT license                    !
! https://opensource.org/licenses/mit-license.php   !
!---------------------------------------------------!
subroutine mesh
  use global_variables
  use hpsi
  use density_matrix
  implicit none
  integer :: ix, iy

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

  allocate(xn(0:Nx),xyn(0:Nx,0:Nx))
  dx = length_x/dble(Nx)

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

  do ix = 0,Nx
  do iy = 0,Nx
     xyn(ix,iy)= xn(ix)+xn(iy)
  end do
  end do

  call initialize_hpsi
  call initialize_density_matrix

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


program ch0802
    ! Rank 2 Whole Arrays in Fortran
    implicit none

    integer, parameter :: n = 5
    real, dimension(1:n,1:n) :: fahrenheit, celsius
    integer :: lat, long

    do lat = 1, n
        print *, ' For Latitude= ', lat
        do long = 1, n
            print *, ' For Longitude', long
            read *, fahrenheit(lat,long)
        end do
    end do
    ! read *, fahrenheit
    celsius = 5./9.*(fahrenheit-32.)
    print *, fahrenheit
    print *, celsius
end program


*DECK DSPCO
      SUBROUTINE DSPCO (AP, N, KPVT, RCOND, Z)
C***BEGIN PROLOGUE  DSPCO
C***PURPOSE  Factor a real symmetric matrix stored in packed form
C            by elimination with symmetric pivoting and estimate the
C            condition number of the matrix.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2B1A
C***TYPE      DOUBLE PRECISION (SSPCO-S, DSPCO-D, CHPCO-C, CSPCO-C)
C***KEYWORDS  CONDITION NUMBER, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION, PACKED, SYMMETRIC
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     DSPCO factors a double precision symmetric matrix stored in
C     packed form by elimination with symmetric pivoting and estimates
C     the condition of the matrix.
C
C     IF  RCOND  is not needed, DSPFA is slightly faster.
C     To solve  A*X = B , follow DSPCO by DSPSL.
C     To compute  INVERSE(A)*C , follow DSPCO by DSPSL.
C     To compute  INVERSE(A) , follow DSPCO by DSPDI.
C     To compute  DETERMINANT(A) , follow DSPCO by DSPDI.
C     To compute  INERTIA(A), follow DSPCO by DSPDI.
C
C     On Entry
C
C        AP      DOUBLE PRECISION (N*(N+1)/2)
C                the packed form of a symmetric matrix  A .  The
C                columns of the upper triangle are stored sequentially
C                in a one-dimensional array of length  N*(N+1)/2 .
C                See comments below for details.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     Output
C
C        AP      a block diagonal matrix and the multipliers which
C                were used to obtain it stored in packed form.
C                The factorization can be written  A = U*D*TRANS(U)
C                where  U  is a product of permutation and unit
C                upper triangular matrices , TRANS(U) is the
C                transpose of  U , and  D  is block diagonal
C                with 1 by 1 and 2 by 2 blocks.
C
C        KPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        RCOND   DOUBLE PRECISION
C                an estimate of the reciprocal condition of  A .
C                For the system  A*X = B , relative perturbations
C                in  A  and  B  of size  EPSILON  may cause
C                relative perturbations in  X  of size  EPSILON/RCOND .
C                If  RCOND  is so small that the logical expression
C                           1.0 + RCOND .EQ. 1.0
C                is true, then  A  may be singular to working
C                precision.  In particular,  RCOND  is zero  if
C                exact singularity is detected or the estimate
C                underflows.
C
C        Z       DOUBLE PRECISION(N)
C                a work vector whose contents are usually unimportant.
C                If  A  is close to a singular matrix, then  Z  is
C                an approximate null vector in the sense that
C                NORM(A*Z) = RCOND*NORM(A)*NORM(Z) .
C
C     Packed Storage
C
C          The following program segment will pack the upper
C          triangle of a symmetric matrix.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  DASUM, DAXPY, DDOT, DSCAL, DSPFA
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890831  Modified array declarations.  (WRB)
C   891107  Modified routine equivalence list.  (WRB)
C   891107  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DSPCO
      INTEGER N,KPVT(*)
      DOUBLE PRECISION AP(*),Z(*)
      DOUBLE PRECISION RCOND
C
      DOUBLE PRECISION AK,AKM1,BK,BKM1,DDOT,DENOM,EK,T
      DOUBLE PRECISION ANORM,S,DASUM,YNORM
      INTEGER I,IJ,IK,IKM1,IKP1,INFO,J,JM1,J1
      INTEGER K,KK,KM1K,KM1KM1,KP,KPS,KS
C
C     FIND NORM OF A USING ONLY UPPER HALF
C
C***FIRST EXECUTABLE STATEMENT  DSPCO
      J1 = 1
      DO 30 J = 1, N
         Z(J) = DASUM(J,AP(J1),1)
         IJ = J1
         J1 = J1 + J
         JM1 = J - 1
         IF (JM1 .LT. 1) GO TO 20
         DO 10 I = 1, JM1
            Z(I) = Z(I) + ABS(AP(IJ))
            IJ = IJ + 1
   10    CONTINUE
   20    CONTINUE
   30 CONTINUE
      ANORM = 0.0D0
      DO 40 J = 1, N
         ANORM = MAX(ANORM,Z(J))
   40 CONTINUE
C
C     FACTOR
C
      CALL DSPFA(AP,N,KPVT,INFO)
C
C     RCOND = 1/(NORM(A)*(ESTIMATE OF NORM(INVERSE(A)))) .
C     ESTIMATE = NORM(Z)/NORM(Y) WHERE  A*Z = Y  AND  A*Y = E .
C     THE COMPONENTS OF  E  ARE CHOSEN TO CAUSE MAXIMUM LOCAL
C     GROWTH IN THE ELEMENTS OF W  WHERE  U*D*W = E .
C     THE VECTORS ARE FREQUENTLY RESCALED TO AVOID OVERFLOW.
C
C     SOLVE U*D*W = E
C
      EK = 1.0D0
      DO 50 J = 1, N
         Z(J) = 0.0D0
   50 CONTINUE
      K = N
      IK = (N*(N - 1))/2
   60 IF (K .EQ. 0) GO TO 120
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         KP = ABS(KPVT(K))
         KPS = K + 1 - KS
         IF (KP .EQ. KPS) GO TO 70
            T = Z(KPS)
            Z(KPS) = Z(KP)
            Z(KP) = T
   70    CONTINUE
         IF (Z(K) .NE. 0.0D0) EK = SIGN(EK,Z(K))
         Z(K) = Z(K) + EK
         CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
         IF (KS .EQ. 1) GO TO 80
            IF (Z(K-1) .NE. 0.0D0) EK = SIGN(EK,Z(K-1))
            Z(K-1) = Z(K-1) + EK
            CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
   80    CONTINUE
         IF (KS .EQ. 2) GO TO 100
            IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 90
               S = ABS(AP(KK))/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               EK = S*EK
   90       CONTINUE
            IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0
         GO TO 110
  100    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0D0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  110    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 60
  120 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
C     SOLVE TRANS(U)*Y = W
C
      K = 1
      IK = 0
  130 IF (K .GT. N) GO TO 160
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 150
            Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     1         Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = ABS(KPVT(K))
            IF (KP .EQ. K) GO TO 140
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  140       CONTINUE
  150    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 130
  160 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
C
      YNORM = 1.0D0
C
C     SOLVE U*D*V = Y
C
      K = N
      IK = N*(N - 1)/2
  170 IF (K .EQ. 0) GO TO 230
         KK = IK + K
         IKM1 = IK - (K - 1)
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. KS) GO TO 190
            KP = ABS(KPVT(K))
            KPS = K + 1 - KS
            IF (KP .EQ. KPS) GO TO 180
               T = Z(KPS)
               Z(KPS) = Z(KP)
               Z(KP) = T
  180       CONTINUE
            CALL DAXPY(K-KS,Z(K),AP(IK+1),1,Z(1),1)
            IF (KS .EQ. 2) CALL DAXPY(K-KS,Z(K-1),AP(IKM1+1),1,Z(1),1)
  190    CONTINUE
         IF (KS .EQ. 2) GO TO 210
            IF (ABS(Z(K)) .LE. ABS(AP(KK))) GO TO 200
               S = ABS(AP(KK))/ABS(Z(K))
               CALL DSCAL(N,S,Z,1)
               YNORM = S*YNORM
  200       CONTINUE
            IF (AP(KK) .NE. 0.0D0) Z(K) = Z(K)/AP(KK)
            IF (AP(KK) .EQ. 0.0D0) Z(K) = 1.0D0
         GO TO 220
  210    CONTINUE
            KM1K = IK + K - 1
            KM1KM1 = IKM1 + K - 1
            AK = AP(KK)/AP(KM1K)
            AKM1 = AP(KM1KM1)/AP(KM1K)
            BK = Z(K)/AP(KM1K)
            BKM1 = Z(K-1)/AP(KM1K)
            DENOM = AK*AKM1 - 1.0D0
            Z(K) = (AKM1*BK - BKM1)/DENOM
            Z(K-1) = (AK*BKM1 - BK)/DENOM
  220    CONTINUE
         K = K - KS
         IK = IK - K
         IF (KS .EQ. 2) IK = IK - (K + 1)
      GO TO 170
  230 CONTINUE
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
C     SOLVE TRANS(U)*Z = V
C
      K = 1
      IK = 0
  240 IF (K .GT. N) GO TO 270
         KS = 1
         IF (KPVT(K) .LT. 0) KS = 2
         IF (K .EQ. 1) GO TO 260
            Z(K) = Z(K) + DDOT(K-1,AP(IK+1),1,Z(1),1)
            IKP1 = IK + K
            IF (KS .EQ. 2)
     1         Z(K+1) = Z(K+1) + DDOT(K-1,AP(IKP1+1),1,Z(1),1)
            KP = ABS(KPVT(K))
            IF (KP .EQ. K) GO TO 250
               T = Z(K)
               Z(K) = Z(KP)
               Z(KP) = T
  250       CONTINUE
  260    CONTINUE
         IK = IK + K
         IF (KS .EQ. 2) IK = IK + (K + 1)
         K = K + KS
      GO TO 240
  270 CONTINUE
C     MAKE ZNORM = 1.0
      S = 1.0D0/DASUM(N,Z,1)
      CALL DSCAL(N,S,Z,1)
      YNORM = S*YNORM
C
      IF (ANORM .NE. 0.0D0) RCOND = YNORM/ANORM
      IF (ANORM .EQ. 0.0D0) RCOND = 0.0D0
      RETURN
      END


program example

   implicit none

   integer, parameter :: n = 3
   real(8), parameter :: small = 1.0d-12
   integer :: ierr
   real(8) :: a(n, n)
   real(8) :: b(n)
   integer :: ipiv(n)
   logical :: roots_ok

   a(1, 1) =  2.0d0
   a(2, 1) =  1.0d0
   a(3, 1) =  3.0d0
   a(1, 2) =  2.0d0
   a(2, 2) =  6.0d0
   a(3, 2) =  8.0d0
   a(1, 3) =  6.0d0
   a(2, 3) =  8.0d0
   a(3, 3) = 18.0d0

   b(1) = 1.0d0
   b(2) = 3.0d0
   b(3) = 5.0d0

   call dgesv(n, 1, a, n, ipiv, b, n, ierr)
   if (ierr /= 0) stop "error in dgesv routine!"

   roots_ok = dabs(b(1) + 0.50d0) <= small .and. &
              dabs(b(2) - 0.25d0) <= small .and. &
              dabs(b(3) - 0.25d0) <= small

   if (roots_ok) then
      print *, 'PASSED'
   else
      stop 'ERROR: dgesv test failed!'
   endif

end program


c-------------------------------------------------------------
c PROGRAM         : WHITE DWARF STARS
c-------------------------------------------------------------
      program main
      implicit none
      real*8 h, rhoc, rmax

      rmax = 2.55d0
      write(*,*)'Enter rhoc'
      read(*,*) rhoc
c	call euler(h, rhoc, rmax)
      call runge_kutta(h, rhoc, rmax)

      end
c-------------------------------------------------------------
c SUBROUTINE      : EULER
c-------------------------------------------------------------

      subroutine euler(h, rhoc, rmax)
      implicit none
      real*8 h, rhoc, rmax
      real*8 f, g, rho0, m0
      real*8 r, rho, m
      real*8 ri, rhoi, mi
      integer*4 n, i

      open(unit=1, file='e_rho.dat', status='unknown')
      open(unit=2, file='e_m.dat', status='unknown')

      n = nint(rmax/h)

      r = h
      m = m0(rhoc, h)
      rho = rho0(rhoc, h)

      do 100 i = 0, n, +1
            ri = r
            rhoi = rho
            mi = m

            r = ri + h
            rho = rhoi + h*f(ri,rhoi,mi)
            m = mi + h*g(ri, rhoi, mi)

            write(1,*)r, rho
            write(2,*)r, m
100   continue

      close(unit=1)
      close(unit=2)

      end

c-------------------------------------------------------------
c SUBROUTINE      : RUNGE_KUTTA
c-------------------------------------------------------------

      subroutine runge_kutta(h, rhoc, rmax)
      implicit none
      real*8 h, rhoc, rmax
      real*8 f, g, rho0, m0
      real*8 r, rho, m
      real*8 ri, rhoi, mi, hon2
      real*8 f1, f2, f3, f4
      real*8 g1, g2, g3, g4
      integer*4 n, i

      open(unit=1, file='rho.dat', status='unknown')
      open(unit=2, file='m.dat', status='unknown')

      n = nint(rmax/h)
      hon2 = h/2.0d0

      r = h
      m = m0(rhoc, h)
      rho = rho0(rhoc, h)

      do 100 i = 0, n, +1
            ri = r
            rhoi = rho
            mi = m

            f1 = f(ri, rhoi, mi)
            g1 = g(ri, rhoi, mi)

            f2 = f(ri + hon2, rhoi + hon2*f1, mi + hon2*g1)
            g2 = g(ri + hon2, rhoi + hon2*f1, mi + hon2*g1)

            f3 = f(ri + hon2, rhoi + hon2*f2, mi + hon2*g2)
            g3 = g(ri + hon2, rhoi + hon2*f2, mi + hon2*g2)

            f4 = f(ri + h, rhoi + h*f3, mi + h*g3)
            g4 = g(ri + h, rhoi + h*f3, mi + h*g3)

            r = ri + h
            rho = rhoi + (h/6.0d0)*(f1 + 2*f2 + 2*f3 + f4)
            m = mi + (h/6.0d0)*(g1 + 2*g2 + 2*g3 + g4)

            write(1,*)r, rho
            write(2,*)r, m, (r*0.005553956), (r*0.005154071d0)
100   continue

      close(unit=1)
      close(unit=2)

      end

c-------------------------------------------------------------
c FUNCTION        : f
c-------------------------------------------------------------

      double precision function f(r, rho, m)
      implicit none
      real*8 r, rho, m, x
      real*8 gama

	if (rho .lt. 0.0d0) then
		write(*,*)'Rho < 0 : Stopping Program'
		stop
	endif

      f = -(m*rho)/(gama(rho**(1.0d0/3.0d0))*r**2.0d0)
      return

      end

c-------------------------------------------------------------
c FUNCTION        : g
c-------------------------------------------------------------

      double precision function g(r, rho, m)
      implicit none
      real*8 r, rho, m

      g = (r**2.0d0)*rho
      return

      end

c-------------------------------------------------------------
c FUNCTION        : gama
c-------------------------------------------------------------

      double precision function gama(x)
      implicit none
      real*8 x

      gama = (x**2.0d0)/(3.0d0*dsqrt(1.0d0 + x**2.0d0))
      return

      end

c-------------------------------------------------------------
c FUNCTION        : m0
c                 : initial value of m
c                 : rhoc = central density
c-------------------------------------------------------------

      double precision function m0(rhoc, h)
      implicit none
      real*8 rhoc, h

      m0 = rhoc*(h**3.0d0)/3.0d0
      return

      end

c-------------------------------------------------------------
c FUNCTION        : rho0
c                 : initial value of rho
c                 : rhoc = central density
c-------------------------------------------------------------

      double precision function rho0(rhoc, h)
      implicit none
      real*8 rhoc, h, x
      real*8 gama

      x = rhoc**(1.0d0/3.0d0)
      rho0 = rhoc*(1 - ((h**2.0d0)*rhoc)/(6*gama(x)) )
      return

      end


module example2

use phaml
implicit none

private
public setup_example2

real(my_real), save :: r0 = 0.7_my_real, &
                       xc = 0.0_my_real, &
                       yc = 0.0_my_real, &
                       alpha = 20.0_my_real

contains

subroutine setup_example2()
use pde_pointers
call set_pde_pointers(pdecoefs, bconds, iconds, trues, truexs, trueys)
end subroutine

subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)

real(my_real) :: rx2, ry2, r, rr, denom, denom2

cxx(1,1) = 1.0_my_real
cyy(1,1) = 1.0_my_real
c(1,1) = 0.0_my_real

rx2 = (x-xc)**2
ry2 = (y-yc)**2
r = sqrt(rx2+ry2)
rr = r-r0
denom = ((1+(alpha*rr)**2))**2
denom2 = r*(1+(alpha*rr)**2)

rs(1) = 2*alpha**3*rr/denom - alpha/denom2

cxy=0; cx=0; cy=0

end subroutine pdecoefs

subroutine bconds(x,y,bmark,itype,c,rs)
real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
itype = DIRICHLET
c = 0.0_my_real
rs = trues(x,y,1,1)
end subroutine bconds

function iconds(x,y,comp,eigen)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds
iconds = 0.0_my_real
end function iconds

function trues(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
trues = atan(alpha*(sqrt((x-xc)**2 + (y-yc)**2)-r0))
end function trues

function truexs(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs

real(my_real) :: r
r = sqrt((x-xc)**2+(y-yc)**2)
truexs = alpha*(x-xc)/(r*(1+(alpha*(r-r0))**2))
end function truexs

function trueys(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys

real(my_real) :: r
r = sqrt((x-xc)**2+(y-yc)**2)
trueys = alpha*(y-yc)/(r*(1+(alpha*(r-r0))**2))
end function trueys

end module


! various radial basis functions

module phi

  implicit none

  private

  public :: phi_mq, phi_imq, phi_tps, phi_g

contains

!---------------------------------- PHI_MQ -----------------------------------80
! Multiquadratic radial basis function.
!-----------------------------------------------------------------------------80
  subroutine phi_mq ( n, r, r0, v )

    use kinddefs, only : dp

    integer,                intent(in)  :: n
    real(dp), dimension(n), intent(in)  :: r
    real(dp),               intent(in)  :: r0
    real(dp), dimension(n), intent(out) :: v

    real(dp) :: r02

    continue

    r02 = r0**2
    v(:) = sqrt( r(:)**2 + r02 )

  end subroutine phi_mq

!---------------------------------- PHI_IMQ ----------------------------------80
! Inverse multiquadratic radial basis function.
!-----------------------------------------------------------------------------80
  subroutine phi_imq ( n, r, r0, v )

    use kinddefs, only : dp

    integer,                intent(in)  :: n
    real(dp), dimension(n), intent(in)  :: r
    real(dp),               intent(in)  :: r0
    real(dp), dimension(n), intent(out) :: v

    real(dp) :: r02

    continue

    r02 = r0**2
    v(:) = 1.d0/sqrt( r(:)**2 + r02 )

  end subroutine phi_imq

!---------------------------------- PHI_TPS ----------------------------------80
! Thin plate spline radial basis function.
!-----------------------------------------------------------------------------80
  subroutine phi_tps ( n, r, r0, v )

    use kinddefs, only : dp

    integer,                intent(in)  :: n
    real(dp), dimension(n), intent(in)  :: r
    real(dp),               intent(in)  :: r0
    real(dp), dimension(n), intent(out) :: v

    v(:) = merge(r(:)**2 * log ( r(:) / r0 ), 0.d0, r(:) > 0.d0)

  end subroutine phi_tps

!------------------------------------ PHI_G ----------------------------------80
! Guassian radial basis function.
!-----------------------------------------------------------------------------80
  subroutine phi_g ( n, r, r0, v )

    use kinddefs, only : dp

    integer,                intent(in)  :: n
    real(dp), dimension(n), intent(in)  :: r
    real(dp),               intent(in)  :: r0
    real(dp), dimension(n), intent(out) :: v

    real(dp) :: rr02

    continue

    rr02 = r0**(-2)
    v(:) = exp(-0.5d0*r(:)**2*rr02)

  end subroutine phi_g

end module phi


! 'utility_mst.f90' contains a fortran functions for getting the degree from the
! edge indices of a minimum spanning tree.

subroutine get_degree_for_index(index1, index2, number_of_nodes, number_of_edges, degree)
    ! Given the edge index this will compute the degree of each node.
    !
    ! Parameters
    ! ----------
    ! index1, index2 : array
    !    The index of the edges of a tree, where the '1' and '2' refer to the ends of each edge.
    ! number_of_nodes : integer
    !    The array integer length of the nodes used to construct the tree.
    ! number_of_edges : integer
    !    The array integer length of the edges forming the constructed tree.
    !
    ! Returns
    ! -------
    ! degree : array
    !    The degree for each node, i.e. the number of edges attached to each node.ß

    implicit none

    integer, intent(in) :: number_of_nodes, number_of_edges
    integer, intent(in) :: index1(number_of_edges), index2(number_of_edges)
    double precision, intent(out) :: degree(number_of_nodes)

    integer :: i

    do i = 1, number_of_nodes
        degree(i) = 0.
    end do

    do i = 1, number_of_edges
        degree(index1(i)+1) = degree(index1(i)+1) + 1.
        degree(index2(i)+1) = degree(index2(i)+1) + 1.
    end do

end subroutine get_degree_for_index