*DECK PSIFN
      SUBROUTINE PSIFN (X, N, KODE, M, ANS, NZ, IERR)
C***BEGIN PROLOGUE  PSIFN
C***PURPOSE  Compute derivatives of the Psi function.
C***LIBRARY   SLATEC
C***CATEGORY  C7C
C***TYPE      SINGLE PRECISION (PSIFN-S, DPSIFN-D)
C***KEYWORDS  DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION,
C             PSI FUNCTION
C***AUTHOR  Amos, D. E., (SNLA)
C***DESCRIPTION
C
C         The following definitions are used in PSIFN:
C
C      Definition 1
C         PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of
C                  the LOG GAMMA function.
C      Definition 2
C                     K   K
C         PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X).
C   ___________________________________________________________________
C       PSIFN computes a sequence of SCALED derivatives of
C       the PSI function; i.e. for fixed X and M it computes
C       the M-member sequence
C
C                  ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X)
C                    for K = N,...,N+M-1
C
C       where PSI(K,X) is as defined above.   For KODE=1, PSIFN returns
C       the scaled derivatives as described.  KODE=2 is operative only
C       when K=0 and in that case PSIFN returns -PSI(X) + LN(X).  That
C       is, the logarithmic behavior for large X is removed when KODE=1
C       and K=0.  When sums or differences of PSI functions are computed
C       the logarithmic terms can be combined analytically and computed
C       separately to help retain significant digits.
C
C         Note that CALL PSIFN(X,0,1,1,ANS) results in
C                   ANS = -PSI(X)
C
C     Input
C           X      - Argument, X .gt. 0.0E0
C           N      - First member of the sequence, 0 .le. N .le. 100
C                    N=0 gives ANS(1) = -PSI(X)       for KODE=1
C                                       -PSI(X)+LN(X) for KODE=2
C           KODE   - Selection parameter
C                    KODE=1 returns scaled derivatives of the PSI
C                    function.
C                    KODE=2 returns scaled derivatives of the PSI
C                    function EXCEPT when N=0. In this case,
C                    ANS(1) = -PSI(X) + LN(X) is returned.
C           M      - Number of members of the sequence, M .ge. 1
C
C    Output
C           ANS    - A vector of length at least M whose first M
C                    components contain the sequence of derivatives
C                    scaled according to KODE.
C           NZ     - Underflow flag
C                    NZ.eq.0, A normal return
C                    NZ.ne.0, Underflow, last NZ components of ANS are
C                             set to zero, ANS(M-K+1)=0.0, K=1,...,NZ
C           IERR   - Error flag
C                    IERR=0, A normal return, computation completed
C                    IERR=1, Input error,     no computation
C                    IERR=2, Overflow,        X too small or N+M-1 too
C                            large or both
C                    IERR=3, Error,           N too large. Dimensioned
C                            array TRMR(NMAX) is not large enough for N
C
C         The nominal computational accuracy is the maximum of unit
C         roundoff (=R1MACH(4)) and 1.0E-18 since critical constants
C         are given to only 18 digits.
C
C         DPSIFN is the Double Precision version of PSIFN.
C
C *Long Description:
C
C         The basic method of evaluation is the asymptotic expansion
C         for large X.ge.XMIN followed by backward recursion on a two
C         term recursion relation
C
C                  W(X+1) + X**(-N-1) = W(X).
C
C         This is supplemented by a series
C
C                  SUM( (X+K)**(-N-1) , K=0,1,2,... )
C
C         which converges rapidly for large N. Both XMIN and the
C         number of terms of the series are calculated from the unit
C         roundoff of the machine environment.
C
C***REFERENCES  Handbook of Mathematical Functions, National Bureau
C                 of Standards Applied Mathematics Series 55, edited
C                 by M. Abramowitz and I. A. Stegun, equations 6.3.5,
C                 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964.
C               D. E. Amos, A portable Fortran subroutine for
C                 derivatives of the Psi function, Algorithm 610, ACM
C                 Transactions on Mathematical Software 9, 4 (1983),
C                 pp. 494-502.
C***ROUTINES CALLED  I1MACH, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   820601  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   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  PSIFN
      INTEGER I, IERR, J, K, KODE, M, MM, MX, N, NMAX, NN, NP, NX, NZ
      INTEGER I1MACH
      REAL ANS, ARG, B, DEN, ELIM, EPS, FLN, FN, FNP, FNS, FX, RLN,
     * RXSQ, R1M4, R1M5, S, SLOPE, T, TA, TK, TOL, TOLS, TRM, TRMR,
     * TSS, TST, TT, T1, T2, WDTOL, X, XDMLN, XDMY, XINC, XLN, XM,
     * XMIN, XQ, YINT
      REAL R1MACH
      DIMENSION B(22), TRM(22), TRMR(100), ANS(*)
      SAVE NMAX, B
      DATA NMAX /100/
C-----------------------------------------------------------------------
C             BERNOULLI NUMBERS
C-----------------------------------------------------------------------
      DATA B(1), B(2), B(3), B(4), B(5), B(6), B(7), B(8), B(9), B(10),
     * B(11), B(12), B(13), B(14), B(15), B(16), B(17), B(18), B(19),
     * B(20), B(21), B(22) /1.00000000000000000E+00,
     * -5.00000000000000000E-01,1.66666666666666667E-01,
     * -3.33333333333333333E-02,2.38095238095238095E-02,
     * -3.33333333333333333E-02,7.57575757575757576E-02,
     * -2.53113553113553114E-01,1.16666666666666667E+00,
     * -7.09215686274509804E+00,5.49711779448621554E+01,
     * -5.29124242424242424E+02,6.19212318840579710E+03,
     * -8.65802531135531136E+04,1.42551716666666667E+06,
     * -2.72982310678160920E+07,6.01580873900642368E+08,
     * -1.51163157670921569E+10,4.29614643061166667E+11,
     * -1.37116552050883328E+13,4.88332318973593167E+14,
     * -1.92965793419400681E+16/
C
C***FIRST EXECUTABLE STATEMENT  PSIFN
      IERR = 0
      NZ=0
      IF (X.LE.0.0E0) IERR=1
      IF (N.LT.0) IERR=1
      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
      IF (M.LT.1) IERR=1
      IF (IERR.NE.0) RETURN
      MM=M
      NX = MIN(-I1MACH(12),I1MACH(13))
      R1M5 = R1MACH(5)
      R1M4 = R1MACH(4)*0.5E0
      WDTOL = MAX(R1M4,0.5E-18)
C-----------------------------------------------------------------------
C     ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT
C-----------------------------------------------------------------------
      ELIM = 2.302E0*(NX*R1M5-3.0E0)
      XLN = LOG(X)
   41 CONTINUE
      NN = N + MM - 1
      FN = NN
      FNP = FN + 1.0E0
      T = FNP*XLN
C-----------------------------------------------------------------------
C     OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X
C-----------------------------------------------------------------------
      IF (ABS(T).GT.ELIM) GO TO 290
      IF (X.LT.WDTOL) GO TO 260
C-----------------------------------------------------------------------
C     COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1
C-----------------------------------------------------------------------
      RLN = R1M5*I1MACH(11)
      RLN = MIN(RLN,18.06E0)
      FLN = MAX(RLN,3.0E0) - 3.0E0
      YINT = 3.50E0 + 0.40E0*FLN
      SLOPE = 0.21E0 + FLN*(0.0006038E0*FLN+0.008677E0)
      XM = YINT + SLOPE*FN
      MX = INT(XM) + 1
      XMIN = MX
      IF (N.EQ.0) GO TO 50
      XM = -2.302E0*RLN - MIN(0.0E0,XLN)
      FNS = N
      ARG = XM/FNS
      ARG = MIN(0.0E0,ARG)
      EPS = EXP(ARG)
      XM = 1.0E0 - EPS
      IF (ABS(ARG).LT.1.0E-3) XM = -ARG
      FLN = X*XM/EPS
      XM = XMIN - X
      IF (XM.GT.7.0E0 .AND. FLN.LT.15.0E0) GO TO 200
   50 CONTINUE
      XDMY = X
      XDMLN = XLN
      XINC = 0.0E0
      IF (X.GE.XMIN) GO TO 60
      NX = INT(X)
      XINC = XMIN - NX
      XDMY = X + XINC
      XDMLN = LOG(XDMY)
   60 CONTINUE
C-----------------------------------------------------------------------
C     GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION
C-----------------------------------------------------------------------
      T = FN*XDMLN
      T1 = XDMLN + XDMLN
      T2 = T + XDMLN
      TK = MAX(ABS(T),ABS(T1),ABS(T2))
      IF (TK.GT.ELIM) GO TO 380
      TSS = EXP(-T)
      TT = 0.5E0/XDMY
      T1 = TT
      TST = WDTOL*TT
      IF (NN.NE.0) T1 = TT + 1.0E0/FN
      RXSQ = 1.0E0/(XDMY*XDMY)
      TA = 0.5E0*RXSQ
      T = FNP*TA
      S = T*B(3)
      IF (ABS(S).LT.TST) GO TO 80
      TK = 2.0E0
      DO 70 K=4,22
        T = T*((TK+FN+1.0E0)/(TK+1.0E0))*((TK+FN)/(TK+2.0E0))*RXSQ
        TRM(K) = T*B(K)
        IF (ABS(TRM(K)).LT.TST) GO TO 80
        S = S + TRM(K)
        TK = TK + 2.0E0
   70 CONTINUE
   80 CONTINUE
      S = (S+T1)*TSS
      IF (XINC.EQ.0.0E0) GO TO 100
C-----------------------------------------------------------------------
C     BACKWARD RECUR FROM XDMY TO X
C-----------------------------------------------------------------------
      NX = INT(XINC)
      NP = NN + 1
      IF (NX.GT.NMAX) GO TO 390
      IF (NN.EQ.0) GO TO 160
      XM = XINC - 1.0E0
      FX = X + XM
C-----------------------------------------------------------------------
C     THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL
C-----------------------------------------------------------------------
      DO 90 I=1,NX
        TRMR(I) = FX**(-NP)
        S = S + TRMR(I)
        XM = XM - 1.0E0
        FX = X + XM
   90 CONTINUE
  100 CONTINUE
      ANS(MM) = S
      IF (FN.EQ.0.0E0) GO TO 180
C-----------------------------------------------------------------------
C     GENERATE LOWER DERIVATIVES, J.LT.N+MM-1
C-----------------------------------------------------------------------
      IF (MM.EQ.1) RETURN
      DO 150 J=2,MM
        FNP = FN
        FN = FN - 1.0E0
        TSS = TSS*XDMY
        T1 = TT
        IF (FN.NE.0.0E0) T1 = TT + 1.0E0/FN
        T = FNP*TA
        S = T*B(3)
        IF (ABS(S).LT.TST) GO TO 120
        TK = 3.0E0 + FNP
        DO 110 K=4,22
          TRM(K) = TRM(K)*FNP/TK
          IF (ABS(TRM(K)).LT.TST) GO TO 120
          S = S + TRM(K)
          TK = TK + 2.0E0
  110   CONTINUE
  120   CONTINUE
        S = (S+T1)*TSS
        IF (XINC.EQ.0.0E0) GO TO 140
        IF (FN.EQ.0.0E0) GO TO 160
        XM = XINC - 1.0E0
        FX = X + XM
        DO 130 I=1,NX
          TRMR(I) = TRMR(I)*FX
          S = S + TRMR(I)
          XM = XM - 1.0E0
          FX = X + XM
  130   CONTINUE
  140   CONTINUE
        MX = MM - J + 1
        ANS(MX) = S
        IF (FN.EQ.0.0E0) GO TO 180
  150 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     RECURSION FOR N = 0
C-----------------------------------------------------------------------
  160 CONTINUE
      DO 170 I=1,NX
        S = S + 1.0E0/(X+NX-I)
  170 CONTINUE
  180 CONTINUE
      IF (KODE.EQ.2) GO TO 190
      ANS(1) = S - XDMLN
      RETURN
  190 CONTINUE
      IF (XDMY.EQ.X) RETURN
      XQ = XDMY/X
      ANS(1) = S - LOG(XQ)
      RETURN
C-----------------------------------------------------------------------
C     COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,...
C-----------------------------------------------------------------------
  200 CONTINUE
      NN = INT(FLN) + 1
      NP = N + 1
      T1 = (FNS+1.0E0)*XLN
      T = EXP(-T1)
      S = T
      DEN = X
      DO 210 I=1,NN
        DEN = DEN + 1.0E0
        TRM(I) = DEN**(-NP)
        S = S + TRM(I)
  210 CONTINUE
      ANS(1) = S
      IF (N.NE.0) GO TO 220
      IF (KODE.EQ.2) ANS(1) = S + XLN
  220 CONTINUE
      IF (MM.EQ.1) RETURN
C-----------------------------------------------------------------------
C     GENERATE HIGHER DERIVATIVES, J.GT.N
C-----------------------------------------------------------------------
      TOL = WDTOL/5.0E0
      DO 250 J=2,MM
        T = T/X
        S = T
        TOLS = T*TOL
        DEN = X
        DO 230 I=1,NN
          DEN = DEN + 1.0E0
          TRM(I) = TRM(I)/DEN
          S = S + TRM(I)
          IF (TRM(I).LT.TOLS) GO TO 240
  230   CONTINUE
  240   CONTINUE
        ANS(J) = S
  250 CONTINUE
      RETURN
C-----------------------------------------------------------------------
C     SMALL X.LT.UNIT ROUND OFF
C-----------------------------------------------------------------------
  260 CONTINUE
      ANS(1) = X**(-N-1)
      IF (MM.EQ.1) GO TO 280
      K = 1
      DO 270 I=2,MM
        ANS(K+1) = ANS(K)/X
        K = K + 1
  270 CONTINUE
  280 CONTINUE
      IF (N.NE.0) RETURN
      IF (KODE.EQ.2) ANS(1) = ANS(1) + XLN
      RETURN
  290 CONTINUE
      IF (T.GT.0.0E0) GO TO 380
      NZ=0
      IERR=2
      RETURN
  380 CONTINUE
      NZ=NZ+1
      ANS(MM)=0.0E0
      MM=MM-1
      IF(MM.EQ.0) RETURN
      GO TO 41
  390 CONTINUE
      IERR=3
      NZ=0
      RETURN
      END


!=====================================================|
subroutine model
!=====================================================|
  use geometry_def, only: xmax,xmin,dx,x,qq &
       & ,nx,nxg,margin
  use const_def, only: cv,gm,pi
  implicit none
  integer :: i

  real(KIND(0.d0)) :: xm,dd,tmp
  real(KIND(0.d0)) :: pr ! pressure
  real(KIND(0.d0)) :: rol,ror,vxl,vxr,prl,prr,byl,byr
!-----------------------------------------------------|

  xmax = 1.d0
  xmin = 0.d0

  dx = (xmax - xmin)/real(nx)
  x(1 + margin) = xmin + 0.5d0*dx
  do i = margin,1,-1
     x(i) = x(i+1) - dx
  enddo

  do i = 2 + margin,nxg
     x(i) = x(i-1) + dx
  enddo

  ! sound wave
  xm = 0.5d0*(xmax + xmin)
  dd = 0.05d0
  do i = 1,nxg
     qq(i,1) = 1.d0 + 0.01d0*exp(-((x(i)-xm)/dd)**2) ! density
     qq(i,2) = 0.d0 ! vx
     qq(i,3) = 0.d0 ! vy
     qq(i,4) = 0.d0 ! vz
     qq(i,5) = 1.d0 ! bx
     qq(i,6) = 1.d0 ! by
     qq(i,7) = 1.d0 ! bz
     pr = qq(i,1)**gm/gm
     qq(i,8) = cv*log(pr/qq(i,1)**gm) ! entropy
  enddo

  rol = 1.d0
  ror = 0.125d0
  vxl = 0.75d0
  vxr = 0.d0
  prl = 1.d0
  prr = 0.1d0
  ! hydrodynamic shock tube
  do i = 1,nxg
!     if( x(i) < 0.5d0) then
!        qq(i,1) = 1.d0
!        pr = 1.d0
!        qq(i,2) = 0.75d0
!     else
!        qq(i,1) = 0.125d0
!        pr = 0.1d0
!        qq(i,2) = 0d0
!     endif
     tmp = 0.5d0 + 0.5d0*tanh((x(i) - 0.5)/(1.d0*dx))
     qq(i,1) = rol + (ror - rol)*tmp
     qq(i,2) = vxl + (vxr - vxl)*tmp
     pr      = prl + (prr - prl)*tmp

     qq(i,3) = 0.d0
     qq(i,4) = 0.d0
     qq(i,5) = 0.d0
     qq(i,6) = 0.d0
     qq(i,7) = 0.d0
     qq(i,8) = cv*log(pr/qq(i,1)**gm) ! entropy
  enddo

!  goto 1000

  ! mhd shock tube (Brio and Wu, 1988)
  rol = 1.d0
  ror = 0.125d0
  prl = 1.d0
  prr = 0.1d0
  byl = 1.d0*sqrt(4.d0*pi)
  byr = -1.d0*sqrt(4.d0*pi)
  do i = 1,nxg
!     if( x(i) < 0.5d0) then
!        qq(i,1) = 1.d0
!        pr = 1.d0
!        qq(i,6) = 1.d0*sqrt(4.d0*pi) ! by
!     else
!        qq(i,1) = 0.125d0
!        pr = 0.1d0
!        qq(i,6) = -1.d0*sqrt(4.d0*pi) ! by
!     endif
     tmp = 0.5d0 + 0.5d0*tanh((x(i) - 0.5)/(1.d0*dx))
     qq(i,1) = rol + (ror - rol)*tmp
     pr      = prl + (prr - prl)*tmp
     qq(i,6) = byl + (byr - byl)*tmp

     qq(i,2) = 0.d0 ! vx
     qq(i,3) = 0.d0 ! vy
     qq(i,4) = 0.d0 ! vy
     qq(i,5) = 0.75d0*sqrt(4.d0*pi)  !bx
     qq(i,7) = 0.d0  !bz
     qq(i,8) = cv*log(pr/qq(i,1)**gm) ! entropy
  enddo

1000 continue

  return
end subroutine model


      SUBROUTINE qromo(func,a,b,ss,choose)
      INTEGER JMAX,JMAXP,K,KM
      REAL a,b,func,ss,EPS
      EXTERNAL func,choose
      PARAMETER (EPS=1.e-6, JMAX=14, JMAXP=JMAX+1, K=5, KM=K-1)
CU    USES polint
      INTEGER j
      REAL dss,h(JMAXP),s(JMAXP)
      h(1)=1.
      do 11 j=1,JMAX
        call choose(func,a,b,s(j),j)
        if (j.ge.K) then
          call polint(h(j-KM),s(j-KM),K,0.,ss,dss)
          if (abs(dss).le.EPS*abs(ss)) return
        endif
        s(j+1)=s(j)
        h(j+1)=h(j)/9.
11    continue
      pause 'too many steps in qromo'
      END

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


!////////////////////////////////////////////////////////////////////////////////////////
!  This program solves the 1-D heat equation, with zero-temperature
!  boundary conditions, in serial.
!  EXERCISE:  Parallelize this code by
!             1)  Adjusting the logic used to initialize my_imin and my_imax
!             2)  Filling in the ghost_zone_comm routine that communicates
!                 boundary values between neighbors.
PROGRAM MAIN
    USE ISO_FORTRAN_ENV, ONLY : output_unit,real64
    USE MPI
    IMPLICIT NONE
    REAL*8, ALLOCATABLE :: var(:), tmp(:)
    INTEGER ::  nx,nt
    REAL( real64) :: ct_one, ct_two, ct_three
    REAL( real64) :: elapsed_time, loop_time, init_time
    INTEGER :: i,j,k,n, ierr

    !/////////////////////////////////////////
    ! These two variables are initialized in INIT_COMM below.
    INTEGER :: my_rank, ncpu  ! Rank of this process; total number of MPI processes
    INTEGER :: my_imin, my_imax ! the range of x-indices that this rank owns
    INTEGER :: my_numx  ! The number of-indices assinged to this processes
                         ! my_numx = my_imax-my_imin+1

    CALL cpu_time( time= ct_one)

    !////////////////////////////////////////////////////
    ! Set some default values for the problem parameters.
    nx = 4096   ! x-dimension of our 3-D array
    nt = 4096   ! number of time steps to integrate over

    !////////////////////////////////////////////////////
    ! Check to see if the user has overridden
    ! these defaults at the command line.
    ! Command line calling syntax:
    ! ./ex5.out -nx 256 -nt 100
    CALL grab_args(nx,nt)

    CALL INIT_COMM()

    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)') ' ///////////////////////////'
        WRITE(output_unit,'(a)') '  1-D Diffusion Equation   '
        WRITE(output_unit,'(a)') '  --Problem Parameters-- '
        WRITE(output_unit,'(a,i0)')'   nx =', nx
        WRITE(output_unit,'(a,i0)')'   nt =', nt
        WRITE(output_unit,'(a,i0)')' ncpu =', ncpu
        WRITE(output_unit,'(a)') ' ///////////////////////////'
        WRITE(output_unit,'(a)') ' '
    ENDIF
    !/////////////////////////////////////////////////////
    ! Initialize var and the work array

    !NOTE: my_imin & my_numx are correct only for ncpu = 1
    !      It should be modified based on my_rank.
    my_numx = nx
    my_imin = 1
    my_imax = my_imin+my_numx-1

    DO i = 0, ncpu-1
        IF (i .eq. my_rank) THEN
            WRITE(6,*)'my_rank, my_imin, my_imax: ', my_rank, my_imin, my_imax
        ENDIF
        ! The use of a barrier here helps the line above to be printed out
        ! "in order"
        IF (ncpu .gt. 1) CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
    ENDDO

    ALLOCATE(var(my_imin-1:my_imax+1))  ! We allow space for two
    ALLOCATE(tmp(my_imin:my_imax))  ! "ghost zones" in the var array

    var(:)   = 0.0d0
    tmp(:)   = 0.0d0
    CALL INIT_ARR(var, 1.0d0, 2) ! single sine wave in x-direction

    !/////////////////////////////////////////////////////
    ! Evolve the system
    CALL cpu_time( time= ct_two)
    DO n = 1, nt
        IF (my_rank .eq. 0) THEN
            IF (MOD(n,100) .eq. 0) Write(output_unit,'(a,i5)')' Timestep: ',n
        ENDIF

        !* EDIT THIS FUNCTION to communicate ghost zones
        !  to left and right neighbor ranks.
        IF (ncpu .gt. 1) CALL GHOST_ZONE_COMM()

        CALL Laplacian(var,tmp)

    ENDDO
    ! We may want to write out the values for debugging
    !Write(output_unit,*) var(:)

    !//////////////////////////////////////////
    ! Write out some timing information.

    CALL cpu_time( time= ct_three)
    elapsed_time = ct_three-ct_one
    init_time = ct_two-ct_one
    loop_time = ct_three-ct_two
    IF (my_rank .eq. 0) THEN
        WRITE(output_unit,'(a)')' Complete!'
        WRITE(output_unit,'( a, ES14.4, a)')'         Elapsed time: ', elapsed_time, ' seconds.'
        WRITE(output_unit, fmt= '( a, ES14.4, a)') '  Initialization time: ', init_time, ' seconds.'
        WRITE(output_unit, fmt= '( a, ES14.4, a)') '            Loop time: ', loop_time, ' seconds.'
    ENDIF

    ! Always call this at the end of the program so that all ranks exit together.
    ! Once your code is working, try removing this call.  The code will still work,
    ! but sometimes you may not see the timing information printed out because other
    ! ranks exit before rank 0 can write.
    CALL MPI_FINALIZE(ierr)
CONTAINS

    SUBROUTINE GHOST_ZONE_COMM()
        IMPLICIT NONE
        ! Communicate boundary values here...

    END SUBROUTINE GHOST_ZONE_COMM

    SUBROUTINE Laplacian(arrin, work)
        IMPLICIT NONE
        REAL*8, INTENT(InOut) :: arrin(my_imin-1:)
        REAL*8, INTENT(InOut) :: work(my_imin:)
        INTEGER :: ni, imin,imax

        ni = size(arrin)

        imin = max(my_imin,2)    ! Avoid the boundaries, which are held fixed at zero
        imax = min(my_imax,nx)

        DO i = imin, imax
            work(i) =  arrin(i-1) + arrin(i+1)
        ENDDO

        DO i = imin, imax
            arrin(i) = work(i)*0.5d0
        ENDDO

    END SUBROUTINE Laplacian

    SUBROUTINE grab_args(numx, numiter)
            IMPLICIT NONE

            INTEGER, INTENT(OUT)   :: numx
            INTEGER, INTENT(OUT)   :: numiter

            INTEGER :: n                    ! Number of command-line arguments
            INTEGER :: i
            CHARACTER(len=1024) :: argname  ! Argument key
            CHARACTER(len=1024) :: val      ! Argument value

            n = command_argument_count()
            DO i=1,n,2
                    CALL get_command_argument(i, argname)
                    CALL get_command_argument(i+1, val)
                    SELECT CASE(argname)
                            CASE('-nx')
                                    read(val, '(I8)') numx
                            CASE('-nt')
                                    read(val, '(I8)') numiter
                            CASE DEFAULT
                                    WRITE(output_unit,'(a)') ' '
                                    WRITE(output_unit,'(a)') &
                                    ' Unrecognized option: '// trim(argname)
                    END SELECT
            ENDDO

    END SUBROUTINE grab_args

    SUBROUTINE INIT_COMM()
        IMPLICIT NONE
        INTEGER :: ierr
        !Initialize MPI  (ierr is an error flag with nonzero value if there's a problem)
        Call MPI_INIT( ierr )
        IF (ierr .ne. 0) STOP 'Error intializing MPI'

        !Find number of MPI processes executing this program (ncpu)
        Call MPI_Comm_size(MPI_COMM_WORLD, ncpu,ierr)
        IF (ierr .ne. 0) STOP 'Error finding ncpu'

        !Find this process's rank (my_rank; unique numeric identifier for each MPI process)
        Call MPI_Comm_rank(MPI_COMM_WORLD, my_rank,ierr)
        IF (ierr .ne. 0) STOP 'Error finding my_rank'
        WRITE(output_unit,'(a,i0,a,i0,a)')'Rank ',my_rank,' of ', ncpu, ' is active.'
        CALL MPI_BARRIER(MPI_COMM_WORLD,ierr)
    END SUBROUTINE INIT_COMM

    SUBROUTINE INIT_ARR(arr, amp, orderx)
        IMPLICIT NONE
        REAL*8, INTENT(INOUT) :: arr(:)
        REAL*8, INTENT(IN) :: amp
        INTEGER, INTENT(IN) :: orderx
        REAL*8 :: sinkx
        REAL*8 :: kx
        REAL*8, PARAMETER :: pi = 3.1415926535897932384626433832795028841972d0
        INTEGER :: i,ni
        ni = size(arr)

        kx = orderx*(pi/(ni-1))

        DO i = my_imin, my_imax
            sinkx = sin(kx*(i-1))
            arr(i) = arr(i)+amp*sinkx
        ENDDO
        If (my_imin .eq. 1) arr(1) = 0
        If (my_imax .eq. ni) arr(ni) = 0

    END SUBROUTINE INIT_ARR
END PROGRAM MAIN


program poisson_mpi1D
	use poisson_module
	use mpi
	implicit none

	integer :: i,j,k,ret
	real, allocatable, dimension(:) :: u,u0,f,u_global
	integer, allocatable, dimension(:) :: buf
	real :: h, l2
	integer :: prank, psize, ierror, tag, status(MPI_STATUS_SIZE)
	double precision :: t_start, t_end
	integer :: n_loc, offset, n_min;
	integer :: j_start, j_end, i_start, i_end
	real :: x,y

! Initialization of the MPI library
	call MPI_INIT(ierror)
	call MPI_COMM_RANK(MPI_COMM_WORLD, prank, ierror)
	call MPI_COMM_SIZE(MPI_COMM_WORLD, psize, ierror)

	n_min = (N+1)
	h = 1. / n_min
! Divide n in psize and distribute the excess to the (n % psize) proc
	if (prank < mod(n_min,psize)) then
		n_loc = (n_min / psize) + 1
	else
		n_loc = (n_min / psize)
	endif
! Computing the offset of where in the global array the local array is
! located. (this is needed to initialize f) It could be computed locally
! without communication but this way you see a Allgather
	allocate(buf(psize))
	call MPI_ALLGATHER(n_loc, 1, MPI_INTEGER, buf, 1, MPI_INTEGER, MPI_COMM_WORLD,ierror)
	offset = 0
	do i = 1, prank
		offset = offset + buf(i)
	enddo
! add 2 for east and west ghost
	n_loc = n_loc + 2

	allocate(u(n_min*n_loc),u0(n_min*n_loc),f(n_min*n_loc))
	if (prank.eq.0) allocate(u_global(n_min*n_min))

	u = 0.
	u0 = 0.
	f = 0.

	do i = 2, n_min-1
		do j = 2, n_loc-1
!			x = real(i) * h
!			y = real(j - j_start + offset) * h
!			f(n_loc*i+j) = -2.*100. * M_PI * M_PI * sin(10.*M_PI*x) * sin(10.*M_PI*y)
			f(n_loc*i+j) = -2.*100. * M_PI * M_PI * sin(10.*M_PI*(i-1)*h) * sin(10.*M_PI*(j-1)*h)

		enddo
	enddo

!if (prank.eq.1) write(*,*) prank, f

	k = 0
	l2 = 1.
	t_start = MPI_WTIME()

!	do while (l2 > eps)
	do while (k < 400)
		l2 = 0.
		j_start = 2
		j_end   = n_loc-1
		i_start = 2
		i_end   = n_min-1

! send recv with left proc
		if (prank > 0)  then
			call MPI_SENDRECV(u0(n_min+2), n_min, MPI_REAL, prank - 1, NORTH, u0(1), n_min, MPI_REAL, prank - 1, SOUTH, MPI_COMM_WORLD, status, ierror)
!			call MPI_SENDRECV(u0(n_min:2*n_min), n_min, MPI_REAL, prank - 1, NORTH, u0(1:n_min), n_min, MPI_REAL, prank - 1, SOUTH, MPI_COMM_WORLD, status, ierror)
!				call MPI_SENDRECV(u0(:,2), n_min, MPI_REAL, prank - 1, NORTH, u0(:,1), n_min, MPI_REAL, prank - 1, SOUTH, MPI_COMM_WORLD, status, ierror)
		endif

! send recv with right proc
		if(prank < psize - 1) then
			call MPI_SENDRECV(u0(n_loc-1), n_min, MPI_REAL, prank + 1, SOUTH, u0(n_loc), n_min, MPI_REAL, prank + 1, NORTH, MPI_COMM_WORLD, status, ierror)
!			call MPI_SENDRECV(u0((n_loc-1)*n_min:(n_loc-1)*2*n_min), n_min, MPI_REAL, prank + 1, SOUTH, u0(n_loc:n_loc+n_min), n_min, MPI_REAL, prank + 1, NORTH, MPI_COMM_WORLD, status, ierror)
!			call MPI_SENDRECV(u0(:,n_loc-1), n_min, MPI_REAL, prank + 1, SOUTH, u0(:,n_loc), n_min, MPI_REAL, prank + 1, NORTH, MPI_COMM_WORLD, status, ierror)
		endif

		do i = i_start, i_end
			do j = j_start,j_end
				u(n_loc*i+j) = 0.25 * ( u0(n_loc*(i-1)+j) + u0(n_loc*(i+1)+j) + u0(n_loc*i+(j-1)) + u0(n_loc*i+(j+1)) - f(n_loc*i+j)*h*h);
				! L2 norm
				l2 = l2 + (u0(n_loc*i+j) - u(n_loc*i+j))*(u0(n_loc*i+j) - u(n_loc*i+j));
			enddo
		enddo

! reduce the 12 norm to every proc
		call MPI_ALLREDUCE(MPI_IN_PLACE, l2, 1, MPI_REAL, MPI_SUM, MPI_COMM_WORLD, ierror);

		call MPI_Gather(u(1),(n_min*(n_loc-2)),MPI_REAL, u_global,(n_min*(n_loc-2)) ,  MPI_REAL, 0, MPI_COMM_WORLD,ierror)
!		if (prank.eq.0) call write_to_file_binary1D(n_min, u_global, k, -1., 1.)

		! output
		if (prank .eq. 0) then
			write(*,*) 'iteration',k,l2
		endif
		k = k + 1
		u0 = u
	enddo
	t_end = MPI_WTIME()
	if (prank .eq. 0) then
		write(*,*) 'T',(t_end - t_start),'[s]'
		write(*,*) 'Nb steps',k,'l2',l2
		write(*,*) 'Size',n_min
	endif

	deallocate(u,u0,f)
	if (prank.eq.0) deallocate(u_global)

	call MPI_FINALIZE(ierror)

end program poisson_mpi1D


SUBROUTINE spl2d(nx,ny,hx,hy,mx,my,f,spl)

! Makes a 2-dimensional cubic spline of function f(x,y)
!
! Input:  nx, ny              number of values in x and y
!         hx, hy              step size in x and y (aequidistant)
!         mx, my              spline mode (0: standard, 1: periodic)
!         f(nx,ny)            f(x,y)-values
! Output: spl                 Array with spline parameters

  USE neo_precision

  IMPLICIT NONE

  INTEGER,                             INTENT(in)  :: nx, ny, mx, my
  REAL(kind=dp),                       INTENT(in)  :: hx, hy
  REAL(kind=dp), DIMENSION(nx,ny)    , INTENT(in)  :: f
  REAL(kind=dp), DIMENSION(4,4,nx,ny), INTENT(out) :: spl

  REAL(kind=dp), DIMENSION(:),         ALLOCATABLE :: bi, ci, di, s
  INTEGER                                          :: i, j, k, l

  ALLOCATE ( bi(nx), ci(nx), di(nx), s(nx) )
  DO j = 1,ny
     DO i = 1,nx
        s(i) = f(i,j)
     END DO
     IF (mx .EQ. 0) THEN
        CALL splreg(nx,hx,s,bi,ci,di)
     ELSE
        CALL splper(nx,hx,s,bi,ci,di)
     ENDIF
     DO i = 1,nx
        spl(1,1,i,j) = s(i)
        spl(2,1,i,j) = bi(i)
        spl(3,1,i,j) = ci(i)
        spl(4,1,i,j) = di(i)
     END DO
  END DO
  DEALLOCATE ( bi, ci, di, s )

  ALLOCATE ( bi(ny), ci(ny), di(ny), s(ny) )
  DO k = 1,4
     DO i = 1,nx
        DO j = 1,ny
           s(j) = spl(k,1,i,j)
        END DO
        IF (my .EQ. 0) THEN
           CALL splreg(ny,hy,s,bi,ci,di)
        ELSE
           CALL splper(ny,hy,s,bi,ci,di)
        ENDIF
        DO j=1,ny
           spl(k,2,i,j)=bi(j)
           spl(k,3,i,j)=ci(j)
           spl(k,4,i,j)=di(j)
        END DO
     END DO
  END DO
  DEALLOCATE ( bi, ci, di, s )

  RETURN
END SUBROUTINE spl2d


!
!     -----------------------------------------------------------------
!           F A C T R L
!     -----------------------------------------------------------------
!
!
      SUBROUTINE FACTRL(NFACT)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE FACT_C
!
!      GAM(I) = LOG( GAMMA(I-1) ), WHERE GAMMA(I) = FACTORIAL I-1
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  21:52:17  11/14/01
!...Switches:
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER , INTENT(IN) :: NFACT
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I
      REAL(DOUBLE) :: ZERO, ONE, TWO, GAMMA, X
!-----------------------------------------------
!
      DATA ZERO, ONE, TWO/ 0.D0, 1.D0, 2.D0/
!
      GAMMA = ONE
      GAM(1) = ZERO
      DO I = 1, NFACT - 1
         GAMMA = I*GAMMA
         GAM(I+1) = DLOG(GAMMA)
      END DO
      DO I = NFACT + 1, 100
         X = I - 1
         GAM(I) = GAM(I-1) + DLOG(X)
      END DO
      RETURN
      END SUBROUTINE FACTRL


!! # ----------------------------------------------------------------------------------
!! # Output and diagnostics
!! # ----------------------------------------------------------------------------------
subroutine fclaw3dx_clawpatch46_fort_conservation_check(mx,my,mz, &
    mbc,mfields,dx,dy,dz,area,q,sum,c_kahan)
    implicit none

    integer :: mx,my,mz,mbc,mfields
    double precision :: dx, dy,dz
    double precision :: sum(mfields), c_kahan(mfields)
    double precision :: q(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,mfields)
    double precision :: area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

    integer :: i,j,k,m
    double precision :: t, y, area_ij, vol_ij
    integer*8 :: cont, get_context
    logical :: fclaw2d_map_is_used

    logical :: use_kahan

    use_kahan = .true.

    cont = get_context()

    area_ij = dx*dy  !! Area in each mesh cell is constant
    do m = 1,mfields
        do k = 1,mz
            do j = 1,my
                do i = 1,mx
                    if (fclaw2d_map_is_used(cont)) then
                        area_ij = area(i,j)  !! Area varies
                    endif
                    vol_ij = area_ij*dz
                    if (use_kahan) then
                        y = q(i,j,k,m)*vol_ij - c_kahan(m)
                        t = sum(m) + y
                        c_kahan(m) = (t-sum(m)) - y
                        sum(m) = t
                    else
                        sum(m) = sum(m) + q(i,j,k,m)*vol_ij
                    endif
                enddo
            enddo
        end do
    end do
end subroutine fclaw3dx_clawpatch46_fort_conservation_check

!! # Compute area of a patch
double precision function fclaw3dx_clawpatch46_fort_compute_patch_area( &
         mx,my, mz, mbc,dx,dy,dz, area)
    implicit none

    integer :: mx,my, mz, mbc
    double precision :: dx, dy, dz
    double precision :: area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

    integer :: i,j
    integer*8 :: cont, get_context
    logical :: fclaw2d_map_is_used
    double precision :: sum

    cont = get_context()

    if (fclaw2d_map_is_used(cont)) then
        sum = 0
        do j = 1,my
            do i = 1,mx
                sum = sum + area(i,j)
            end do
        end do
    else
        sum = dx*dy*mx*my
    endif

    fclaw3dx_clawpatch46_fort_compute_patch_area = sum

end function fclaw3dx_clawpatch46_fort_compute_patch_area

subroutine fclaw3dx_clawpatch46_fort_compute_error_norm( &
     blockno, mx,my,mz,mbc,mfields,dx,dy,dz,area,error,error_norm)
    implicit none

    integer :: mx,my,mz, mbc,mfields, blockno
    double precision :: dx, dy, dz
    double precision :: error_norm(mfields,3)
    double precision :: error(1-mbc:mx+mbc,1-mbc:my+mbc,1-mbc:mz+mbc,mfields)
    double precision :: area(-mbc:mx+mbc+1,-mbc:my+mbc+1)

    integer :: i,j,k,m
    double precision :: dxdydz, eij, vol_ij

    integer*8 :: cont, get_context
    logical :: fclaw2d_map_is_used

    cont = get_context()

    !! # error_norm(:) comes in with values;  do not initialize it here!
    dxdydz = dx*dy*dz
    do m = 1,mfields
       if (fclaw2d_map_is_used(cont)) then
            do k = 1,mz
                do j = 1,my
                    do i = 1,mx
                        vol_ij = area(i,j)*dz
                        eij = abs(error(i,j,k,m))
                        error_norm(m,1) = error_norm(m,1) + &
                            eij*vol_ij
                        error_norm(m,2) = error_norm(m,2) + &
                            eij**2*vol_ij
                        error_norm(m,3) = max(eij,error_norm(m,3))
                    end do
                end do
            end do
        else
            do k = 1,mz
                do j = 1,my
                    do i = 1,mx
                        eij = abs(error(i,j,k,m))
                        error_norm(m,1) = error_norm(m,1) + &
                            eij*dxdydz
                        error_norm(m,2) = error_norm(m,2) + &
                            eij**2*dxdydz
                        error_norm(m,3) = max(eij,error_norm(m,3))
                    end do
                end do
            end do
        endif
    end do

end subroutine fclaw3dx_clawpatch46_fort_compute_error_norm


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$

module meteor_mod

use        types_mod, only : r8, deg2rad

implicit none
private

public :: invert_altimeter,        &
          pres_alt_to_pres,        &
          sat_vapor_pressure,      &
          specific_humidity,       &
          theta_to_temp,           &
          wind_dirspd_to_uv,       &
          rh_and_temp_to_dewpoint, &
          temp_and_dewpoint_to_rh

real(r8), parameter :: grav    = 9.81_r8,      & ! gravitational constant
                       Cp      = 1004.5_r8,    &
                       Rd      = 287.0_r8,     &
                       Rv      = 461.6_r8,     &
                       Lvap    = 2500000.0_r8, &
                       R_earth = 6370.0_r8,    &
                       Pref    = 100000.0,     & ! reference pressure
                       Pralt   = 101325.0,     & ! altimeter reference P
                       Talt    = 288.15,       & ! altimeter reference T
                       es0C    = 611.0_r8,     & ! vapor pressure at 0 C (Pa)
                       Tfrez   = 273.15_r8,    & ! water freezing point (K)
                       RvRd    = Rv/Rd,        & ! Rv/Rd
                       RdRv    = Rd/Rv,        & ! Rd/Rv  added 11/2009
                       kappa   = Rd/Cp,        & ! kappa for pot. temp
                       dTdzsta =0.0065           ! standard atmosphere lapse rate K/m

contains

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   invert_altimeter - function that computes the surface pressure
!                      given an altimeter setting and the station
!                      elevation.
!
!    altimeter_setting - altimeter setting (hPa)
!    elevation         - elevation of station (m)
!    invert_altimeter  - surface pressure value (hPa)
!
!     created Dec. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function invert_altimeter(altimeter_setting, elevation)

use        types_mod, only : r8

implicit none

real(r8), parameter :: k1 = 0.190284_r8
real(r8), parameter :: k2 = 8.4228807E-5_r8

real(r8), intent(in) :: altimeter_setting, elevation

real(r8) :: invert_altimeter !  (hPa)

invert_altimeter = (altimeter_setting ** k1 - k2 * elevation) ** (1 / k1) + 0.3_r8

return
end function invert_altimeter

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   pres_alt_to_pres - function that computes the pressure level given
!                      the pressure altitude.  Used mostly for ACARS
!                      observations.
!
!    hght - pressure-height level (m)
!
!     created Oct. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function pres_alt_to_pres(hght)

real(r8), parameter  :: Po   = 101325.0_r8
real(r8), intent(in) :: hght

real(r8) :: C1, pres_alt_to_pres

C1 = grav / (dTdzsta * Rd)
pres_alt_to_pres = Po * exp( C1 * log( 1 - (dTdzsta * hght) / Talt) )

end function pres_alt_to_pres

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   sat_vapor_pressure - function that computes the water vapor
!                        saturation vapor pressure given a temperature.
!
!    tmpk - temperature (K)
!
!     created Oct. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function sat_vapor_pressure(tmpk)

real(r8), intent(in) :: tmpk

real(r8) :: sat_vapor_pressure
! Clausius-Clapeyron w/ constant Lv in Pa
sat_vapor_pressure = es0C * exp((Lvap/Rv)*(1.0_r8/Tfrez - 1.0_r8/tmpk))

return
end function sat_vapor_pressure

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   specific_humidity - function that computes the specific humidity
!                       given the vapor pressure and atmospheric dry
!                       air pressure.
!
!    vapor_pres - vapor pressure (Pa)
!    pres       - atmospheric pressure (Pa)
!
!     created Dec. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function specific_humidity(vapor_pres, pres)

real(r8), intent(in) :: vapor_pres, pres

real(r8) :: specific_humidity

! 11/2009 changed to Emanuel (1994) eqn 4.1.4
 specific_humidity = (RdRv * vapor_pres) / (pres - vapor_pres*(1.0_r8-RdRv))

return
end function specific_humidity

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   theta_to_temp - function that computes the temperature given a
!                   potential temperature and the pressure level.
!
!    thta - potential temperature (K)
!    pres - pressure (Pa)
!
!     created Oct. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function theta_to_temp(thta, pres)

real(r8), intent(in) :: thta, pres

real(r8) :: theta_to_temp

theta_to_temp = thta * (Pref/pres) ** (-kappa)

return
end function theta_to_temp

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   wind_dirspd_to_uv - subroutine that converts a wind direction and
!                       wind speed to a zonal and meridional wind
!                       component.
!
!    wdir - wind direction
!    wspd - wind speed (m/s)
!    uwnd - u component of the wind (m/s)
!    vwnd - v component of the wind (m/s)
!
!     created Oct. 2007 Ryan Torn, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine wind_dirspd_to_uv(wdir, wspd, uwnd, vwnd)

real(r8), intent(in)  :: wdir, wspd
real(r8), intent(out) :: uwnd, vwnd

uwnd =  wspd * cos(deg2rad * (90.0_r8 + wdir))
vwnd = -wspd * sin(deg2rad * (90.0_r8 + wdir))

return
end subroutine wind_dirspd_to_uv

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   sat_vapor_press_bolton - function that uses Bolton's approximation to
!                            compute saturation vapor pressure given
!                            temperature.
!
!   reference:  Bolton 1980, MWR, 1046-1053
!
!    sat_vapor_press_bolton - saturation vapor pressure (Pa)
!    tmpk                   - temperature (K)
!
!     created Dec. 2008 David Dowell, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function sat_vapor_press_bolton(tmpk)

real(r8)             :: sat_vapor_press_bolton
real(r8), intent(in) :: tmpk

real(r8)             :: tmpc               ! temperature (Celsius)

tmpc = tmpk - Tfrez
if ( tmpc <= -200.0_r8 ) then
  print*,'sat_vapor_press_bolton:  tmpc too low ',tmpc
  stop
end if
sat_vapor_press_bolton = es0C * exp( 17.67_r8 * tmpc / (tmpc + 243.5_r8) )

return
end function sat_vapor_press_bolton

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   temp_and_dewpoint_to_rh - function that computes the relative humidity
!                             given temperature and dewpoint
!
!    temp_and_dewpoint_to_rh - relative humidity (0.00 - 1.00)
!    tmpk                    - temperature (Kelvin)
!    dptk                    - dewpoint (Kelvin)
!
!     created Dec. 2008 David Dowell, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function temp_and_dewpoint_to_rh(tmpk, dptk)

real(r8)             :: temp_and_dewpoint_to_rh
real(r8), intent(in) :: tmpk
real(r8), intent(in) :: dptk

real(r8)             :: e                  ! vapor pressure (Pa)
real(r8)             :: es                 ! saturation vapor pressure (Pa)

e = sat_vapor_press_bolton(dptk)
es = sat_vapor_press_bolton(tmpk)

temp_and_dewpoint_to_rh = e / es

if (temp_and_dewpoint_to_rh > 1.00_r8) then
  print*,'rh = ', temp_and_dewpoint_to_rh, ', resetting to 1.00'
  temp_and_dewpoint_to_rh = 1.00_r8
end if

return
end function temp_and_dewpoint_to_rh

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!   rh_and_temp_to_dewpoint - function that computes the dewpoint
!                             given relative humidity and temperature
!
!    rh_and_temp_to_dewpoint - dewpoint (Kelvin)
!    rh                      - relative humidity (0.00 - 1.00)
!    tmpk                    - temperature (Kelvin)
!
!     created Dec. 2008 David Dowell, NCAR/MMM
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function rh_and_temp_to_dewpoint(rh, tmpk)

real(r8)             :: rh_and_temp_to_dewpoint
real(r8), intent(in) :: rh
real(r8), intent(in) :: tmpk

real(r8)             :: e                  ! vapor pressure (Pa)
real(r8)             :: es                 ! saturation vapor pressure (Pa)
real(r8)             :: dptc               ! dptc (Celsius)

if ( ( rh <= 0.00_r8 ) .or. ( rh > 1.00_r8 ) ) then
  print*,'rh_and_temp_to_dewpoint:  bad rh ',rh
  stop
end if
if ( rh <= 0.01_r8 ) then
  print*,'rh_and_temp_to_dewpoint: low rh ',rh
end if

es = sat_vapor_press_bolton(tmpk)
e = rh * es

dptc = 243.5_r8 / (17.67_r8 / log(e/es0C) - 1.0_r8)

rh_and_temp_to_dewpoint = dptc + Tfrez

return
end function rh_and_temp_to_dewpoint

end module meteor_mod

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


c
c --- main program below module
c
      MODULE EULER_ROTATION
      IMPLICIT NONE

!-----------------------------------------------------------------------
! euler rotation of model geometry
!-----------------------------------------------------------------------
! based on code fragments provided for AOMIP by David Holland.
! http://fish.cims.nyu.edu/project_aomip/model_grid/overview.html
!-----------------------------------------------------------------------
!
! C_ALPHA : rotation about z-axis
! C_BETA  : rotation about new y-axis
! C_GAMMA : rotation about new z-axis
! C_FORWARD : rotation matricies to geographic coordinates
! C_REVERSE : rotation matricies to model coordinates
!
!-----------------------------------------------------------------------

      REAL*8 ::
     &      C_ALPHA  = 000.0

      REAL*8 ::
     &      C_BETA   = 000.0

      REAL*8 ::
     &      C_GAMMA  = 000.0

      REAL*8,
     &      DIMENSION (1:3, 1:3) ::
     &      C_FORWARD = 0.0

      REAL*8,
     &      DIMENSION (1:3, 1:3) ::
     &      C_REVERSE = 0.0

      REAL*8, PRIVATE, PARAMETER :: C_EPSILON=1.0d-5
      REAL*8, PRIVATE, PARAMETER ::    RADIAN=57.29577951D0
      REAL*8, PRIVATE, PARAMETER :: INVRADIAN=1.d0/RADIAN

!-----------------------------------------------------------------------
      CONTAINS
!-----------------------------------------------------------------------

      REAL*8 FUNCTION C_SIND(X)
      REAL*8 X
      C_SIND = SIN(X*INVRADIAN)
      END FUNCTION C_SIND

      REAL*8 FUNCTION C_COSD(X)
      REAL*8 X
      C_COSD = COS(X*INVRADIAN)
      END FUNCTION C_COSD

      REAL*8 FUNCTION C_INV_SIND(X)
      REAL*8 X
      C_INV_SIND = RADIAN*ASIN(X)
      END FUNCTION C_INV_SIND

      REAL*8 FUNCTION C_INV_COSD(X)
      REAL*8 X
      C_INV_COSD = RADIAN*ACOS(X)
      END FUNCTION C_INV_COSD

      SUBROUTINE C_EULER_ROTATION_MATRIX

!-----------------------------------------------------------------------
! purpose: compute euler rotation matrix
!-----------------------------------------------------------------------
!
! C_ALPHA   : rotation about z-axis
! C_BETA    : rotation about new y-axis
! C_GAMMA   : rotation about new z-axis
! C_REVERSE : rotation to model coordinates
! C_FORWARD : rotation to geographic coordinates
!
!-----------------------------------------------------------------------

      !local vars
      REAL*8 ::
     &
     &      COSA,
     &      SINA,
     &      COSB,
     &      SINB,
     &      COSG,
     &      SING

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

      !compute sin and cos of all angles in degrees
      COSA  = C_COSD (C_ALPHA )
      SINA  = C_SIND (C_ALPHA )
      COSB  = C_COSD (C_BETA  )
      SINB  = C_SIND (C_BETA  )
      COSG  = C_COSD (C_GAMMA )
      SING  = C_SIND (C_GAMMA )

      !compute rotation matrix into model coordinates
      C_REVERSE (1,1) =   COSA * COSB * COSG  -  SINA * SING
      C_REVERSE (1,2) =   SINA * COSB * COSG  +  COSA * SING
      C_REVERSE (1,3) =        - SINB * COSG
      C_REVERSE (2,1) = - COSA * COSB * SING  -  SINA * COSG
      C_REVERSE (2,2) = - SINA * COSB * SING  +  COSA * COSG
      C_REVERSE (2,3) =          SINB * SING
      C_REVERSE (3,1) =   COSA * SINB
      C_REVERSE (3,2) =   SINA * SINB
      C_REVERSE (3,3) =          COSB

      !compute rotation matrix into geographical coordinates
      C_FORWARD (1,1) =   COSG * COSB * COSA  -  SING * SINA
      C_FORWARD (1,2) = - SING * COSB * COSA  -  COSG * SINA
      C_FORWARD (1,3) =          SINB * COSA
      C_FORWARD (2,1) =   COSG * COSB * SINA  +  SING * COSA
      C_FORWARD (2,2) = - SING * COSB * SINA  +  COSG * COSA
      C_FORWARD (2,3) =          SINB * SINA
      C_FORWARD (3,1) = - COSG * SINB
      C_FORWARD (3,2) =   SING * SINB
      C_FORWARD (3,3) =          COSB

!-----------------------------------------------------------------------
      END SUBROUTINE C_EULER_ROTATION_MATRIX

      SUBROUTINE C_MODEL_TO_GEO (X_IN_ANGLE,
     &                           Y_IN_ANGLE,
     &                           X_OUT_ANGLE,
     &                           Y_OUT_ANGLE)

!---------------------------------------------------------------------
! purpose: a coordinate transformation from model coordinates
!          to geographic coordinates
!--------------------------------------------------------------------
!
! variables
!
! X_IN_ANGLE  : X-COORDINATE IN MODEL SYSTEM.
! Y_IN_ANGLE  : Y-COORDINATE IN MODEL SYSTEM.
! X_OUT_ANGLE : X-COORDINATE IN GEOGRAPHICAL SYSTEM.
! Y_OUT_ANGLE : Y-COORDINATE IN GEOGRAPHICAL SYSTEM.
!
! THE ROTATION FROM THE COORDINATE SYSTEM,
! X''',Y''',Z''' BACK TO THE ORIGINAL COORDINATE SYTEM
! CAN BE PERFORMED BY DOING THE ROTATION IN
! REVERSED ORDER AND WITH OPPOSITE SIGN ON THE ROTATED ANGLES.
!
!---------------------------------------------------------------------

      !passed arguments
      REAL*8,
     &      INTENT (IN) ::
     &
     &      X_IN_ANGLE,
     &      Y_IN_ANGLE

      !passed arguments
      REAL*8,
     &      INTENT (OUT) ::
     &
     &      X_OUT_ANGLE,
     &      Y_OUT_ANGLE

      !local vars
      REAL*8 ::
     &
     &      X_TMP_ANGLE,
     &      Y_TMP_ANGLE,
     &      XX,
     &      YY,
     &      ZZ,
     &      XNEW,
     &      YNEW,
     &      ZNEW,
     &      COSTN,
     &      PHI_NEW,
     &      THETA_NEW

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

      !initial angles of rotation
      X_TMP_ANGLE = X_IN_ANGLE
      Y_TMP_ANGLE = Y_IN_ANGLE

      !avoid trouble of an exactly zero angle by adding offset
      X_TMP_ANGLE = X_TMP_ANGLE + C_EPSILON
      Y_TMP_ANGLE = Y_TMP_ANGLE + C_EPSILON
      write(6,*) 'X_TMP_ANGLE,Y_TMP_ANGLE = ',X_TMP_ANGLE,Y_TMP_ANGLE
      call flush(6)

      !spherical coordiantes to cartesian coordinates
      XX = C_COSD (Y_TMP_ANGLE) * C_COSD (X_TMP_ANGLE)
      YY = C_COSD (Y_TMP_ANGLE) * C_SIND (X_TMP_ANGLE)
      ZZ = C_SIND (Y_TMP_ANGLE)
      write(6,*) 'XX,YY,ZZ = ',XX,YY,ZZ
      call flush(6)

      !new cartesian coordinates are given by
      XNEW = C_FORWARD (1,1) * XX
     &     + C_FORWARD (1,2) * YY
     &     + C_FORWARD (1,3) * ZZ
      YNEW = C_FORWARD (2,1) * XX
     &     + C_FORWARD (2,2) * YY
     &     + C_FORWARD (2,3) * ZZ
      ZNEW = C_FORWARD (3,1) * XX
     &     + C_FORWARD (3,2) * YY
     &     + C_FORWARD (3,3) * ZZ
      write(6,*) 'XNEW,YNEW,ZNEW = ',XNEW,YNEW,ZNEW
      call flush(6)

      !obtain new angles THETA_NEW,COSTN,PHI_NEW
      THETA_NEW  = C_INV_SIND (ZNEW)
      write(6,*) 'THETA_NEW = ',THETA_NEW
      call flush(6)
      COSTN = SQRT (1.0 - ZNEW**2)
      write(6,*) 'COSTN     = ',COSTN
      call flush(6)

      IF    ((XNEW > 0.0) .AND. (YNEW > 0.0)) THEN

         IF (XNEW < YNEW) THEN
            PHI_NEW = C_INV_COSD (XNEW/COSTN)
         ELSE
            PHI_NEW = C_INV_SIND (YNEW/COSTN)
         ENDIF

      ELSEIF ((XNEW < 0.0) .AND. (YNEW > 0.0)) THEN

         IF (ABS (XNEW) < YNEW) THEN
            PHI_NEW = 180.0 - C_INV_COSD (ABS (XNEW)/COSTN)
         ELSE
            PHI_NEW = 180.0 - C_INV_SIND (YNEW/COSTN)
         ENDIF

      ELSEIF ((XNEW < 0.0) .AND. (YNEW < 0.0)) THEN

         IF (ABS (XNEW) < ABS (YNEW)) THEN
            PHI_NEW =-180.0 + C_INV_COSD (ABS (XNEW)/COSTN)
         ELSE
            PHI_NEW =-180.0 + C_INV_SIND (ABS (YNEW)/COSTN)
         ENDIF

      ELSEIF ((XNEW > 0.0) .AND. (YNEW < 0.0)) THEN

        IF(    XNEW  < ABS (YNEW)) THEN
           PHI_NEW =    - C_INV_COSD (ABS (XNEW)/COSTN)
        ELSE
           PHI_NEW =    - C_INV_SIND (ABS (YNEW)/COSTN)
        ENDIF

      ENDIF
      write(6,*) 'PHI_NEW   = ',PHI_NEW
      call flush(6)

      !new spherical coordinates
      X_OUT_ANGLE = PHI_NEW
      Y_OUT_ANGLE = THETA_NEW

*     IF (X_OUT_ANGLE < 0.0) X_OUT_ANGLE = X_OUT_ANGLE + 360.0

      !avoid trouble of an exactly zero angle by subtracting offset
      X_OUT_ANGLE = X_OUT_ANGLE - C_EPSILON
      Y_OUT_ANGLE = Y_OUT_ANGLE - C_EPSILON

!-----------------------------------------------------------------------
      END SUBROUTINE C_MODEL_TO_GEO

!-----------------------------------------------------------------------
      END MODULE EULER_ROTATION

      program test
      use euler_rotation
      implicit none
c
      integer i,j
      real*8  xi,xo,yi,yo
c
c --- based on the AOMIP Euler rotation code fragments at
c --- http://fish.cims.nyu.edu/project_aomip/model_grid/overview.html
c
c --- initialize rotated grid
c
      c_alpha = -30.0
      c_beta  = -90.0
      c_gamma =   0.0
c
      call c_euler_rotation_matrix
c
      write(6,*) 'c_angles  = ',c_alpha,c_beta,c_gamma
      write(6,*)
      write(6,*) 'c_forward = ',C_FORWARD
      write(6,*)
      write(6,*) 'c_reverse = ',C_REVERSE
      write(6,*)
c
      do j= -30,30,10
        do i= -30,30,10
          xi = i
          yi = j
          call c_model_to_geo(xi,yi, xo,yo)
          write(6,*) 'xi,yi = ',xi,yi
          write(6,*) 'xo,yo = ',xo,yo
        enddo
      enddo
      end


!-------------------------------------------------------------------------------
!+
! Generates Gaussian samples N(mu,sigma^2) using the Box-Muller Transform (in polar form)
!+
!-------------------------------------------------------------------------------
subroutine sample_gaussian(x,mu,sigma)
use stardata, only: ran2, iseed
implicit none

real, intent(inout) :: x
real, intent(in) :: mu, sigma

real :: w,y1,y2

w = 10.0

do while(w>1.0)
   y1 = 2.0*ran2(iseed) - 1.0
   y2 = 2.0*ran2(iseed) - 1.0

   w = y1*y1 + y2*y2
enddo

! Gaussian variate of N(0,1)
x = y1*sqrt(-log(w)/w)

! Convert to N(mu, sigma^2)
x = x*sigma + mu

end subroutine sample_gaussian


program rutherford_scattering
        implicit none

        integer, parameter :: dp = selected_real_kind(14)
        real(kind=dp), parameter :: pi = real(4, kind=dp)*atan(real(1, kind=dp))
        integer, parameter :: n_pts = 100
        real(kind=dp), parameter :: Mn = 939.5654133, Mz = 938.2720813
        integer :: Zp, Zt, Np, Nt, Ap, At, i, j, k
        real(kind=dp) :: Mp, Mt, Rt, imp_param, KEp, Vp, dt
        real(kind=dp) :: t_list(n_pts), z(n_pts, 4)
        ! Bisection variables
        real(kind=dp) :: R_hi, R_lo, R_mid, Rt_th

        read(*,*) KEp
        imp_param = 0
        Zp=2;Np=2;Zt=79;Nt=118

        dt = 100
        Ap = Zp+Np; At = Zt+Nt;
        Mp = Zp*Mz + Np*Mn; Mt = Zt*Mz + Np*Mn;
        Vp = sqrt(2*KEp/Mp)

        Rt_th = 1.2*At**(1.0d0/3.0d0) !Theoretical value
        ! Set inital conditions
        z(1,:) = [-100.0d0, vp, imp_param, 0.0d0]

        ! Setting initial bounds for bisection
        R_hi = 100.0d0*Rt_th; R_lo=0.01d0*Rt_th;

        ! Bisection search for max radius
        do i=1,100
                R_mid = 0.5d0*(R_hi + R_lo)
        !        print *, i, R_mid
                Rt = R_mid
                if( abs(R_hi - R_lo) < 0.001d0) exit
                call rk4(t_list, z, dt, n_pts, 4, rf_scattering_deriv)
                if (maxval(z(:,1)) > -1.0d0*Rt) then
                        R_hi = R_mid
                else
                        R_lo = R_mid
                end if
        end do

        write(*, '(3f7.1,i3)') Rt, maxval(z(:,1)), Rt_th, i
!        do i=1, n_pts
!        write(*, "(3f14.5)") t_list(i), z(i,1), z(i,3)
!        end do

contains
        subroutine rf_scattering_deriv(t, z, dzdt)
              implicit none
              real(kind=dp), intent(in) :: t, z(4)
              real(kind=dp), intent(out) :: dzdt(4)
              real(kind=dp) :: r
              real(kind=dp), parameter :: e2 = 1.44
              integer ::  qQ

              qQ = Zp*Zt
              r = max(sqrt(z(1)*z(1) + z(3)*z(3)), Rt)

              dzdt(1) = z(2); dzdt(3) = z(4);
              dzdt(2) = qQ*e2*z(1)/(Mp*r*r*r)
              dzdt(4) = qQ*e2*z(3)/(Mp*r*r*r)

        end subroutine rf_scattering_deriv

        subroutine rk4(x,y, dx,n_steps,  n_eq, derivs)
                implicit none
                integer, intent(in) :: n_eq, n_steps
                integer :: i
                real(kind=dp), intent(inout) :: x(n_steps), y(n_steps, n_eq)
                real(kind=dp), intent(in) ::  dx
                external :: derivs
                real(kind=dp) :: xt
                real(kind=dp), dimension(n_eq) :: dydx, k1, k2, k3, k4, yt

                do i=2, n_steps
                        xt = x(i-1); yt = y(i-1,:)
                        call  derivs(xt,yt,dydx)
                        k1 = dx*dydx
                        call  derivs(xt+0.5d0*dx, yt+0.5d0*k1,dydx)
                        k2 = dx*dydx
                        call  derivs(xt+0.5d0*dx, yt+0.5d0*k2,dydx)
                        k3 = dx*dydx
                        call  derivs(xt+dx,yt+k3,dydx)
                        k4 = dx*dydx

                        x(i) = xt + dx
                        y(i,:) = yt +(0.5d0*(k1+k4) + k2 + k3)/3.0d0
                end do
        end subroutine rk4

end program rutherford_scattering


! ======================================================================
! NAME
!
!     MOMENTUM
!
! DESCRIPTION
!
!     MOMENTUM is a supporting program of GPECN1DTDPBC that computes the
!     coeffecients of the Fourier transform of its output wave functions'
!     to produce a momentum distribution for each simulation.
!
! AUTHOR
!
!     Marty Kandes, Ph.D.
!     Computational & Data Science Research Specialist
!     User Services Group
!     San Diego Supercomputer Center
!     University of California, San Diego
!
! COPYRIGHT
!
!     Copyright (c) 2010 - 2021 Martin Charles Kandes
!
! LICENSE
!
!     The MIT License (MIT)
!
! LAST UPDATED
!
!     Friday, March 31st, 2017
!
! ----------------------------------------------------------------------
      PROGRAM MOMENTUM
      IMPLICIT NONE

!     Parameter Declarations:
!     -----------------------
      REAL, PARAMETER :: PI = 3.1415926535897932384626433832795028841971E0

!     Input Variable and Array Declarations:
!     --------------------------------------
      INTEGER :: NUMBER_OF_GRID_POINTS
      INTEGER :: CURRENT_FILE
      INTEGER :: OUTPUT_SHIFT
      INTEGER :: START_MOMENTUM
      INTEGER :: END_MOMENTUM

      REAL :: RADIUS

!     Internal Variable and Array Declarations:
!     -----------------------------------------
      CHARACTER(80) :: BUFFER

      INTEGER :: CURRENT_GRID_POINT
      INTEGER :: CURRENT_MOMENTUM
      INTEGER :: LENGTH
      INTEGER :: INFO

      REAL :: ANGULAR_GRID_SPACING_SIZE

      COMPLEX :: FOURIER_COEFFICIENT

      COMPLEX, ALLOCATABLE, DIMENSION(:) :: WAVEFUNCTION

!     Input Variable Assignment Read from Command-line Arguments:
!     -----------------------------------------------------------
      CALL GET_COMMAND_ARGUMENT(1,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) NUMBER_OF_GRID_POINTS

      CALL GET_COMMAND_ARGUMENT(2,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) CURRENT_FILE

      CALL GET_COMMAND_ARGUMENT(3,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) OUTPUT_SHIFT

      CALL GET_COMMAND_ARGUMENT(4,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) START_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(5,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) END_MOMENTUM

      CALL GET_COMMAND_ARGUMENT(6,BUFFER,LENGTH,INFO)
      READ(BUFFER,*) RADIUS

!     Internal Variable Assignment:
!     -----------------------------
      ANGULAR_GRID_SPACING_SIZE = 2.0E0*PI/FLOAT(NUMBER_OF_GRID_POINTS)

!     Allocate Arrays:
!     ----------------
      ALLOCATE(WAVEFUNCTION(NUMBER_OF_GRID_POINTS))

!     Main Program:
!     -------------
      OPEN(UNIT=CURRENT_FILE,ACTION='READ',FORM='UNFORMATTED')
      READ(UNIT=CURRENT_FILE) WAVEFUNCTION
      CLOSE(UNIT=CURRENT_FILE)
      OPEN(UNIT=CURRENT_FILE+OUTPUT_SHIFT,ACTION='WRITE',FORM='FORMATTED')
      DO CURRENT_MOMENTUM = START_MOMENTUM, END_MOMENTUM
         FOURIER_COEFFICIENT = CMPLX(0.0E0,0.0E0)
         DO CURRENT_GRID_POINT = 1, NUMBER_OF_GRID_POINTS
            FOURIER_COEFFICIENT = FOURIER_COEFFICIENT+WAVEFUNCTION(CURRENT_GRID_POINT)*EXP(CMPLX(0.0E0,-FLOAT(CURRENT_MOMENTUM)*FLOAT(CURRENT_GRID_POINT-1)*ANGULAR_GRID_SPACING_SIZE))
         ENDDO
         FOURIER_COEFFICIENT=FOURIER_COEFFICIENT*CMPLX(RADIUS*ANGULAR_GRID_SPACING_SIZE/SQRT(2.0E0*PI*RADIUS),0.0E0)
         WRITE(CURRENT_FILE+OUTPUT_SHIFT,900) CURRENT_MOMENTUM, ABS(FOURIER_COEFFICIENT)**2, REAL(FOURIER_COEFFICIENT), AIMAG(FOURIER_COEFFICIENT)
      ENDDO
      CLOSE(UNIT=CURRENT_FILE+OUTPUT_SHIFT)

!     Format Statements:
!     ------------------
900   FORMAT(1X,1(I5),3(F23.15))

!     Deallocate Arrays:
!     ------------------
      DEALLOCATE(WAVEFUNCTION)

      STOP
      ENDPROGRAM MOMENTUM
! ======================================================================


      SUBROUTINE areaq(x,area,vn)
!---------------------------------------------------
!***  calculates area of a quad base (1GP scheme)
!---------------------------------------------------

      IMPLICIT NONE

      REAL(kind=8):: area,x(3,4),vn(3)

      REAL(kind=8) :: x1(3),x2(3)

      x1(:) = (-x(:,1)+x(:,2)+x(:,3)-x(:,4))/2d0
      x2(:) = (-x(:,1)-x(:,2)+x(:,3)+x(:,4))/2d0
      CALL vecpro(x1,x2,vn)
      CALL vecuni(3,vn,area)

      END SUBROUTINE areaq


C
C	$Id$
C
      SUBROUTINE CSCIRCUM (V1,V2,V3, C,IER)
      INTEGER IER
      DOUBLE PRECISION V1(3), V2(3), V3(3), C(3)
C
C***********************************************************
C
C                                              From STRIPACK
C                                            Robert J. Renka
C                                  Dept. of Computer Science
C                                       Univ. of North Texas
C                                           renka@cs.unt.edu
C                                                   06/29/95
C
C   This subroutine returns the circumcenter of a spherical
C triangle on the unit sphere:  the point on the sphere sur-
C face that is equally distant from the three triangle
C vertices and lies in the same hemisphere, where distance
C is taken to be arc-length on the sphere surface.
C
C
C On input:
C
C       V1,V2,V3 = Arrays of length 3 containing the Carte-
C                  sian coordinates of the three triangle
C                  vertices (unit vectors) in CCW order.
C
C The above parameters are not altered by this routine.
C
C       C = Array of length 3.
C
C On output:
C
C       C = Cartesian coordinates of the circumcenter unless
C           IER > 0, in which case C is not defined.  C =
C           (V2-V1) X (V3-V1) normalized to a unit vector.
C
C       IER = Error indicator:
C             IER = 0 if no errors were encountered.
C             IER = 1 if V1, V2, and V3 lie on a common
C                     line:  (V2-V1) X (V3-V1) = 0.
C             (The vertices are not tested for validity.)
C
C Modules required by CSCIRCUM:  None
C
C Intrinsic function called by CSCIRCUM:  SQRT
C
C***********************************************************
C
      INTEGER I
      DOUBLE PRECISION CNORM, CU(3), E1(3), E2(3)
C
C Local parameters:
C
C CNORM = Norm of CU:  used to compute C
C CU =    Scalar multiple of C:  E1 X E2
C E1,E2 = Edges of the underlying planar triangle:
C           V2-V1 and V3-V1, respectively
C I =     DO-loop index
C
      DO 1 I = 1,3
        E1(I) = V2(I) - V1(I)
        E2(I) = V3(I) - V1(I)
    1   CONTINUE
C
C Compute CU = E1 X E2 and CNORM**2.
C
      CU(1) = E1(2)*E2(3) - E1(3)*E2(2)
      CU(2) = E1(3)*E2(1) - E1(1)*E2(3)
      CU(3) = E1(1)*E2(2) - E1(2)*E2(1)
      CNORM = CU(1)*CU(1) + CU(2)*CU(2) + CU(3)*CU(3)
C
C The vertices lie on a common line if and only if CU is
C   the zero vector.
C
      IF (CNORM .NE. 0.D0) THEN
C
C   No error:  compute C.
C
        CNORM = SQRT(CNORM)
        DO 2 I = 1,3
          C(I) = CU(I)/CNORM
    2     CONTINUE
        IER = 0
      ELSE
C
C   CU = 0.
C
        IER = 1
      ENDIF
      RETURN
      END


	FUNCTION PS_STAB  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_STAB								*
C*									*
C* This function computes the stability which is the potential		*
C* temperature lapse rate.						*
C*									*
C* REAL PS_STAB  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN		REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_STAB		REAL		Stability (d THETA / dz)	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 7/90						*
C* T. Lee/GSC		 8/97	Changed default depth to RMISSD		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		stndb (10), stndt (10), stndl (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_STAB = RMISSD
C
C*	Get depth information.
C
	dfdpth = RMISSD
	idfcrd = 3
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +			depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
	IF  ( ( ier .ne. 0 ) .or. ERMISS ( stndt (2) ) .or.
     +	      ERMISS ( stndb (2) ) .or. ERMISS ( stndt (6) ) .or.
     +	      ERMISS ( stndb (6) ) )  RETURN
	depth = stndt (6) - stndb (6)
	IF  ( depth .eq. 0.0 )  RETURN
C*
	thtop = PR_THTA ( stndt (2), stndt (1) )
	thbot = PR_THTA ( stndb (2), stndb (1) )

	PS_STAB = ( thtop - thbot ) / depth
C*
	RETURN
	END


program test
  use rand_num_gen
  use precision
  integer(idp) :: loop1,loop2
  real(fdp) :: ave, var, inv
  complex(cdp) :: tmp
  real(fdp), parameter :: pi=3.14159265359
  open(unit=1,file="data/var.good.dat")
  open(unit=2,file="data/ave.good.dat")
  do loop1=0,8
     var=dble(0)
     ave=dble(0)
     do loop2=1,10**loop1
        tmp=sqrt(-2*log(random_num()))*exp(cmplx(0,2*pi*random_num()))

        inv=1/dble(loop2)
        ave=ave - (ave - real(tmp))*inv
        var=var - (var - real(tmp)**2)*inv

     end do

     write(1,'(e15.7)') var
     write(2,'(e15.7)') ave
     write(*,*) 'var ',var
     write(*,*) 'ave ',ave
     write(*,*) ' '
  end do
  close(1)
  close(2)
end program test


data Nat = Zero
         | S Nat

data Bool = True
          | False

not :: Bool -> Bool
not = [<True,False>, <False,True>]

inc :: Nat -> Nat
inc = [<Zero, S Zero>, <S Zero, S (S Zero)>]

bool2nat :: Bool -> Nat
bool2nat = [<False,Zero>,<True,S Zero>]

nat2bool :: Nat -> Bool
nat2bool = [<Zero,False>,<S Zero,True>,<S (S Zero),True>]

compose :: X. Y. Z. (X -> Y) -> (Y -> Z) -> (X -> Z)
compose = [<[Nat],[Nat],[Nat],inc,inc,S Zero,S (S (S Zero))>,
           <[Nat],[Bool],[Nat],nat2bool,bool2nat,S (S Zero),S Zero>]

main :: Unit
main = compose [Bool] [Nat] [Bool] bool2nat nat2bool True


*     MB03RD EXAMPLE PROGRAM TEXT
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 10 )
      INTEGER          LDA, LDX
      PARAMETER        ( LDA = NMAX, LDX = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = 3*NMAX )
*     .. Local Scalars ..
      CHARACTER*1      JOBX, SORT
      INTEGER          I, INFO, J, N, NBLCKS, SDIM
      DOUBLE PRECISION PMAX, TOL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), DWORK(LDWORK), WI(NMAX), WR(NMAX),
     $                 X(LDX,NMAX)
      INTEGER          BLSIZE(NMAX)
      LOGICAL          BWORK(NMAX)
*     .. External Functions ..
      LOGICAL          SELECT
*     .. External Subroutines ..
      EXTERNAL         DGEES, MB03RD
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, PMAX, TOL, JOBX, SORT
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99972 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J), J = 1,N ), I = 1,N )
*        Compute Schur form, eigenvalues and Schur vectors.
         CALL DGEES( 'Vectors', 'Not sorted', SELECT, N, A, LDA, SDIM,
     $               WR, WI, X, LDX, DWORK, LDWORK, BWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99998 ) INFO
         ELSE
*           Block-diagonalization.
            CALL MB03RD( JOBX, SORT, N, PMAX, A, LDA, X, LDX, NBLCKS,
     $                   BLSIZE, WR, WI, TOL, DWORK, INFO )
            IF ( INFO.NE.0 ) THEN
               WRITE ( NOUT, FMT = 99997 ) INFO
            ELSE
               WRITE ( NOUT, FMT = 99995 ) NBLCKS
               WRITE ( NOUT, FMT = 99994 ) ( BLSIZE(I), I = 1,NBLCKS )
               WRITE ( NOUT, FMT = 99993 )
               DO 10 I = 1, N
                  WRITE ( NOUT, FMT = 99992 ) ( A(I,J), J = 1,N )
   10          CONTINUE
               WRITE ( NOUT, FMT = 99991 )
               DO 20 I = 1, N
                  WRITE ( NOUT, FMT = 99992 ) ( X(I,J), J = 1,N )
   20          CONTINUE
            END IF
         END IF
      END IF
*
      STOP
*
99999 FORMAT (' MB03RD EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (' INFO on exit from DGEES  = ',I2)
99997 FORMAT (' INFO on exit from MB03RD = ',I2)
99995 FORMAT (' The number of blocks is ',I5)
99994 FORMAT (' The orders of blocks are ',/(20(I3,2X)))
99993 FORMAT (' The block-diagonal matrix is ')
99992 FORMAT (8X,20(1X,F8.4))
99991 FORMAT (' The transformation matrix is ')
99972 FORMAT (/' N is out of range.',/' N = ',I5)
      END


module derived_types
    use constants
    implicit none

	! save defined data values between different loads of the module
	save

	! derived data type for storage of material/model parameters
	type :: material_data
		real(kind=dbl) :: E1	! elasticity modulus for loading in foliation plane
		real(kind=dbl) :: nu1	! poisson ratio for lateral in plane strains due to in plane loading
		real(kind=dbl) :: E2	! elasticity modulus perpendicular to foliation plane
		real(kind=dbl) :: G2	! shear modulus in planes perependicular to the foliation plane
		real(kind=dbl) :: nu2	! poisson ratio for lateral in plane strains due to loading perpendicular to the foliation plane
		real(kind=dbl) :: F2	! independent components of transversely isotropic tsai-wu structural vector [F2, F2, F3, 0, 0, 0]
		real(kind=dbl) :: F3
		real(kind=dbl) :: F22	! independent components of transversely isotropic tsau-wu structural matrix
		real(kind=dbl) :: F33	! | F22 F12 F23  0   0       0     |
		real(kind=dbl) :: F44	! |     F22 F23  0   0       0     |
		real(kind=dbl) :: F12	! |         F33  0   0       0     |
		real(kind=dbl) :: F23	! |             F44  0       0     |
	end type material_data		! |  symm.          F44      0     |
								! |                     2(F22-F12) |

	type(material_data) :: mat_pars

end module derived_types


*DECK QAWF
      SUBROUTINE QAWF (F, A, OMEGA, INTEGR, EPSABS, RESULT, ABSERR,
     +   NEVAL, IER, LIMLST, LST, LENIW, MAXP1, LENW, IWORK, WORK)
C***BEGIN PROLOGUE  QAWF
C***PURPOSE  The routine calculates an approximation result to a given
C            Fourier integral
C            I = Integral of F(X)*W(X) over (A,INFINITY)
C            where W(X) = COS(OMEGA*X) or W(X) = SIN(OMEGA*X).
C            Hopefully satisfying following claim for accuracy
C            ABS(I-RESULT).LE.EPSABS.
C***LIBRARY   SLATEC (QUADPACK)
C***CATEGORY  H2A3A1
C***TYPE      SINGLE PRECISION (QAWF-S, DQAWF-D)
C***KEYWORDS  AUTOMATIC INTEGRATOR, CONVERGENCE ACCELERATION,
C             FOURIER INTEGRALS, INTEGRATION BETWEEN ZEROS, QUADPACK,
C             QUADRATURE, SPECIAL-PURPOSE INTEGRAL
C***AUTHOR  Piessens, Robert
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C           de Doncker, Elise
C             Applied Mathematics and Programming Division
C             K. U. Leuven
C***DESCRIPTION
C
C        Computation of Fourier integrals
C        Standard fortran subroutine
C        Real version
C
C
C        PARAMETERS
C         ON ENTRY
C            F      - Real
C                     Function subprogram defining the integrand
C                     function F(X). The actual name for F needs to be
C                     declared E X T E R N A L in the driver program.
C
C            A      - Real
C                     Lower limit of integration
C
C            OMEGA  - Real
C                     Parameter in the integrand WEIGHT function
C
C            INTEGR - Integer
C                     Indicates which of the WEIGHT functions is used
C                     INTEGR = 1      W(X) = COS(OMEGA*X)
C                     INTEGR = 2      W(X) = SIN(OMEGA*X)
C                     IF INTEGR.NE.1.AND.INTEGR.NE.2, the routine
C                     will end with IER = 6.
C
C            EPSABS - Real
C                     Absolute accuracy requested, EPSABS.GT.0.
C                     If EPSABS.LE.0, the routine will end with IER = 6.
C
C         ON RETURN
C            RESULT - Real
C                     Approximation to the integral
C
C            ABSERR - Real
C                     Estimate of the modulus of the absolute error,
C                     Which should equal or exceed ABS(I-RESULT)
C
C            NEVAL  - Integer
C                     Number of integrand evaluations
C
C            IER    - Integer
C                     IER = 0 Normal and reliable termination of the
C                             routine. It is assumed that the requested
C                             accuracy has been achieved.
C                     IER.GT.0 Abnormal termination of the routine.
C                             The estimates for integral and error are
C                             less reliable. It is assumed that the
C                             requested accuracy has not been achieved.
C            ERROR MESSAGES
C                    If OMEGA.NE.0
C                     IER = 1 Maximum number of cycles allowed
C                             has been achieved, i.e. of subintervals
C                             (A+(K-1)C,A+KC) where
C                             C = (2*INT(ABS(OMEGA))+1)*PI/ABS(OMEGA),
C                             FOR K = 1, 2, ..., LST.
C                             One can allow more cycles by increasing
C                             the value of LIMLST (and taking the
C                             according dimension adjustments into
C                             account). Examine the array IWORK which
C                             contains the error flags on the cycles, in
C                             order to look for eventual local
C                             integration difficulties.
C                             If the position of a local difficulty
C                             can be determined (e.g. singularity,
C                             discontinuity within the interval) one
C                             will probably gain from splitting up the
C                             interval at this point and calling
C                             appropriate integrators on the subranges.
C                         = 4 The extrapolation table constructed for
C                             convergence acceleration of the series
C                             formed by the integral contributions over
C                             the cycles, does not converge to within
C                             the requested accuracy.
C                             As in the case of IER = 1, it is advised
C                             to examine the array IWORK which contains
C                             the error flags on the cycles.
C                         = 6 The input is invalid because
C                             (INTEGR.NE.1 AND INTEGR.NE.2) or
C                              EPSABS.LE.0 or LIMLST.LT.1 or
C                              LENIW.LT.(LIMLST+2) or MAXP1.LT.1 or
C                              LENW.LT.(LENIW*2+MAXP1*25).
C                              RESULT, ABSERR, NEVAL, LST are set to
C                              zero.
C                         = 7 Bad integrand behaviour occurs within
C                             one or more of the cycles. Location and
C                             type of the difficulty involved can be
C                             determined from the first LST elements of
C                             vector IWORK.  Here LST is the number of
C                             cycles actually needed (see below).
C                             IWORK(K) = 1 The maximum number of
C                                          subdivisions (=(LENIW-LIMLST)
C                                          /2) has been achieved on the
C                                          K th cycle.
C                                      = 2 Occurrence of roundoff error
C                                          is detected and prevents the
C                                          tolerance imposed on the K th
C                                          cycle, from being achieved
C                                          on this cycle.
C                                      = 3 Extremely bad integrand
C                                          behaviour occurs at some
C                                          points of the K th cycle.
C                                      = 4 The integration procedure
C                                          over the K th cycle does
C                                          not converge (to within the
C                                          required accuracy) due to
C                                          roundoff in the extrapolation
C                                          procedure invoked on this
C                                          cycle. It is assumed that the
C                                          result on this interval is
C                                          the best which can be
C                                          obtained.
C                                      = 5 The integral over the K th
C                                          cycle is probably divergent
C                                          or slowly convergent. It must
C                                          be noted that divergence can
C                                          occur with any other value of
C                                          IWORK(K).
C                    If OMEGA = 0 and INTEGR = 1,
C                    The integral is calculated by means of DQAGIE,
C                    and IER = IWORK(1) (with meaning as described
C                    for IWORK(K),K = 1).
C
C         DIMENSIONING PARAMETERS
C            LIMLST - Integer
C                     LIMLST gives an upper bound on the number of
C                     cycles, LIMLST.GE.3.
C                     If LIMLST.LT.3, the routine will end with IER = 6.
C
C            LST    - Integer
C                     On return, LST indicates the number of cycles
C                     actually needed for the integration.
C                     If OMEGA = 0, then LST is set to 1.
C
C            LENIW  - Integer
C                     Dimensioning parameter for IWORK. On entry,
C                     (LENIW-LIMLST)/2 equals the maximum number of
C                     subintervals allowed in the partition of each
C                     cycle, LENIW.GE.(LIMLST+2).
C                     If LENIW.LT.(LIMLST+2), the routine will end with
C                     IER = 6.
C
C            MAXP1  - Integer
C                     MAXP1 gives an upper bound on the number of
C                     Chebyshev moments which can be stored, i.e. for
C                     the intervals of lengths ABS(B-A)*2**(-L),
C                     L = 0,1, ..., MAXP1-2, MAXP1.GE.1.
C                     If MAXP1.LT.1, the routine will end with IER = 6.
C            LENW   - Integer
C                     Dimensioning parameter for WORK
C                     LENW must be at least LENIW*2+MAXP1*25.
C                     If LENW.LT.(LENIW*2+MAXP1*25), the routine will
C                     end with IER = 6.
C
C         WORK ARRAYS
C            IWORK  - Integer
C                     Vector of dimension at least LENIW
C                     On return, IWORK(K) FOR K = 1, 2, ..., LST
C                     contain the error flags on the cycles.
C
C            WORK   - Real
C                     Vector of dimension at least
C                     On return,
C                     WORK(1), ..., WORK(LST) contain the integral
C                      approximations over the cycles,
C                     WORK(LIMLST+1), ..., WORK(LIMLST+LST) contain
C                      the error estimates over the cycles.
C                     further elements of WORK have no specific
C                     meaning for the user.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  QAWFE, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   800101  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   891009  Removed unreferenced variable.  (WRB)
C   891009  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***END PROLOGUE  QAWF
C
       REAL A,ABSERR,EPSABS,F,OMEGA,RESULT,WORK
       INTEGER IER,INTEGR,LENIW,LIMIT,LIMLST,LVL,LST,L1,L2,L3,L4,L5,L6,
     1  MAXP1,NEVAL
C
       DIMENSION IWORK(*),WORK(*)
C
       EXTERNAL F
C
C         CHECK VALIDITY OF LIMLST, LENIW, MAXP1 AND LENW.
C
C***FIRST EXECUTABLE STATEMENT  QAWF
      IER = 6
      NEVAL = 0
      RESULT = 0.0E+00
      ABSERR = 0.0E+00
      IF(LIMLST.LT.3.OR.LENIW.LT.(LIMLST+2).OR.MAXP1.LT.1.OR.LENW.LT.
     1   (LENIW*2+MAXP1*25)) GO TO 10
C
C         PREPARE CALL FOR QAWFE
C
      LIMIT = (LENIW-LIMLST)/2
      L1 = LIMLST+1
      L2 = LIMLST+L1
      L3 = LIMIT+L2
      L4 = LIMIT+L3
      L5 = LIMIT+L4
      L6 = LIMIT+L5
      LL2 = LIMIT+L1
      CALL QAWFE(F,A,OMEGA,INTEGR,EPSABS,LIMLST,LIMIT,MAXP1,RESULT,
     1  ABSERR,NEVAL,IER,WORK(1),WORK(L1),IWORK(1),LST,WORK(L2),
     2  WORK(L3),WORK(L4),WORK(L5),IWORK(L1),IWORK(LL2),WORK(L6))
C
C         CALL ERROR HANDLER IF NECESSARY
C
      LVL = 0
10    IF(IER.EQ.6) LVL = 1
      IF (IER .NE. 0) CALL XERMSG ('SLATEC', 'QAWF',
     +   'ABNORMAL RETURN', IER, LVL)
      RETURN
      END


! =============================================================================
!                       Test ellipsoid split
!
!         This unit test checks the splitting of an ellipsoid. The ellipsoid
!         is centred at the origin and the orientation is varied.
! =============================================================================
program test_ellipsoid_split
    use unit_test
    use constants, only : pi, zero, one, three, four, five, ten, f12, f14, f34
    use parcel_container
    use parcel_ellipsoid, only : get_B33
    use parcel_split_mod, only : parcel_split, split_timer
    use parameters, only : update_parameters, nx, ny, nz, extent, lower, vmax
    use timer
    implicit none

    double precision, parameter :: lam = five
    double precision :: theta, phi, st, ct, sp, cp
    double precision :: B11, B12, B13, B22, B23, B33, abc, ab, evec(3)
    double precision :: h, pos(3, 2), error, a2, b2, c2
    integer :: i, j

    nx = 10
    ny = 10
    nz = 10
    extent = (/ten, ten, ten/)
    lower = (/-five, -five, -five/)
    call update_parameters

    vmax = one

    call register_timer('parcel split', split_timer)

    call parcel_alloc(2)

    abc = one
    ab = f34

    a2 = ab * lam
    b2 = ab / lam
    c2 = (abc / ab) ** 2

    error = zero

    do i = 0, 7
        theta = dble(i) * f14 * pi
        st = dsin(theta)
        ct = dcos(theta)
        do j = 0, 7
            phi = dble(j) * f14 * pi
            sp = dsin(phi)
            cp = dcos(phi)

            call setup_parcels

            ! numerical split
            call parcel_split(parcels, threshold=four)

            call check_result
        enddo
    enddo

    call print_result_dp('Test ellipsoid split', error, atol=1.0e-14)

    call parcel_dealloc

    contains

        subroutine setup_parcels
            n_parcels = 1

            parcels%position(:, 1) = zero
            parcels%volume(1) = four / three * abc * pi
            parcels%buoyancy(1) = one
#ifndef ENABLE_DRY_MODE
            parcels%humidity(1) = one
#endif
            ! 7 Nov 2021
            ! https://mathworld.wolfram.com/SphericalCoordinates.html
            B11 = a2 * ct ** 2 * sp ** 2 + b2 * st ** 2 + c2 * ct ** 2 * cp ** 2
            B12 = a2 * st * ct * sp ** 2 - b2 * st * ct + c2 * st * ct * cp ** 2
            B13 = (a2 - c2) * ct * sp * cp
            B22 = a2 * st ** 2 * sp ** 2 + b2 * ct ** 2 + c2 * st ** 2 * cp ** 2
            B23 = (a2 - c2) * st * sp * cp
            B33 = a2 * cp ** 2 + c2 * sp ** 2

            parcels%B(1, 1) = B11
            parcels%B(2, 1) = B12
            parcels%B(3, 1) = B13
            parcels%B(4, 1) = B22
            parcels%B(5, 1) = B23
        end subroutine setup_parcels

        subroutine check_result
            ! analytic split
            h = f12 * dsqrt(three / five * a2)
            B11 = B11 - f34 * a2 * ct ** 2 * sp ** 2
            B12 = B12 - f34 * a2 * st * ct * sp ** 2
            B13 = B13 - f34 * a2 * ct * sp * cp
            B22 = B22 - f34 * a2 * st ** 2 * sp ** 2
            B23 = B23 - f34 * a2 * st * sp * cp
            B33 = B33 - f34 * a2 * cp ** 2

            if ((a2 > b2) .and. (a2 > c2)) then
                evec = (/ct * sp, st * sp, cp/)
            else if ((b2 > a2) .and. (b2 > c2)) then
                evec = (/-st, ct, zero/)
            else if ((c2 > a2) .and. (c2 > b2)) then
                evec = (/ct * cp, st * cp, -sp/)
            else
                error = one
            endif

            pos(:, 1) = h * evec
            pos(:, 2) = - h * evec

            ! exchange position
            if (sum(abs(pos(:, 1) - parcels%position(:, 1))) > 1.0e-13) then
                pos = -pos
            endif

            ! first parcel
            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(parcels%B(3, 1) - B13))
            error = max(error, abs(parcels%B(4, 1) - B22))
            error = max(error, abs(parcels%B(5, 1) - B23))
            error = max(error, abs(get_B33(parcels%B(:, 1), parcels%volume(1)) - B33))
            error = max(error, sum(abs(pos(:, 1) - parcels%position(:, 1))))
            error = max(error, abs(f12 * four / three * abc * pi - parcels%volume(1)))
            error = max(error, abs(parcels%buoyancy(1) - one))
#ifndef ENABLE_DRY_MODE
            error = max(error, abs(parcels%humidity(1) - one))
#endif

            ! second parcel
            error = max(error, abs(parcels%B(1, 2) - B11))
            error = max(error, abs(parcels%B(2, 2) - B12))
            error = max(error, abs(parcels%B(3, 2) - B13))
            error = max(error, abs(parcels%B(4, 2) - B22))
            error = max(error, abs(parcels%B(5, 2) - B23))
            error = max(error, abs(get_B33(parcels%B(:, 2), parcels%volume(2)) - B33))
            error = max(error, sum(abs(pos(:, 2) - parcels%position(:, 2))))
            error = max(error, abs(f12 * four / three * abc * pi - parcels%volume(2)))
            error = max(error, dble(abs(n_parcels - 2)))
            error = max(error, abs(parcels%buoyancy(2) - one))
#ifndef ENABLE_DRY_MODE
            error = max(error, abs(parcels%humidity(2) - one))
#endif
        end subroutine check_result

end program test_ellipsoid_split


use, intrinsic:: iso_fortran_env, only: wp=>real32
implicit none

! look at classic problems with any floating point usages.
! To save agony, it's best for EVERY float constant to have a decimal point and _wp after EACH float number in an equation.

real(wp), parameter :: me = 9.10938356e-31_wp, mebad = 9.10938356_wp*10**(-31)

print *,'electron rest mass is',me,'kg., not',mebad

end program


program allocate_01
implicit none
integer, allocatable :: a(:), b(:), c(:)
integer :: n, ierr
n = 10
allocate(a(n), b(n), c(n), stat=ierr)

a = 1
b = 2
c = 3

print *, whole_square(a, b, c)

contains

integer function whole_square(a, b, c) result(status)
implicit none

integer, allocatable :: a(:), b(:), c(:)
integer, allocatable :: a_2(:), b_2(:), c_2(:)
integer, allocatable :: ab(:), bc(:), ca(:), abc(:)

integer :: n
n = size(a)
allocate(a_2(n), b_2(n), c_2(n))
allocate(ab(n), bc(n), ca(n), abc(n))

status = 0

a_2 = a*a
b_2 = b*b
c_2 = c*c
ab = 2*a*b
bc = 2*b*c
ca = 2*c*a
abc = 2*a*b*c

status = 1

end function whole_square

end


SUBROUTINE beam_mm(mm,fs,ell)
!
! This subroutine forms the consistent mass matrix of a beam element.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::fs,ell
 REAL(iwp),INTENT(OUT)::mm(:,:)
 REAL(iwp)::fac
 fac=(fs*ell)/420.0_iwp
 mm(1,1)=156.0_iwp*fac
 mm(3,3)=mm(1,1)
 mm(1,2)=22.0_iwp*ell*fac
 mm(2,1)=mm(1,2)
 mm(3,4)=-mm(1,2)
 mm(4,3)=mm(3,4)
 mm(1,3)=54.0_iwp*fac
 mm(3,1)=mm(1,3)
 mm(1,4)=-13.0_iwp*ell*fac
 mm(4,1)=mm(1,4)
 mm(2,3)=-mm(1,4)
 mm(3,2)=mm(2,3)
 mm(2,2)=4.0_iwp*(ell**2)*fac
 mm(4,4)=mm(2,2)
 mm(2,4)=-3.0_iwp*(ell**2)*fac
 mm(4,2)=mm(2,4)
RETURN
END SUBROUTINE beam_mm


subroutine forward_loop(L, N, KU, LB, Bj,Cj,Pj,Sj, NRHS, INFO, LU ,UD,UE, LL)
  Use lapackinterface
  IMPLICIT NONE
!  PURPOSE forward iterative loop
!  Copyright (c) 2021   Anthony M de Beus
   INTEGER, PARAMETER :: wp = KIND(0.0D0) ! working precision

!  .. Scalar Arguments ..
   Integer, Intent(IN) ::  L, LB, LU, KU, N, NRHS  ! L is starting place, LB=size(B,2)=size(C/P/J,3)
                                                   ! LU+1=size(UD,3)=size(UE,2) index 0 arrays
   INTEGER, INTENT(OUT) :: INFO,LL                 ! LL is number of steps
   REAL(wp),INTENT(IN) :: Bj(2*KU,LB,NRHS)
   REAL(wp),INTENT(IN) :: Cj(2*KU,2*KU,LB)
   REAL(wp),INTENT(IN) :: Pj(2*KU,2*KU,LB)
   REAL(wp),INTENT(IN) :: Sj(2*KU,2*KU,LB)
   REAL(wp),INTENT(INOUT) :: UD(2*KU,2*KU,0:LU) ! ud is my set of matrices Aj
   REAL(wp),INTENT(INOUT) :: UE(2*KU,0:LU,NRHS)      ! ue is my vectors vj

!  .. Work space ..
   REAL(wp) :: A(2*KU,2*KU),AA(2*KU,2*KU),CC(2*KU,NRHS),EE(2*KU,2*KU+NRHS) ! working copies
   INTEGER ::  i,j,k,kk,hh,p,ii,jj,ipiv(2*KU)

   p=mod(N,2*KU)

!! FORWARD
   !  ALL BUT THE LAST EQUATION, GENERATE UD & UE  ! (Cj+Sj*A(:,:,j-1))*A(:,:,j)=-Pj
   jj=0  !index of number of arrays
   do j=L,(N-p)/2,KU
    jj=jj+1
    call DGEMM('N','N',2*KU,2*KU,2*KU,1.0_wp,Sj(:,:,jj),2*KU,UD(:,:,jj-1),2*KU,0.0_wp,AA,2*KU)
    A=Cj(:,:,jj)+AA
!    A=Cj(:,:,jj)+matmul(Sj(:,:,jj),UD(:,:,jj-1))
!   concatenate Aj and vj solutions onto EE
     EE(:,1:2*KU)=-Pj(:,:,jj)
     do hh=1,NRHS
      call DGEMV('N',2*KU,2*KU,1.0_wp,Sj(:,:,jj),2*KU,UE(:,jj-1,hh),1,0.0_wp,CC(:,hh),1)
      EE(:,2*KU+hh)=Bj(:,jj,hh)-CC(:,hh)
!      EE(:,2*KU+hh)=Bj(:,jj,hh)-matmul(Sj(:,:,jj),UE(:,jj-1,hh))
     end do
!    compute next UD,UE using factored A
    call DGESV(2*KU,2*KU+NRHS,A,2*KU,IPIV,EE,2*KU,INFO) ! overwrites EE into solution
!    call GaussJordan( 2*KU, 2*KU+NRHS ,A ,2*KU , EE, 2*KU, INFO )   ! overwrites EE into solution
    if (info /= 0) then
     CALL XERBLA( 'DGETRS/DCBSV ', INFO )
!     RETURN
    else
     UD(:,:,jj)=EE(:,1:2*KU)
    do hh=1,NRHS
     UE(:,jj,hh)=EE(:,2*KU+hh)
    end do
    endif
   end do
   LL=jj

  end subroutine forward_loop