 MODULE GDSWZDCB_MOD
!$$$  MODULE DOCUMENTATION BLOCK
!
! $Revision: 71314 $
!
! MODULE:  GDSWZDCB_MOD  GDS WIZARD MODULE FOR ROTATED EQUIDISTANT
!                        CYLINDRICAL GRIDS ("E" STAGGER).
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: - CONVERT FROM EARTH TO GRID COORDINATES OR VICE VERSA.
!           - COMPUTE VECTOR ROTATION SINES AND COSINES.
!           - COMPUTE MAP JACOBIANS.
!           - COMPUTE GRID BOX AREA.
!
! PROGRAM HISTORY LOG:
!   2015-01-21  GAYNO   INITIAL VERSION FROM A MERGER OF
!                       ROUTINES GDSWIZCB AND GDSWZDCB.
!
! USAGE:  "USE GDSWZDCB_MOD"  THEN CALL THE PUBLIC DRIVER
!         ROUTINE "GDSWZDCB".
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 PRIVATE

 PUBLIC                          :: GDSWZDCB

 INTEGER,         PARAMETER      :: KD=SELECTED_REAL_KIND(15,45)

 REAL(KIND=KD),   PARAMETER      :: PI=3.14159265358979_KD
 REAL(KIND=KD),   PARAMETER      :: DPR=180._KD/PI
 REAL(KIND=KD),   PARAMETER      :: RERTH=6.3712E6_KD

 INTEGER                         :: IROT

 REAL(KIND=KD)                   :: CLAT, CLAT0, CLATR
 REAL(KIND=KD)                   :: CLON, DLATS, DLONS
 REAL(KIND=KD)                   :: RLON0, SLAT, SLAT0, SLATR

 CONTAINS

 SUBROUTINE GDSWZDCB(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET, &
                     CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZDCB   GDS WIZARD FOR ROTATED EQUIDISTANT CYLINDRICAL
!   PRGMMR: IREDELL       ORG: W/NMC23       DATE: 96-04-10
!
! ABSTRACT: THIS SUBPROGRAM DECODES THE GRIB GRID DESCRIPTION SECTION
!           (PASSED IN INTEGER FORM AS DECODED BY SUBPROGRAM W3FI63)
!           AND RETURNS ONE OF THE FOLLOWING:
!             (IOPT=+1) EARTH COORDINATES OF SELECTED GRID COORDINATES
!             (IOPT=-1) GRID COORDINATES OF SELECTED EARTH COORDINATES
!           FOR E-STAGGERED ROTATED EQUIDISTANT CYLINDRICAL PROJECTIONS.
!           (SEE UNDER THE DESCRIPTION OF KGDS TO DETERMINE WHETHER
!           TO COMPUTE A STAGGERED WIND GRID OR A STAGGERED MASS GRID.)
!           IF THE SELECTED COORDINATES ARE MORE THAN ONE GRIDPOINT
!           BEYOND THE THE EDGES OF THE GRID DOMAIN, THEN THE RELEVANT
!           OUTPUT ELEMENTS ARE SET TO FILL VALUES.
!           THE ACTUAL NUMBER OF VALID POINTS COMPUTED IS RETURNED TOO.
!           OPTIONALLY, THE VECTOR ROTATIONS, THE MAP JACOBIANS AND
!           THE GRID BOX AREAS MAY BE RETURNED AS WELL.  TO COMPUTE
!           THE VECTOR ROTATIONS, THE OPTIONAL ARGUMENTS 'SROT' AND 'CROT'
!           MUST BE PRESENT.  TO COMPUTE THE MAP JACOBIANS, THE
!           OPTIONAL ARGUMENTS 'XLON', 'XLAT', 'YLON', 'YLAT' MUST BE PRESENT.
!           TO COMPUTE THE GRID BOX AREAS, THE OPTIONAL ARGUMENT
!           'AREA' MUST BE PRESENT.
!
! PROGRAM HISTORY LOG:
!   96-04-10  IREDELL
!   97-10-20  IREDELL  INCLUDE MAP OPTIONS
!   98-08-19  BALDWIN  MODIFY GDSWZDC9 FOR TYPE 203 ETA GRIDS
! 2003-06-11  IREDELL    INCREASE PRECISION
! 2012-08-02  GAYNO    INCREASE XMAX SO ON-GRID POINTS ARE NOT
!                      TAGGED AS OFF-GRID.
! 2015-01-21  GAYNO    MERGER OF GDSWIZCB AND GDSWZDCB.  MAKE
!                      CROT,SORT,XLON,XLAT,YLON,YLAT AND AREA
!                      OPTIONAL ARGUMENTS.  MAKE PART OF A MODULE.
!                      MOVE VECTOR ROTATION, MAP JACOBIAN AND GRID
!                      BOX AREA COMPUTATIONS TO SEPARATE SUBROUTINES.
!
! USAGE:    CALL GDSWZDCB(KGDS,IOPT,NPTS,FILL,XPTS,YPTS,RLON,RLAT,NRET,
!    &                    CROT,SROT,XLON,XLAT,YLON,YLAT,AREA)
!
!   INPUT ARGUMENT LIST:
!     KGDS     - INTEGER (200) GDS PARAMETERS AS DECODED BY W3FI63
!                IMPORTANT NOTE: IF THE 9TH BIT (FROM RIGHT) OF KGDS(11)
!                                (SCANNING MODE FLAG) IS 1, THEN THIS
!                                THE GRID IS COMPUTED FOR A WIND FIELD;
!                                OTHERWISE IT IS FOR A MASS FIELD.  THUS
!                                MOD(KGDS(11)/256,2)=0 FOR MASS GRID.
!     IOPT     - INTEGER OPTION FLAG
!                (+1 TO COMPUTE EARTH COORDS OF SELECTED GRID COORDS)
!                (-1 TO COMPUTE GRID COORDS OF SELECTED EARTH COORDS)
!     NPTS     - INTEGER MAXIMUM NUMBER OF COORDINATES
!     FILL     - REAL FILL VALUE TO SET INVALID OUTPUT DATA
!                (MUST BE IMPOSSIBLE VALUE; SUGGESTED VALUE: -9999.)
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT>0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT>0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT<0
!                (ACCEPTABLE RANGE: -360. TO 360.)
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT<0
!                (ACCEPTABLE RANGE: -90. TO 90.)
!
!   OUTPUT ARGUMENT LIST:
!     XPTS     - REAL (NPTS) GRID X POINT COORDINATES IF IOPT<0
!     YPTS     - REAL (NPTS) GRID Y POINT COORDINATES IF IOPT<0
!     RLON     - REAL (NPTS) EARTH LONGITUDES IN DEGREES E IF IOPT>0
!     RLAT     - REAL (NPTS) EARTH LATITUDES IN DEGREES N IF IOPT>0
!     NRET     - INTEGER NUMBER OF VALID POINTS COMPUTED
!     CROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION COSINES
!     SROT     - REAL, OPTIONAL (NPTS) CLOCKWISE VECTOR ROTATION SINES
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!     XLON     - REAL, OPTIONAL (NPTS) DX/DLON IN 1/DEGREES
!     XLAT     - REAL, OPTIONAL (NPTS) DX/DLAT IN 1/DEGREES
!     YLON     - REAL, OPTIONAL (NPTS) DY/DLON IN 1/DEGREES
!     YLAT     - REAL, OPTIONAL (NPTS) DY/DLAT IN 1/DEGREES
!     AREA     - REAL, OPTIONAL (NPTS) AREA WEIGHTS IN M**2
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
 IMPLICIT NONE
!
 INTEGER,         INTENT(IN   ) :: IOPT, KGDS(200), NPTS
 INTEGER,         INTENT(  OUT) :: NRET
!
 REAL,            INTENT(IN   ) :: FILL
 REAL,            INTENT(INOUT) :: RLON(NPTS),RLAT(NPTS)
 REAL,            INTENT(INOUT) :: XPTS(NPTS),YPTS(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: CROT(NPTS),SROT(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: XLON(NPTS),XLAT(NPTS)
 REAL, OPTIONAL,  INTENT(  OUT) :: YLON(NPTS),YLAT(NPTS),AREA(NPTS)
!
 INTEGER                        :: IM, JM, IS1, N
 INTEGER                        :: ISCAN, KSCAN
!
 LOGICAL                        :: LROT, LMAP, LAREA
!
 REAL(KIND=KD)                  :: RLAT1,RLON1,RLAT0
 REAL(KIND=KD)                  :: SLAT1,CLAT1
 REAL(KIND=KD)                  :: CLON1,CLONR
 REAL(KIND=KD)                  :: RLATR,RLONR
 REAL                           :: HI,HS
 REAL                           :: XMAX, XMIN, YMAX, YMIN, XPTF, YPTF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(PRESENT(CROT)) CROT=FILL
 IF(PRESENT(SROT)) SROT=FILL
 IF(PRESENT(XLON)) XLON=FILL
 IF(PRESENT(XLAT)) XLAT=FILL
 IF(PRESENT(YLON)) YLON=FILL
 IF(PRESENT(YLAT)) YLAT=FILL
 IF(PRESENT(AREA)) AREA=FILL
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 IF(KGDS(1).EQ.203) THEN
   RLAT1=KGDS(4)*1.E-3_KD
   RLON1=KGDS(5)*1.E-3_KD
   RLAT0=KGDS(7)*1.E-3_KD
   RLON0=KGDS(8)*1.E-3_KD
   IROT=MOD(KGDS(6)/8,2)
   IM=KGDS(2)*2-1
   JM=KGDS(3)
   KSCAN=MOD(KGDS(11)/256,2)
   ISCAN=MOD(KGDS(11)/128,2)
   HI=(-1.)**ISCAN
   SLAT1=SIN(RLAT1/DPR)
   CLAT1=COS(RLAT1/DPR)
   SLAT0=SIN(RLAT0/DPR)
   CLAT0=COS(RLAT0/DPR)
   HS=SIGN(1._KD,MOD(RLON1-RLON0+180+3600,360._KD)-180)
   CLON1=COS((RLON1-RLON0)/DPR)
   SLATR=CLAT0*SLAT1-SLAT0*CLAT1*CLON1
   CLATR=SQRT(1-SLATR**2)
   CLONR=(CLAT0*CLAT1*CLON1+SLAT0*SLAT1)/CLATR
   RLATR=DPR*ASIN(SLATR)
   RLONR=HS*DPR*ACOS(CLONR)
   DLATS=RLATR/(-(JM-1)/2)
   DLONS=RLONR/(-(IM-1)/2)
   IF(KSCAN.EQ.0) THEN
     IS1=(JM+1)/2
   ELSE
     IS1=JM/2
   ENDIF
   XMIN=0
   XMAX=IM+2
   YMIN=0
   YMAX=JM+1
   NRET=0
   IF(PRESENT(CROT).AND.PRESENT(SROT))THEN
     LROT=.TRUE.
   ELSE
     LROT=.FALSE.
   ENDIF
   IF(PRESENT(XLON).AND.PRESENT(XLAT).AND.PRESENT(YLON).AND.PRESENT(YLAT))THEN
     LMAP=.TRUE.
   ELSE
     LMAP=.FALSE.
   ENDIF
   IF(PRESENT(AREA))THEN
     LAREA=.TRUE.
   ELSE
     LAREA=.FALSE.
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE GRID COORDINATES TO EARTH COORDINATES
   IF(IOPT.EQ.0.OR.IOPT.EQ.1) THEN
     DO N=1,NPTS
       XPTF=YPTS(N)+(XPTS(N)-IS1)
       YPTF=YPTS(N)-(XPTS(N)-IS1)+KSCAN
       IF(XPTF.GE.XMIN.AND.XPTF.LE.XMAX.AND. &
          YPTF.GE.YMIN.AND.YPTF.LE.YMAX) THEN
         HS=HI*SIGN(1.,XPTF-(IM+1)/2)
         RLONR=(XPTF-(IM+1)/2)*DLONS
         RLATR=(YPTF-(JM+1)/2)*DLATS
         CLONR=COS(RLONR/DPR)
         SLATR=SIN(RLATR/DPR)
         CLATR=COS(RLATR/DPR)
         SLAT=CLAT0*SLATR+SLAT0*CLATR*CLONR
         IF(SLAT.LE.-1) THEN
           CLAT=0.
           CLON=COS(RLON0/DPR)
           RLON(N)=0
           RLAT(N)=-90
         ELSEIF(SLAT.GE.1) THEN
           CLAT=0.
           CLON=COS(RLON0/DPR)
           RLON(N)=0
           RLAT(N)=90
         ELSE
           CLAT=SQRT(1-SLAT**2)
           CLON=(CLAT0*CLATR*CLONR-SLAT0*SLATR)/CLAT
           CLON=MIN(MAX(CLON,-1._KD),1._KD)
           RLON(N)=MOD(RLON0+HS*DPR*ACOS(CLON)+3600,360._KD)
           RLAT(N)=DPR*ASIN(SLAT)
         ENDIF
         NRET=NRET+1
         IF(LROT) CALL GDSWZDCB_VECT_ROT(RLON(N),CROT(N),SROT(N))
         IF(LMAP) CALL GDSWZDCB_MAP_JACOB(FILL, RLON(N), &
                                          XLON(N),XLAT(N),YLON(N),YLAT(N))
         IF(LAREA) CALL GDSWZDCB_GRID_AREA(FILL, AREA(N))
       ELSE
         RLON(N)=FILL
         RLAT(N)=FILL
       ENDIF
     ENDDO
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  TRANSLATE EARTH COORDINATES TO GRID COORDINATES
   ELSEIF(IOPT.EQ.-1) THEN
     DO N=1,NPTS
       IF(ABS(RLON(N)).LE.360.AND.ABS(RLAT(N)).LE.90) THEN
         HS=SIGN(1._KD,MOD(RLON(N)-RLON0+180+3600,360._KD)-180)
         CLON=COS((RLON(N)-RLON0)/DPR)
         SLAT=SIN(RLAT(N)/DPR)
         CLAT=COS(RLAT(N)/DPR)
         SLATR=CLAT0*SLAT-SLAT0*CLAT*CLON
         IF(SLATR.LE.-1) THEN
           CLATR=0.
           RLONR=0
           RLATR=-90
         ELSEIF(SLATR.GE.1) THEN
           CLATR=0.
           RLONR=0
           RLATR=90
         ELSE
           CLATR=SQRT(1-SLATR**2)
           CLONR=(CLAT0*CLAT*CLON+SLAT0*SLAT)/CLATR
           CLONR=MIN(MAX(CLONR,-1._KD),1._KD)
           RLONR=HS*DPR*ACOS(CLONR)
           RLATR=DPR*ASIN(SLATR)
         ENDIF
         XPTF=(IM+1)/2+RLONR/DLONS
         YPTF=(JM+1)/2+RLATR/DLATS
         IF(XPTF.GE.XMIN.AND.XPTF.LE.XMAX.AND. &
            YPTF.GE.YMIN.AND.YPTF.LE.YMAX) THEN
           XPTS(N)=IS1+(XPTF-(YPTF-KSCAN))/2
           YPTS(N)=(XPTF+(YPTF-KSCAN))/2
           NRET=NRET+1
           IF(LROT) CALL GDSWZDCB_VECT_ROT(RLON(N),CROT(N),SROT(N))
           IF(LMAP) CALL GDSWZDCB_MAP_JACOB(FILL, RLON(N), &
                                            XLON(N),XLAT(N),YLON(N),YLAT(N))
           IF(LAREA) CALL GDSWZDCB_GRID_AREA(FILL, AREA(N))
         ELSE
           XPTS(N)=FILL
           YPTS(N)=FILL
         ENDIF
       ELSE
         XPTS(N)=FILL
         YPTS(N)=FILL
       ENDIF
     ENDDO
   ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
!  PROJECTION UNRECOGNIZED
 ELSE
   IF(IOPT.GE.0) THEN
     DO N=1,NPTS
       RLON(N)=FILL
       RLAT(N)=FILL
     ENDDO
   ENDIF
   IF(IOPT.LE.0) THEN
     DO N=1,NPTS
       XPTS(N)=FILL
       YPTS(N)=FILL
     ENDDO
   ENDIF
 ENDIF
! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 END SUBROUTINE GDSWZDCB
!
 SUBROUTINE GDSWZDCB_VECT_ROT(RLON, CROT, SROT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZDCB_VECT_ROT   VECTOR ROTATION FIELDS FOR
!                                  ROTATED EQUIDISTANT CYLINDRICAL
!                                  GRIDS - "E" STAGGER.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE VECTOR ROTATION SINES AND
!           COSINES FOR A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:    CALL GDSWZDCB_VECT_ROT(RLON, CROT, SROT)
!
!   INPUT ARGUMENT LIST:
!     RLON     - LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     CROT     - CLOCKWISE VECTOR ROTATION COSINES (REAL)
!     SROT     - CLOCKWISE VECTOR ROTATION SINES (REAL)
!                (UGRID=CROT*UEARTH-SROT*VEARTH;
!                 VGRID=SROT*UEARTH+CROT*VEARTH)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL         ,    INTENT(IN   ) :: RLON
 REAL         ,    INTENT(  OUT) :: CROT, SROT

 REAL(KIND=KD)                   :: SLON

 IF(IROT.EQ.1) THEN
   IF(CLATR.LE.0) THEN
     CROT=-SIGN(1._KD,SLATR*SLAT0)
     SROT=0.
   ELSE
     SLON=SIN((RLON-RLON0)/DPR)
     CROT=(CLAT0*CLAT+SLAT0*SLAT*CLON)/CLATR
     SROT=SLAT0*SLON/CLATR
   ENDIF
 ELSE
   CROT=1.
   SROT=0.
 ENDIF

 END SUBROUTINE GDSWZDCB_VECT_ROT
!
 SUBROUTINE GDSWZDCB_MAP_JACOB(FILL, RLON, &
                               XLON, XLAT, YLON, YLAT)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZDCB_MAP_JACOB  MAP JACOBIANS FOR
!                                  ROTATED EQUIDISTANT CYLINDRICAL
!                                  GRIDS - "E" STAGGER.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE MAP JACOBIANS FOR
!           A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZDCB_MAP_JACOB(FILL,RLON,XLON,XLAT,YLON,YLAT)
!
!   INPUT ARGUMENT LIST:
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!     RLON     - LONGITUDE IN DEGREES (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     XLON     - DX/DLON IN 1/DEGREES (REAL)
!     XLAT     - DX/DLAT IN 1/DEGREES (REAL)
!     YLON     - DY/DLON IN 1/DEGREES (REAL)
!     YLAT     - DY/DLAT IN 1/DEGREES (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL         ,    INTENT(IN   ) :: FILL, RLON
 REAL         ,    INTENT(  OUT) :: XLON, XLAT, YLON, YLAT

 REAL(KIND=KD)                   :: SLON, TERM1, TERM2
 REAL(KIND=KD)                   :: XLATF, XLONF, YLATF, YLONF

 IF(CLATR.LE.0._KD) THEN
   XLON=FILL
   XLAT=FILL
   YLON=FILL
   YLAT=FILL
 ELSE
   SLON=SIN((RLON-RLON0)/DPR)
   TERM1=(CLAT0*CLAT+SLAT0*SLAT*CLON)/CLATR
   TERM2=SLAT0*SLON/CLATR
   XLONF=TERM1*CLAT/(DLONS*CLATR)
   XLATF=-TERM2/(DLONS*CLATR)
   YLONF=TERM2*CLAT/DLATS
   YLATF=TERM1/DLATS
   XLON=XLONF-YLONF
   XLAT=XLATF-YLATF
   YLON=XLONF+YLONF
   YLAT=XLATF+YLATF
 ENDIF

 END SUBROUTINE GDSWZDCB_MAP_JACOB
!
 SUBROUTINE GDSWZDCB_GRID_AREA(FILL, AREA)
!$$$  SUBPROGRAM DOCUMENTATION BLOCK
!
! SUBPROGRAM:  GDSWZDCB_GRID_AREA  GRID BOX AREA FOR
!                                  ROTATED EQUIDISTANT CYLINDRICAL
!                                  GRIDS - "E" STAGGER.
!
!   PRGMMR: GAYNO     ORG: W/NMC23       DATE: 2015-01-21
!
! ABSTRACT: THIS SUBPROGRAM COMPUTES THE GRID BOX AREA FOR
!           A ROTATED EQUIDISTANT CYLINDRICAL GRID -
!           "E" STAGGER.
!
! PROGRAM HISTORY LOG:
! 2015-01-21  GAYNO    INITIAL VERSION
!
! USAGE:  CALL GDSWZDCB_GRID_AREA(FILL,AREA)
!
!   INPUT ARGUMENT LIST:
!     FILL     - FILL VALUE FOR UNDEFINED POINTS (REAL)
!
!   OUTPUT ARGUMENT LIST:
!     AREA     - AREA WEIGHTS IN M**2 (REAL)
!
! ATTRIBUTES:
!   LANGUAGE: FORTRAN 90
!
!$$$
!
 IMPLICIT NONE

 REAL,             INTENT(IN   ) :: FILL
 REAL,             INTENT(  OUT) :: AREA

 IF(CLATR.LE.0._KD) THEN
   AREA=FILL
 ELSE
   AREA=RERTH**2*CLATR*DLATS*DLONS*2/DPR**2
 ENDIF

 END SUBROUTINE GDSWZDCB_GRID_AREA

 END MODULE GDSWZDCB_MOD


        program PINATUBO
        character*10 ipa1
        real xtau,n(20),k(20)
        real rad(22),dvdlnr(22)
        real cij1,cij2,rm1,rm2,rst1,rst2
	real pi,cte,tmp1,tmp2
	Integer nday
        data rad /0.050000,0.065604,0.086077,0.112939,0.148184,
     &  0.194429,0.255105,0.334716,0.439173,0.576227,0.756052,
     &  0.991996,1.301571,1.707757,2.240702,2.939966,3.857452,
     &  5.061260,6.640745,8.713145,11.432290,15.000000/
C note the optical thickness is at 500nm (but probably close enough to 550nm
C not to worry too much about it.
        call getarg(1,ipa1)
        read(ipa1,'(I4)') nday
        if (nday.gt.1000) then
	 nday=1000
	 endif
        pi=atan(1.)*4.0
	cte=sqrt(2*pi)
	if (nday.lt.365) then
	   reff=0.17+(2.07E-03-(2.8E-06*nday))*nday
	   else
	   reff=0.17+0.38*exp(-(nday-365.)/1483.)
	   endif

	rm1=reff
	rst1=log(1.6)
	rm1=reff/exp(5.*rst1*rst1/2.)
	rm1=exp(log(rm1)+3*rst1*rst1)
	cij1=1.0
	cij2=0.0
	do i=1,20
	n(i)=1.34
	k(i)=0.000
	enddo
	write(6,*) "22"
	do i=1,22
	tmp1=exp(-(log(rad(i))-log(rm1))**2./2./rst1/rst1)
 	tmp2=exp(-(log(rad(i))-log(rm2))**2./2./rst2/rst2)
	dvdlnr(i)=(cij1*tmp1/cte/rst1)+(cij2*tmp2/cte/rst2)
	write(6,*) rad(i),dvdlnr(i)
	enddo
	write(6,101) (n(i),i=1,20)
	write(6,102) (k(i),i=1,20)
 101    format(20(F10.5,1X))
 102    format(20(F10.7,1X))
	stop
	end


      subroutine derivs (x,y,yprime,nvar)

*  ____________________________________________________________________
* |                                                                    |
* |...  Define the system of nonlinear differential equations for each |
* |...  active slip-system (k)                                         |
* |                                                                    |
* |           tau_dot(k)   = 2*mu*Pij(k)*[Dij_dev - Dij_p_dev]         |
* |           Dij_p_dev    = Pij(n)*gamma_dot(n)                       |
* |           gamma_dot(n) = ref_gamma_dot(n)*[tau(n)/tau_r(n)]**(1/m) |
* |                                                                    |
* |____________________________________________________________________|
*

      parameter (nss = 24)

      common/wblock6/ xmhigh(nss),ref_gamma_dot(nss),Pij_Dijdev(nss),
     >                tau(nss), p(nss,4), taur(nss), twomu, g

      dimension y(nss), yprime(nss), r(nss), g(nss)
	  integer nn,nvar

      dummy = 0.0
      sat   = 1.0/1.0
	  nn=nvar
      !write(*,*) 'beginning of derivs, nn then nvar'
	  !write(*,*) nn
	  !write(*,*) nvar
      do i = 1, nn
         r(i) = ((abs(y(i)/taur(i))*sat)**(xmhigh(i)-1.0))*
     >                                 (y(i)/taur(i))*sat
         g(i) = 0.0
      end do

      do i = 1, nn
         do j = 1, nn
            dummy = r(j)*ref_gamma_dot(j)*(p(i,1)*p(j,1) +
     >                                     p(i,2)*p(j,2) +
     >                                   2*p(i,3)*p(j,3) +
     >                                     p(i,4)*p(j,4))
            g(i) = g(i) + dummy
         end do
      end do

      do i = 1, nn
         yprime(i) = twomu*(Pij_Dijdev(i) - g(i))
c		 write(*,*) 'r,g,dummy,nn,Pij_Dijdev(i),rgd',r(i),g(i),
c	1        dummy,nn,Pij_Dijdev(i),ref_gamma_dot(i)
      end do
	  nvar=nn
	  !write(*,*) 'in derivs'

	  !write(*,*) nvar

      return
      end


! The MIT License (MIT)
!
! Copyright (c) 2016 odlomax
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the "Software"), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in all
! copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
! SOFTWARE.

! module containing some useful maths function and simple computer science procedures
module m_maths

   use m_kind_parameters
   use m_constants_parameters

   implicit none

   ! all routines are public
   public

   ! generic interfaces

   interface quicksort
      procedure :: quicksort_1
      procedure :: quicksort_2
   end interface

   interface swap
      procedure :: swap_real
      procedure :: swap_integer
   end interface

   interface lerp
      procedure :: lerp_1
      procedure :: lerp_2
   end interface

   interface gerp
      procedure :: gerp_1
      procedure :: gerp_2
   end interface

   interface lookup_and_interpolate
      procedure :: lookup_and_interpolate_1
      procedure :: lookup_and_interpolate_2
      procedure :: lookup_and_interpolate_3
   end interface

   interface lookup_and_geo_interpolate
      procedure :: lookup_and_geo_interpolate_1
      procedure :: lookup_and_geo_interpolate_2
   end interface

   interface rotate_vector
      procedure :: rotate_vector_3d
   end interface

   contains

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

! MATHEMATICAL FUNCTIONS

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

   ! return the nth real root of x
   elemental function nth_rt(x,n) result (nth_rt_x)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x       ! variate
      integer(kind=int_kind),intent(in) :: n    ! nth root

      ! result declaration
      real(kind=rel_kind) :: nth_rt_x           ! nth root of x

      ! different result if number is odd or even
      if (mod(n,2_int_kind)==0) then

         ! return NaN if x is negative
         nth_rt_x=x**(1._rel_kind/real(n,rel_kind))

      else

         ! return real number if x is negative
         nth_rt_x=sign(abs(x)**(1._rel_kind/real(n,rel_kind)),x)

      end if

      return

   end function

   ! returns the real cube root of real number
   elemental function real_cbrt(a)

      real(kind=rel_kind) :: real_cbrt                   ! cube root of a
      real(kind=rel_kind),intent(in) :: a

      real_cbrt=sign(abs(a)**one_third,a)

      return

   end function

   ! return roots of quadratic equation
   pure function quadratic(a,b,c)

      ! argument declarations
      complex(kind=cpx_kind) :: quadratic(2)          ! roots
      real(kind=rel_kind),intent(in) :: a             ! ax**2+bx+c=0
      real(kind=rel_kind),intent(in) :: b
      real(kind=rel_kind),intent(in) :: c

      ! variable declarations
      real(kind=rel_kind) :: inv2a                    ! some useful quantities
      complex(kind=cpx_kind) :: sqrtdelta

      !calculate useful quantities
      inv2a=0.5_rel_kind/a
      sqrtdelta=sqrt(cmplx(b**2-4._rel_kind*a*c,0._rel_kind,cpx_kind))

      !calculate roots

      quadratic(1)=-(b+sqrtdelta)*inv2a
      quadratic(2)=-(b-sqrtdelta)*inv2a

      return

   end function

   ! return roots of cubic equation (method from Wolfram Alpha)
   pure function cubic(a,b,c,d)

      complex(kind=cpx_kind) :: cubic(3)              ! roots

      real(kind=rel_kind),intent(in) :: a             ! ax**3+bx**2+cx+d=0
      real(kind=rel_kind),intent(in) :: b
      real(kind=rel_kind),intent(in) :: c
      real(kind=rel_kind),intent(in) :: d

      real(kind=rel_kind) :: a2                       ! some useful quantities
      real(kind=rel_kind) :: a1
      real(kind=rel_kind) :: a0
      real(kind=rel_kind) :: inva
      real(kind=rel_kind) :: big_q
      real(kind=rel_kind) :: big_r
      real(kind=rel_kind) :: big_d
      real(kind=rel_kind) :: big_s
      real(kind=rel_kind) :: big_t
      real(kind=rel_kind) :: sqrtbig_d
      real(kind=rel_kind) :: sqrtbig_q
      real(kind=rel_kind) :: theta

      !calculate useful quantities

      inva=1._rel_kind/a
      a2=b*inva
      a1=c*inva
      a0=d*inva

      big_q=(3._rel_kind*a1-a2**2)*(1._rel_kind/9._rel_kind)
      big_r=(9._rel_kind*a2*a1-27._rel_kind*a0-2._rel_kind*a2**3)*(1._rel_kind/54._rel_kind)

      big_d=big_q**3+big_r**2

      !calculate roots

      if (big_d<0._rel_kind) then                      ! three distinct real roots
         sqrtbig_q=sqrt(abs(big_q))
         theta=acos(big_r/sqrtbig_q**3)
         cubic(1)=2._rel_kind*sqrtbig_q*cos(theta*one_third)-one_third*a2
         cubic(2)=2._rel_kind*sqrtbig_q*cos((theta+2._rel_kind*pi)*one_third)-one_third*a2
         cubic(3)=2._rel_kind*sqrtbig_q*cos((theta+4._rel_kind*pi)*one_third)-one_third*a2
      else                                            ! two identical or complex roots
         sqrtbig_d=sqrt(big_d)
         big_s=real_cbrt(big_r+sqrtbig_d)
         big_t=real_cbrt(big_r-sqrtbig_d)
         cubic(1)=-one_third*a2+(big_s+big_t)
         cubic(2)=&
            &-one_third*a2-0.5_rel_kind*(big_s+big_t)+0.5_rel_kind*(0._rel_kind,1._rel_kind)*root_three*(big_s-big_t)
         cubic(3)=&
            &-one_third*a2-0.5_rel_kind*(big_s+big_t)-0.5_rel_kind*(0._rel_kind,1._rel_kind)*root_three*(big_s-big_t)
      end if

      return

   end function

   ! return roots of quartic equation (method from Wolfram Alpha)
   pure function quartic(a,b,c,d,e)

      complex(kind=cpx_kind) :: quartic(4)                  ! roots

      real(kind=rel_kind),intent(in) :: a                   ! ax**4+bx**3+cx**2+dx+e=0
      real(kind=rel_kind),intent(in) :: b
      real(kind=rel_kind),intent(in) :: c
      real(kind=rel_kind),intent(in) :: d
      real(kind=rel_kind),intent(in) :: e

      real(kind=rel_kind) :: a3                             ! some useful quantites
      real(kind=rel_kind) :: a2
      real(kind=rel_kind) :: a1
      real(kind=rel_kind) :: a0
      real(kind=rel_kind) :: inva

      complex(kind=cpx_kind) :: y(3)
      complex(kind=cpx_kind) :: big_r
      complex(kind=cpx_kind) :: big_d
      complex(kind=cpx_kind) :: big_e
      complex(kind=cpx_kind) :: y1term

      !calculate useful quantities

      inva=1._rel_kind/a
      a3=b*inva
      a2=c*inva
      a1=d*inva
      a0=e*inva

      y=cubic(1._rel_kind,-a2,a1*a3-4._rel_kind*a0,4._rel_kind*a2*a0-a1**2-a3**2*a0)

      big_r=sqrt(0.25_rel_kind*a3**2-a2+y(1))

      if (abs(big_r)>0._rel_kind) then
         y1term=0.25_rel_kind*(4._rel_kind*a3*a2-8._rel_kind*a1-a3**3)/big_r
         big_d=sqrt(0.75_rel_kind*a3**2-big_r**2-2._rel_kind*a2+y1term)
         big_e=sqrt(0.75_rel_kind*a3**2-big_r**2-2._rel_kind*a2-y1term)
      else
         y1term=2._rel_kind*sqrt(y(1)**2-4._rel_kind*a0)
         big_d=sqrt(0.75_rel_kind*a3**2-2._rel_kind*a2+y1term)
         big_e=sqrt(0.75_rel_kind*a3**2-2._rel_kind*a2-y1term)
      end if

      !calculate roots

      quartic(1)=-0.25_rel_kind*a3+0.5_rel_kind*big_r+0.5_rel_kind*big_d
      quartic(2)=-0.25_rel_kind*a3+0.5_rel_kind*big_r-0.5_rel_kind*big_d
      quartic(3)=-0.25_rel_kind*a3-0.5_rel_kind*big_r+0.5_rel_kind*big_e
      quartic(4)=-0.25_rel_kind*a3-0.5_rel_kind*big_r-0.5_rel_kind*big_e

      return

   end function

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

! RANDOM NUMBERS

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

   subroutine gaussian_random_number(r_num)

      ! result declaration
      real(kind=rel_kind),intent(out) :: r_num(2)  ! gaussian random numbers

      ! variable declarations
      real(kind=rel_kind) :: w                     ! polar magnitude sqrd

      do
         call random_number(r_num)
         r_num=(r_num*2._rel_kind)-1._rel_kind
         w=sum(r_num**2)
         if (w<=1._rel_kind) exit
      end do

      w=sqrt(-2._rel_kind*log(w)/w)
      r_num=r_num*w

      return

   end subroutine

   subroutine gaussian_random_array(r_num)

      ! argument declaration
      real(kind=rel_kind),intent(out) :: r_num(:)       ! gaussian random number

      ! variable declarations
      integer(kind=int_kind) :: i                       ! counter
      real(kind=rel_kind) :: r_num_temp(2)

      do i=1,size(r_num)/2

         call gaussian_random_number(r_num_temp)
         r_num(2*i-1:2*i)=r_num_temp

      end do

      if (mod(size(r_num),2)==1) then

         call gaussian_random_number(r_num_temp)
         r_num(size(r_num))=r_num_temp(1)

      end if

      return

   end subroutine

   ! calculates the unit vector of a random direction
   subroutine random_direction(direction)

      ! argument declarations
      real(kind=rel_kind),intent(out) :: direction(:)

      ! variable declarations
      call gaussian_random_array(direction)
      direction=direction/norm2(direction)

      return

   end subroutine

   ! calculates the unit vector of a direction scattered from a normal by a cosine
   subroutine scattered_direction_3d(direction,norm,cos_theta)

      ! argument declarations
      real(kind=rel_kind),intent(out) :: direction(3)   ! direction vector
      real(kind=rel_kind),intent(in) :: norm(3)         ! normal vector
      real(kind=rel_kind),intent(in) :: cos_theta       ! cosine between norm and direction

      ! variable declaration
      real(kind=rel_kind) :: r_num                      ! random number
      real(kind=rel_kind) :: sin_theta
      real(kind=rel_kind) :: phi
      real(kind=rel_kind) :: cos_theta_s                ! norm angles
      real(kind=rel_kind) :: sin_theta_s
      real(kind=rel_kind) :: phi_s
      real(kind=rel_kind) :: cos_phi_s
      real(kind=rel_kind) :: sin_phi_s
      real(kind=rel_kind) :: r_matrix(3,3)              ! rotation matrix

      sin_theta=sqrt(1._rel_kind-cos_theta**2)

      ! draw phi from interval [0:2pi]
      call random_number(r_num)
      phi=2._rel_kind*pi*r_num

      ! make direction vector
      direction(1)=sin_theta*cos(phi)
      direction(2)=sin_theta*sin(phi)
      direction(3)=cos_theta

      ! rotate direction into plane of norm
      cos_theta_s=norm(3)
      sin_theta_s=sin(acos(cos_theta_s))
      phi_s=atan2(norm(2),norm(1))
      cos_phi_s=cos(phi_s)
      sin_phi_s=sin(phi_s)

      r_matrix(1,:)=(/cos_phi_s*cos_theta_s,-sin_phi_s,cos_phi_s*sin_theta_s/)
      r_matrix(2,:)=(/sin_phi_s*cos_theta_s,cos_phi_s,sin_phi_s*sin_theta_s/)
      r_matrix(3,:)=(/-sin_theta_s,0._rel_kind,cos_theta_s/)

      direction=matmul(r_matrix,direction)

      return

   end subroutine

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

! PHYSICAL QUANTITIES

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

   ! Planck function [erg s^-1 sr^-1 cm^-2 micron^-1]
   elemental function planck_lambda(lambda,t) result(b)

      ! argument delcarations
      real(kind=rel_kind),intent(in) :: lambda                ! wavelength in microns
      real(kind=rel_kind),intent(in) :: t                     ! temperature in K

      ! result declaration
      real(kind=rel_kind) :: b                                ! planck function
                                                        ! [erg s^-1 sr^-1 cm^-2 micron^-1]
      ! variable declaration
      real(kind=rel_kind) :: lambda_si                        ! wavelength in m
      real(kind=rel_kind) :: exp_part                   ! exponential part
      real(kind=rel_kind) :: denominator

      lambda_si=1e-6_rel_kind*lambda
      exp_part=exp(h_planck*c_light/(lambda_si*k_boltz*t))

      if (exp_part<huge(0._rel_kind)) then
         ! calculate planck function

         denominator=lambda_si**5*(exp_part-1._rel_kind)

         if (denominator<huge(0._rel_kind)) then

            b=2._rel_kind*h_planck*c_light**2/denominator

         else

            b=0._rel_kind

         end if

      else

         b=0._rel_kind

      end if

      ! normalize to cgs
      b=1e-3_rel_kind*b

      return

   end function

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

! INTERPOLATION, INTEGRATION, EXTRAPOLATION, ETC

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

   ! 1D lookup and interpolate
   pure function lookup_and_interpolate_1(x,x_array,f_array) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x_values
      real(kind=rel_kind),intent(in),contiguous :: f_array(:) ! array of f(x)

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x)

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      real(kind=rel_kind) :: x_adj                            ! adjusted value of x

      ! enforce that x is within range of x_array
      x_adj=min(x,x_array(size(x_array)))
      x_adj=max(x_adj,x_array(1))

      ! lookup indices
      i_0=binary_search(x,x_array)

      ! interpolate for f
      f=lerp(x_adj,x_array(i_0),x_array(i_0+1),f_array(i_0),f_array(i_0+1))

      return

   end function

   ! 1D lookup and interpolate two quantities
   pure function lookup_and_interpolate_2(x,x_array,f_array_1,f_array_2) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x_values
      real(kind=rel_kind),intent(in),contiguous :: f_array_1(:) ! array of f(x)
      real(kind=rel_kind),intent(in),contiguous :: f_array_2(:) ! array of f(x)

      ! result declaration
      real(kind=rel_kind) :: f(2)                             ! f(x)

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      real(kind=rel_kind) :: x_adj                            ! adjusted value of x

      ! enforce that x is within range of x_array
      x_adj=min(x,x_array(size(x_array)))
      x_adj=max(x_adj,x_array(1))

      ! lookup indices
      i_0=binary_search(x,x_array)

      ! interpolate for f
      f=lerp(x_adj,x_array(i_0),x_array(i_0+1),&
         &(/f_array_1(i_0),f_array_2(i_0)/),(/f_array_1(i_0+1),f_array_2(i_0+1)/))

      return

   end function

   ! lookup and inverse quad interpolate
   pure function lookup_and_inv_interpolate(f,f_array,x_array,dfdx_array) result (x)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: f                     ! value of f(x)
      real(kind=rel_kind),intent(in),contiguous :: f_array(:) ! array of f(x)
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x
      real(kind=rel_kind),intent(in),contiguous :: dfdx_array(:)        ! array of df(x)/dx

      ! result declaration
      real(kind=rel_kind) :: x                                ! x

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      real(kind=rel_kind) :: f_adj                            ! adjusted value of f(x)

      ! enforce that x is within range of x_array
      f_adj=min(f,f_array(size(f_array)))
      f_adj=max(f_adj,f_array(1))

      ! lookup indices
      i_0=binary_search(f,f_array)

      ! interpolate for f
      x=inv_querp(f_adj,f_array(i_0),f_array(i_0+1),x_array(i_0),x_array(i_0+1),&
         &dfdx_array(i_0),dfdx_array(i_0+1))

      return

   end function

   ! 2D lookup and interpolate
   pure function lookup_and_interpolate_3(x,y,x_array,y_array,f_array) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: y                     ! value of y
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x values
      real(kind=rel_kind),intent(in),contiguous :: y_array(:) ! array of y values
      real(kind=rel_kind),intent(in),contiguous :: f_array(:,:) ! array of f(x,y)

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x,y)

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      integer(kind=int_kind) :: j_0
      real(kind=rel_kind) :: x_adj                            ! adjusted value of x
      real(kind=rel_kind) :: y_adj                            ! adjusted value of y

      ! enforce that x and y are within range
      x_adj=min(x,x_array(size(x_array)))
      x_adj=max(x_adj,x_array(1))
      y_adj=min(y,y_array(size(y_array)))
      y_adj=max(y_adj,y_array(1))

      ! lookup indices
      i_0=binary_search(x_adj,x_array)
      j_0=binary_search(y_adj,y_array)

      ! interpolate for f
      f=lerp(x_adj,y_adj,x_array(i_0),x_array(i_0+1),y_array(j_0),y_array(j_0+1),&
         &f_array(i_0,j_0),f_array(i_0,j_0+1),f_array(i_0+1,j_0),f_array(i_0+1,j_0+1))

      return

   end function

   ! look and geometically interpolate quantity in one dimension
   pure function lookup_and_geo_interpolate_1(x,x_array,f_array) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x_values
      real(kind=rel_kind),intent(in),contiguous :: f_array(:) ! array of f(x)

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x)

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      real(kind=rel_kind) :: x_adj                            ! adjusted value of x

      ! enforce that x is within range of x_array
      x_adj=min(x,x_array(size(x_array)))
      x_adj=max(x_adj,x_array(1))

      ! lookup indices
      i_0=binary_search(x,x_array)

      ! interpolate for f
      f=gerp(x_adj,x_array(i_0),x_array(i_0+1),f_array(i_0),f_array(i_0+1))

      return

   end function

   ! look and geometically interpolate quantity in two dimensions
   pure function lookup_and_geo_interpolate_2(x,y,x_array,y_array,f_array) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: y                     ! value of y
      real(kind=rel_kind),intent(in),contiguous :: x_array(:) ! array of x values
      real(kind=rel_kind),intent(in),contiguous :: y_array(:) ! array of y values
      real(kind=rel_kind),intent(in),contiguous :: f_array(:,:) ! array of f(x,y)

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x,y)

      ! variable declarations
      integer(kind=int_kind) :: i_0                           ! interpolation indices
      integer(kind=int_kind) :: j_0
      real(kind=rel_kind) :: x_adj                            ! adjusted value of x
      real(kind=rel_kind) :: y_adj                            ! adjusted value of y

      ! enforce that x and y are within range
      x_adj=min(x,x_array(size(x_array)))
      x_adj=max(x_adj,x_array(1))
      y_adj=min(y,y_array(size(y_array)))
      y_adj=max(y_adj,y_array(1))

      ! lookup indices
      i_0=binary_search(x_adj,x_array)
      j_0=binary_search(y_adj,y_array)

      ! interpolate for f
      f=gerp(x_adj,y_adj,x_array(i_0),x_array(i_0+1),y_array(j_0),y_array(j_0+1),&
         &f_array(i_0,j_0),f_array(i_0,j_0+1),f_array(i_0+1,j_0),f_array(i_0+1,j_0+1))

      return

   end function

   ! linear interpolation
   elemental function lerp_1(x,x_0,x_1,f_0,f_1) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: f_0                   ! f(x) interpolation points
      real(kind=rel_kind),intent(in) :: f_1

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x)

      ! solve for f
      f=f_0+(f_1-f_0)*(x-x_0)/(x_1-x_0)

      return

   end function

   ! bilinear interpolation
   ! three linear interpolations
   elemental function lerp_2(x,y,x_0,x_1,y_0,y_1,f_00,f_01,f_10,f_11) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: y                     ! value of y
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: y_0                   ! y interpolation points
      real(kind=rel_kind),intent(in) :: y_1
      real(kind=rel_kind),intent(in) :: f_00                  ! f(x,y) values
      real(kind=rel_kind),intent(in) :: f_01
      real(kind=rel_kind),intent(in) :: f_10
      real(kind=rel_kind),intent(in) :: f_11

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x,y)

      ! solve for f
      f=lerp(y,y_0,y_1,lerp(x,x_0,x_1,f_00,f_10),lerp(x,x_0,x_1,f_01,f_11))

      return

   end function

   ! geometic interpolation
   elemental function gerp_1(x,x_0,x_1,f_0,f_1) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: f_0                   ! f(x) interpolation points
      real(kind=rel_kind),intent(in) :: f_1

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x)

      ! variable declarations
      real(kind=rel_kind) :: weight                           ! (x-x_0)/(x_1-x_0)

      ! solve for f

      weight=(x-x_0)/(x_1-x_0)
      f=f_0**(1._rel_kind-weight)*f_1**(weight)

      return

   end function

   ! bi-geometic interpolation
   ! three geometric interpolations
   elemental function gerp_2(x,y,x_0,x_1,y_0,y_1,f_00,f_01,f_10,f_11) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: y                     ! value of y
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: y_0                   ! y interpolation points
      real(kind=rel_kind),intent(in) :: y_1
      real(kind=rel_kind),intent(in) :: f_00                  ! f(x,y) values
      real(kind=rel_kind),intent(in) :: f_01
      real(kind=rel_kind),intent(in) :: f_10
      real(kind=rel_kind),intent(in) :: f_11

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x,y)

      ! solve for f
      f=gerp(y,y_0,y_1,gerp(x,x_0,x_1,f_00,f_10),gerp(x,x_0,x_1,f_01,f_11))

      return

   end function

   ! linear interpolation (with x forced into interval)
   elemental function lerp_forced(x,x_0,x_1,f_0,f_1) result (f)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x                     ! value of x
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: f_0                   ! f(x) interpolation points
      real(kind=rel_kind),intent(in) :: f_1

      ! result declaration
      real(kind=rel_kind) :: f                                ! f(x)

      ! solve for f
      f=f_0+(f_1-f_0)*(min(max(x,x_0),x_1)-x_0)/(x_1-x_0)

      return

   end function

   ! inverse quadratic interpolation
   elemental function inv_querp(f,f_0,f_1,x_0,x_1,dfdx_0,dfdx_1) result(x)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: f                     ! value of f(x)
      real(kind=rel_kind),intent(in) :: f_0                   ! f(x) interpolation points
      real(kind=rel_kind),intent(in) :: f_1
      real(kind=rel_kind),intent(in) :: x_0                   ! x interpolation points
      real(kind=rel_kind),intent(in) :: x_1
      real(kind=rel_kind),intent(in) :: dfdx_0                ! df(x)/dx intepolation points
      real(kind=rel_kind),intent(in) :: dfdx_1

      ! result declaration
      real(kind=rel_kind) :: x                                ! x

      ! variable declarations
      real(kind=rel_kind) :: delta_f                          ! f-f_0
      real(kind=rel_kind) :: delta_x                          ! x-x_0
      real(kind=rel_kind) :: dfdx                             ! simple df(x)/dx
      real(kind=rel_kind) :: d2fdx2                           ! d^2f(x)/dx^2
      real(kind=rel_kind) :: discriminant                     ! dfdx_0**2+2._rel_kind*d2fdx2*delta_f

      delta_f=f_0-f
      dfdx=(f_1-f_0)/(x_1-x_0)
      d2fdx2=(dfdx_1-dfdx_0)/(x_1-x_0)
      discriminant=dfdx_0**2-2._rel_kind*delta_f*d2fdx2

      if (discriminant>0._rel_kind) then

         ! Halley's irrational formula
         delta_x=-2._rel_kind*delta_f/(dfdx_0+sign(sqrt(discriminant),dfdx_0))

      else if (abs(dfdx)>0._rel_kind) then

         ! Newton Raphson
         delta_x=-delta_f/dfdx

      else

         delta_x=0._rel_kind

      end if

      x=x_0+delta_x

      return

   end function

   ! makes a 1D histogram from a list of values and and array of bins
   pure function make_hist(values,bins,weight_in) result (hist)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: values(:)             ! array of values
      real(kind=rel_kind),intent(in) :: bins(:)               ! array of bin values
      real(kind=rel_kind),intent(in),optional :: weight_in(:) ! weight of values

      ! result declaration
      real(kind=rel_kind) :: hist(size(bins)-1)               ! histogram values

      ! variable declarations
      integer(kind=int_kind) :: i                             ! counter
      integer(kind=int_kind) :: j
      real(kind=rel_kind) :: weight(size(values))             ! weight of values

      if (present(weight_in)) then
         weight=weight_in
      else
         weight=1._rel_kind
      end if

      ! initialise histogram
      hist=0._rel_kind

      ! loop over values and update histogram
      do i=1,size(values)

         j=binary_search(values(i),bins)
         hist(j)=hist(j)+weight(i)

      end do

      ! normalise bins
      hist=hist/(real(size(values),rel_kind)*(bins(2:)-bins(:size(bins)-1)))

      return

   end function

   ! produce an array of linearly spaced values
   pure function lin_space(x_min,x_max,n_x) result(x)

      ! argument declarations
      integer(kind=int_kind),intent(in) :: n_x        ! number of values
      real(kind=rel_kind),intent(in) :: x_min         ! min value
      real(kind=rel_kind),intent(in) :: x_max         ! max value

      ! result declaration
      real(kind=rel_kind) :: x(n_x)                   ! arrray of n_x values

      ! variable declarations
      integer(kind=int_kind) :: i                     ! counter
      real(kind=rel_kind) :: dx                       ! x incriment

      dx=(x_max-x_min)/real(n_x-1,rel_kind)
      x=(/(x_min+real(i-1,rel_kind)*dx,i=1,n_x)/)

      return

   end function

   ! produce an array of logarithmically spaced values
   pure function log_lin_space(x_min,x_max,n_x) result(x)

      ! argument declarations
      integer(kind=int_kind),intent(in) :: n_x        ! number of values
      real(kind=rel_kind),intent(in) :: x_min         ! min value
      real(kind=rel_kind),intent(in) :: x_max         ! max value

      ! result declaration
      real(kind=rel_kind) :: x(n_x)                   ! arrray of n_x values

      ! variable declarations
      integer(kind=int_kind) :: i                     ! counter
      real(kind=rel_kind) :: log_x_min                ! min log x
      real(kind=rel_kind) :: log_x_max                ! max log x
      real(kind=rel_kind) :: dlog_x                   ! log x incriment

      log_x_min=log(x_min)
      log_x_max=log(x_max)

      dlog_x=(log_x_max-log_x_min)/real(n_x-1,rel_kind)
      x=(/(exp(log_x_min+real(i-1,rel_kind)*dlog_x),i=1,n_x)/)

      return

   end function

   ! perform a trapezoidal integration
   pure function trapz_intgr(x_values,f_values) result (value)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x_values(:)   ! array of x
      real(kind=rel_kind),intent(in) :: f_values(:)   ! array of f(x)

      ! result declaration
      real(kind=rel_kind) :: value                    ! integral of f(x)dx

      ! variable declarations
      integer(kind=int_kind) :: n_x                   ! number of x_values

      n_x=size(x_values)

      value=0.5_rel_kind*sum((f_values(1:n_x-1)+f_values(2:n_x))*&
         &(x_values(2:n_x)-x_values(1:n_x-1)))

      return

   end function

   ! create cumulative dist of f(x)
   pure function cum_dist_func(x_values,f_values,normalise) result (values)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x_values(:)   ! array of x
      real(kind=rel_kind),intent(in) :: f_values(:)   ! array of f(x)
      logical(kind=log_kind),intent(in),optional :: normalise  ! normalise distribution to one

      ! result declaration
      real(kind=rel_kind) :: values(size(x_values))   ! integral of f(x)dx

      ! variable declaration
      integer(kind=int_kind) :: i                     ! counter
      integer(kind=int_kind) :: n_x                   ! number of x_values

      n_x=size(x_values)

      ! first element is zero by definition
      values(1)=0._rel_kind

      ! loop over array and calculate cumulative dist
      do i=2,n_x
         values(i)=values(i-1)+&
            &0.5_rel_kind*(f_values(i-1)+f_values(i))*&
            &(x_values(i)-x_values(i-1))
      end do
      ! normalise distribution to one
      if (present(normalise)) then
         if (normalise) values=values/values(n_x)
      end if

      return

   end function

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

! ARRAY SEARCHES, SORTS, ETC

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

   ! binary search
   ! find right-most element in monotonically increasing array with value less than x
   ! x must be in range array(i) <= x <= array(size(array))
   pure function binary_search(x,array) result(i_0)

      ! argument declations
      real(kind=rel_kind),intent(in) :: x                     ! target value
      real(kind=rel_kind),intent(in),contiguous :: array(:)   ! array of values

      ! result declaration
      integer(kind=int_kind) :: i_0                           ! right most lower index

      ! variable declarations
      integer(kind=int_kind) :: i_1                           ! left most upper index
      integer(kind=int_kind) :: i_mid                         ! mid point between i_0 and i_1

      ! set initial array bounds
      i_0=1
      i_1=size(array)

      ! find i_0
      do
         ! set i_0 to array mid point
         i_mid=i_0+(i_1-i_0)/2

         ! exit or change array boundaries
         if (i_1-i_0<=1) then
            exit
         else if (array(i_mid)<=x) then
            i_0=i_mid
         else
            i_1=i_mid
         end if

      end do

   end function

   ! produce an array of integers equal to the indices of sorted array
   pure function array_ranking(array) result (indices)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: array(:)              ! array (obviously)

      ! result declaration
      integer(kind=int_kind) :: indices(size(array))          ! ranked array indices

      ! variable declarations
      integer(kind=int_kind) :: i                             ! counter
      real(kind=rel_kind) :: temp_array(size(array))

      ! make local copy of array
      temp_array=array

      ! initialise ranking
      indices=(/(i,i=1,size(indices))/)

      call quicksort(temp_array,indices)

      return

   end function

   ! quick sort algorithm
   pure recursive subroutine quicksort_1(array)

      !argument declarations
      real(kind=rel_kind),intent(inout) :: array(:)    !array to be sorted

      !variable declarations
      integer(kind=int_kind) :: i                      !counter
      integer(kind=int_kind) :: n                      !size of array
      integer(kind=int_kind) :: pivot                  !pivot index

      !Quicksort algorithm

      !return if array has one or zero elements
      n=size(array)
      if(n<=1) return

      !set pivot to central array element
      pivot=1+(n-1)/2

      !move pivot to end of array
      call swap(array(pivot),array(n))

      !loop over array and place elements
      !lower than the pivot value left of pivot
      pivot=1
      do i=1,n-1

         if(array(i)<=array(n)) then
            call swap(array(pivot),array(i))
            pivot=pivot+1
         end if

      end do

      !move pivot back from end of array
      call swap(array(pivot),array(n))

      !sort the array slices either side of pivot
      call quicksort(array(:pivot-1))
      call quicksort(array(pivot+1:))

      return

   end subroutine

   ! quick sort algorithm
   ! also maintains list of original indices
   pure recursive subroutine quicksort_2(array,indices)

      !argument declarations
      integer(kind=int_kind),intent(inout) :: indices(:)  !original indices of array elements
      real(kind=rel_kind),intent(inout) :: array(:)    !array to be sorted

      !variable declarations
      integer(kind=int_kind) :: i                      !counter
      integer(kind=int_kind) :: n                      !size of array
      integer(kind=int_kind) :: pivot                  !pivot index

      !Quicksort algorithm

      !return if array has one or zero elements
      n=size(array)
      if(n<=1) return

      !set pivot to central array element
      pivot=1+(n-1)/2

      !move pivot to end of array
      call swap(array(pivot),array(n))
      call swap(indices(pivot),indices(n))

      !loop over array and place elements
      !lower than the pivot value left of pivot
      pivot=1
      do i=1,n-1

         if(array(i)<=array(n)) then
            call swap(array(pivot),array(i))
            call swap(indices(pivot),indices(i))
            pivot=pivot+1
         end if

      end do

      !move pivot back from end of array
      call swap(array(pivot),array(n))
      call swap(indices(pivot),indices(n))

      !sort the array slices either side of pivot
      call quicksort(array(:pivot-1),indices(:pivot-1))
      call quicksort(array(pivot+1:),indices(pivot+1:))

      return

   end subroutine

   pure subroutine swap_real(a,b)

      ! argument declarations
      real(kind=rel_kind),intent(inout) :: a
      real(kind=rel_kind),intent(inout) :: b

      ! variable declarations
      real(kind=rel_kind) :: temp

      temp=a
      a=b
      b=temp

      return

   end subroutine

   pure subroutine swap_integer(a,b)

      ! argument declarations
      integer(kind=int_kind),intent(inout) :: a
      integer(kind=int_kind),intent(inout) :: b

      ! variable declarations
      integer(kind=int_kind) :: temp

      temp=a
      a=b
      b=temp

      return

   end subroutine

   pure function rotate_vector_3d(x,u,theta) result(x_new)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(3)       ! vector to rotate
      real(kind=rel_kind),intent(in) :: u(3)       ! axis of rotation unit vector
      real(kind=rel_kind),intent(in) :: theta      ! angle of rotation

      ! result declaration
      real(kind=rel_kind) :: x_new(3)              ! rotated x vector

      x_new=matmul(rotation_matrix_3d(u,theta),x)

      return

   end function

   ! construct a 3d rotation matrix for an angle about a unit vector
   pure function rotation_matrix_3d(u,theta) result(r)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: u(3)    ! unit vector
      real(kind=rel_kind),intent(in) :: theta   ! angle of rotation

      ! result declaration
      real(kind=rel_kind) :: r(3,3)             ! rotation matrix

      ! variable declarations
      real(kind=rel_kind) :: cos_theta             ! cos(theta)
      real(kind=rel_kind) :: sin_theta             ! sin(theta)

      cos_theta=cos(theta)
      sin_theta=sin(theta)

      r(:,1)=(/cos_theta+u(1)**2*(1._rel_kind-cos_theta),&
         &u(2)*u(1)*(1._rel_kind-cos_theta)+u(3)*sin_theta,&
         &u(3)*u(1)*(1._rel_kind-cos_theta)-u(2)*sin_theta/)
      r(:,2)=(/u(1)*u(2)*(1._rel_kind-cos_theta)-u(3)*sin_theta,&
         &cos_theta+u(2)**2*(1._rel_kind-cos_theta),&
         &u(3)*u(2)*(1._rel_kind-cos_theta)+u(1)*sin_theta/)
      r(:,3)=(/u(1)*u(3)*(1._rel_kind-cos_theta)+u(2)*sin_theta,&
         &u(2)*u(3)*(1._rel_kind-cos_theta)-u(1)*sin_theta,&
         &cos_theta+u(3)**2*(1._rel_kind-cos_theta)/)

      return

   end function

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

! POINT DISTRIBUTIONS

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

   ! cube of edge length 1 rotated through euler angles
   pure function rotated_cube_vertices(angles) result(vertices)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: angles(3)  ! three Euler angles

      ! result declaration
      real(kind=rel_kind) :: vertices(3,8)        ! eight three-dimensional positions

      ! variable declarations
      integer(kind=int_kind) :: i                  ! counter
      real(kind=rel_kind) :: unit_vectors(3,3)     ! three unit vectors
      real(kind=rel_kind) :: rotation_matrix(3,3)       ! rotation matrix

      ! set initial vector/vertices
      vertices(:,1)=(/-0.5_rel_kind,-0.5_rel_kind,-0.5_rel_kind/)
      vertices(:,2)=(/-0.5_rel_kind,-0.5_rel_kind,0.5_rel_kind/)
      vertices(:,3)=(/-0.5_rel_kind,0.5_rel_kind,-0.5_rel_kind/)
      vertices(:,4)=(/-0.5_rel_kind,0.5_rel_kind,0.5_rel_kind/)
      vertices(:,5)=(/0.5_rel_kind,-0.5_rel_kind,-0.5_rel_kind/)
      vertices(:,6)=(/0.5_rel_kind,-0.5_rel_kind,0.5_rel_kind/)
      vertices(:,7)=(/0.5_rel_kind,0.5_rel_kind,-0.5_rel_kind/)
      vertices(:,8)=(/0.5_rel_kind,0.5_rel_kind,0.5_rel_kind/)
      unit_vectors(:,1)=(/1._rel_kind,0._rel_kind,0._rel_kind/)
      unit_vectors(:,2)=(/0._rel_kind,1._rel_kind,0._rel_kind/)
      unit_vectors(:,3)=(/0._rel_kind,0._rel_kind,1._rel_kind/)

      ! perform rotation about x axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,1),angles(1))
      ! rotate vertices
      do i=1,8
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do
      ! rotate unit vectors
      unit_vectors(:,2)=matmul(rotation_matrix,unit_vectors(:,2))
      unit_vectors(:,3)=matmul(rotation_matrix,unit_vectors(:,3))

      ! perform rotation about y axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,2),angles(2))
      ! rotate vertices
      do i=1,8
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do
      ! rotate unit vectors
      unit_vectors(:,1)=matmul(rotation_matrix,unit_vectors(:,1))
      unit_vectors(:,3)=matmul(rotation_matrix,unit_vectors(:,3))

      ! perform rotation about x axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,3),angles(3))
      ! rotate vertices
      do i=1,8
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do

      return

   end function

      ! cube of edge length 1 rotated through euler angles
   pure function rotated_hcp_ball_vertices(angles) result(vertices)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: angles(3)  ! three Euler angles

      ! result declaration
      real(kind=rel_kind) :: vertices(3,13)        ! eight three-dimensional positions

      ! variable declarations
      integer(kind=int_kind) :: i                  ! counter
      real(kind=rel_kind) :: unit_vectors(3,3)     ! three unit vectors
      real(kind=rel_kind) :: rotation_matrix(3,3)       ! rotation matrix

      ! set initial vector/vertices
      vertices(:,1)=(/0._rel_kind,sqrt(3._rel_kind)/3._rel_kind,-sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,2)=(/-0.5_rel_kind,-sqrt(3._rel_kind)/6._rel_kind,-sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,3)=(/0.5_rel_kind,-sqrt(3._rel_kind)/6._rel_kind,-sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,4)=(/-0._rel_kind,-sqrt(3._rel_kind)/3._rel_kind,sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,5)=(/0.5_rel_kind,sqrt(3._rel_kind)/6._rel_kind,sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,6)=(/-0.5_rel_kind,sqrt(3._rel_kind)/6._rel_kind,sqrt(6._rel_kind)/3._rel_kind/)
      vertices(:,7)=(/-0.5_rel_kind,0.5_rel_kind*sqrt(3._rel_kind),0._rel_kind/)
      vertices(:,8)=(/0.5_rel_kind,0.5_rel_kind*sqrt(3._rel_kind),0._rel_kind/)
      vertices(:,9)=(/0.5_rel_kind,-0.5_rel_kind*sqrt(3._rel_kind),0._rel_kind/)
      vertices(:,10)=(/-0.5_rel_kind,-0.5_rel_kind*sqrt(3._rel_kind),0._rel_kind/)
      vertices(:,11)=(/-1._rel_kind,0._rel_kind,0._rel_kind/)
      vertices(:,12)=(/1._rel_kind,0._rel_kind,0._rel_kind/)
      vertices(:,13)=0._rel_kind

      unit_vectors(:,1)=(/1._rel_kind,0._rel_kind,0._rel_kind/)
      unit_vectors(:,2)=(/0._rel_kind,1._rel_kind,0._rel_kind/)
      unit_vectors(:,3)=(/0._rel_kind,0._rel_kind,1._rel_kind/)

      ! perform rotation about x axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,1),angles(1))
      ! rotate vertices
      do i=1,12
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do
      ! rotate unit vectors
      unit_vectors(:,2)=matmul(rotation_matrix,unit_vectors(:,2))
      unit_vectors(:,3)=matmul(rotation_matrix,unit_vectors(:,3))

      ! perform rotation about y axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,2),angles(2))
      ! rotate vertices
      do i=1,12
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do
      ! rotate unit vectors
      unit_vectors(:,1)=matmul(rotation_matrix,unit_vectors(:,1))
      unit_vectors(:,3)=matmul(rotation_matrix,unit_vectors(:,3))

      ! perform rotation about x axis
      rotation_matrix=rotation_matrix_3d(unit_vectors(:,3),angles(3))
      ! rotate vertices
      do i=1,12
         vertices(:,i)=matmul(rotation_matrix,vertices(:,i))
      end do

      return

   end function

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

! DISTRIBUTION MOMENTS

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

   ! distribution moment
   pure function dist_moment(x,c,n,w_in) result(mu_n)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      real(kind=rel_kind),intent(in) :: c                   ! centre
      integer(kind=int_kind),intent(in) :: n                ! order
      real(kind=rel_kind),intent(in),optional :: w_in(:)    ! weights

      ! result declaration
      real(kind=rel_kind) :: mu_n                           ! moment

      ! variable declarations
      real(kind=rel_kind) :: w(size(x))                     ! weights

      if (present(w_in)) then
         w=w_in
      else
         w=1._rel_kind
      end if

      mu_n=sum(w*(x-c)**n)/sum(w)

      return

   end function

   ! arithmetic mean
   pure function mean(x,w) result(mu)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      real(kind=rel_kind),intent(in),optional :: w(:)       ! weights

      ! variable declarations
      real(kind=rel_kind) :: mu                             ! mean

      mu=dist_moment(x,0._rel_kind,1_int_kind,w)

      return

   end function

   ! central moment of distribution
   pure function central_moment(x,n,w) result(mu_n)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      integer(kind=int_kind),intent(in) :: n                ! order
      real(kind=rel_kind),intent(in),optional :: w(:)       ! weights

      ! result declaration
      real(kind=rel_kind) :: mu_n                           ! moment

      ! variable declarations
      real(kind=rel_kind) :: mu                             ! mean

      mu=mean(x,w)
      mu_n=dist_moment(x,mu,n,w)

      return

   end function

   ! arithmetic standard deviation
   pure function standard_deviation(x,w) result(sigma)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      real(kind=rel_kind),intent(in),optional :: w(:)       ! weights

      ! result declaration
      real(kind=rel_kind) :: sigma                          ! standard deviation

      sigma=sqrt(central_moment(x,2_int_kind,w))

      return

   end function

   ! arithmetic skewness
   pure function skewness(x,w) result(gamma)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      real(kind=rel_kind),intent(in),optional :: w(:)       ! weights

      ! result declaration
      real(kind=rel_kind) :: gamma                          ! skewness

      ! variable declarations
      real(kind=rel_kind) :: mu                             ! mean

      mu=mean(x,w)
      gamma=dist_moment(x,mu,3_int_kind,w)/sqrt(dist_moment(x,mu,2_int_kind,w))**3

      return

   end function

   ! arithmetic kurtosis
   pure function kurtosis(x,w) result(beta)

      ! argument declarations
      real(kind=rel_kind),intent(in) :: x(:)                ! x values
      real(kind=rel_kind),intent(in),optional :: w(:)       ! weights

      ! result declaration
      real(kind=rel_kind) :: beta                           ! kurtosis

      ! variable declarations
      real(kind=rel_kind) :: mu                             ! mean

      mu=mean(x,w)
      beta=dist_moment(x,mu,4_int_kind,w)/dist_moment(x,mu,2_int_kind,w)**2

      return

   end function

end module


      SUBROUTINE power_to_legendre(n, a, b, ac, tc)
      USE stel_kinds
      IMPLICIT NONE
      INTEGER, INTENT(IN):: n
      REAL(rprec), DIMENSION(0:n), INTENT(IN):: ac
      REAL(rprec), DIMENSION(0:n), INTENT(OUT):: tc
      REAL(rprec), DIMENSION(0:n,0:n), INTENT(IN):: a, b
      INTEGER:: i, j, k
!------------------------------------------------------------------
!      Given the following notation:
!
!           TC == (tc(1), ...tc(n))==>  vector of coefficients
!                 for Legendre series in [-1,1]
!           AC == (ac(1), ...ac(n))==>  vector of coefficients
!                 for power series in [0,1]
!      THEN:
!                        TC = AC* B * A
!------------------------------------------------------------------
      DO i = 0, n
         tc(i) = 0
         DO j= 0, n
           DO k = 0, n
             tc(i) = tc(i) + ac(j) * b(j,k) * a(k,i)
           END DO
         END DO
      END DO

      END SUBROUTINE power_to_legendre


*deck ang1
      subroutine ang1(ang,dfac,nanb,lalb,mamb,lamu,lmf,lml,lmx,lmy,lmz,
     &  ltot1,xab,yab,zab,xk,yk,zk,zlm)
c
c  compute type 1 angular integrals
c
      implicit real*8 (a-h,o-z)
      parameter (a0=0.0d0, a1=1.0d0)
      dimension ang(ltot1,*), dfac(*), lmf(*), lml(*), lmx(*), lmy(*),
     &  lmz(*), xab(*), yab(*), zab(*), zlm(*)
c
      call wzero(ltot1*lamu,ang,1)
      do 96 n=1,nanb
      if(xab(n).eq.a0) go to 96
      do 94 l=1,lalb
      if(yab(l).eq.a0) go to 94
      do 92 m=1,mamb
      if(zab(m).eq.a0) go to 92
      nlm=((n-2)+l)+m
      lamlo=mod(nlm-1,2)+1
      lamhi=min(nlm,lamu)
      if(lamlo.gt.lamhi) go to 92
      do 90 lam=lamlo,lamhi,2
      l2=lam+lam-1
      angt=a0
      loc=(lam-1)**2
      do 80 mu1=1,l2
      istart=lmf(loc+mu1)
      if(mod(n,2).eq.mod(lmx(istart),2).or.
     1   mod(l,2).eq.mod(lmy(istart),2).or.
     2   mod(m,2).eq.mod(lmz(istart),2)) go to 80
      pre=a0
      aint=a0
      iend=lml(loc+mu1)
      do 70 i=istart,iend
        indx=lmx(i)
        indy=lmy(i)
        indz=lmz(i)
        if(indx.eq.0) then
          xkp=a1
        else
          xkp=xk**indx
        endif
        if(indy.eq.0) then
          ykp=a1
        else
          ykp=yk**indy
        endif
        if(indz.eq.0) then
          zkp=a1
        else
          zkp=zk**indz
        endif
        pre=pre+zlm(i)*xkp*ykp*zkp
        aint=aint+zlm(i) * dfac(n+indx) * dfac(l+indy) * dfac(m+indz)/
     1    dfac((n+indx)+(l+indy)+(m+indz))
   70 continue
      angt=angt+pre*aint
   80 continue
      ang(nlm,lam)=ang(nlm,lam)+((xab(n)*yab(l))*zab(m))*angt
   90 continue
   92 continue
   94 continue
   96 continue
      return
      end


!
!   Example 5
!
!   Interface:    Linear-Algebraic (IJ), Babel-based version in Fortran90/9x
!
!   Compile with: make ex5b90
!
!   Sample run:   mpirun -np 4 ex5b90
!
!   Description:  This example solves the 2-D
!                 Laplacian problem with zero boundary conditions
!                 on an nxn grid.  The number of unknowns is N=n^2.
!                 The standard 5-point stencil is used, and we solve
!                 for the interior nodes only.
!
!                 This example solves the same problem as Example 3.
!                 Available solvers are AMG, PCG, and PCG with AMG or
!                 Parasails preconditioners.

! HOW TO BUILD:
! Fortran 90 is not yet fully supported by the hypre build system, so this
! is a little more complicated than C or Fortran 77.  These instructions have
! only been tried in one environment so far.
! 1. Make sure you have a Fortran 90 compiler!
! 2. Make sure your MPI library supports Fortran 90, true if it supplies an
!    mpi.mod file and mpif90 compiler-wrapper.
! 3. Set the environment variable FC to your mpif90, the MPI wrapper for your
!    Fortran 90 compiler.
! 4. Install Chasm, which Babel requires for handling Fortran arrays.  See
!    the Babel users manual for more information.
! 5. Set the environment variable CHASMPREFIX, same as your --prefix option
!    in configuring Chasm.
! 6. Run hypre's 'configure --with-babel ...' and make.
! 7. cd babel/bHYPREClient-F90; make
! 8. cd examples; make ex5b90

program ex5b90

  use mpi
!  ... reguires mpi.mod, not available (I think) on my machine's (public) old version
! of mpich, but works with my private latest version of OpenMPI.(JfP)
! If a real Fortran 90 mpi.mod isn't available, the only alternative is to include
! the Fortran 77 one, plus corresponding changes thereafter ...
!#include "mpif.h"

  use sidl_SIDLException
  use bHYPRE_BoomerAMG
  use bHYPRE_MPICommunicator
  use bHYPRE_IJParCSRMatrix
  use bHYPRE_IJParCSRVector

  integer, parameter::  MAX_LOCAL_SIZE = 123000

  integer    ierr, ierrtmp
  integer    num_procs, myid
  integer    local_size, extra
  integer    n, solver_id, print_solution, ng
  integer    nnz, ilower, iupper, i
  real(8)    h, h2
  real(8)    rhs_values(MAX_LOCAL_SIZE)
  real(8)    x_values(MAX_LOCAL_SIZE)
  integer    rows(MAX_LOCAL_SIZE)
  integer    cols(5)
  real(8)    values(5)
  integer    num_iterations
  real(8)    final_res_norm, tol
  integer(8) mpi_comm

  type(bHYPRE_MPICommunicator_t) bHYPRE_mpicomm
  type(bHYPRE_IJParCSRMatrix_t)  parcsr_A
  type(bHYPRE_Operator_t)        op_A
  type(bHYPRE_IJParCSRVector_t)  par_b
  type(bHYPRE_IJParCSRVector_t)  par_x
  type(bHYPRE_Vector_t)          vec_b
  type(bHYPRE_Vector_t)          vec_x
  type(bHYPRE_BoomerAMG_t)       amg_solver
  type(sidl_SIDLException_t)     except
  !     ... except is for Babel exceptions, which we shall ignore

!-----------------------------------------------------------------------
!     Initialize MPI
!-----------------------------------------------------------------------

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
      mpi_comm = MPI_COMM_WORLD
      call bHYPRE_MPICommunicator_CreateF_f( mpi_comm, bHYPRE_mpicomm, except )

!   Default problem parameters
      n = 33
      solver_id = 0
      print_solution  = 0
      tol = 1.0d-7

!   The input section not implemented yet.

!   Preliminaries: want at least one processor per row
      if ( n*n .lt. num_procs) then
         n = int(sqrt(real(num_procs))) + 1
      endif
!     ng = global no. rows, h = mesh size
      ng = n*n
      h = 1.0d0/(n+1)
      h2 = h*h

!     Each processor knows only of its own rows - the range is denoted by ilower
!     and upper.  Here we partition the rows. We account for the fact that
!     N may not divide evenly by the number of processors.
      local_size = ng/num_procs
      extra = ng - local_size*num_procs

      ilower = local_size*myid
      ilower = ilower + min(myid, extra)

      iupper = local_size*(myid+1)
      iupper = iupper + min(myid+1, extra)
      iupper = iupper - 1

!     How many rows do I have?
      local_size = iupper - ilower + 1

!     Create the matrix.
!     Note that this is a square matrix, so we indicate the row partition
!     size twice (since number of rows = number of cols)
      call bHYPRE_IJParCSRMatrix_Create_f( bHYPRE_mpicomm, ilower, iupper, ilower, iupper, &
           parcsr_A, except )

!     op_A will be needed later as a function argument
      call bHYPRE_Operator__cast_f( parcsr_A, op_A, except )

!     Choose a parallel csr format storage (see the User's Manual)
!     Note: Here the HYPRE interface requires a SetObjectType call.
!     I am using the bHYPRE interface in a way which does not because
!     the object type is already specified through the class name.

!     Initialize before setting coefficients
      call bHYPRE_IJParCSRMatrix_Initialize_f( parcsr_A, ierrtmp, except )

!     Now go through my local rows and set the matrix entries.
!     Each row has at most 5 entries. For example, if n=3:
!
!      A = [M -I 0; -I M -I; 0 -I M]
!      M = [4 -1 0; -1 4 -1; 0 -1 4]
!
!     Note that here we are setting one row at a time, though
!     one could set all the rows together (see the User's Manual).

      do i = ilower, iupper
         nnz = 1

!        The left identity block:position i-n
         if ( (i-n) .ge. 0 ) then
	    cols(nnz) = i-n
	    values(nnz) = -1.0d0
	    nnz = nnz + 1
         endif

!         The left -1: position i-1
         if ( mod(i,n).ne.0 ) then
            cols(nnz) = i-1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

!        Set the diagonal: position i
         cols(nnz) = i
         values(nnz) = 4.0d0
         nnz = nnz + 1

!        The right -1: position i+1
         if ( mod((i+1),n) .ne. 0 ) then
            cols(nnz) = i+1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

!        The right identity block:position i+n
         if ((i+n) .lt. ng ) then
            cols(nnz) = i+n
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

!        Set the values for row i
         call bHYPRE_IJParCSRMatrix_SetValues_f( parcsr_A, 1, nnz-1, i, cols, values, 5, &
              ierrtmp, except )

      enddo

!     Assemble after setting the coefficients
      call bHYPRE_IJParCSRMatrix_Assemble_f( parcsr_A, ierrtmp, except )

!     Create the rhs and solution
      call bHYPRE_IJParCSRVector_Create_f( bHYPRE_mpicomm, ilower, iupper, par_b, except )
!     vec_b will be needed later for function arguments
      call bHYPRE_Vector__cast_f( par_b, vec_b, except )

      call bHYPRE_IJParCSRVector_Initialize_f( par_b, ierrtmp, except )

      call bHYPRE_IJParCSRVector_Create_f( bHYPRE_mpicomm, ilower, iupper, par_x, except )
!     vec_x will be needed later for function arguments
      call bHYPRE_Vector__cast_f( par_x, vec_x, except )

      call bHYPRE_IJParCSRVector_Initialize_f( par_x, ierrtmp, except )

!     Set the rhs values to h^2 and the solution to zero
      do i = 1, local_size
         rhs_values(i) = h2
         x_values(i) = 0.0
         rows(i) = ilower + i -1
      enddo
      call bHYPRE_IJParCSRVector_SetValues_f( par_b, local_size, rows, rhs_values, &
           ierrtmp, except )
      call bHYPRE_IJParCSRVector_SetValues_f( par_x, local_size, rows, x_values, ierrtmp, except )

      call bHYPRE_IJParCSRVector_Assemble_f( par_b, ierrtmp, except )
      call bHYPRE_IJParCSRVector_Assemble_f( par_x, ierrtmp, except )

!     Choose a solver and solve the system

!      AMG
      if ( solver_id == 0 ) then

!        Create solver
         call bHYPRE_BoomerAMG_Create_f( bHYPRE_mpicomm, parcsr_A, amg_solver, except )

!        Set some parameters (See Reference Manual for more parameters)
!        PrintLevel=3 means print solve info + parameters
!        CoarsenType=6 means Falgout coarsening
!        RelaxType=3 means Gauss-Seidel/Jacobi hybrid relaxation
         call bHYPRE_BoomerAMG_SetIntParameter_f( amg_solver, "PrintLevel", 3, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f( amg_solver, "CoarsenType", 6, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f( amg_solver, "RelaxType", 3, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f( amg_solver, "NumSweeps", 1, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f( amg_solver, "MaxLevels", 20, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetDoubleParameter_f( amg_solver, "Tolerance", tol, ierrtmp, &
              except )

!        Now setup and solve!
         call bHYPRE_BoomerAMG_Setup_f( amg_solver, vec_b, vec_x, ierrtmp, except )
         call bHYPRE_BoomerAMG_Apply_f( amg_solver, vec_b, vec_x, ierrtmp, except )

!        Run info - needed logging turned on
         call bHYPRE_BoomerAMG_GetIntValue_f( amg_solver, "NumIterations", num_iterations, &
              ierrtmp, except )
         ierr = ierr + ierrtmp
         call bHYPRE_BoomerAMG_GetDoubleValue_f( amg_solver, "RelResidualNorm", final_res_norm, &
              ierrtmp, except )

      if (myid .eq. 0) then
         print *
         print *, "Iterations = ", num_iterations
         print *, "Final Relative Residual Norm = ", final_res_norm
         print *
      endif

!     Destroy solver
      call bHYPRE_BoomerAMG_deleteRef_f( amg_solver, except )

      endif

!     The calls of other solvers are not implemented yet.

!     Print the solution
      if ( print_solution .ne. 0 ) then
         call bHYPRE_IJParCSRVector_Print_f( par_x, "ij.out.x", except )
      endif

!     Clean up
      call bHYPRE_Operator_deleteRef_f( op_A, except )
      call bHYPRE_Vector_deleteRef_f( vec_b, except )
      call bHYPRE_Vector_deleteRef_f( vec_x, except )
      call bHYPRE_IJParCSRMatrix_deleteRef_f( parcsr_A, except )
      call bHYPRE_IJParCSRVector_deleteRef_f( par_b, except )
      call bHYPRE_IJParCSRVector_deleteRef_f( par_x, except )
      call bHYPRE_MPICommunicator_deleteRef_f( bHYPRE_mpicomm, except )

!     We need a multi-language equivalent of hypre_assert.
      if ( ierr .ne. 0 ) then
         print *
         print *, "***** Bad ierr = ", ierr
         print *
      endif

!     Finalize MPI
      call MPI_Finalize(ierrtmp)

      stop
      end


      SUBROUTINE KSTWO(DATA1,N1,DATA2,N2,D,PROB)
      DIMENSION DATA1(N1),DATA2(N2)
      CALL SORT(N1,DATA1)
      CALL SORT(N2,DATA2)
      EN1=N1
      EN2=N2
      J1=1
      J2=1
      FO1=0.
      FO2=0.
      D=0.
1     IF(J1.LE.N1.AND.J2.LE.N2)THEN
        IF(DATA1(J1).LT.DATA2(J2))THEN
          FN1=J1/EN1
          DT=AMAX1(ABS(FN1-FO2),ABS(FO1-FO2))
          IF(DT.GT.D)D=DT
          FO1=FN1
          J1=J1+1
        ELSE
          FN2=J2/EN2
          DT=AMAX1(ABS(FN2-FO1),ABS(FO2-FO1))
          IF(DT.GT.D)D=DT
          FO2=FN2
          J2=J2+1
        ENDIF
      GO TO 1
      ENDIF
      PROB=PROBKS(SQRT(EN1*EN2/(EN1+EN2))*D)
      RETURN
      END


subroutine take_backward_euler_step(t, dt, q, success)

! Takes a time step using backward Euler.
!
! Args:
!   t: Time at the beginning of the current step.
!   dt: Length of the current time step.
!   q: Discrete PDE solution being updated.  Holds value at beginning of step
!     on entry.  Contains value at end of step on return.
!   success: Indicates whether time step was successful.  (Newton's method
!     or the linear solver could have failed to converge.)

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision, intent(in) :: t, dt
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn),  &
        intent(inout) :: q
    logical, intent(out) :: success

    integer :: newton_max_iter, newton_verbosity
    double precision :: newton_tolerance
    common /newton_config/ newton_max_iter, newton_tolerance, newton_verbosity

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) ::  &
        d_iterate, iterate
    double precision :: norm_d_iterate, old_norm_d_iterate, residual_norm
    integer :: iter, ix, iy, ieqn
    double precision, external :: inner_product

    success = .false.
    norm_d_iterate = newton_tolerance + 1.d0
    old_norm_d_iterate = norm_d_iterate
    iter = 0

    call apply_bcs(t, q)

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1, mx
                iterate(ix, iy, ieqn) = q(ix, iy, ieqn)
            end do
        end do
    end do

    do iter = 1, newton_max_iter
        call get_backward_euler_rhs(t, dt, q, iterate, d_iterate)
        ! residual_norm is currently unused.
        call solve_backward_euler_system(t, dt, iterate, d_iterate, residual_norm)

        old_norm_d_iterate = norm_d_iterate
        norm_d_iterate = 0.d0

        do ieqn = 1, meqn
            !$omp parallel do private(ix)
            do iy = 1, my
                do ix = 1, mx
                    iterate(ix, iy, ieqn) = iterate(ix, iy, ieqn) +  &
                        d_iterate(ix, iy, ieqn)
                end do
            end do
        end do
        norm_d_iterate = sqrt(inner_product(d_iterate, d_iterate))

        if (newton_verbosity > 0) then
           print '(A,I2,A,E16.10)', 'Newton iteration ', iter,  &
                ', norm(d_iterate) = ', norm_d_iterate
        end if

        ! Give up if norm_d_iterate gets too big, as this indicates nonconvergence
        if (norm_d_iterate > 1e6) exit

        ! If we've converged, then update the solution and return.
        if (norm_d_iterate < newton_tolerance) then
            do ieqn = 1, meqn
                !$omp parallel do private(ix)
                do iy = 1, my
                    do ix = 1, mx
                        q(ix, iy, ieqn) = iterate(ix, iy, ieqn)
                    end do
                end do
            end do

            success = .true.
            if (newton_verbosity > 0) then
               print '(A,I2,A,E16.10)', 'Newton''s method finished after ',  &
                    iter, ' iterations with norm(d_iterate) = ', norm_d_iterate
            end if
            return
        end if
    end do

    ! If we're still here, Newton's method failed to converge.
    if (newton_verbosity > 0) then
        print '(A,I2)', 'Newton''s method failed to converge after ',  &
            newton_max_iter, 'iterations.'
    end if

end subroutine take_backward_euler_step