      SUBROUTINE DLKAPM (ARG,BLKAPM)
C
C     SUBROUTINE FOR COMPUTING LOGARITHMIC DERIVATIVE OF KAPPA MINUS
C
      COMPLEX         BLKAPM,AI,C1,D1,D2,C1TEST,ARG,E1,ALP0,ALP,ALN
      CHARACTER       UFM*23
      COMMON /XMSSG / UFM
      COMMON /SYSTEM/ SYSBUF,IBBOUT
      COMMON /BLK1  / SCRK,SPS,SNS,DSTR,AI,PI,DEL,SIGMA,BETA,RES
C
      C1   =-AI/2.0*(SPS-SNS)
      PI2  = 2.0*PI
      S1   = SPS/(DSTR**2)
      S2   = SNS/DSTR
      GAM0 = SPS*DEL - SIGMA
      C2Q  = GAM0/DSTR - SCRK
      C3Q  = GAM0/DSTR + SCRK
      NN   = 0
      CSEC = C2Q*C3Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAM0*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2Q.LT.0.0 .AND. C3Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALP0 = T1 + T2
      IF (NN .EQ. 1) ALP0 = CMPLX(T1,T2)
      C1   = C1 + 1.0/(ARG-ALP0)
      A1   = PI2/(SPS-SNS)
      A2   =-A1
      B1   = GAM0/(SPS-SNS)
      C1TEST = 0.0
      DO 20 I = 1,200
      R    = I
      GAMP = PI2*R + GAM0
      GAMN =-PI2*R + GAM0
      C2P  = GAMP/DSTR - SCRK
      C2Q  = GAMP/DSTR + SCRK
      C2N  = GAMN/DSTR - SCRK
      C3Q  = GAMN/DSTR + SCRK
      NN   = 0
      CSEC = C2P*C2Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAMP*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2P.LT.0.0 .AND. C2Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALP = T1 + T2
      IF (NN .EQ. 1) ALP = CMPLX(T1,T2)
      NN   = 0
      CSEC = C2N*C3Q
      IF (CSEC .LT. 0.0) NN = 1
      T1   = GAMN*S1
      T2   = S2*SQRT(ABS(CSEC))
      IF (C2N.LT.0.0 .AND. C3Q.LT.0.0) T2 =-T2
      IF (NN .EQ. 0) ALN = T1 + T2
      IF (NN .EQ. 1) ALN = CMPLX(T1,T2)
      E1   = A1*R + B1 - ARG
      D1   = (ALP-A1*R-B1)/E1
      D2   = D1/E1
      C1   = C1 + 1.0/(1.0+D1)*D2
      E1   = A2*R + B1 - ARG
      D1   = (ALN-A2*R-B1)/E1
      D2   = D1/E1
      C1   = C1 + 1.0/(1.0+D1)*D2
      IF (CABS((C1-C1TEST)/C1) .LT. 0.0006) GO TO 50
      C1TEST = C1
   20 CONTINUE
      GO TO 70
   50 CONTINUE
      E1   = ARG - B1
      B    = PI/A1
      C1   = C1 - 1.0/E1 + B*CCOS(B*E1)/(CSIN(B*E1))
      BLKAPM = C1
      RETURN
C
   70 WRITE  (IBBOUT,80) UFM
   80 FORMAT (A23,' - AMG MODULE -SUBROUTINE DLKAPM')
      CALL MESAGE (-61,0,0)
      RETURN
      END


	SUBROUTINE SN_MGHT ( datain, nparms, tmpk, pres, hght,
     +			     npt, iret )
C************************************************************************
C* SN_MGHT								*
C*									*
C* This subroutine finds the pressure and height of the temperature,	*
C* TMPK, from moist-adiabatic method. If the sounding is stable, a	*
C* non-zero value is returned.						*
C*									*
C* SN_MGHT  ( DATAIN, NPARMS, TMPK, PRES, HGHT, NPT, IRET )		*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARMS,*)REAL		Station data			*
C*	NPARMS		INTEGER		Number of parameters		*
C*	TMPK		REAL		Temperature in K		*
C*									*
C* Output parameters:							*
C*	PRES (NPT)	REAL		Pressure in mb			*
C*	HGHT (NPT)	REAL		Height in meters		*
C*	NPT		INTEGER		No of intersections		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +5 = stable sounding		*
C*					-29 = invalid station data	*
C**									*
C* Log:									*
C* T. Lee/GSC		 4/00	Created					*
C* T. Lee/SAIC		 5/03	Initialized npt				*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	PARAMETER	( JPRE=1, JTMP=2, JDWP=3, JHGT=6 )
	PARAMETER	( MAXSTN=50, NPMS=7, P600=600., P500=500. )
	REAL		datain ( nparms, * )
	REAL		pres ( * ), hght ( * )
	REAL		outdat (MMPARM)
C*
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
	iret = 0
	npt  = 0
C
C*	Moist-adiabatic cloud height methodology: Find the most
C*	unstable level below 600 mb. Lift the parcel to 500 mb.
C*	If the lifted index is less than 0, (air parcel is warmer
C*	than the environment), continue lifting the parcel
C*	moist-adiabatically until the parcel temperature is cooled
C*	off to the cloud temperature, TMPK.
C
	tg = 0.
	CALL PS_USTB ( datain, nparms, P600, outdat, ier )
	pp = outdat ( JPRE )
	tt = outdat ( JTMP )
	td = outdat ( JDWP )
	te = PR_THTE ( pp, tt, td )
	tmst = PR_TMST ( te, P500, tg )
C
C*	Get environmental temperature at 500 mb and compute
C*	the best lifted index.
C
	CALL PC_CMDT ( 5, 6, 7, P500, 1, datain, outdat, ier )
	t500 = outdat ( JTMP )
	bli  = RMISSD
	IF  ( ERMISS ( t500 ) .or. ERMISS ( tmst ) )  THEN
	    iret = -29
	    RETURN
C
	  ELSE
	    bli = t500 - PR_TMKC ( tmst )
	END IF
C
C*	Go through moist-adiabatic. If the best lifted index
C*	is greater than or equal to 0., return with a non-zero
C*	value.
C
	pmst = PR_PMST ( te, tmpk )
C
	CALL PC_CMDT  ( 5, 6, 7, pmst, 1, datain, outdat, iret )
	IF  ( iret .eq. 0 )  THEN
	    npt = 1
	    pres ( npt ) = outdat ( JPRE )
	    hght ( npt ) = outdat ( JHGT )
	    IF  ( bli .ge. 0. ) iret = +5
	  ELSE
	    iret = -29
	END IF
C*
	RETURN
	END


SUBROUTINE K_Elast2RectLinear(eNum)
   USE PrecTypes
   USE GlobalData
   USE Gauss
   IMPLICIT NONE

   ! -------------------------------------------------------------------------
   ! NAME:   K_Elast2RectLinear
   ! PARENT: Mat_Elast2RectLinear
   ! STATUS: Current
   ! OWNER:  Toshiro Matsumoto
   ! TEXT:   Calculate stiffness matrix a rectangular linear element for
   !         two-dimensional elastostatic and thermo-elastostatic problems.
   ! REVISION DATE: 16-Jul-2009
   ! -------------------------------------------------------------------------

   INTEGER, INTENT(IN) :: eNum

   INTEGER :: i,j,k,l

   ! Variables used for integrations of rectilinear elements
   REAL(dp) :: Delta
   REAL(dp) :: x1, x2, x3, y1, y2, y3, x4, y4
   REAL(dp) :: xi_m1, xi_p1, eta_m1, eta_p1
   REAL(dp) :: xi, w_xi, eta, w_eta
   REAL(dp) :: xi4, eta4
   REAL(dp) :: N1, N2, N3, N4
   REAL(dp) :: DN1Dxi, DN1Deta, DN2Dxi, DN2Deta, DN3Dxi, DN3Deta, DN4Dxi, DN4Deta
   REAL(dp) :: DxDxi, DxDeta, DyDxi, DyDeta
   REAL(dp) :: invJ11, invJ12, invJ21, invJ22
   REAL(dp) :: DN1Dx, DN1Dy, DN2Dx, DN2Dy, DN3Dx, DN3Dy, DN4Dx, DN4Dy
   REAL(dp) :: det
   REAL(dp) :: Dm(3,3)
   REAL(dp) :: Bm1(3,2),      Bm2(3,2),      Bm3(3,2),      Bm4(3,2)
   REAL(dp) :: Bm1_T(2,3),    Bm2_T(2,3),    Bm3_T(2,3),    Bm4_T(2,3)
   REAL(dp) :: Bm1_T_Dm(2,3), Bm2_T_Dm(2,3), Bm3_T_Dm(2,3), Bm4_T_Dm(2,3)
   REAL(dp) :: Klocal(4,4,2,2), Klocal_eta(4,4,2,2)
   real(dp) :: Thlocal(4,2,4), Thlocal_eta(4,2,4)

   REAL(dp) :: Yng, Pssn, coef

   INTEGER  :: p1, p2, p3, p4

   Krect = 0.0_dp
   if (pcode == 3) Threct = 0.0_dp

   Yng  = E( emtype(eNum) )  ! Young's modulus
   Pssn = v( emtype(eNum) )  ! Poisson's ratio
   !       E
   !   ------------
   !   (1+v)(1-2v)
   coef = Yng / (( 1.0 + Pssn )*(1.0 - 2.0 * Pssn))

   ! [D] matrix
   !
   !            E      |  1-v     v      0      |
   ! [D] = ----------- |   v     1-v     0      |
   !       (1+v)(1-2v) |   0      0   (1-2v)/2  |
   Dm(1,1) = 1.0 - Pssn
   Dm(1,2) = Pssn
   Dm(1,3) = 0.0
   Dm(2,1) = Pssn
   Dm(2,2) = 1.0 - Pssn
   Dm(2,3) = 0.0
   Dm(3,1) = 0.0
   Dm(3,2) = 0.0
   Dm(3,3) = 0.5 - Pssn
   Dm = coef * Dm

   Bm1 = 0.0
   Bm2 = 0.0
   Bm3 = 0.0
   Bm4 = 0.0

   ! Global node numbers of the element under consideration
   p1 = elm(eNum,1)
   p2 = elm(eNum,2)
   p3 = elm(eNum,3)
   p4 = elm(eNum,4)

   ! Coordinates of node 1
   x1 = x( p1 )
   y1 = y( p1 )

   ! Coordinates of node 2
   x2 = x( p2 )
   y2 = y( p2 )

   ! Coordinates of node 3
   x3 = x( p3 )
   y3 = y( p3 )

   ! Coordinates of node 4
   x4 = x( p4 )
   y4 = y( p4 )

   DO i=1, gausspoint

      xi   = zt(i)
      w_xi = wt(i)

      xi4  = 0.25_dp * xi     !  xi/4

      KlocaL = 0.0_dp         ! initialize the array for storing the integrated results for j-loop

      IF (pcode == 3) THEN               ! for a thermoelastic problem
         Thlocal = 0.0_dp                ! initialize the array for storing the integrated
                                         ! results for j-loop
         xi_m1 = (1.0_dp - xi) * 0.5_dp  !  (1 - xi)/2
         xi_p1 = (1.0_dp + xi) * 0.5_dp  !  (1 + xi)/2
      END IF

      DO j=1, gausspoint

         Klocal_eta = 0.0_dp

         eta   = zt(j)
         w_eta = wt(j)
         if (pcode==3) then
            Thlocal_eta = 0.0_dp
            eta_m1 = (1.0_dp - eta) * 0.5_dp    !  (1 - eta)/2
            eta_p1 = (1.0_dp + eta) * 0.5_dp    !  (1 + eta)/2
         end if

         eta4 = 0.25_dp * eta    ! eta/4

         DN1Dxi  = -0.25_dp + eta4
         DN1Deta = -0.25_dp + xi4
         DN2Dxi  =  0.25_dp - eta4
         DN2Deta = -0.25_dp - xi4
         DN3Dxi  =  0.25_dp + eta4
         DN3Deta =  0.25_dp + xi4
         DN4Dxi  = -0.25_dp - eta4
         DN4Deta =  0.25_dp - xi4

         DxDxi  = DN1Dxi  * x1 + DN2Dxi  * x2 + DN3Dxi  * x3 + DN4Dxi  * x4
         DxDeta = DN1Deta * x1 + DN2Deta * x2 + DN3Deta * x3 + DN4Deta * x4
         DyDxi  = DN1Dxi  * y1 + DN2Dxi  * y2 + DN3Dxi  * y3 + DN4Dxi  * y4
         DyDeta = DN1Deta * y1 + DN2Deta * y2 + DN3Deta * y3 + DN4Deta * y4

         det = DxDxi * DyDeta - DyDxi * DxDeta
         Delta = ABS(det)

         invJ11 =  DyDeta
         invJ12 = -DyDxi
         invJ21 = -DxDeta
         invJ22 =  DxDxi
         DN1Dx = (invJ11 * DN1Dxi + invJ12 * DN1Deta)/det       !   ∂N1/∂x
         DN1Dy = (invJ21 * DN1Dxi + invJ22 * DN1Deta)/det       !   ∂N1/∂y
         DN2Dx = (invJ11 * DN2Dxi + invJ12 * DN2Deta)/det       !   ∂N2/∂x
         DN2Dy = (invJ21 * DN2Dxi + invJ22 * DN2Deta)/det       !   ∂N2/∂y
         DN3Dx = (invJ11 * DN3Dxi + invJ12 * DN3Deta)/det       !   ∂N3/∂x
         DN3Dy = (invJ21 * DN3Dxi + invJ22 * DN3Deta)/det       !   ∂N3/∂y
         DN4Dx = (invJ11 * DN4Dxi + invJ12 * DN4Deta)/det       !   ∂N4/∂x
         DN4Dy = (invJ21 * DN4Dxi + invJ22 * DN4Deta)/det       !   ∂N4/∂y

         !         |  ∂N1/∂x    0     |
         ! [B1] =  |   0      ∂N1/∂y  |
         !         |  ∂N1/∂y  ∂N1/∂x  |
         Bm1(1,1) = DN1Dx
         Bm1(2,2) = DN1Dy
         Bm1(3,1) = DN1Dy
         Bm1(3,2) = DN1Dx

         !         |  ∂N2/∂x    0     |
         ! [B2] =  |   0      ∂N2/∂y  |
         !         |  ∂N2/∂y  ∂N2/∂x  |
         Bm2(1,1) = DN2Dx
         Bm2(2,2) = DN2Dy
         Bm2(3,1) = DN2Dy
         Bm2(3,2) = DN2Dx

         !         |  ∂N3/∂x    0     |
         ! [B3] =  |   0      ∂N3/∂y  |
         !         |  ∂N3/∂y  ∂N3/∂x  |
         Bm3(1,1) = DN3Dx
         Bm3(2,2) = DN3Dy
         Bm3(3,1) = DN3Dy
         Bm3(3,2) = DN3Dx

         !         |  ∂N4/∂x    0     |
         ! [B4] =  |   0      ∂N4/∂y  |
         !         |  ∂N4/∂y  ∂N4/∂x  |
         Bm4(1,1) = DN4Dx
         Bm4(2,2) = DN4Dy
         Bm4(3,1) = DN4Dy
         Bm4(3,2) = DN4Dx

         !   Bm1 = Bm1/Delta2
         !   Bm2 = Bm2/Delta2
         !   Bm3 = Bm3/Delta2
         !   Bm4 = Bm4/Delta2

         ! [B1], [B2], [B3], [B4] の転置
         Bm1_T = TRANSPOSE(Bm1)
         Bm2_T = TRANSPOSE(Bm2)
         Bm3_T = TRANSPOSE(Bm3)
         Bm4_T = TRANSPOSE(Bm4)

         Bm1_T_Dm = MATMUL(Bm1_T, Dm)
         Bm2_T_Dm = MATMUL(Bm2_T, Dm)
         Bm3_T_Dm = MATMUL(Bm3_T, Dm)
         Bm4_T_Dm = MATMUL(Bm4_T, Dm)

         ! [K11] = [B1]^T [D] [B1]
         ! [K12] = [B1]^T [D] [B2]
         ! [K13] = [B1]^T [D] [B3]
         ! [K14] = [B1]^T [D] [B3]
         Klocal_eta(1,1,:,:) = MATMUL( Bm1_T_Dm, Bm1 ) * Delta
         Klocal_eta(1,2,:,:) = MATMUL( Bm1_T_Dm, Bm2 ) * Delta
         Klocal_eta(1,3,:,:) = MATMUL( Bm1_T_Dm, Bm3 ) * Delta
         Klocal_eta(1,4,:,:) = MATMUL( Bm1_T_Dm, Bm4 ) * Delta

         ! [K21] = [B2]^T [D] [B1]
         ! [K22] = [B2]^T [D] [B2]
         ! [K23] = [B2]^T [D] [B3]
         ! [K24] = [B2]^T [D] [B4]
         Klocal_eta(2,1,:,:) = MATMUL( Bm2_T_Dm, Bm1 ) * Delta
         Klocal_eta(2,2,:,:) = MATMUL( Bm2_T_Dm, Bm2 ) * Delta
         Klocal_eta(2,3,:,:) = MATMUL( Bm2_T_Dm, Bm3 ) * Delta
         Klocal_eta(2,4,:,:) = MATMUL( Bm2_T_Dm, Bm4 ) * Delta

         ! [K31] = [B3]^T [D] [B1]
         ! [K32] = [B3]^T [D] [B2]
         ! [K33] = [B3]^T [D] [B3]
         ! [K34] = [B3]^T [D] [B4]
         Klocal_eta(3,1,:,:) = MATMUL( Bm3_T_Dm, Bm1 ) * Delta
         Klocal_eta(3,2,:,:) = MATMUL( Bm3_T_Dm, Bm2 ) * Delta
         Klocal_eta(3,3,:,:) = MATMUL( Bm3_T_Dm, Bm3 ) * Delta
         Klocal_eta(3,4,:,:) = MATMUL( Bm3_T_Dm, Bm4 ) * Delta

         ! [K41] = [B4]^T [D] [B1]
         ! [K42] = [B4]^T [D] [B2]
         ! [K43] = [B4]^T [D] [B3]
         ! [K44] = [B4]^T [D] [B4]
         Klocal_eta(4,1,:,:) = MATMUL( Bm4_T_Dm, Bm1 ) * Delta
         Klocal_eta(4,2,:,:) = MATMUL( Bm4_T_Dm, Bm2 ) * Delta
         Klocal_eta(4,3,:,:) = MATMUL( Bm4_T_Dm, Bm3 ) * Delta
         Klocal_eta(4,4,:,:) = MATMUL( Bm4_T_Dm, Bm4 ) * Delta

      !   Klocal = Klocal * w_eta
         Klocal_eta =  Klocal_eta * w_eta

         Klocal = Klocal + Klocal_eta

         IF (pcode == 3) THEN
            N1 = xi_m1 * eta_m1   ! (1 - xi)/2 * (1 - eta)/2
            N2 = xi_p1 * eta_m1   ! (1 + xi)/2 * (1 - eta)/2
            N3 = xi_p1 * eta_p1   ! (1 + xi)/2 * (1 + eta)/2
            N4 = xi_m1 * eta_p1   ! (1 - xi)/2 * (1 + eta)/2
            coef = alpha( emtype(eNum) )*Yng / (1 - 2*Pssn)   ! a * E/(1-2v)
            !------
            Thlocal_eta(1,1,1) = coef * DN1Dx * N1
            Thlocal_eta(1,1,2) = coef * DN1Dx * N2
            Thlocal_eta(1,1,3) = coef * DN1Dx * N3
            Thlocal_eta(1,1,4) = coef * DN1Dx * N4
            Thlocal_eta(1,2,1) = coef * DN1Dy * N1
            Thlocal_eta(1,2,2) = coef * DN1Dy * N2
            Thlocal_eta(1,2,3) = coef * DN1Dy * N3
            Thlocal_eta(1,2,4) = coef * DN1Dy * N4
            !------
            Thlocal_eta(2,1,1) = coef * DN2Dx * N1
            Thlocal_eta(2,1,2) = coef * DN2Dx * N2
            Thlocal_eta(2,1,3) = coef * DN2Dx * N3
            Thlocal_eta(2,1,4) = coef * DN2Dx * N4
            Thlocal_eta(2,2,1) = coef * DN2Dy * N1
            Thlocal_eta(2,2,2) = coef * DN2Dy * N2
            Thlocal_eta(2,2,3) = coef * DN2Dy * N3
            Thlocal_eta(2,2,4) = coef * DN2Dy * N4
            !------
            Thlocal_eta(3,1,1) = coef * DN3Dx * N1
            Thlocal_eta(3,1,2) = coef * DN3Dx * N2
            Thlocal_eta(3,1,3) = coef * DN3Dx * N3
            Thlocal_eta(3,1,4) = coef * DN3Dx * N4
            Thlocal_eta(3,2,1) = coef * DN3Dy * N1
            Thlocal_eta(3,2,2) = coef * DN3Dy * N2
            Thlocal_eta(3,2,3) = coef * DN3Dy * N3
            Thlocal_eta(3,2,4) = coef * DN3Dy * N4
            !------
            Thlocal_eta(4,1,1) = coef * DN4Dx * N1
            Thlocal_eta(4,1,2) = coef * DN4Dx * N2
            Thlocal_eta(4,1,3) = coef * DN4Dx * N3
            Thlocal_eta(4,1,4) = coef * DN4Dx * N4
            Thlocal_eta(4,2,1) = coef * DN4Dy * N1
            Thlocal_eta(4,2,2) = coef * DN4Dy * N2
            Thlocal_eta(4,2,3) = coef * DN4Dy * N3
            Thlocal_eta(4,2,4) = coef * DN4Dy * N4
            !------
            Thlocal = Thlocal + Thlocal_eta * w_eta * Delta
         END IF

      END DO  ! end of loop for eta

      Krect = Krect + Klocal * w_xi
      IF (pcode == 3) Threct = Threct + Thlocal * w_xi

   END DO   ! end of loop for xi

   Krect = Krect * thickness(eNum)
   IF (pcode == 3)  Threct = Threct * thickness(eNum)

   RETURN
END SUBROUTINE K_Elast2RectLinear


      subroutine cli_clgen(iwgn)

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine calculates the daylength, distribution of
!!    radiation throughout the day and maximum radiation for day

!!    ~ ~ ~ INCOMING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    j           |none          |HRU number
!!    latcos(:)   |none          |Cos(Latitude) for HRU
!!    latsin(:)   |none          |Sin(Latitude) for HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ OUTGOING VARIABLES ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    frad(:,:)   |none          |fraction of solar radiation occuring during
!!                               |hour in day in HRU
!!    hru_rmx(:)  |MJ/m^2        |maximum possible radiation for the day in HRU
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ LOCAL DEFINITIONS ~ ~ ~
!!    name        |units         |definition
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    sdlat       |none          |(-Tan(sd)*Tan(lat))
!!    cosrho(:)   |none          |Cos(zenith angle for hour)
!!    dd          |none          |relative distance of the earth from the sun
!!    h           |none          |Acos(-Tan(sd)*Tan(lat))
!!    ii          |none          |counter
!!    sd          |radians       |solar declination: latitude at which the sun
!!                               |is directly overhead at noon
!!    totrho      |none          |sum of cosrho values for all hours of day
!!    yc          |none          |Cos(sd)*Cos(lat)
!!    ys          |none          |Sin(sd)*Sin(lat)
!!    w           |none          |hour angle
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~

!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Sin, Tan, Acos, Cos, Real
!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use climate_module
      use time_module
      use hydrograph_module

      implicit none

      integer :: ii               !none          |counter
      integer :: iwgn             !units         |description
      real :: sd                  !radians       |solar declination: latitude at which the sun
                                  !              |is directly overhead at noon
      real :: sdlat               !none          |(-Tan(sd)*Tan(lat))
      real :: h                   !none          |Acos(-Tan(sd)*Tan(lat))
      real :: ys                  !none          |Sin(sd)*Sin(lat)
      real :: yc                  !none          |Cos(sd)*Cos(lat)
      real :: dd                  !none          |relative distance of the earth from the sun
      real :: cosrho(time%step)   !none          |Cos(zenith angle for hour)
      real :: totrho              !none          |sum of cosrho values for all hours of day
      real :: w                   !none          |hour angle

      !! Reset prior day category for precipitation
      if (wst(iwst)%weat%precip >= 0.1) then
        wst(iwst)%weat%precip_prior_day = "wet"
      else
        wst(iwst)%weat%precip_prior_day = "dry"
      end if

      !! Calculate Daylength !!
      !! calculate solar declination: equation 2.1.2 in SWAT manual
      sd = Asin(.4 * Sin((Real(time%day) - 82.) / 58.09))  !!365/2pi = 58.09

      !! calculate the relative distance of the earth from the sun
      !! the eccentricity of the orbit
      !! equation 2.1.1 in SWAT manual
      dd = 1.0 + 0.033 * Cos(Real(time%day) / 58.09)

      !!daylength = 2 * Acos(-Tan(sd) * Tan(lat)) / omega
      !!where the angular velocity of the earth"s rotation, omega, is equal
      !! to 15 deg/hr or 0.2618 rad/hr and 2/0.2618 = 7.6374
      !! equation 2.1.6 in SWAT manual

      sdlat = -wgn_pms(iwgn)%latsin * Tan(sd) / wgn_pms(iwgn)%latcos

      if (sdlat > 1.) then    !! sdlat will be >= 1. if latitude exceeds +/- 66.5 deg in winter
        h = 0.
      elseif (sdlat >= -1.) then
        h = Acos(sdlat)
      else
        h = 3.1416         !! latitude exceeds +/- 66.5 deg in summer
      endif
      wst(iwst)%weat%daylength = 7.6394 * h

      !! Calculate Potential (maximum) Radiation !!
      !! equation 2.2.7 in SWAT manual
      ys = wgn_pms(iwgn)%latsin * Sin(sd)
      yc = wgn_pms(iwgn)%latcos * Cos(sd)
      wst(iwst)%weat%solradmx = 30. * dd * (h * ys + yc * Sin(h))

      !! Calculate fraction of radiation recieved during each hour in day
      !! this calculation assumes solar noon (when the angle between the
      !! observer on the earth to the sun and a line normal to the earth"s
      !! at that position is at a minimum) falls at 12 noon in day.
      !! equation 2.2.10 in SWAT manual

      cosrho = 0.
      totrho = 0.
      do ii = 1, time%step
        !!angular velocity times hour away from solar noon. To calculate
        !!radiation for an hour, the hour angle for the midpoint of the
        !!time period is used. time = 0. at solar noon with positive values
        !! in the morning and negative in the evening
        w = 0.
        w = (12.5 - Real(ii)) * 0.2618 * time%dtm / 60.   !!0.2618 rad/hr
        cosrho(ii) = ys + yc * Cos(w)
        if (cosrho(ii) <= 0.) cosrho(ii) = 0.
        totrho = totrho + cosrho(ii)
      end do
      if (totrho > 0.001) then
        do ii = 1, time%step
          frad(iwgn,ii) = cosrho(ii) / totrho
        end do
      end if

      return
      end subroutine cli_clgen


C++--------------------------------------------------------------------------
C  PROGRAM TO COMPUTE THE PERIOD/ENERGY/RMAX RELATION FOR A GIVEN POTENTIAL
C
C  Initially called "DVHALO"
C
C  P.J.QUINN FEB.82
C
C--------------------------------------------------------------------------
	PROGRAM DVHALO
        IMPLICIT DOUBLE PRECISION (A-H,O-Y)
        DIMENSION ZEN(500,2),ZPERIOD(500,2),ZRMAX(500,2),NPTS(2)
        DIMENSION WN(500),X(500)
        DIMENSION ZRESID(500)
C
        TOL = 0.001

        WRITE(6,1)
   1    FORMAT('0')
        WRITE(6,2)
   2    FORMAT(1X,'PE>> SUPPLY GM1  AND GAMMA1             : '$)
        READ(5,*)GM1,GAMMA1
        WRITE(6,330)
 330    FORMAT(1X,'PE>> SUPPLY HALO CUTOFF  : RCUT         : '$)
        READ(5,*)RCUT
        CHI=RCUT/GAMMA1
C        WRITE(6,100)
C 100    FORMAT(1X,'PE>> SUPPLY GM2 AND GAMMA2              : '$)
C        READ(5,*)GM2,GAMMA2
	GM2=1.
	GAMMA2=1.
 331    WRITE(9,*)GM1,GAMMA1,CHI,GM2,GAMMA2
        RZ=0.
        CALL POT4(RZ,GM1,GAMMA1,CHI,GM2,GAMMA2,PZ)
        WRITE(6,98)PZ
  98    FORMAT(1X,'PE>> CENTRAL POTENTIAL VALUE IS      : ',F12.6)

        WRITE(6,300)
 300    FORMAT(1X,'PE> MIN AND MAX RADII VALUES OF INTEREST',
     1	' (IN Re UNITS): '$)
        READ(5,*)RIN,ROUT
        CALL POT4(RIN,GM1,GAMMA1,CHI,GM2,GAMMA2,EMIN)
        CALL POT4(ROUT,GM1,GAMMA1,CHI,GM2,GAMMA2,EMAX)
        WRITE(6,301)EMIN,EMAX
 301    FORMAT(1X,'PE> POTENTIAL AT RMIN, RMAX  :',F12.6,X,F12.6)

C       WRITE(6,3)
C  3    FORMAT(1X,'PE>> SUPPLY ENERGY RANGE (MIN TO MAX) :'$)
C        READ(5,*)EMIN,EMAX
C        WRITE(6,4)
C   4    FORMAT(1X,'PE>>        # ENERGY INCREMENTS      : '$)
C        READ(5,*)NE
	NE=100
        DELE=(EMAX-EMIN)/(FLOAT(NE)+0.1)
C        WRITE(6,6)
C   6    FORMAT(1X,'PE>>        # SUMMATION TERMS        : '$)
C        READ(5,*)N
	N=20
        CALL POLYNM(N,X)
        print *,'>>Legendre fn. and quad. parameters set <<'
        M=2*N
        CALL WEIGHTS(M,X,WN)
        print *,'>>Weights set <<'
        E=EMIN
        DO 10 I =1,NE
        if(mod(i,10).eq.0) write(6,*) i
        ZEN(I,1)=E
        ZEN(I,2)=E
        CALL FINDR4(GM1,GAMMA1,CHI,GM2,GAMMA2,E,TOL,R)
        ZPERIOD(I,2)=3.14159*(10+DSQRT(R*R+100))**1.5
        ZPERIOD(I,2)=ZPERIOD(I,2)/(2.*DSQRT(2.D+0))
        ZRMAX(I,1)=R
        ZRMAX(I,2)=R
        ANS=0.
        DO 20 K=1,N
          XX=(1.-X(K)*X(K))
          XXX=XX*R
          CALL POT4(XXX,GM1,GAMMA1,CHI,GM2,GAMMA2,P)
          FUN=DSQRT((1.-XX)/(E-P))
          ANS=ANS+FUN*2.*WN(K)
  20    CONTINUE
        ZPERIOD(I,1)=R*1.4142*ANS
        ZRESID(I)=ZPERIOD(I,1)-ZPERIOD(I,2)
        E=E+DELE
  10    continue
 103    DO 30 L=1,NE
        WRITE(10,*)ZPERIOD(L,1),ZRMAX(L,1)
  30    continue
        END
C-------------------------------------------------------------------
C
C SUBROUTINE POT4 TO GENERATE POTENTIAL VALUES
C
C-------------------------------------------------------------------
        SUBROUTINE POT4(R,GM1,GAMMA1,CHI,GM2,GAMMA2,P)
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IF(R.EQ.0.)THEN
          P=-0.5*(GM1/(GAMMA1*(CHI-DATAN(CHI))))*DLOG(1.+CHI*CHI)
          P=P-2.62175
          RETURN
        END IF
        RX=R/GAMMA1
        IF(RX.GT.CHI)THEN
          P=-GM1/R
        ELSE
          T1=0.5*DLOG((1.+R*R/(GAMMA1*GAMMA1))/(1.+CHI*CHI))
          T2=-1.+(1./RX)*DATAN(RX)
          P=(GM1/(GAMMA1*(CHI-DATAN(CHI))))*(T1+T2)
        END IF
          IF(R.GE..1) GO TO 10
        PS=-10.49*(R*DLOG10(R)+.166*R)-2.62175
        P=P+PS
        RETURN
 10       IF(R.GE.1.) GO TO 20
        PS=1.978441+.953731*DLOG10(R)*(1.-.42*DLOG10(R)-
     &     .26*(DLOG10(R))**2)-2.62175
        P=P+PS
        RETURN

 20     R14=R**.25
        PS=-1./R+161.68466*R**(5./8.)*DEXP(-7.66924944*R14)*(1.+
     &     1.3259771/R14+2.2593429/(R14**2)+.14729883/(R14**3)
     &     -9.6032102E-3/R+1.8782563E-3/(R*R14)-6.1226858E-4/(R*R14*R14)
     &     )
        P=P+PS
        RETURN
        END
C--------------------------------------------------------------------------
C
C       SUBROUTINE TO GENERATE THE POTENTIAL
C       DERIVATIVE VALUES.
C
C--------------------------------------------------------------------------
        SUBROUTINE DPOTENTIAL4(R,GM1,GAMMA1,CHI,GM2,GAMMA2,DP)
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        IF(R.EQ.0.)THEN
          DP=0.
          RETURN
        END IF
        RX=R/GAMMA1
        IF(RX.LE.CHI)THEN
          T1=(RX/GAMMA1)*(1./(1.+RX*RX))
          T2=-(GAMMA1/(R*R))*DATAN(RX)
          T3=(1./R)*(1./(1.+RX*RX))
          DP=(GM1/(GAMMA1*(CHI-DATAN(CHI))))*(T1+T2+T3)
        ELSE
          DP=GM1/(R*R)
        END IF
          IF(R.GE.1.E-3) GO TO 10
        R14=R**.25
        DP=DP+621.1*R14*(1.-9.4*R14+46.4*R14**2-102.*R14**3)
        RETURN
 10       IF(R.GE..1) GO TO 20
        DP=DP-10.49*(.6+DLOG10(R))
        RETURN
 20       IF(R.GE.1.) GO TO 30
        DP=DP+.4209595*(1.-.84*DLOG10(R)-.78*(DLOG10(R))**2)/R
        RETURN
 30     R14=R**.25
        DP=DP+(1.-310.*R**(11./8.)*DEXP(-7.66924944*R14)*(2.
     &     +R14+R14**2))/(R**2)
        RETURN
        END
C--------------------------------------------------------------------------
C
C       A SUBROUTINE TO COMPUTE THE TURNING RADII OF
C       A GIVEN POTENTIAL BY NEWTONS METHOD
C
C--------------------------------------------------------------------------
        SUBROUTINE FINDR4(GM1,GAMMA1,CHI,GM2,GAMMA2,E,
     1	TOL,R)
C
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
c       RI=-(GM1+GM2)/(2.*E)
        RI=0.
        CALL POT4(RI,GM1,GAMMA1,CHI,GM2,GAMMA2,P)
        AA=E-P
        ASIGN=AA/DABS(AA)
  99    RI=RI+0.1*(GAMMA1+gamma2)
        CALL POT4(RI,GM1,GAMMA1,CHI,GM2,GAMMA2,P)
        BB=E-P
        if(bb.eq.0.) bsign=asign

        if(bb.ne.0.) BSIGN=BB/DABS(BB)
        IF(ASIGN.NE.BSIGN)GOTO 101
        ASIGN=BSIGN
        GOTO 99
 101    RI=RI-0.1*(GAMMA1+gamma2)/2.
   10   CALL POT4(RI,GM1,GAMMA1,CHI,GM2,GAMMA2,P)
C       CALL DPOTENTIAL(RI,GM,GAMMA,DP)
C       CALL DPOTENTIAL3(RI,GM,GAMMA,CHI,DP)
        CALL DPOTENTIAL4(RI,GM1,GAMMA1,CHI,GM2,GAMMA2,DP)
        DP=-DP
        RI2=RI-(E-P)/DP
C       WRITE(6,*)RI,RI2
        DEL=ABS(RI-RI2)
        IF(DEL.LE.TOL)GOTO 20
        RI=RI2
        GOTO 10
 20     R=RI2
        RETURN
        END
C--------------------------------------------------------------------------
C
C       SUBROUTINE TO GENERATE GAUSSIAN WEIGHTS.
C
C--------------------------------------------------------------------------
        SUBROUTINE WEIGHTS(N,X,WN)
C
C
        IMPLICIT DOUBLE PRECISION (A-H,O-Z)
        DIMENSION WN(1),X(1)
C
        DIMENSION P(1000),DP(1000)
C
        FF=FLOAT(N)/2.
        FAC=FF-N/2
        IF(FAC.NE.0.)THEN
          NN=INT(FF)+1
        ELSE
          NN=INT(FF)
        END IF
        DO 50 M=1,NN
          XX=X(M)
          P(1)=1
          P(2)=XX
          DO 10 I=3,N+1
            T1=(2*FLOAT(I-2)+1)*XX*P(I-1)
            T2=FLOAT(I-2)*P(I-2)
	    P(I)=(T1-T2)/FLOAT(I-1)
10	  CONTINUE
C       WRITE(6,*)(P(K),K=1,N+1)
          DP(1)=0
          DO 20 K=2,N+1
            T3=-FLOAT(K-1)*XX*P(K)
            T4=FLOAT(K-1)*P(K-1)
            DP(K)=(1./(1-XX*XX))*(T3+T4)
20	  CONTINUE
C         WRITE(6,*)(DP(K),K=1,N+1)
          WN(M)=2./((1-XX*XX)*DP(N+1)*DP(N+1))
  50    CONTINUE
        RETURN
        END

C-----------------------------------------------------------------------
C Subroutine POLYNM
C----------------------------------------------------------------------
        SUBROUTINE POLYNM(NP,XI)
C       *** COMPUTES LEGENDRE FUNCTIONS, AND QUADRATURE PARAMETERS.
        DOUBLE PRECISION X,XJ,PL,DPL,P(257),DP(257),XI(1)
C       DIMENSION XI(1)
        N=NP+NP
        PIN=1.5707963/(N+N+1)
        PL=1D0
        P(1)=1D0
        DP(1)=0D0
        DO 40 MJ=1,NP
        M=NP-MJ+1
        THE=(4*M-1)*PIN
        Y=THE+1.0/(8*N*N*TAN(THE))
        X=COS(Y)
 35     P(2)=X
        DP(2)=1D0-X*X
        IF (N.LE.1) GO TO 20
        DO 30 J=2,N
        XJ=J
        P(J+1)=((J+J-1)*X*P(J)-(J-1)*P(J-1))/XJ
 30     DP(J+1)=XJ*(P(J)-X*P(J+1))
 20     PL=P(N+1)
        DPL=DP(N+1)/(1D0-X*X)
        X=X-PL/DPL
        IF (DABS(PL).GE.1D-9) GO TO 35
        XI(MJ)=X
 40     CONTINUE
        RETURN
        END


c     Subroutine to find time interval between successive measurements
c     AJ_Kettle, Dec6/2017

      SUBROUTINE find_time_interval(f_ndflag,l_mlent,j_sd,
     +  st_sd_year,st_sd_month,st_sd_day,st_sd_timeutc_hh_mm_ss,
     +  f_deltime_s)

      IMPLICIT NONE
c************************************************************************
      REAL                :: f_ndflag

      INTEGER             :: l_mlent
      INTEGER             :: j_sd

      CHARACTER(LEN=4)    :: st_sd_year(l_mlent)
      CHARACTER(LEN=2)    :: st_sd_month(l_mlent)
      CHARACTER(LEN=2)    :: st_sd_day(l_mlent)
      CHARACTER(LEN=8)    :: st_sd_timeutc_hh_mm_ss(l_mlent)

      DOUBLE PRECISION    :: d_jday,d_jday_vec(l_mlent)

      INTEGER             :: i,j,k,ii,jj,kk

      CHARACTER(LEN=4)    :: s_year
      CHARACTER(LEN=2)    :: s_month
      CHARACTER(LEN=2)    :: s_day
      CHARACTER(LEN=2)    :: s_hour
      CHARACTER(LEN=2)    :: s_minute
      CHARACTER(LEN=2)    :: s_second
      CHARACTER(LEN=8)    :: s_time_single

      REAL                :: f_year
      REAL                :: f_month
      REAL                :: f_day
      REAL                :: f_hour
      REAL                :: f_minute
      REAL                :: f_second

      REAL                :: f_test

      REAL                :: f_deltime_s(l_mlent)
      REAL                :: f_min_deltime_s
      REAL                :: f_max_deltime_s
c************************************************************************
c      print*,'just entered find_time_interval'

c     Find julian time for each record
      DO i=1,j_sd

       s_year        =st_sd_year(i)
       s_month       =st_sd_month(i)
       s_day         =st_sd_day(i)

       s_time_single =st_sd_timeutc_hh_mm_ss(i)
       s_hour        =s_time_single(1:2)
       s_minute      =s_time_single(4:5)
       s_second      =s_time_single(7:8)

c      Convert to floats
       READ(s_year,*) f_test
       f_year      =f_test
       READ(s_month,*) f_test
       f_month     =f_test
       READ(s_day,*) f_test
       f_day       =f_test
       READ(s_hour,*) f_test
       f_hour      =f_test
       READ(s_minute,*) f_test
       f_minute    =f_test
       READ(s_second,*) f_test
       f_second    =f_test

       d_jday=DBLE( 367.0*f_year-
     +   INT(7.0*(f_year+INT((f_month+9.0)/12.0))/4.0)-
     +   INT(3.0*(INT((f_year+INT((f_month-9.0)/7.0))/100.0)+1.0)/4.0)+
     +   INT(275.0*f_month/9.0)+f_day ) +
     +   DBLE(100000.0)+
     +   DBLE(f_hour/24.0)+DBLE(f_minute/(24.0*60.0))+
     +   DBLE(f_second/(24.0*3600.0))

       d_jday_vec(i)=d_jday

c       print*,'d_jday=',d_jday
c       print*,'year=',  s_year,f_year
c       print*,'month=', s_month,f_month
c       print*,'day=',   s_day,f_day
c       print*,'hour=',  s_hour,f_hour
c       print*,'minute=',s_minute,f_minute
c       print*,'second=',s_second,f_second
c       CALL SLEEP(1)

      ENDDO

c     Find time interval
c      print*,'just before time interval calculator'
      ii=0
      jj=0
c     Initialize deltime variable
      DO i=1,j_sd
       f_deltime_s(i)=f_ndflag
      ENDDO
      DO i=1,j_sd-1
       f_deltime_s(i+1)=(d_jday_vec(i+1)-d_jday_vec(i))*3600.0*24.0

c      Place ndflag if deltime>0.5days
       IF (f_deltime_s(i+1).GT.0.5*3600.0*24.0) THEN
        f_deltime_s(i+1)=f_ndflag
        ii=ii+1
       ENDIF
       IF (.NOT.(f_deltime_s(i+1).GT.0.5*3600.0*24.0)) THEN
        jj=jj+1
       ENDIF

c       print*,'f_deltime_s(i+1)=',i,f_deltime_s(i+1)
c       CALL SLEEP(1)
      ENDDO

c      print*,'f_deltime_s=',(f_deltime_s(i),i=1,5)
c      print*,'number ndflag deltime,j_sd=',ii,j_sd
c      print*,'number good deltime,  j_sd=',jj,j_sd

c     Find min & max of time interval
      f_min_deltime_s=50000.0
      f_max_deltime_s=0.0
      DO i=2,j_sd
       f_min_deltime_s=MIN(f_min_deltime_s,f_deltime_s(i))
       f_max_deltime_s=MAX(f_max_deltime_s,f_deltime_s(i))
      ENDDO

c      print*,'f_min_deltime_s=',f_min_deltime_s
c      print*,'f_max_deltime_s=',f_max_deltime_s

c      print*,'f_min_deltime_d=',f_min_deltime_s/(24.0*3600.0)
c      print*,'f_max_deltime_d=',f_max_deltime_s/(24.0*3600.0)
c************************************************************************
c      print*,'just leaving find_time_interval'
c      CALL SLEEP(5)

      RETURN
      END


! MIT License
!
! Copyright (c) 2017 Lars Andersen Bratholm
!
! 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 fastmath

    implicit none

contains

function fast_erf(x2, x, n, m, k) result(val)

    double precision, dimension(n), intent(in) :: x2
    double precision, dimension(n), intent(in) :: x
    integer, intent(in) :: m
    integer, intent(in) :: n
    double precision, intent(in) :: k

    double precision, dimension(n) :: val

    val = -0.6956521739130435d0 * x2 - 1.1283791670955126d0 * x
    val = 1.0d0 - fast_exp(val, n, m, k)

    ! second order
    !val = 1.0d0 - 0.7897872340425532 * fast_exp(-0.9069444444444444 * x2-0.749958629819626*x,n,m,k) &
    !    & -0.21021276595744676 * fast_exp(-0.9069444444444444 * x2-2.5501372990470221*x,n,m,k)

    ! exact
    !val = erf(x)

end function fast_erf

function fast_exp(x, n, m, k) result(val)
    double precision, dimension(n), intent(in) :: x
    integer, intent(in) :: n
    integer, intent(in) :: m
    double precision, intent(in) :: k

    integer :: i
    double precision, dimension(n) :: val

    val = (1.0d0+k*x)

    ! Makes sure the expression converges
    where (val < 0.0d0) val = 0.0d0

    do i=2, m
        val = val * val
    enddo

    ! exact
    !val = exp(x)

end function fast_exp

end module fastmath

!! Algorithm 2 but subtracting the mean of each feature
!! in the preprocessing
!subroutine fffn(features, seed, nmax, nmem, final_ordering)
!
!    implicit none
!
!    double precision, dimension(:,:), intent(in) :: features
!    integer, intent(in) :: seed
!    integer, intent(in) :: nmax
!    integer, intent(in) :: nmem
!    integer, dimension(nmax), intent(out) :: final_ordering
!
!    double precision, allocatable, dimension(:) :: means
!    double precision, allocatable, dimension(:) :: feature_means
!    double precision, allocatable, dimension(:) :: std
!    integer, allocatable, dimension(:) :: ordering
!
!    integer :: partition_size, remainder, nsamples, nfeatures
!    integer :: i, j, k, idx, n, m, p, l
!    double precision :: maxdist, ub, d, huge_double, lb, tmp
!
!    nsamples = size(features,dim=1)
!    nfeatures = size(features, dim=2)
!
!    ! Allocate temporary
!    allocate(means(nsamples))
!    allocate(feature_means(nfeatures))
!    allocate(std(nsamples))
!    allocate(ordering(nsamples))
!
!    huge_double = huge(1.0d0)
!
!    ! Begin preprocessing
!    means = 0.0d0
!    std = 0.0d0
!
!    feature_means = sum(features, dim=1) / nsamples
!
!    !$OMP PARALLEL DO
!    do i = 1, nsamples
!        means(i) = sum(features(i,:) - feature_means) / nfeatures
!        std(i) = sqrt(sum((features(i,:) - feature_means - means(i))**2) / nfeatures)
!    enddo
!    !$OMP END PARALLEL DO
!
!    ! Initialize the ordering
!    ordering = (/ (i, i = 1, nsamples) /)
!
!    ! The first item will be the seed
!    ordering(seed) = ordering(1)
!    ordering(1) = seed
!
!
!    ! Do the actual algorithm
!    do i = 2, nmax
!        p = ordering(i)
!        maxdist = 0.0d0
!        idx = i
!        do j = i, nsamples
!            n = ordering(j)
!            d = huge_double
!            !$OMP PARALLEL DO PRIVATE(m, lb, ub, tmp) REDUCTION(min:d)
!            do k = max(1, i - nmem), i-1
!                if (d <= maxdist) then
!                    cycle
!                endif
!
!                m = ordering(k)
!                tmp = (means(n) - means(m))**2 + std(n)**2 + std(m)**2
!                ub = nfeatures * (tmp + 2*std(n)*std(m))
!
!                if (ub <= maxdist) then
!                    d = 0.0d0
!                    cycle
!                endif
!
!                lb = nfeatures * (tmp - 2*std(n)*std(m))
!
!                if (lb >= d) then
!                    cycle
!                endif
!
!                d = min(d,sum((features(n,:) - features(m,:))**2))
!
!            enddo
!            !$OMP END PARALLEL DO
!
!            if (d > maxdist) then
!                idx = j
!                maxdist = d
!            endif
!        enddo
!
!        ordering(i) = ordering(idx)
!        ordering(idx) = p
!    enddo
!
!
!    ! Generate output in python format
!    final_ordering = ordering(:nmax) - 1
!
!    ! Deallocate temporary
!    deallocate(means)
!    deallocate(feature_means)
!    deallocate(std)
!    deallocate(ordering)
!
!end subroutine fffn

! Algorithm 4 but subtracting the mean of each feature
! in the preprocessing
subroutine fiffn(features, seed, npartitions, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: npartitions
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    double precision, allocatable, dimension(:,:) :: means
    double precision, allocatable, dimension(:) :: feature_means
    double precision, allocatable, dimension(:) :: tmp
    double precision, allocatable, dimension(:,:) :: std
    integer, allocatable, dimension(:) :: ordering
    integer, allocatable, dimension(:) :: weights

    integer :: partition_size, remainder, nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p
    double precision :: maxdist, ub, d, huge_double, lb

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Repartition the features
    partition_size = int(nfeatures/npartitions)
    remainder = mod(nfeatures, partition_size)

    if (remainder == 0) then
        remainder = partition_size
    else
        partition_size = partition_size + 1
        remainder = mod(nfeatures, partition_size)
    endif

    ! Allocate temporary
    allocate(means(nsamples, npartitions))
    allocate(feature_means(nfeatures))
    allocate(std(nsamples, npartitions))
    allocate(weights(npartitions))
    allocate(tmp(npartitions))
    allocate(ordering(nsamples))

    huge_double = huge(1.0d0)

    ! Begin preprocessing
    means = 0.0d0
    std = 0.0d0

    feature_means = sum(features, dim=1) / nsamples

    !$OMP PARALLEL DO PRIVATE(idx)
    do i = 1, nsamples
        do j = 1, npartitions-1
            idx = (j-1) * partition_size
            means(i,j) = sum(features(i, idx+1:idx+partition_size) - feature_means(idx+1:idx+partition_size)) / partition_size
            std(i,j) = sqrt(sum((features(i, idx+1:idx+partition_size) - &
                & feature_means(idx+1:idx+partition_size) - means(i,j))**2) / partition_size)
        enddo

        means(i,npartitions) = sum(features(i, (npartitions-1)*partition_size+1:) - &
            & feature_means((npartitions-1)*partition_size+1:)) / remainder
        std(i,npartitions) = sqrt(sum((features(i, (npartitions-1)*partition_size+1:) &
            & - feature_means((npartitions-1)*partition_size+1:) - means(i,npartitions))**2) / remainder)
    enddo
    !$OMP END PARALLEL DO

    weights = partition_size
    weights(npartitions) = remainder
    ! end preprocessing

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m, ub, lb, tmp)
            do k = max(1, i - nmem), i-1
                if (d <= maxdist) then
                    cycle
                endif

                m = ordering(k)
                tmp = (means(n,:) - means(m,:))**2 + std(n,:)**2 + std(m,:)**2
                ub = sum(weights * (tmp + 2*std(n,:)*std(m,:)))

                if (ub <= maxdist) then
                    d = 0.0d0
                    cycle
                endif

                lb = sum(weights * (tmp - 2*std(n,:)*std(m,:)))

                if (lb >= d) then
                    cycle
                endif

                d = min(d,sum((features(n,:) - features(m,:))**2))

            enddo
            !$OMP END PARALLEL DO

            if (d > maxdist) then
                idx = j
                maxdist = d
            endif

        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(means)
    deallocate(feature_means)
    deallocate(std)
    deallocate(tmp)
    deallocate(ordering)
    deallocate(weights)

end subroutine fiffn

! Brute force approach (Algorithm 5 but for furthest neighbours)
subroutine fobf(features, seed, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    integer, allocatable, dimension(:) :: ordering

    integer :: nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p
    double precision :: maxdist,  d, huge_double

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Allocate temporary
    allocate(ordering(nsamples))
    huge_double = huge(1.0d0)

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m)
            do k = max(1, i - nmem), i-1
                if (d <= maxdist) then
                    cycle
                endif
                m = ordering(k)
                d = min(sum((features(n,:) - features(m,:))**2),d)
            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(ordering)

end subroutine fobf

! Variation that uses an approximation to the l2 distance
subroutine fifafn(features, seed, npartitions, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: npartitions
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    double precision, allocatable, dimension(:,:) :: means
    double precision, allocatable, dimension(:) :: feature_means
    double precision, allocatable, dimension(:,:) :: var
    integer, allocatable, dimension(:) :: ordering
    integer, allocatable, dimension(:) :: weights

    integer :: partition_size, remainder, nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p
    double precision :: maxdist, d, huge_double

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Repartition the features
    partition_size = int(nfeatures/npartitions)
    remainder = mod(nfeatures, partition_size)

    if (remainder == 0) then
        remainder = partition_size
    else
        partition_size = partition_size + 1
        remainder = mod(nfeatures, partition_size)
    endif

    ! Allocate temporary
    allocate(means(nsamples, npartitions))
    allocate(feature_means(nfeatures))
    allocate(var(nsamples, npartitions))
    allocate(weights(npartitions))
    allocate(ordering(nsamples))

    huge_double = huge(1.0d0)

    ! Begin preprocessing
    means = 0.0d0
    var = 0.0d0

    feature_means = sum(features, dim=1) / nsamples

    !$OMP PARALLEL DO PRIVATE(idx)
    do i = 1, nsamples
        do j = 1, npartitions-1
            idx = (j-1) * partition_size
            means(i,j) = sum(features(i, idx+1:idx+partition_size) - feature_means(idx+1:idx+partition_size)) / partition_size
            var(i,j) = (sum((features(i, idx+1:idx+partition_size) - &
                & feature_means(idx+1:idx+partition_size) - means(i,j))**2) / partition_size)
        enddo

        means(i,npartitions) = sum(features(i, (npartitions-1)*partition_size+1:) - &
            & feature_means((npartitions-1)*partition_size+1:)) / remainder
        var(i,npartitions) = (sum((features(i, (npartitions-1)*partition_size+1:) &
            & - feature_means((npartitions-1)*partition_size+1:) - means(i,npartitions))**2) / remainder)
    enddo
    !$OMP END PARALLEL DO

    weights = partition_size
    weights(npartitions) = remainder
    ! end preprocessing

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        ! Redundant extra calculation, but might be better to start with a realistic guess
        ! than 0 depending on the parallelisation
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m)
            do k = max(1, i - nmem), i-1
                if (d <= maxdist) then
                    cycle
                endif

                m = ordering(k)
                d = sum(weights * ((means(n,:) - means(m,:))**2 + var(n,:) + var(m,:)))

            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            ! and allows for easy parallelisation
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(means)
    deallocate(feature_means)
    deallocate(var)
    deallocate(ordering)
    deallocate(weights)

end subroutine fifafn

! l1-distance brute force approach, with distances stored in memory
subroutine fobf_l1_inmem(features, seed, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    integer, allocatable, dimension(:) :: ordering
    real, allocatable, dimension(:) :: distances

    integer :: nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p,r,s
    double precision :: maxdist,  d, huge_double

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Allocate temporary
    allocate(ordering(nsamples))
    allocate(distances((nsamples*(nsamples-1))/2))
    huge_double = huge(1.0d0)

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    !$OMP PARALLEL DO SCHEDULE(dynamic)
    do i = 1, nsamples-1
        do j = i+1, nsamples
            distances(((2*i-2)*nsamples+2*j-i**2-i)/2) = sum(abs(features(i,:)-features(j,:)))
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m)
            do k = max(1, i - nmem), i-1
                m = ordering(k)
                if (n > m) then
                    d = min(d, distances(((2*m-2)*nsamples+2*n-m**2-m)/2))
                else
                    d = min(d, distances(((2*n-2)*nsamples+2*m-n**2-n)/2))
                endif

            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(ordering)

end subroutine fobf_l1_inmem

! l2-distance brute force approach, with distances stored in memory
subroutine fobf_l2_inmem(features, seed, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    integer, allocatable, dimension(:) :: ordering
    real, allocatable, dimension(:) :: distances

    integer :: nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p,r,s
    double precision :: maxdist,  d, huge_double

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Allocate temporary
    allocate(ordering(nsamples))
    allocate(distances((nsamples*(nsamples-1))/2))
    huge_double = huge(1.0d0)

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    !$OMP PARALLEL DO SCHEDULE(dynamic)
    do i = 1, nsamples-1
        do j = i+1, nsamples
            distances(((2*i-2)*nsamples+2*j-i**2-i)/2) = sum((features(i,:)-features(j,:))**2)
        enddo
    enddo
    !$OMP END PARALLEL DO

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m)
            do k = max(1, i - nmem), i-1
                m = ordering(k)
                if (n > m) then
                    d = min(d, distances(((2*m-2)*nsamples+2*n-m**2-m)/2))
                else
                    d = min(d, distances(((2*n-2)*nsamples+2*m-n**2-n)/2))
                endif
            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(ordering)

end subroutine fobf_l2_inmem

! l1-distance brute force approach
subroutine fobf_l1(features, seed, nmax, nmem, final_ordering)

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: nmax
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    integer, allocatable, dimension(:) :: ordering

    integer :: nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p
    double precision :: maxdist,  d, huge_double

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Allocate temporary
    allocate(ordering(nsamples))
    huge_double = huge(1.0d0)

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m)
            do k = max(1, i - nmem), i-1
                if (d <= maxdist) then
                    cycle
                endif
                m = ordering(k)
                d = min(sum(abs(features(n,:) - features(m,:))),d)
            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(ordering)

end subroutine fobf_l1

! Variation that uses an approximation to the l1 distance
! Slightly more complicated than the l2 case but fast implementations
! of erf and exp should keep the speed reasonable
subroutine fifafn_l1(features, seed, npartitions, nmax, exp_approx_factor, nmem, final_ordering)

    use fastmath, only: fast_erf, fast_exp

    implicit none

    double precision, dimension(:,:), intent(in) :: features
    integer, intent(in) :: seed
    integer, intent(in) :: npartitions
    integer, intent(in) :: nmax
    integer, intent(in) :: exp_approx_factor
    integer, intent(in) :: nmem
    integer, dimension(nmax), intent(out) :: final_ordering

    double precision, allocatable, dimension(:,:) :: means
    double precision, allocatable, dimension(:,:) :: var
    double precision, allocatable, dimension(:) :: sigma, mu, expon, sigma2, feature_means
    integer, allocatable, dimension(:) :: ordering, weights

    integer :: partition_size, remainder, nsamples, nfeatures
    integer :: i, j, k, idx, n, m, p
    double precision :: maxdist, d, pi, sqrt_2_over_pi, one_over_sqrt_2, c1, huge_double, dd

    pi = 4.0d0 * atan(1.0d0)
    huge_double = huge(1.0d0)

    nsamples = size(features,dim=1)
    nfeatures = size(features, dim=2)

    ! Repartition the features
    partition_size = int(nfeatures/npartitions)
    remainder = mod(nfeatures, partition_size)

    if (remainder == 0) then
        remainder = partition_size
    else
        partition_size = partition_size + 1
        remainder = mod(nfeatures, partition_size)
    endif

    ! Allocate temporary
    allocate(means(nsamples, npartitions))
    allocate(var(nsamples, npartitions))
    allocate(ordering(nsamples))
    allocate(sigma(npartitions))
    allocate(sigma2(npartitions))
    allocate(mu(npartitions))
    allocate(feature_means(nfeatures))
    allocate(expon(npartitions))
    allocate(weights(npartitions))

    ! Begin preprocessing
    means = 0.0d0
    var = 0.0d0
    weights = partition_size
    weights(npartitions) = remainder

    feature_means = sum(features, dim=1) / nsamples

    !$OMP PARALLEL DO PRIVATE(idx)
    do i = 1, nsamples
        do j = 1, npartitions-1
            idx = (j-1) * partition_size
            means(i,j) = sum(features(i, idx+1:idx+partition_size) - feature_means(idx+1:idx+partition_size)) / partition_size
            var(i,j) = (sum((features(i, idx+1:idx+partition_size) - &
                & feature_means(idx+1:idx+partition_size) - means(i,j))**2) / partition_size)
        enddo

        means(i,npartitions) = sum(features(i, (npartitions-1)*partition_size+1:) - &
            & feature_means((npartitions-1)*partition_size+1:)) / remainder
        var(i,npartitions) = (sum((features(i, (npartitions-1)*partition_size+1:) &
            & - feature_means((npartitions-1)*partition_size+1:) - means(i,npartitions))**2) / remainder)
    enddo
    !$OMP END PARALLEL DO

    ! Initialize the ordering
    ordering = (/ (i, i = 1, nsamples) /)

    ! The first item will be the seed
    ordering(seed) = ordering(1)
    ordering(1) = seed

    sqrt_2_over_pi = sqrt(2.0d0/pi)
    one_over_sqrt_2 = 1.0d0 / sqrt(2.0d0)

    c1 = 0.5d0**exp_approx_factor

    ! TODO: parallelise in some way, ie. threadlocking maxdist
    ! Do the actual algorithm
    do i = 2, nmax
        p = ordering(i)
        maxdist = 0.0d0
        idx = i
        do j = i, nsamples
            n = ordering(j)
            d = huge_double
            !$OMP PARALLEL DO REDUCTION(min:d) PRIVATE(m, mu, sigma2, sigma, expon, dd)
            do k = max(1, i - nmem), i-1
                if (d <= maxdist) then
                    cycle
                endif
                m = ordering(k)
                mu = abs(means(n,:) - means(m,:))
                sigma2 = var(n,:) + var(m,:)
                sigma = sqrt(sigma2)
                expon = 0.5d0 * mu**2 / sigma2
                d = sum(weights * (sqrt_2_over_pi * sigma * fast_exp(-expon, npartitions, exp_approx_factor, c1) + &
                    & abs(mu) * fast_erf(expon, sqrt(expon), npartitions, exp_approx_factor, c1)))
                !d = sum(weights * (sqrt_2_over_pi * sigma * exp(-expon) + &
                !    & abs(mu) * erf(sqrt(expon))))
                !write(*,*) d, dd,sum(abs(features(n,:) - features(m,:)))

            enddo
            !$OMP END PARALLEL DO

            ! Having this outside the loop is somewhat faster
            if (d > maxdist) then
                idx = j
                maxdist = d
            endif
        enddo

        ordering(i) = ordering(idx)
        ordering(idx) = p
    enddo

    ! Generate output in python format
    final_ordering = ordering(:nmax) -1

    ! Deallocate temporary
    deallocate(means)
    deallocate(feature_means)
    deallocate(var)
    deallocate(ordering)
    deallocate(sigma)
    deallocate(sigma2)
    deallocate(mu)
    deallocate(expon)
    deallocate(weights)

end subroutine fifafn_l1


SUBROUTINE CHARGE(RX,S,FPIV,FUNCT,DELTA,JEND,SUM)
  USE param, ONLY: NRAD
  IMPLICIT NONE
  REAL*8, intent(out):: SUM
  REAL*8, intent(in) :: RX(NRAD), FUNCT(NRAD)
  REAL*8, intent(in) :: S, FPIV, DELTA
  INTEGER, intent(in):: JEND
  ! locals
  INTEGER :: NPOINT, JS, JF, J

  SUM=0.0D0
  NPOINT=JEND
  JS=2-MOD(NPOINT,2)
  JF=JEND-2
  DO J=JS,JF,2
     SUM=SUM+FUNCT(J)*RX(J)+4.*FUNCT(J+1)*RX(J+1)+FUNCT(J+2)*RX(J+2)
  ENDDO
  SUM=SUM*DELTA/3.0D0
  SUM=SUM+(1-MOD(NPOINT,2))*( FUNCT(1)+FUNCT(JS) )/ 2.0D0*( RX(JS)-RX(1))
  SUM=SUM*FPIV*S
  RETURN
END SUBROUTINE CHARGE


program GDINV

!-------------------------------------------------------
!    GEODETIC DATA INVERSION WITH abic MINIMUM CRITERION
!
!    @@@ ATTENTION @@@
!          YOU MUST ALREADY PROCESSED PROGRAM GDJAC
!-------------------------------------------------------

use prm_matrix
use prm_inv
use prm_var

use mod_ctpinv
use mod_setinv
use mod_sabicm
use mod_inv
use mod_dissou

implicit none

integer :: nsource, icm, isel, i, j, lname
character(len=24) :: flobspd, cal, fmp, hd, fctp = "                        "
	character(len=24) :: fcalp = "                        "
	character(len=24) :: fobsp = "                        "
	character(len=24) :: fo_cp = "                        "

open(77,file='../tmp/gdinv.out')

call getarg(1,fctp)

open(9,file=fctp)
	CALL SETCP(hd,flobspd,cal,fmp,nsource)
close(9)

open(33,file=flobspd,status='old')
	CALL INPUTD(33)
close(33)

CALL SETUP(flobspd,nsource,icm,0)
CALL SETWT

if(icm /= 0) CALL CHGPM

CALL SABICM(icm,isel)

if(isel /= 2) then

! === CALL DRESID ===
	ysl(1:itotal) = 0.d0
	do j = 1, jsp
		do i = 1, itotal
			ysl(i) = ysl(i) + zz(i,j) * x(j)
		end do
	end do

	do i = 1, itotal
		ysl(i) = ysl(i) * dabs(ee(i))
		yy(i)  = yy(i)  * dabs(ee(i))
	end do
! === /DRESID ===

	lname = len_trim(cal)
	fcalp(1:lname-4) = cal(1:lname-4)
	fobsp(1:lname-4) = cal(1:lname-4)
	fo_cp(1:lname-4) = cal(1:lname-4)
	fcalp(lname-3:lname+4) = "_cal.dat"
	fobsp(lname-3:lname+4) = "_obs.dat"
	fo_cp(lname-3:lname+4) = "_o_c.dat"

	open(60,file=fcalp)
	open(61,file=fobsp)
	open(62,file=fo_cp)

	open(21,file=cal,status='unknown')
		CALL OUTDAT(hd)
	close(21)

	close(60)
	close(61)
	close(62)

	CALL COVAR

	if(icm /= 0) CALL CHGIMP

	open(22,file=fmp,status='unknown')
		CALL OUTSOL(hd,flobspd,nsource)
	close(22)

	CALL DISSOU(hd,nsource)

end if

close(77)

end


      PROGRAM LA_SGGGLM_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GGGLM
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" .
      INTEGER :: I, J, INFO, M, N, P
!  .. "Local Arrays" ..
      REAL(WP), ALLOCATABLE :: A(:,:), B(:,:), D(:), X(:), Y(:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GGGLM Example Program Results'
      M=5; N = 4; P = 2
      ALLOCATE( A(M,N), B(M,P), D(M), X(N), Y(P) )

      OPEN(UNIT=21,FILE='ggglm.ma',STATUS='UNKNOWN')
      DO I=1,M
         DO J=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      OPEN(UNIT=22,FILE='ggglm.mb',STATUS='UNKNOWN')
      DO I=1,M
         DO J=1,P
            READ(22,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(22)

      OPEN(UNIT=24,FILE='ggglm.d',STATUS='UNKNOWN')
      DO I=1,M
         READ(24,*) D(I)
      ENDDO
      CLOSE(24)

      WRITE(*,*)'Matrix A :'
      DO I=1,M;
         WRITE(*,"(4(F9.5))") A(I,:);
      ENDDO
      WRITE(*,*)'Matrix B :'
      DO I=1,M;
         WRITE(*,"(2(F9.5))") B(I,:);
      ENDDO
      WRITE(*,*)'Vector D :'
      DO I=1,M;
         WRITE(*,"(F9.5))") D(I);
      ENDDO

      WRITE(*,*) 'CALL LA_GGGLM( A, B, D, X, Y, INFO )'
      CALL LA_GGGLM( A, B, D, X, Y, INFO )
      WRITE(*,*) 'X on exit:'
      DO I=1,N; WRITE(*,"(E14.6)") X(I); ENDDO

      WRITE(*,*) 'Y on exit:'
      DO I=1,P; WRITE(*,"(E14.6)") Y(I); ENDDO

      WRITE(*,*)'INFO = ',INFO

      END PROGRAM LA_SGGGLM_EXAMPLE


      subroutine matvett(nmax,NN,NTERM,IAT,IAC,COEF,x,r)
      implicit none
      integer nmax,nterm
      integer i,j,IAC(nmax),IAT(nterm),NN,ind
      real*8 COEF(nterm),x(nmax),r(nmax)
C     prodotto matrice-vettore nel caso di matrice simmetrica scritta
C     in forma compatta  Ax=r
C     COEF coefficienti non nulli della matrice simmetrica A
C     IAT indice di topologia di A
C     IAC indice di colonne di A
C     IAT(i).LE.j.LT.IAT(i+1) -- COEF(j)=A(i,IAC(j))
      do i=1,NN
         r(i)=0.d0
      end do
      do i=1,NN
         ind=IAT(i)
         r(i)=r(i)+COEF(ind)*x(IAC(ind))
         do j=ind+1,IAT(i+1)-1
            r(i)=r(i)+COEF(j)*x(IAC(j))
            r(IAC(j))=r(IAC(j))+COEF(j)*x(i)
         end do
      end do
      end