      SUBROUTINE MB01XY( UPLO, N, A, LDA, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix product U' * U or L * L', where U and L are
C     upper and lower triangular matrices, respectively, stored in the
C     corresponding upper or lower triangular part of the array A.
C
C     If UPLO = 'U' then the upper triangle of the result is stored,
C     overwriting the matrix U in A.
C     If UPLO = 'L' then the lower triangle of the result is stored,
C     overwriting the matrix L in A.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which triangle (U or L) is given in the array A,
C             as follows:
C             = 'U':  the upper triangular part U is given;
C             = 'L':  the lower triangular part L is given.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the triangular matrices U or L.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array must contain the upper
C             triangular matrix U.
C             On entry, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array must contain the lower
C             triangular matrix L.
C             On exit, if UPLO = 'U', the leading N-by-N upper
C             triangular part of this array contains the upper
C             triangular part of the product U' * U. The strictly lower
C             triangular part is not referenced.
C             On exit, if UPLO = 'L', the leading N-by-N lower
C             triangular part of this array contains the lower
C             triangular part of the product L * L'. The strictly upper
C             triangular part is not referenced.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= max(1,N).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The matrix product U' * U or L * L' is computed using BLAS 2 and
C     BLAS 1 operations (an unblocked algorithm).
C
C     FURTHER COMMENTS
C
C     This routine is a counterpart of LAPACK Library routine DLAUU2,
C     which computes the matrix product U * U' or L' * L.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Nov. 2000.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ONE
      PARAMETER         ( ONE = 1.0D0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, LDA, N
C     ..
C     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I
      DOUBLE PRECISION   AII
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT
      EXTERNAL           DDOT, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMV, DSCAL, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01XY', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      IF( UPPER ) THEN
C
C        Compute the product U' * U.
C
         A( N, N ) = DDOT( N, A( 1, N ), 1, A( 1, N ), 1 )
C
         DO 10 I = N-1, 2, -1
            AII = A( I, I )
            A( I, I ) = DDOT( I, A( 1, I ), 1, A( 1, I ), 1 )
            CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ), LDA,
     $                  A( 1, I ), 1, AII, A( I, I+1 ), LDA )
   10    CONTINUE
C
         IF( N.GT.1 ) THEN
            AII = A( 1, 1 )
            CALL DSCAL( N, AII, A( 1, 1 ), LDA )
         END IF
C
      ELSE
C
C        Compute the product L * L'.
C
         A( N, N ) = DDOT( N, A( N, 1 ), LDA, A( N, 1 ), LDA )
C
         DO 20 I = N-1, 2, -1
            AII = A( I, I )
            A( I, I ) = DDOT( I, A( I, 1 ), LDA, A( I, 1 ), LDA )
            CALL DGEMV( 'No Transpose', N-I, I-1, ONE, A( I+1, 1 ),
     $                  LDA, A( I, 1 ), LDA, AII, A( I+1, I ), 1 )
   20    CONTINUE
C
         IF( N.GT.1 ) THEN
            AII = A( 1, 1 )
            CALL DSCAL( N, AII, A( 1, 1 ), 1 )
         END IF
      END IF
C
      RETURN
C
C *** Last line of MB01XY ***
      END


      subroutine fem_elastic_stiffness(i, j, D)
!***********************************************************************
! Copyright 2011 Los Alamos National Security, LLC  All rights reserved
! Unless otherwise indicated,  this information has been authored by an
! employee or employees of the Los Alamos National Security, LLC (LANS),
! operator of the  Los  Alamos National  Laboratory  under Contract  No.
! DE-AC52-06NA25396  with  the U. S. Department  of  Energy.  The  U. S.
! Government   has   rights  to  use,  reproduce,  and  distribute  this
! information.  The  public may copy  and  use this  information without
! charge, provided that this  Notice and any statement of authorship are
! reproduced on all copies.  Neither  the  Government nor LANS makes any
! warranty,   express   or   implied,   or   assumes  any  liability  or
! responsibility for the use of this information.
!***********************************************************************
!
! Returns the 6x6 material stiffness (D) matrix for a linear, isotropic,
! elastic solid when the 'plastic' submacro is used with 'fem' computations
!
! Author : Sai Rapaka
!

      use comai, only: iout, iptty, ns
      use comsi, only: modelNumber, plasticModel, elastic_mod, poisson
      use comsi, only: iPlastic
      use comfem

      implicit none
      integer                      :: i, j
      real*8,  dimension(6,6)      :: D

      integer                      :: k, itmp, iModel, node
      real*8                       :: e1bar, e2bar, e3bar
      real*8                       :: E, nu, lambda, G

      if(iPlastic.ne.0) then
        itmp = modelNumber(elnode(i, 1))
        iModel = plasticModel(itmp)

        do k=2,ns
          itmp = modelNumber(elnode(i, k))
          if(iModel.ne.plasticModel(itmp)) then
            write(iout, *) 'Multiple plastic models being used !
     &          Not supported at this time! '
            write(iptty, *) 'Multiple plastic models being used !
     &          Not supported at this time! '
            stop
          endif
        enddo
      endif

      D = 0.0d0

      e1bar = 0.0d0
      e2bar = 0.0d0
      e3bar = 0.0d0

      do k=1,ns
        node = elnode(i, k)
        E = elastic_mod(node)
        nu = poisson(node)
        lambda = E*nu/((1 + nu)*(1 - 2.0d0*nu))
        G = E/(2.0d0*(1 + nu))

        e1bar = e1bar + Psi(i, j, k)*(lambda + 2.0d0*G)
        e2bar = e2bar + Psi(i, j, k)*lambda
        e3bar = e3bar + Psi(i, j, k)*G
      enddo

      D(1,1) = e1bar
      D(2,2) = e1bar
      D(3,3) = e1bar

      D(1,2) = e2bar
      D(1,3) = e2bar
      D(2,1) = e2bar
      D(2,3) = e2bar
      D(3,1) = e2bar
      D(3,2) = e2bar

      D(4,4) = e3bar
      D(5,5) = e3bar
      D(6,6) = e3bar

      end subroutine fem_elastic_stiffness


      SUBROUTINE CALBAL5
C
C CHANGE RECORD
C **  SUBROUTINES CALBAL CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
	IMPLICIT NONE
	REAL::ENEEND,ENEOUT,VOLBMO,SALBMO,DYEBMO,UMOBMO,VMOBMO,ENEBMO
	REAL::VOLERR,SALERR,DYEERR,UMOERR,VMOERR,ENEERR,RVERDE,RSERDE
	REAL::RDERDE,RUERDE,REERDE,RVERDO,RSERDO,RUERDO,ENEBEG,RDERDO
	REAL::REERDO,RUMERDE,RVMERDE,RUMERDO,UUEBMO,VVEBMO,PPEBMO
	REAL::BBEBMO,RVMERDO,PPEEND,BBEEND,AMOEND,VOLEND,SALEND,DYEEND
	REAL::VMOEND,UUEEND,VVEEND,UMOEND
	INTEGER::K,L,LN
C
C **  CHECK FOR END OF BALANCE PERIOD
C
      IF(NBAL.EQ.NTSMMT)THEN
C
C **  CALCULATE ENDING VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC
C **  ENERGY AND POTENTIAL ENERGY, AND ASSOCIATED FLUXES
C
        VOLEND=0.
        SALEND=0.
        DYEEND=0.
        UMOEND=0.
        VMOEND=0.
        UUEEND=0.
        VVEEND=0.
        PPEEND=0.
        BBEEND=0.
        DO L=2,LA
          LN=LNC(L)
          VOLEND=VOLEND+SPB(L)*DXYP(L)*HP(L)
         UMOEND=UMOEND+SPB(L)*0.5*DXYP(L)*HP(L)*(DYIU(L)*HUI(L)*UHDYE(L)
     &        +DYIU(LEAST(L))*HUI(LEAST(L))*UHDYE(LEAST(L)))
         VMOEND=VMOEND+SPB(L)*0.5*DXYP(L)*HP(L)*(DXIV(L)*HVI(L)*VHDXE(L)
     &        +DXIV(LN)*HVI(LN)*VHDXE(LN))
          PPEEND=PPEEND+SPB(L)*0.5*DXYP(L)
     &        *(GI*P(L)*P(L)-G*BELV(L)*BELV(L))
        ENDDO
        AMOEND=SQRT(UMOEND*UMOEND+VMOEND*VMOEND)
        DO K=1,KC
          DO L=2,LA
            LN=LNC(L)
            SALEND=SALEND+SCB(L)*DXYP(L)*HP(L)*SAL(L,K)*DZC(K)
            DYEEND=DYEEND+SCB(L)*DXYP(L)*HP(L)*DYE(L,K)*DZC(K)
            UUEEND=UUEEND+SPB(L)*0.125*DXYP(L)*HP(L)*DZC(K)
     &          *( (U(L,K)+U(LEAST(L),K))*(U(L,K)+U(LEAST(L),K)) )
            VVEEND=VVEEND+SPB(L)*0.125*DXYP(L)*HP(L)*DZC(K)
     &          *( (V(L,K)+V(LN,K))*(V(L,K)+V(LN,K)) )
            BBEEND=BBEEND+SPB(L)*GP*DXYP(L)*HP(L)*DZC(K)*( BELV(L)
     &          +0.5*HP(L)*(Z(K)+Z(K-1)) )*B(L,K)
          ENDDO
        ENDDO
        UUEOUT=DT*UUEOUT
        VVEOUT=DT*VVEOUT
        PPEOUT=DT*PPEOUT
        BBEOUT=DT*BBEOUT
        VOLOUT=DT*VOLOUT
        SALOUT=DT*SALOUT
        DYEOUT=DT*DYEOUT
        UMOOUT=DT*UMOOUT
        VMOOUT=DT*VMOOUT
        ENEBEG=UUEBEG+VVEBEG+PPEBEG+BBEBEG
        ENEEND=UUEEND+VVEEND+PPEEND+BBEEND
        ENEOUT=UUEOUT+VVEOUT+PPEOUT+BBEOUT
        VOLBMO=VOLBEG-VOLOUT
        SALBMO=SALBEG-SALOUT
        DYEBMO=DYEBEG-DYEOUT
        UMOBMO=UMOBEG-DYEOUT
        VMOBMO=VMOBEG-DYEOUT
        ENEBMO=ENEBEG-ENEOUT
        VOLERR=VOLEND-VOLBMO
        SALERR=SALEND-SALBMO
        DYEERR=DYEEND-DYEBMO
        UMOERR=UMOEND-UMOBMO
        VMOERR=VMOEND-VMOBMO
        ENEERR=ENEEND-ENEBMO
        RVERDE=-9999.
        RSERDE=-9999.
        RDERDE=-9999.
        RUERDE=-9999.
        RVERDE=-9999.
        REERDE=-9999.
        RVERDO=-9999.
        RSERDO=-9999.
        RDERDO=-9999.
        RUERDO=-9999.
        RVERDO=-9999.
        REERDO=-9999.
        IF(VOLEND.NE.0.) RVERDE=VOLERR/VOLEND
        IF(SALEND.NE.0.) RSERDE=SALERR/SALEND
        IF(DYEEND.NE.0.) RDERDE=DYEERR/DYEEND
        IF(UMOEND.NE.0.) RUMERDE=UMOERR/UMOEND
        IF(VMOEND.NE.0.) RVMERDE=VMOERR/VMOEND
        IF(ENEEND.NE.0.) REERDE=ENEERR/ENEEND
        IF(VOLOUT.NE.0.) RVERDO=VOLERR/VOLOUT
        IF(SALOUT.NE.0.) RSERDO=SALERR/SALOUT
        IF(DYEOUT.NE.0.) RDERDO=DYEERR/DYEOUT
        IF(UMOOUT.NE.0.) RUMERDO=UMOERR/UMOOUT
        IF(VMOOUT.NE.0.) RVMERDO=VMOERR/VMOOUT
        IF(ENEOUT.NE.0.) REERDO=ENEERR/ENEOUT
C
C **  OUTPUT BALANCE RESULTS TO FILE BAL.OUT
C
        IF(JSBAL.EQ.1)THEN
          OPEN(89,FILE='BAL.OUT',STATUS='UNKNOWN')
          CLOSE(89,STATUS='DELETE')
          OPEN(89,FILE='BAL.OUT',STATUS='UNKNOWN')
          JSBAL=0
        ELSE
          OPEN(89,FILE='BAL.OUT',POSITION='APPEND',STATUS='UNKNOWN')
        ENDIF
        WRITE(89,890)NTSMMT,N
        WRITE(89,891)
        WRITE(89,892)VOLBEG,SALBEG,DYEBEG,ENEBEG,UMOBEG,VMOBEG,AMOBEG
        WRITE(89,900)
        WRITE(89,893)
        WRITE(89,892)VOLOUT,SALOUT,DYEOUT,ENEOUT,UMOOUT,VMOOUT
        WRITE(89,900)
        WRITE(89,894)
        WRITE(89,892)VOLBMO,SALBMO,DYEBMO,ENEBMO,UMOBMO,VMOBMO
        WRITE(89,900)
        WRITE(89,895)
        WRITE(89,892)VOLEND,SALEND,DYEEND,ENEEND,UMOEND,VMOEND,AMOEND
        WRITE(89,900)
        WRITE(89,896)
        WRITE(89,892)VOLERR,SALERR,DYEERR,ENEERR,UMOERR,VMOERR
        WRITE(89,900)
        WRITE(89,897)
        WRITE(89,892)RVERDE,RSERDE,RDERDE,REERDE,RUMERDE,RVMERDE
        WRITE(89,900)
        WRITE(89,898)
        WRITE(89,892)RVERDO,RSERDO,RDERDO,REERDO,RUMERDO,RVMERDO
        WRITE(89,899)
        UUEBMO=UUEBEG-UUEOUT
        VVEBMO=VVEBEG-VVEOUT
        PPEBMO=PPEBEG-PPEOUT
        BBEBMO=BBEBEG-BBEOUT
        WRITE(89,901)UUEBEG
        WRITE(89,902)UUEOUT
        WRITE(89,903)UUEBMO
        WRITE(89,904)UUEEND
        WRITE(89,900)
        WRITE(89,905)VVEBEG
        WRITE(89,906)VVEOUT
        WRITE(89,907)VVEBMO
        WRITE(89,908)VVEEND
        WRITE(89,900)
        WRITE(89,909)PPEBEG
        WRITE(89,910)PPEOUT
        WRITE(89,911)PPEBMO
        WRITE(89,912)PPEEND
        WRITE(89,900)
        WRITE(89,913)BBEBEG
        WRITE(89,914)BBEOUT
        WRITE(89,915)BBEBMO
        WRITE(89,916)BBEEND
        WRITE(89,900)
        WRITE(89,899)
        CLOSE(89)
  890 FORMAT (' VOLUME, MASS, AND ENERGY BALANCE OVER',I5,' TIME STEPS'
     &    ,' ENDING AT TIME STEP',I5,//)
  891 FORMAT (' INITIAL VOLUME    INITIAL SALT    INITIAL DYE     '
     &    ,'INITIAL ENER    INITIAL UMO     INITIAL VMO     '
     &    ,'INITIAL AMO',/)
  892 FORMAT (1X,7(E14.6,2X))
  893 FORMAT (' VOLUME OUT        SALT OUT        DYE OUT         '
     &    ,'ENERGY OUT      UMO OUT         VMO OUT',/)
  894 FORMAT (' INITIAL-OUT VOL   INIT-OUT SALT   INIT-OUT DYE    '
     &    ,'INIT-OUT ENER   INIT-OUT UMO    INIT-OUT VMO',/)
  895 FORMAT (' FINAL VOLUME      FINAL SALT      FINAL DYE       '
     &    ,'FINAL ENERGY    FINAL UMO       FINAL VMO       '
     &    ,'FINAL AMO',/)
  896 FORMAT (' VOLUME ERR        SALT ERR        DYE ERR         '
     &    ,'ENERGY ERR      UMO ERR         VMO ERR',/)
  897 FORMAT (' R VOL/END ER      R SAL/END ER    R DYE/END ER    '
     &    ,'R ENE/END ER    R UMO/END ER    R VMO/END ER',/)
  898 FORMAT (' R VOL/OUT ER      R SAL/OUT ER    R DYE/OUT ER    '
     &    ,'R ENE/OUT ER    R UMO/OUT ER    R VMO/OUT ER',/)
  899 FORMAT (////)
  900 FORMAT (//)
  901 FORMAT(' UUEBEG =  ',E14.6)
  902 FORMAT(' UUEOUT =  ',E14.6)
  903 FORMAT(' UUEBMO =  ',E14.6)
  904 FORMAT(' UUEEND =  ',E14.6)
  905 FORMAT(' VVEBEG =  ',E14.6)
  906 FORMAT(' VVEOUT =  ',E14.6)
  907 FORMAT(' VVEBMO =  ',E14.6)
  908 FORMAT(' VVEEND =  ',E14.6)
  909 FORMAT(' PPEBEG =  ',E14.6)
  910 FORMAT(' PPEOUT =  ',E14.6)
  911 FORMAT(' PPEBMO =  ',E14.6)
  912 FORMAT(' PPEEND =  ',E14.6)
  913 FORMAT(' BBEBEG =  ',E14.6)
  914 FORMAT(' BBEOUT =  ',E14.6)
  915 FORMAT(' BBEBMO =  ',E14.6)
  916 FORMAT(' BBEEND =  ',E14.6)
        NBAL=0
      ENDIF
      NBAL=NBAL+1
      RETURN
      END


      program test
      implicit none
      real*8 fc,adf,edf,ncp,dncf,dfqf,p,df1,df2
      integer ifault
      external dncf, dfqf

      fc = 3.0
      adf=3.0
      edf = 24.0
      ncp = 56.0
      ifault = 0
      write(*,*) 1.0-dncf(fc,adf,edf,ncp,ifault)
      ncp = 100.0
      write(*,*) 1.0-dncf(fc,adf,edf,ncp,ifault)
      write(*,*) ifault

      p=0.9
      df1=2.3
      df2=2.2
      write(*,*) dfqf(p,df1,df2,ifault)
      write(*,*) ifault

      end


*DECK R9LGIT
      FUNCTION R9LGIT (A, X, ALGAP1)
C***BEGIN PROLOGUE  R9LGIT
C***SUBSIDIARY
C***PURPOSE  Compute the logarithm of Tricomi's incomplete Gamma
C            function with Perron's continued fraction for large X and
C            A .GE. X.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C7E
C***TYPE      SINGLE PRECISION (R9LGIT-S, D9LGIT-D)
C***KEYWORDS  FNLIB, INCOMPLETE GAMMA FUNCTION, LOGARITHM,
C             PERRON'S CONTINUED FRACTION, SPECIAL FUNCTIONS, TRICOMI
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C Compute the log of Tricomi's incomplete gamma function with Perron's
C continued fraction for large X and for A .GE. X.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  R1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   770701  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900720  Routine changed from user-callable to subsidiary.  (WRB)
C***END PROLOGUE  R9LGIT
      SAVE EPS, SQEPS
      DATA EPS, SQEPS / 2*0.0 /
C***FIRST EXECUTABLE STATEMENT  R9LGIT
      IF (EPS.EQ.0.0) EPS = 0.5*R1MACH(3)
      IF (SQEPS.EQ.0.0) SQEPS = SQRT(R1MACH(4))
C
      IF (X .LE. 0.0 .OR. A .LT. X) CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'X SHOULD BE GT 0.0 AND LE A', 2, 2)
C
      AX = A + X
      A1X = AX + 1.0
      R = 0.0
      P = 1.0
      S = P
      DO 20 K=1,200
        FK = K
        T = (A+FK)*X*(1.0+R)
        R = T/((AX+FK)*(A1X+FK)-T)
        P = R*P
        S = S + P
        IF (ABS(P).LT.EPS*S) GO TO 30
 20   CONTINUE
      CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'NO CONVERGENCE IN 200 TERMS OF CONTINUED FRACTION', 3, 2)
C
 30   HSTAR = 1.0 - X*S/A1X
      IF (HSTAR .LT. SQEPS) CALL XERMSG ('SLATEC', 'R9LGIT',
     +   'RESULT LESS THAN HALF PRECISION', 1, 1)
C
      R9LGIT = -X - ALGAP1 - LOG(HSTAR)
C
      RETURN
      END


!===================================================================================
!=================== SUBROUTINE PREDICTOR - CORRECTOR ==============================
!=================== VELOCITY - X ==================================================

subroutine pc_ukx2coh(Nx,Ny,Nh,pi,time,nk,ukx,ukx_new,uky,dn_dt,dux_dt,duy_dt)
implicit none
integer ( kind = 4 ) Nx,Ny,Nh, i, j
real ( kind = 8 ) pi,time,dt,Lx,Ly,mux,muy,ms,CS
real ( kind = 8 ) n(Nx,Ny),ux(Nx,Ny),uy(Nx,Ny)
complex ( kind = 8 ) predict(Nh,Ny),correct(Nh,Ny)
complex ( kind = 8 ) nk(Nh,Ny),ukx(Nh,Ny),uky(Nh,Ny),nk_new(Nh,Ny),ukx_new(Nh,Ny),uky_new(Nh,Ny)
complex ( kind = 8 ) dum_nk(Nh,Ny),dum_ukx(Nh,Ny),dum_uky(Nh,Ny)
complex ( kind = 8 ) dn_dt(Nh,Ny),dux_dt(Nh,Ny),duy_dt(Nh,Ny)
complex ( kind = 8 ) dn_dt_old(Nh,Ny),dux_dt_old(Nh,Ny),duy_dt_old(Nh,Ny)
complex ( kind = 8 ) dn_dt_new(Nh,Ny),dux_dt_new(Nh,Ny),duy_dt_new(Nh,Ny)
common/comm/Lx,Ly,mux,muy,ms,CS,dt

do i = 1,Nh
  do j = 1,Ny
    predict(i,j) = dux_dt(i,j)
    dum_ukx(i,j) = ukx(i,j) + predict(i,j)*dt   ! Predictor using Euler Method...
  end do
end do

  call derive2coh(Nx,Ny,Nh,pi,time+dt,nk,dum_ukx,uky, &
  dn_dt_old,dux_dt_old,duy_dt_old,dn_dt_new,dux_dt_new,duy_dt_new)

do i = 1,Nh
  do j = 1,Ny
    correct(i,j) = dux_dt(i,j)
    ukx_new(i,j) = ukx(i,j) + ( predict(i,j) + correct(i,j) )*dt/2.0d0   ! Corrector using Predicted slope...
  end do
end do

return

end subroutine pc_ukx2coh


module Freecell
  use lcgs
  implicit none

  character(4)  :: suit = "CDHS"
  character(13) :: rank = "A23456789TJQK"
  character(2) :: deck(0:51)

contains

subroutine Createdeck()
  integer :: i, j, n

  n = 0
  do i = 1, 13
    do j = 1, 4
      deck(n) = rank(i:i) // suit(j:j)
      n = n + 1
    end do
  end do

end subroutine

subroutine Freecelldeal(game)
  integer, intent(in) :: game
  integer(i64) :: rnum
  integer :: i, n
  character(2) :: tmp

  call Createdeck()
  rnum = msrand(game)

  do i = 51, 1, -1
    n = mod(rnum, i+1)
    tmp = deck(n)
    deck(n) = deck(i)
    deck(i) = tmp
    rnum = msrand()
  end do

  write(*, "(a, i0)") "Game #", game
  write(*, "(8(a, tr1))") deck(51:0:-1)
  write(*,*)

end subroutine
end module Freecell

program Freecell_test
  use Freecell
  implicit none

  call Freecelldeal(1)
  call Freecelldeal(617)

end program


	SUBROUTINE CROSSP(A,B,C)
	DIMENSION A(3),B(3),C(3)
	A(1) = B(2)*C(3) - B(3)*C(2)
	A(2) = B(3)*C(1) - B(1)*C(3)
	A(3) = B(1)*C(2) - B(2)*C(1)
	RETURN
	END


program TestCilmPlus
!------------------------------------------------------------------------------
!
!    This program will
!
!    (1) Read in a spherical harmonic file of maximum degree Lmax, expand it in
!        the spatial domain, and then re-expand it into spherical harmonics
!        using Guass-Legendre quadrature. The relativive errors in the space
!        and spectral domaines will be determined.
!    (2) Using these routines, the potential coefficients will be computed
!        according to the algorithm of Wieczorek and Phillips (1998). The
!        maximum order of the exspansion will be determined as well.
!    (3) The difference between using nmax*lmax coefficients when calculating
!        the gravity coefficients vs. n*lmax will be determined.
!    (4) A 2d gridded data file of the input coefficients with equal latitude
!        and longitude spacings) will be output.
!
!    Notes: The only two parameters in this program that might want
!    to be changed is MAX and MAX2DGRID. The first sets the maximum
!    degree that can be computed in the spherical harmonic expansions,
!    while the second sets the maximum size of the output 2d grid.
!
!    Comments on compiling and modifying this code:
!
!    1. This example code uses a lot of memory, and runs slowly in order to
!    demonstrate the accuracy of the routines. It may be necessary to compile
!    it with the -s option (static memory). Also, if memory is not an issue,
!    then the arrays plx and plxn should be precomputed.
!    2. As is seen in the output, for Mars (and also the Moon) nmax should be
!    about 5 in order to achieve an accuracy comparable to the spherical
!    harmonic model.
!    3. In order to exactly calculate the gravity field using the Wieczorek
!    and Phillips (1998) method, if the original field is defined up to lmax,
!    the final output field should be nmax*lmax. This is achieved in practice
!    by zero padding the input field from lmax+1 to nmax*lmax+1. However, as is
!    seen in the output, in practice, it is only necessary to increase the size
!    of the input field by about 50%. At the same time, since the topography
!    spherical harmonic coefficients are NOT really zero beyond lmax, zero
!    padding between (lmax+1, and nmax*lmax+1) still only yields an
!    approximation to the gravity field. This would only be strictly correct
!    if the topography was bandlimited to degree lmax.
!
!    Copyright (c) 2005, SHTOOLS
!    All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS
    use PlanetsConstants
    use ftypes

    implicit none

    integer, parameter :: degmax = 650, max2dgrid = 181
    real(dp) :: zero(degmax+1), w(degmax+1), c1ilm(2, degmax+1, degmax+1), &
                zeron(degmax+1), wn(degmax+1), cilm(2, degmax+1, degmax+1), &
                c2ilm(2,degmax+1, degmax+1), grid1glq(degmax+1, 2*degmax+1), &
                gridglq(degmax+1, 2*degmax+1), grid2glq(degmax+1, 2*degmax+1), &
                grid3glq(degmax+1, 2*degmax+1), pi, maxerror, err1, err2, &
                d, rho, mass, grav, gm, grid2d(max2dgrid, 2*max2dgrid), &
                interval, timein, timeout
    real(dp), allocatable :: plxn(:,:),  plx(:,:)
    integer(int32) :: lmax, i, j, l, m, nlat, nlong, nmax, n, astat, &
                      lmaxfile, lmaxn, nlatn, nlongn, precomputeplx
    character(200) :: infile, outfile

    call cpu_time(timein)

    pi = acos(-1.0_dp)

    rho = 2900.0_dp            ! assumed crustal density
    grav = Grav_Constant
    gm = GM_Mars
    mass = Mass_Mars

    precomputeplx = 0            ! set to 1 precompute arrays PLXN and PLX

    !print*, "Spherical Harmonic file > "
    !read(*,*) infile
    infile = "../../ExampleDataFiles/MarsTopo719.shape"

    !print*, "Maximum degree to read > "
    !read(*,*) lmax
    lmax = 90

    if (precomputeplx == 1) then
        allocate (plx(lmax+1, (lmax+1)*(lmax+2)/2), stat = astat)
        if (astat /=0) then
            print*, "Problem allocating plx"
            stop
        end if
    end if

    if (lmax > degmax) then
        print*, "lmax must be less than or equal to , ", degmax
        print*, "Change max and recompile"
        stop
    end if

    nlat = NGLQSH(lmax)     ! These are the sizes of the grids used in (lmax+1)
    nlong = 2 * lmax + 1    ! the gauss-legendre quadtrature routines

    !--------------------------------------------------------------------------
    !
    !    Read Spherical harmonic coefficients
    !
    !--------------------------------------------------------------------------

    call SHRead(infile, cilm, lmaxfile)

    print*, "Input file name = ", infile
    print*, "Maximum degree of input file = ", lmaxfile
    print*, "Maximum degree used in the calculations = ", lmax
    if (lmaxfile > lmax) then
        cilm(:,lmax+2:lmaxfile+1,lmax+2:lmaxfile+1) = 0.0_dp
        ! zero coefficients greater than lmax
    end if

    !--------------------------------------------------------------------------
    !
    !    Call a routine which will compute a number of arrays that will be
    !    used later on (these include the guass points, weights, and plx).
    !
    !--------------------------------------------------------------------------

    print*, "Precomputing data structures..."

    if (precomputeplx == 1) then
        call SHGLQ(lmax, zero, w, plx = plx)
    else
        call SHGLQ(lmax, zero, w)
    end if

    !--------------------------------------------------------------------------
    !
    !    Compute a grid from the spherical harmonic coefficients.
    !    Note that this grid is equally spaced in longitude,
    !    but unevenly space in latitude according to the gauss points.
    !
    !--------------------------------------------------------------------------

    print*, "Making Grid..."

    if (precomputeplx == 1) then
        call MakeGridGLQ(gridglq, cilm, lmax, plx = plx)
    else
        call MakeGridGLQ(gridglq, cilm, lmax, zero = zero)
    end if

    !--------------------------------------------------------------------------
    !
    !    This routine expands the grid into spherical harmonics
    !
    !--------------------------------------------------------------------------

    print*, "Expanding into spherical harmonics"

    if (precomputeplx == 1) then
        call SHExpandGLQ(c2ilm, lmax, gridglq, w, plx = plx)
    else
        call SHExpandGLQ(c2ilm, lmax, gridglq, w, zero = zero)
    end if

    !--------------------------------------------------------------------------
    !
    !    Next, compute relative errors between the original and
    !    computed spherical harmonic coefficients
    !
    !--------------------------------------------------------------------------

    maxerror = 0.0_dp
    do l = 0, lmax
        do m = 0, l
            if (m == 0) then
                err1 = abs(cilm(1,l+1,m+1)-c2ilm(1,l+1,m+1)) / abs(cilm(1,l+1,m+1))
                if (err1 >= maxerror) maxerror = err1
            else
                err1 = abs(cilm(1,l+1,m+1) - c2ilm(1,l+1,m+1)) / abs(cilm(1,l+1,m+1))
                err2 = abs(cilm(2,l+1,m+1) - c2ilm(2,l+1,m+1)) / abs(cilm(2,l+1,m+1))
                if (err1 >= maxerror) maxerror = err1
                if (err2 >= maxerror) maxerror = err2
            end if
        end do
    end do

    print*, "Maximum relative error between spherical harmonic coefficients = ", maxerror

    !--------------------------------------------------------------------------
    !
    !    Next, compute the maximum error in the space domain
    !    at the gauss points.
    !
    !--------------------------------------------------------------------------

    if (precomputeplx == 1) then
        call MakeGridGLQ(grid2glq, &
                         cilm(:,1:lmax+1,1:lmax+1) - c2ilm(:,1:lmax+1,1:lmax+1), &
                         lmax, plx = plx)
    else
        call MakeGridGLQ(grid2glq, &
                         cilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), &
                         lmax, zero = zero)
    end if

    print*, "Maximum error (meters) at the gauss points = ", maxval(abs(grid2glq(1:nlat,1:nlong)))

    !--------------------------------------------------------------------------
    !
    !    Compute the potential coefficients due to the topography
    !    using nmax, and then determine the maximum difference between
    !    this gravity field and that calculated at a smaller n
    !    in the space domain. Note, even though the gravity field
    !    is calculated up to nmax*lmax, the differences that are
    !    output only correspond to the first lmax coefficients.
    !
    !    Note: the minimum gravity anomaly of Lemoine et al. (2001) is
    !    about 6 mgals. I have also determined that the the relative
    !    error for the Moho coefficients is smaller than that of the
    !    topography (The opposite is the case for the Moon). Thus the
    !    value of n used for the topography is sufficient for the moho as well.
    !
    !    The reason that the maximum degree of the spherical harmonic
    !    fields needs to be increased beyond lmax is that raising a field to
    !    the nth power results in a field with coefficients up to n*lmax.
    !
    !--------------------------------------------------------------------------

    nmax = 7
    lmaxn = lmax * nmax
    nlatn = NGLQSH(lmaxn)    ! These are the sizes of the grids used in (lmax+1)
    nlongn = 2 * lmaxn + 1     ! the gauss-legendre quadtrature routines

    print*, "Maximum spherical harmonic degree corresponding to n = ", nmax, " = ", lmaxn
    if (lmaxn > degmax ) then
        print*, "lmaxn is greater than max. Change max and recompile."
        stop
    end if

    if (precomputeplx == 1) then
        ! This must be called again since the value of lmax is different than above
        allocate (plxn(lmaxn+1, (lmaxn+1)*(lmaxn+2)/2), stat = astat)
        if (astat /=0) then
            print*, "Problem allocating plxn"
            stop
        end if
    end if

    print*, "Computing gravity coefficients..."
    if (precomputeplx == 1) then
        call SHGLQ(lmaxn, zeron, wn, plx = plxn)
        call MakeGridGLQ(gridglq, cilm, lmaxn, plx = plxn)
        call CilmPlus(c1ilm, gridglq, lmaxn, nmax, mass, d, rho, &
                      gridtype = 1, w = wn, plx = plxn)
    else
        call SHGLQ(lmaxn, zeron, wn)
        call MakeGridGLQ(gridglq, cilm, lmaxn, zero = zeron)
        call CilmPlus(c1ilm, gridglq, lmaxn, nmax, mass, d, rho, &
                      gridtype = 1, w = wn, zero = zeron)
    end if

    do l = 0, lmaxn
        c1ilm(:,l+1,1:l+1) = c1ilm(:,l+1,1:l+1) * (l+1.0_dp) * gm * (1.0e5_dp) / d**2
        ! convert to gravity coefficients in mgals
    end do

    do n = 1, nmax - 1

        if (precomputeplx == 1) then
            call CilmPlus(c2ilm, gridglq, lmaxn, n, mass, d, rho, &
                          gridtype = 1, w = wn, plx = plxn)
        else
            call CilmPlus(c2ilm, gridglq, lmaxn, n, mass, d, rho, &
                          gridtype = 1, w = wn, zero = zeron)
        end if

        do l = 0, lmaxn
            c2ilm(:,l+1,1:l+1) = c2ilm(:,l+1,1:l+1) * (l+1.0_dp) * gm * (1.0e5_dp) / d**2
        end do

        ! Compute difference only up to lmax, not lmaxn

        if (precomputeplx == 1) then
            call MakeGridGLQ(grid3glq, &
                c1ilm(:,1:lmax+1,1:lmax+1) - c2ilm(:,1:lmax+1,1:lmax+1), &
                lmax, plx = plx)
        else
            call MakeGridGLQ(grid3glq, &
                c1ilm(:,1:lmax+1,1:lmax+1) - c2ilm(:,1:lmax+1,1:lmax+1), &
                lmax, zero = zero)
        end if

        print*, "Maximum difference (mgals) between nmax = ", nmax, " and ", n, " = ", &
            maxval(abs(grid3glq(1:nlat,1:nlong)))

    end do

    !--------------------------------------------------------------------------
    !
    !    Next calculate the difference in the gravity field that arrises from
    !    doing the GLQ integrations with a field zero-padded up to lmaxn as
    !    opposed to nmax*lmax.
    !
    !--------------------------------------------------------------------------

    do n = 1, 10
        !lmaxn = lmax * n
        lmaxn = lmax + (n-1) * 10
        nlatn = NGLQSH(lmaxn)
        nlongn = 2 * lmaxn + 1

        if (precomputeplx == 1) then
            call SHGLQ(lmaxn, zeron, wn, plx = plxn)
            call MakeGridGLQ(gridglq, cilm, lmaxn, plx = plxn)
            call CilmPlus(c2ilm, gridglq, lmaxn, nmax, mass, d, rho, &
                          gridtype = 1, w = wn, plx = plxn)
        else
            call SHGLQ(lmaxn, zeron, wn)
            call MakeGridGLQ(gridglq, cilm, lmaxn, zero = zeron)
            call CilmPlus(c2ilm, gridglq, lmaxn, nmax, mass, d, rho, &
                          gridtype = 1, w = wn, zero = zeron)
        end if

        do l = 0, lmaxn
            c2ilm(:,l+1,1:l+1) = c2ilm(:,l+1,1:l+1) * (l+1.0_dp) * gm * (1.0e5_dp) / d**2
            ! convert to gravity coefficients in mgals
        end do

        ! Compute difference only up to lmax, not lmaxn

        if (precomputeplx == 1) then
            call MakeGridGLQ(grid1glq, &
                c1ilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), &
                lmax, plx = plx)
        else
            call MakeGridGLQ(grid1glq, &
                c1ilm(:,1:lmax+1,1:lmax+1)-c2ilm(:,1:lmax+1,1:lmax+1), &
                lmax, zero = zero)
        end if

        print*, "Maximum difference (mgals) between using Lmax of expansion equal to ", lmax * nmax, " and LMAX = ", lmaxn, &
             maxval(abs(grid1glq(1:nlat,1:nlong)))

    end do

    !--------------------------------------------------------------------------
    !
    !    Calculate a 2d grid with equal longitude and latitude spacings.
    !    Note that if you want a grid finer than 1 degree, that you must
    !    increase the parameter maxgrid2d.
    !
    !--------------------------------------------------------------------------

    print*, "Making 2d grid with equal latitude and longitude spacings"
    interval = 2
    cilm(1,1,1) = 0.0_dp        ! set degree-zero term to zero
    cilm(1,3,1) = 0.0_dp        ! set j2 term to zero

    outfile = "grid2d.dat"
    open(12,file = outfile)

    call MakeGrid2d(grid2d, cilm, lmax, interval, nlat, nlong)

    write(12,*) nlat, nlong     ! header line giving the dimensions of the
                                ! following raster image
    do i = 1, nlat
        do j = 1, nlong
            write(12,*) grid2d(i,j)
        end do
    end do

    close(12)

    if (precomputeplx == 1) then
        deallocate(plx)
        deallocate(plxn)
    end if

    call cpu_time(timeout)
    print*, "time (sec) = ", timeout-timein

end program TestCilmPlus


      subroutine nut_pminrl

!!    ~ ~ ~ PURPOSE ~ ~ ~
!!    this subroutine computes p flux between the labile, active mineral
!!    and stable mineral p pools.
!!    ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~ ~
!!    ~ ~ ~ SUBROUTINES/FUNCTIONS CALLED ~ ~ ~
!!    Intrinsic: Min

!!    ~ ~ ~ ~ ~ ~ END SPECIFICATIONS ~ ~ ~ ~ ~ ~

      use basin_module
      use organic_mineral_mass_module
      use hru_module, only : ihru
      use soil_module
      use output_landscape_module, only : hnb_d

      implicit none

      real, parameter :: bk = .0006     !              |
      integer :: j                      !none          |HRU number
      integer :: l                      !none          |counter
      real :: rto                       !              |
      real :: rmp1                      !kg P/ha       |amount of phosphorus moving from the solution
                                        !              |mineral to the active mineral pool in the
                                        !              |soil layer
      real :: roc                       !kg P/ha       |amount of phosphorus moving from the active
                                        !              |mineral to the stable mineral pool in the
                                        !              |soil layer

      j = ihru

      hnb_d(j)%lab_min_p = 0.
      hnb_d(j)%act_sta_p = 0.

      rto = bsn_prm%psp / (1. - bsn_prm%psp)

      do l = 1, soil(j)%nly
        rmp1 = (soil1(j)%mp(l)%lab - soil1(j)%mp(l)%act * rto)
        !! mike changed/added per isabelle beaudin"s email from 01/21/09
        if (rmp1 > 0.) rmp1 = rmp1 * 0.1
        if (rmp1 < 0.) rmp1 = rmp1 * 0.6
        !! mike changed/added per isabelle beaudin"s email from 01/21/09
        rmp1 = Min(rmp1, soil1(j)%mp(l)%lab)

        roc = bk * (4. * soil1(j)%mp(l)%act - soil1(j)%mp(l)%sta)
        if (roc < 0.) roc = roc * .1
        roc = Min(roc, soil1(j)%mp(l)%act)

        soil1(j)%mp(l)%sta = soil1(j)%mp(l)%sta + roc
        if (soil1(j)%mp(l)%sta < 0.) soil1(j)%mp(l)%sta = 0.

        soil1(j)%mp(l)%act = soil1(j)%mp(l)%act - roc + rmp1
        if (soil1(j)%mp(l)%act < 0.) soil1(j)%mp(l)%act = 0.

        soil1(j)%mp(l)%lab = soil1(j)%mp(l)%lab - rmp1
        if (soil1(j)%mp(l)%lab < 0.) soil1(j)%mp(l)%lab = 0.

        hnb_d(j)%lab_min_p = hnb_d(j)%lab_min_p + rmp1
        hnb_d(j)%act_sta_p = hnb_d(j)%act_sta_p + roc
      end do

      return
      end subroutine nut_pminrl


      SUBROUTINE CURVPS (SIGS, PRIN)
C*****
C  COMPUTES PRINCIPAL STRESSES OR STRAINS AND ANGLE OF MAXIMUM.
C*****
      REAL SIGS(3), PRIN(4)
C
      TEMP = SIGS(1) - SIGS(2)
      PRIN(4) = SQRT( (TEMP/2.0)**2 + SIGS(3)**2 )
      DELTA = ( SIGS(1) + SIGS(2) ) / 2.0
      PRIN(2) = DELTA + PRIN(4)
      PRIN(3) = DELTA - PRIN(4)
      DELTA = 2.0 * SIGS(3)
      IF( ABS(DELTA).LT.1.0E-15 .AND. ABS(TEMP).LT.1.0E-15 ) GO TO 100
      PRIN(1) = ATAN2( DELTA, TEMP )*28.6478898E0
      RETURN
C
  100 PRIN(1) = 0.0
      RETURN
      END


      subroutine   furlea(
     i                    spavac,time1,time0,
     m                    ii)
c
c     + + + PURPOSE + + +
c     This subprogram allows for lower end advance during the depletion
c     and recession phases.
c
c     Called from FURREC
c     Author(s): E. R. Kottwitz
c     Reference in User Guide: Chapter 12
c
c     NOTE:  THIS MODULE HAS NOT BEEN RECODED
c
c     + + + PARAMETERS + + +
      include 'pmxpln.inc'
      include 'pmxsrg.inc'
      include 'pxstep.inc'
c
c     + + + ARGUMENT DECLARATIONS + + +
      integer   ii
      real      spavac,time1,time0
c
c     + + + ARGUMENT DEFINITIONS + + +
c     ii     - primary kinematic wave calculation counter
c     spavac - space averaging coefficient for flow area for current
c              time
c     time1  - time of current set of calculations (s)
c     time0  - time of previous set of calculations (s)
c
c     + + + COMMON BLOCKS + + +
      include 'ciraflo.inc'
c       read: aqcnst,aqexp
c
      include 'cirfurr.inc'
c       read: spavz
c     modify: aflow(0:xsteps,2),infltr(0:xsteps,2),inoptm(0:xsteps),
c             tadvan(0:xsteps),xpostn(0:xsteps)
c
      include 'cirinfl.inc'
c       read: kosta,kostf,kostk
c
c     + + + LOCAL VARIABLES + + +
      real      deltax,ratio,tiavq
c
c     + + + LOCAL DEFINITIONS + + +
c     deltax - advance distance during the current time step (m)
c     ratio  - ratio of deltax to (location of next node - location of
c              current node) (m/m)
c     tiavq  - time averaging coefficient for flow rate
c
c     + + + DATA INITIALIZATIONS + + +
      data      tiavq/0.35/
c
c     + + + END SPECIFICATIONS + + +
c
c     Determine advance distance (deltax) and ratio of this distance to
c     the interval between the next node and the current node
c
c      ---- (WEPP Equation 12.14, solved for DELTAX)
      deltax = (1.0-tiavq)*qflow(ii,2)*(time1-time0)/
     1         (spavac*aflow(ii,2)+spavz*(infltr(ii,2)-infltr(ii,1)))
   10 ratio = deltax/(xpostn(ii+1)-xpostn(ii))
c
c     If next statement is true then shift current calculation
c     boundary downslope.  Linearly interpolate for inoptm(i) and
c     adjust aflow, infltr, tadvan, and xpostn arrays.
c
      if(ratio.le.0.5 .or. (ratio.lt.1.0 .and. ii.eq.xsteps-1))then
        inoptm(ii) = inoptm(ii)+(inoptm(ii+1)-inoptm(ii))*ratio
        xpostn(ii) = xpostn(ii)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If next statement is true then shift next calculation boundary
c     upslope.  Linearly interpolate for inoptm(i+1), adjust aflow,
c     infltr, tadvan, and xpostn arrays.
c
      elseif(ratio.gt.0.5 .and. ratio.lt.1.0 .and. ii.lt.(xsteps-1))then
        ii = ii+1
        inoptm(ii) = inoptm(ii-1)+(inoptm(ii)-inoptm(ii-1))*ratio
        xpostn(ii) = xpostn(ii-1)+deltax
        tadvan(ii) = time1
        aflow(ii,2) = 0.0
        qflow(ii,2) = 0.0
c
c        ---- (WEPP Equation 12.4, where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
        infltr(ii,2) = infltr(ii,1)
c
c     If none of the above statements is true then increment i.
c     Linearly interpolate for tadvan(i) and aflow(i,2) and adjust
c     infltr array
c
      else
        ii = ii+1
        tadvan(ii) = time0+(time1-time0)/ratio
        aflow(ii,2) = aflow(ii-1,2)*(ratio-1.0)/ratio
        qflow(ii,2) = aqcnst*aflow(ii,2)**aqexp
c
c        ---- (WEPP Equation 12.4, where tau=inoptm+time1-tadvan)
        infltr(ii,2) = kostk*(inoptm(ii)+time1-tadvan(ii))**kosta+
     1                 kostf*(inoptm(ii)+time1-tadvan(ii))
c
c        ---- (WEPP Equation 12.4 where tau=inoptm)
        infltr(ii,1) = kostk*inoptm(ii)**kosta+kostf*inoptm(ii)
c
c       If the next statement is true then adjust deltax and make next
c       round of calculation boundary adjustments.
c
        if(ii.lt.xsteps)then
          deltax = deltax-(xpostn(ii)-xpostn(ii-1))
          goto 10
        endif
      endif
c
      return
      end


      subroutine interf(plmofz,
     >eta,rm,lmax,ndlm,mofj,lofj,clm,xgs,wgs,ngauss_mad,rdif,dqintl)
c     integrate gaussian from xi0 to infinity
c     to get(one/r- error function/r) subtract one/r to get
c     potential from -gaussian a distance rdif from origin on z-axis
c     integrate over cos(theta) at a distance rm from origin to get dqintl
c
      implicit none
c
      integer lmax
c
      integer ndlm
      integer lofj(ndlm)
      integer mofj(ndlm)
      integer l
      integer m
      integer j
      integer iz
      integer ngauss_mad
c
      real*8 erfc
      real*8 clm(ndlm)
      real*8 plmofz(ndlm)
      real*8 fnpi
      real*8 rm
c
      real*8 xgs(ngauss_mad)
      real*8 wgs(ngauss_mad)
c
      real*8 dqintl(0:lmax)
      real*8 r
      real*8 eta
      real*8 xi0
      real*8 sum
      real*8 half
      real*8 one
      real*8 rho2
      real*8 z
      real*8 rdif
      real*8 pi
      real*8 twopi
      real*8 two
      parameter (half=0.5d0)
      parameter (one=1.0d0)
      parameter (two=2.0d0)
c    -------------------------------------------------------------------
      pi=fnpi()
      twopi=two*pi
      call zeroout(dqintl(0),lmax+1)
      xi0 = sqrt(eta)*half
c         loop over cos(theta)
      do iz=1,ngauss_mad
        z=xgs(iz)
c           sin(theta)**2
            rho2=one-z*z
c           actual x*x+y*y
            rho2=rm*rm*rho2
c           distance from sphere to gaussian center at z=rdif
c           actual z determined by cos(theta) and rm
	    r=sqrt((rdif-rm*z)**2+rho2)
c           calculate potential at this distance
c    -------------------------------------------------------------------
c erfc is defined as
c  2/sqrt(pi) int_x^infty exp(-x*x)dx
c   --- xgz
              sum=(erfc(r*xi0)-one)/r
c             sum contribution of potential to particular L
          sum=wgs(iz)*sum*twopi
c             it doesn't matter if we use ylm or cylm because m=0
c             we could save time with a legengre polynomial routine for m=0
c     get legendre polynomials on z=cos(theta) grid
! meis: changed to normalized associated Legendre functions
        call plm_normalized(lmax,z,plmofz)
c     loop over L
        do j=1,ndlm
          m=mofj(j)
c       only m=0 contributes
          if(m.eq.0)then
            l=lofj(j)
            dqintl(l) = dqintl(l)+clm(j)*plmofz(j)*sum
          endif
        enddo
      enddo
c
      return
c
      end


    !-------------------------------------------------------------------------------------------------------------
    !
    !> \file    CompExcessGibbsEnergyRKMP.f90
    !> \brief   Compute the partial molar excess Gibbs energy of mixing of solution phase constituents in a RKMP
    !!           or RKMPM solution phase.
    !> \author  M.H.A. Piro
    !> \date    January 14, 2013
    !> \sa      CompExcessGibbsEnergy.f90
    !> \sa      CompExcessGibbsEnergyQKTO.f90
    !> \sa      CompExcessGibbsEnergySUBL.f90
    !
    !
    ! Revisions:
    ! ==========
    !
    !   Date            Programmer          Description of change
    !   ----            ----------          ---------------------
    !   01/14/2013      M.H.A. Piro         Original code.
    !   05/14/2014      M.H.A. Piro         Fixed bug in computing binary term: cycle if dx = 0, which could
    !                                        cause problems when computing dxvmo = dx**(iExponent-1) when
    !                                        iExponent = 1.
    !
    !
    ! Purpose:
    ! ========
    !
    !> \details The purpose of this subroutine is to compute the partial molar excess Gibbs energy of mixing
    !! (dPartialExcessGibbs) of all constituents in a non-ideal solution phase designated as 'RKMP'
    !! (Redlich-Kister-Muggiano-Polynomial) or 'RKMPM' (RKMP-Magnetic) phases.
    !!
    !! The molar excess Gibbs energy of mixing from a binary interaction term \f$ z \f$ is:
    !!
    !! \f$  g_{\lambda,z}^{ex} = x_1 x_2 \sum_{v=0}^{N_z} {^v} L_{1,2} (x_1 - x_2)^v  \f$
    !!
    !! where \f$ x_1 \f$ and \f$ x_2 \f$ are the mole fractions of constituents 1 and 2 in the binary parameter and
    !! \f$ {^v} L_{1,2} \f$ is the \f$ v \f$th order mixing parameter.
    !!
    !! The molar excess Gibbs energy of mixing from a ternary interaction term \f$ z \f$ is:
    !!
    !! \f$  g_{\lambda,z}^{ex} = x_1 x_2 x_3 \left( \frac{1-x_1 - x_2 - x_3}{3} + x_j \right) {^0}L_{1,2,3}  \f$
    !!
    !! where \f$ x_j \f$ is the \f$ j \f$th mixing term and \f$ j = 1,2,3 \f$.
    !!
    !! The molar excess Gibbs energy of mixing from a quaternary interaction term \f$ z \f$ is:
    !!
    !! \f$  g_{\lambda,z}^{ex} = x_1 x_2 x_3 x_4 {^0}L_{1,2,3,4}  \f$
    !!
    !! Finally, the total molar excess Gibbs energy of mixing for solution phase \f$ \lambda \f$ is
    !!
    !! \f$ g_{\lambda}^{ex} = \sum_{z=1}^Z g_{\lambda,z}^{ex} \f$
    !!
    !!
    !! For more information on the RKMP model, the Muggiano interpolation scheme and the molar excess Gibbs energy
    !! of mixing equations, the reader is referred to the following literature:
    !!
    !!      P. Chartrand and A. Pelton, "On the Choice of 'Geometric' Thermodynamic Models",
    !!      Journal of Phase Equilibria, 21, 2 (2000) 141-147.
    !!

    !
    ! Pertinent variables:
    ! ====================
    !
    !> \param[in] iSolnIndex    Absolute index of a solution phase
    !
    ! nSpeciesPhase             An integec vector representing the last index of a species in a particular
    !                            solution phase
    ! nParamPhase               An integer vector representing the number of parameters for a particular phase.
    ! iParam                    An integer scalar representing the index number of a parameter.
    ! iRegularParam             An integer matrix representing the relative indices of species mixing for a
    !                            particular parmater.
    ! iFirstSpecies             An integer scalar representing the absolute index of the first species in a phase.
    ! iLastSpecies              An integer scalar representing the absolute index of the last species in a phase.
    ! dMolFraction              A double real vector representing hte mole fraction of all species in the system.
    ! dExcessGibbsParam         A double real vector representing the molar excess Gibbs energy of mixing for
    !                            each subsystem.
    ! dPartialExcessGibbs       Partial molar excess Gibbs energy of mixing of species.
    ! dMolFraction              Current estimated mole fraction.
    ! KD                        A double real scalar representing the Kronecker-Delta.  This is equal to unity
    !                            when a constituent in a ternary mixing term is equal to the higher order term.
    ! x1, x2, x3, x4            A double real scalar representing the mole fraction of the first, second, third
    !                            and fourth constituents in the parameter, respectively.
    ! dx                        A double real scalar representing the difference in x1 and x2.
    ! xprod                     A double real scalar representing the product of mole fractions of all
    !                            constituents associated with a parameter.
    ! dxvmo                     A double real scalar representing = (x1 - x2) ** (v-1).
    ! cSolnPhaseType            A character vector representing the solution phase type.
    !
    !-------------------------------------------------------------------------------------------------------------

subroutine CompExcessGibbsEnergyRKMP(iSolnIndex)

    USE ModuleThermo
    USE ModuleThermoIO, ONLY: INFOThermo
    USE ModuleGEMSolver

    implicit none

    integer :: i, j, iParam, iSolnIndex, iFirstSpecies, iLastSpecies, iExponent
    real(8) :: x1, x2, x3, x4, dx, xprod, xi, xj, KD, dxvmo

    ! Return control to the parent subroutine if there aren't any interaction parameters for this phase:
    if (nParamPhase(iSolnIndex) - nParamPhase(iSolnIndex-1) == 0) return

    ! Only proceed if the phase type is correct:
    IF_RKMP: if ((cSolnPhaseType(iSolnIndex) == 'RKMP').OR.(cSolnPhaseType(iSolnIndex) == 'RKMPM')) then

        ! Store the indices of the first and last species in this phase:
        iFirstSpecies = nSpeciesPhase(iSolnIndex-1) + 1
        iLastSpecies  = nSpeciesPhase(iSolnIndex)

        ! Loop through all interaction parameters in this phase:
        LOOP_Param: do iParam = nParamPhase(iSolnIndex-1)+1, nParamPhase(iSolnIndex)
            ! Compute temporary variables for sake of convenience:
            x1    = dMolFraction(iFirstSpecies + iRegularParam(iParam,2) - 1)
            x2    = dMolFraction(iFirstSpecies + iRegularParam(iParam,3) - 1)
            xprod = x1 * x2
            dx    = x1 - x2

            IF_ParamType: if (iRegularParam(iParam,1) == 2) then

                ! Binary parameter:

                ! Cycle if dx = 0 to prevent calculating either an INF or a NAN:
                if (dx == 0D0) cycle LOOP_Param

                iExponent = iRegularParam(iParam,4)
                dxvmo     = dx**(iExponent-1)
                dxvmo     = DMIN1(dxvmo,1D30)

                ! Loop through species in this phase:
                do i = iFirstSpecies, iLastSpecies

                    j = i - iFirstSpecies + 1
                    if (j == iRegularParam(iParam,2)) then
                        ! First species of parameter.
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dExcessGibbsParam(iParam) * &
                            dxvmo * ((x2 - xprod)*dx + DFLOAT(iExponent)*xprod*(1D0 - dx))

                    elseif (j == iRegularParam(iParam,3)) then
                        ! Second species of parameter.
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dExcessGibbsParam(iParam) * &
                            dxvmo * ((x1 - xprod)*dx - DFLOAT(iExponent)*xprod*(1D0 + dx))
                    else
                        ! This species does not belong to the parameter.
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) - dExcessGibbsParam(iParam) * &
                            (dx**(iExponent)) * xprod * (1D0 + DFLOAT(iExponent))
                    end if

                end do

            elseif (iRegularParam(iParam,1) == 3) then

                ! Ternary parameter:
                x3    = dMolFraction(iFirstSpecies + iRegularParam(iParam,4) - 1)
                xj    = dMolFraction(iRegularParam(iParam,5) + iFirstSpecies - 1)
                xprod = xprod * x3

                ! Loop through species in this phase:
                do i = iFirstSpecies, iLastSpecies
                    ! Relative species index in phase:
                    j = i - iFirstSpecies + 1
                    ! Compute Kronecker-Delta term for ternary parameter:
                    KD = 0
                    if (iRegularParam(iParam,5) == j) KD = 1

                    if ((j == iRegularParam(iParam,2)).OR.(j == iRegularParam(iParam,3)).OR. &
                        (j == iRegularParam(iParam,4))) then

                        ! This species contributes to the parameter.
                        xi = dMolFraction(i)

                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dExcessGibbsParam(iParam) * &
                            xprod * (((1d0 / xi) - 3D0) * ((1D0 - x1 - x2 - x3)/3D0 + xj) + KD)
                    else
                        ! This species does not contribute to the parameter.
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dExcessGibbsParam(iParam) * &
                            xprod * (x1 + x2 + x3 - 3D0*xj - 2D0/3D0)
                    end if
                end do

            elseif (iRegularParam(iParam,1) == 4) then

                ! Quaternary parameter:
                x3    = dMolFraction(iFirstSpecies + iRegularParam(iParam,4) - 1)
                x4    = dMolFraction(iFirstSpecies + iRegularParam(iParam,5) - 1)
                xprod = xprod * x3 * x4

                ! Loop through species in this phase:
                do i = iFirstSpecies, iLastSpecies

                    j = i - iFirstSpecies + 1

                    if ((j == iRegularParam(iParam,2)).OR.(j == iRegularParam(iParam,3)).OR. &
                        (j == iRegularParam(iParam,4)).OR.(j == iRegularParam(iParam,5))) then

                        ! This species contributes to the paramter:
                        xi = dMolFraction(i)
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) + dExcessGibbsParam(iParam) * &
                            xprod * ((1D0 / xi) - 3D0)
                    else
                        ! This species does not contribute to the parameter:
                        dPartialExcessGibbs(i) = dPartialExcessGibbs(i) - 3D0 * xprod * dExcessGibbsParam(iParam)
                    end if

                end do
            else
                ! The parameter index is not supported/recognized.  Report an error and exit.
                INFOThermo = 32
                exit LOOP_Param

            end if IF_ParamType

        end do LOOP_Param

    end if IF_RKMP

    return

end subroutine CompExcessGibbsEnergyRKMP


! subroutine cal_track
SUBROUTINE cal_track(num,tin,orb_elements,spheroid,smodel, &
             psx,psy,track,istat)

!   Cal_Track calculates information at num points in time
!   along the satellite track. The times are in tin.
!   Results are put into the track common block

!   Re-written as an independent subroutine by JS, Aug 2014

!   Inputs:
!       num
!       tin
!       orb_elements
!           1. Orbital inclination (degrees)
!           2. Semi_major radius (m)
!           3. Angular velocity (rad sec-1)
!       spheroid
!           1. Spheroid major axis
!           2. Inverse flattening
!           3. Eccentricity squared
!           4. Earth rotational angular velocity rad/sec
!       smodel
!           1. phi0
!           2. phi0_p
!           3. rho0
!           4. t0
!           5. lam0
!           6. gamm0
!           7. beta0
!           8. rotn0
!           9. hxy0
!           10. N0
!           11. H0
!           12. th_ratio0
!       track
!           1. t
!           2. rho
!           3. phi_p
!           4. lam
!           5. beta
!           6. hxy
!           7. mj
!           8. skew
!       psx
!           Approximate pixel size (in degrees longitude)
!       psy
!           Approximate pixel size (in degrees latitude)
!
!   Outputs:
!       track
!       istat

    use sys_variables, only : pi, d2r, r2d

    implicit none

    integer, intent(in) :: num
    integer, intent(inout) :: istat
    double precision, dimension(num), intent(in) :: tin
    double precision, dimension(4), intent(in) :: spheroid
    double precision, dimension(3), intent(in) :: orb_elements
!   smodel(phi0,phi0_p,rho0,t0,lam0,gamm0,beta0,rotn0,hxy0,N0,H0,th_ratio0)
    double precision, dimension(12), intent(in) :: smodel
    double precision, intent(in) :: psx, psy
!   track(t,rho,phi_p,lam,beta,hxy,mj,skew)
    double precision, dimension(num,8), intent(out) :: track
    double precision, dimension(num) :: t, rho, phi_p, lam, beta
    double precision, dimension(num) :: hxy, mj, skew

!f2py depend(num), tin, track
!f2py depend(num), t, rho, phi_p, lam, beta, hxy, mj, skew

    double precision oi, ws
    double precision we
    double precision rho0, t0, gamm0

    double precision psx_out, psy_out
    integer j

!   Initialise the return status
!   It will be overwritten by other routine calls
    istat = 0

!   smodel parameters
    rho0 = smodel(3)
    t0 = smodel(4)
    gamm0 = smodel(6)

!   Satellite orbital parameters
!   orbital inclination (degrees)
!   angular velocity (rad sec-1)
    oi = orb_elements(1)*d2r
    ws = orb_elements(3)

!   Spheroid parameters
!   Earth rotational angular velocity rad/sec
    we = spheroid(4)

    do j=1,num
        t(j) = tin(j)
        rho(j) = rho0+ws*(t(j)-t0)
        phi_p(j) = asin(cos(rho(j))*sin(oi))
        lam(j) = gamm0-pi/2.0d0+atan(tan(rho(j))/cos(oi))-we*(t(j)-t0)
        beta(j) = atan(-1.0d0/(tan(oi)*sin(rho(j))))
        skew(j) = atan(we*cos(phi_p(j))*cos(beta(j))/(ws+we* &
          cos(phi_p(j))*sin(beta(j))))
        call geo2metres_pixel_size(phi_p(j)*r2d,psx,psy,spheroid,&
               psx_out,psy_out,istat)
        hxy(j) = psx_out/psy_out
        if (j.gt.1) then
            mj(j-1) = (phi_p(j)-phi_p(j-1))/(lam(j)-lam(j-1))
        endif
    enddo

!   Store individual track variables into the track array
    track(:,1) = t
    track(:,2) = rho
    track(:,3) = phi_p
    track(:,4) = lam
    track(:,5) = beta
    track(:,6) = hxy
    track(:,7) = mj
    track(:,8) = skew

    return

END SUBROUTINE cal_track


      subroutine gauss(x1,x2,x,w,n)
      integer n
      real x1,x2,x(n),w(n)
      double precision xm,xl,z,p1,p2,p3,pp,z1
      integer m,i,j
      parameter (eps=3.d-14)
      m=(n+1)/2
      xm=0.5d0*(x2+x1)
      xl=0.5d0*(x2-x1)
      do 12 i=1,m
        z=cos(3.141592654d0*(i-.25d0)/(n+.5d0))
1       continue
          p1=1.d0
          p2=0.d0
          do 11 j=1,n
            p3=p2
            p2=p1
            p1=((2.d0*j-1.d0)*z*p2-(j-1.d0)*p3)/j
11        continue
          pp=n*(z*p1-p2)/(z*z-1.d0)
          z1=z
          z=z1-p1/pp
        if(abs(z-z1).gt.eps)go to 1
        if (abs(z).lt.eps) z=0.
        x(i)=xm-xl*z
        x(n+1-i)=xm+xl*z
        w(i)=2.d0*xl/((1.d0-z*z)*pp*pp)
        w(n+1-i)=w(i)
12    continue
      return
      end


      program DRDSI
c>> 1994-10-19 DRDSI   Krogh  Changes to use M77CON
c>> 1991-11-19  DRDSI   CLL
c>> 1989-04-26  DRDSI   Snyder at JPL, Original Code
c--D replaces "?":  DR?SI, ?CI, ?CIN, ?SI
c
c     Demonstration driver for Sine and Cosine integrals.
c
      double precision DCI, DCIN, DSI, X
      integer I
      external DCI, DCIN, DSI
c
c     Print values of Si(x), Ci(x) and Cin(x)
c     for X = 1.0 (1.0) 15.0
c
      print '(''  X'',11x,''Si(x)'',11x,''Ci(x)'',11x,''Cin(x)''/)'
      do 10 i = 1, 15
         x = dble(i)
         print '(f4.0,3f16.7)', x, dsi(x), dci(x), dcin(x)
   10 continue
      stop
      end


      SUBROUTINE MA02ES( UPLO, N, A, LDA )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To store by skew-symmetry the upper or lower triangle of a
C     skew-symmetric matrix, given the other triangle. The diagonal
C     entries are set to zero.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     UPLO    CHARACTER*1
C             Specifies which part of the matrix is given as follows:
C             = 'U':  Upper triangular part;
C             = 'L':  Lower triangular part.
C             For all other values, the array A is not referenced.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrix A.  N >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N upper triangular part
C             (if UPLO = 'U'), or lower triangular part (if UPLO = 'L'),
C             of this array must contain the corresponding upper or
C             lower triangle of the skew-symmetric matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the skew-symmetric matrix A with all elements stored.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Sep. 2012.
C
C     REVISIONS
C
C     -
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            LDA, N
C     .. Array Arguments ..
      DOUBLE PRECISION   A(LDA,*)
C     .. Local Scalars ..
      INTEGER            J
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C
C     .. Executable Statements ..
C
C     For efficiency reasons, the parameters are not checked for errors.
C
      IF( LSAME( UPLO, 'L' ) ) THEN
C
C        Construct the upper triangle of A.
C
         DO 20 I = 1, N
            A(I,I) = ZERO
            DO 10 J = 2, N
               A(I,J) = -A(J,I)
   10       CONTINUE
   20    CONTINUE
C
      ELSE IF( LSAME( UPLO, 'U' ) ) THEN
C
C        Construct the lower triangle of A.
C
         DO 40 I = 1, N
            A(I,I) = ZERO
            DO 30 J = 2, N
               A(J,I) = -A(I,J)
   30       CONTINUE
   40    CONTINUE
C
      END IF
      RETURN
C *** Last line of MA02ES ***
      END


program timer
  use arrayfire
  implicit none
  double precision elapsed
  type(array) A, B

  ! Generate a random matrix
  A = randu(1024, 2048)

  ! Start the timer
  call timer_start()

  ! Perform operations here.
  B = matmul(A, transpose(A))

  ! Stop the timer
  elapsed = timer_stop()

  ! Print time taken
  write (*,"(a15, d8.2)") "Time taken: ", elapsed
end program timer