! ##################################################################################################################################
! Begin MIT license text.
! _______________________________________________________________________________________________________

! Copyright 2019 Dr William R Case, Jr (dbcase29@gmail.com)

! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
! associated documentation files (the "Software"), to deal in the Software without restriction, including
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
! the following conditions:

! The above copyright notice and this permission notice shall be included in all copies or substantial
! portions of the Software and documentation.

! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
! _______________________________________________________________________________________________________

! End MIT license text.

      SUBROUTINE MATMULT_SFF ( MAT_A_NAME, NROWS_A, NCOLS_A, NTERM_A, SYM_A, I_A, J_A, A, MAT_B_NAME, NROWS_B, NCOLS_B, B,         &
                               WRITE_SC1, MAT_C_NAME, CONS, C )

! Sparse matrix multiply to obtain C = cons*A*B with A in sparse format and B in full format. Input A is stored in compressed
! row storage (CRS) format. In addition, if A is symmetric it can be stored  with only the terms on, and above, the diagonal

! Input matrix A is stored in compressed row storage (CRS) format using arrays I_A(NROWS_A+1), J_A(NTERM_A) A(NTERM_A) where NROWS_A
! IS the number of rows in matrix A and NTERM_A are the number of nonzero terms in matrix A:

!      I_A is an array of NROWS_A+1 integers that is used to specify the number of nonzero terms in rows of matrix A. That is:
!          I_A(I+1) - I_A(I) are the number of nonzero terms in row I of matrix A

!      J_A is an integer array giving the col numbers of the NTERM_A nonzero terms in matrix A

!        A is a real array of the nonzero terms in matrix A. If SYM_A='Y' then only the terms on, and above, the diag are stored.

! Input  matrix B is stored in B(NROWS_B,NCOLS_B) where NROWS_B, NCOLS_B are the number of rows and columns of matrix B

! Output matrix C, which must have the same number of rows as matrix A and the same number of columns as matrix B,
! is stored in full format.

! This subr determines real array C

      USE PENTIUM_II_KIND, ONLY       :  BYTE, LONG, DOUBLE
      USE IOUNT1, ONLY                :  ERR, F04, F06, SC1, WRT_ERR, WRT_LOG
      USE SCONTR, ONLY                :  BLNK_SUB_NAM, FATAL_ERR
      USE TIMDAT, ONLY                :  TSEC
      USE SUBR_BEGEND_LEVELS, ONLY    :  MATMULT_SFF_BEGEND
      USE CONSTANTS_1, ONLY           :  ZERO
      USE PARAMS, ONLY                :  EPSIL
      USE DEBUG_PARAMETERS, ONLY      :  DEBUG
      USE SPARSE_ALG_ARRAYS, ONLY     :  AROW, J_AROW

      USE MATMULT_SFF_USE_IFs

      IMPLICIT NONE

      CHARACTER, PARAMETER            :: CR13 = CHAR(13)   ! This causes a carriage return simulating the "+" action in a FORMAT
      CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'MATMULT_SFF'
      CHARACTER(LEN=*), INTENT(IN)    :: MAT_A_NAME        ! Name of matrix A
      CHARACTER(LEN=*), INTENT(IN)    :: MAT_B_NAME        ! Name of matrix B
      CHARACTER(LEN=*), INTENT(IN)    :: MAT_C_NAME        ! Name of matrix C
      CHARACTER(LEN=*), INTENT(IN)    :: SYM_A             ! ='Y' if matrix A is input symmetric (terms on and above diag only)
      CHARACTER(LEN=*), INTENT(IN)    :: WRITE_SC1         ! ='Y' if we need to write to screen to advance 1 line before write msg

      INTEGER(LONG), INTENT(IN )      :: NROWS_B           ! Number of rows in input matrix B
      INTEGER(LONG), INTENT(IN )      :: NCOLS_A           ! NUMBER OF COLS IN INPUT MATRIX A
      INTEGER(LONG), INTENT(IN )      :: NCOLS_B           ! Number of cols in input matrix B
      INTEGER(LONG), INTENT(IN )      :: NROWS_A           ! Number of rows in input matrix A
      INTEGER(LONG), INTENT(IN )      :: NTERM_A           ! Number of nonzero terms in input  matrix A
      INTEGER(LONG), INTENT(IN )      :: I_A(NROWS_A+1)    ! I_A(I+1) - I_A(I) = num nonzeros in row I of matrix A (CRS)
      INTEGER(LONG), INTENT(IN )      :: J_A(NTERM_A)      ! Col no's for nonzero terms in matrix A
      INTEGER(LONG)                   :: A_COL_NUM         ! A col number in matrix A
      INTEGER(LONG)                   :: A_ROW_BEG         ! Index into array I_A where a row of matrix A begins
      INTEGER(LONG)                   :: A_ROW_END         ! Index into array I_A where a row of matrix A ends
      INTEGER(LONG)                   :: A_NTERM_ROW_I     ! Number of terms in row I of matrix A
      INTEGER(LONG)                   :: AROW_MAX_TERMS    ! Max number of terms in any row of A
      INTEGER(LONG)                   :: DELTA_KTERM_C     ! Incr in KTERM_C (0,1) resulting from mult row of A x col of B
      INTEGER(LONG)                   :: I,J,K,II          ! DO loop indices
      INTEGER(LONG)                   :: KTERM_C           ! Count of number of terms put into output matrix C
      INTEGER(LONG)                   :: NCOLS_C           ! Number of cols in output matrix A (= NCOLS_B)
      INTEGER(LONG)                   :: NROWS_C           ! Number of rows in output matrix A (= NROWS_A)
      INTEGER(LONG)                   :: NHITS             ! Number of "hits" of terms in a row of A existing where terms in
!                                                            a col of B exist when a row of A is multiplied by a col of B
      INTEGER(LONG)                   :: NTERM_AROW        ! Number of nonzero terms in AROW (one row of A)
      INTEGER(LONG), PARAMETER        :: SUBR_BEGEND = MATMULT_SFF_BEGEND

      REAL(DOUBLE) , INTENT(IN )      :: A(NTERM_A)        ! Nonzero values in matrix A
      REAL(DOUBLE) , INTENT(IN )      :: B(NROWS_B,NCOLS_B)! Real values in matrix B
      REAL(DOUBLE) , INTENT(OUT)      :: C(NROWS_A,NCOLS_B)! Real values in matrix c
      REAL(DOUBLE) , INTENT(IN )      :: CONS              ! Constant multiplier in cons*A*B to get C
      REAL(DOUBLE)                    :: EPS1              ! A small value to compare to zero
      real(double)                    :: tsec_beg          !
      real(double)                    :: tsec_end          !

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         WRITE(F04,9001) SUBR_NAME,TSEC
 9001    FORMAT(1X,A,' BEGN ',F10.3)
      ENDIF
      tsec_beg = tsec

! **********************************************************************************************************************************
! Initialize outputs

      DO I=1,NROWS_A
         DO J=1,NCOLS_B
            C(I,J) = ZERO
         ENDDO
      ENDDO

! Calc outputs

      IF (WRITE_SC1 == 'Y') THEN
         WRITE(SC1, * )                                    ! Advance 1 line for screen messages
      ENDIF

      EPS1 = EPSIL(1)

      NROWS_C = NROWS_A
      NCOLS_C = NCOLS_B

! Calc AROW_MAX_TERMS (used to allocate AROW and J_AROW)

      A_ROW_BEG      = 1
      AROW_MAX_TERMS = 0                                   ! Find the max number of nonzero terms in any row of input matrix A
      DO I=1,NROWS_A
         IF (WRITE_SC1 == 'Y') THEN
            WRITE(SC1,22345,ADVANCE='NO') I, NROWS_A, CR13
         ENDIF
         A_NTERM_ROW_I = I_A(I+1) - I_A(I)
         A_ROW_END = A_ROW_BEG + A_NTERM_ROW_I - 1
         NTERM_AROW = 0
         IF (SYM_A == 'Y') THEN
            DO K=1,A_ROW_BEG-1
               IF (J_A(K) == I) THEN
                  NTERM_AROW = NTERM_AROW + 1
               ENDIF
            ENDDO
         ENDIF
         DO K=A_ROW_BEG,A_ROW_END
            NTERM_AROW = NTERM_AROW + 1
         ENDDO
         IF (NTERM_AROW > AROW_MAX_TERMS) THEN
            AROW_MAX_TERMS = NTERM_AROW
         ENDIF
         A_ROW_BEG = A_ROW_END + 1
      ENDDO
!xx   WRITE(SC1,*) CR13
                                                           ! Allocate  vectors long enough to hold the max terms in a row of A
      CALL ALLOCATE_SPARSE_ALG ( 'J_AROW', AROW_MAX_TERMS, 0, SUBR_NAME )
      CALL ALLOCATE_SPARSE_ALG (   'AROW', AROW_MAX_TERMS, 0, SUBR_NAME )

      IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '1', '   ' )

! Now do the multiply, using values put into AROW and J_AROW for each row of A. This is done to facilitate the SYM option for A

      DELTA_KTERM_C = 0                                    ! Initialize variables used in the matrix multiplication in the DO I loop
      KTERM_C       = 0
      NHITS         = 0
      A_ROW_BEG = 1
i_do: DO I=1,NROWS_A                                       ! Matrix multiply loop. Range over the rows in A

         A_NTERM_ROW_I = I_A(I+1) - I_A(I)                 ! Number of terms in matrix A in row I
         A_ROW_END = A_ROW_BEG + A_NTERM_ROW_I - 1         ! A_ROW_BEG to A_ROW_END is range of indices of terms in A for row I of A
         IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '2', '   ' )

         DO K=1,AROW_MAX_TERMS                             ! Null J_AROW and AROW each time we begin a new row of A
            J_AROW(K) = 0
              AROW(K) = ZERO
         ENDDO

         NTERM_AROW = 0                                    ! Formulate J_AROW, AROW - a CRS representation of one row of A
         IF (SYM_A == 'Y') THEN                            ! 1st, look for terms that would be in this row, but are not, due to SYM
            DO K=1,A_ROW_BEG-1
              IF (J_A(K) == I) THEN
                  NTERM_AROW         = NTERM_AROW + 1
                  AROW(NTERM_AROW)   = A(K)
                  DO II=1,I-1
                     IF ((K >= I_A(II)) .AND. (K < I_A(II+1))) THEN
                        J_AROW(NTERM_AROW) = II
                        IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '5', ' #2' )
                     ENDIF
                  ENDDO
               ENDIF
            ENDDO
         ENDIF

         DO K=A_ROW_BEG,A_ROW_END                          ! 2nd, get terms from this row of A from the diagonal out
            NTERM_AROW = NTERM_AROW + 1
            AROW(NTERM_AROW)   = A(K)
            J_AROW(NTERM_AROW) = J_A(K)
            IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '6', ' #1' )
         ENDDO

j_do:    DO J=1,NCOLS_B                                    ! J loops over the number of columns in B

            IF (WRITE_SC1 == 'Y') THEN
               WRITE(SC1,12345,ADVANCE='NO') I, NROWS_A, J, NCOLS_B, CR13
            ENDIF

            C(I,J) = ZERO

k_do:       DO K=1,NTERM_AROW                              ! The following 2 loops produce the ij-th term of C
               A_COL_NUM = J_AROW(K)
               C(I,J) = C(I,J) + CONS*AROW(K)*B(A_COL_NUM,J)
!_do:          DO L=1,NROWS_B
!                 IF (A_COL_NUM == L) THEN
!***********         IF (DABS(B(L,J)) > EPS1) THEN !! REMOVE EPS1 TEST - IGNORING SMALL TERMS CAUSED PROBS W/ MATMULT_SFF IN LANCZOS
!                       NHITS = NHITS + 1
!                       DELTA_KTERM_C = 1
!                       C(I,J) = C(I,J) + CONS*AROW(K)*B(L,J)
!***********         ENDIF
!                 ENDIF
!              ENDDO l_do
            ENDDO k_do
            KTERM_C  = KTERM_C + DELTA_KTERM_C
            IF (NHITS > 0) THEN
               IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '7', '   ' )
            ENDIF

            NHITS = 0

         ENDDO j_do

         A_ROW_BEG = A_ROW_END + 1
         IF (DEBUG(82) == 1) THEN
            WRITE(F06,*)
         ENDIF

      ENDDO i_do
      WRITE(SC1,*) CR13

      CALL DEALLOCATE_SPARSE_ALG ( 'J_AROW' )
      CALL DEALLOCATE_SPARSE_ALG ( 'AROW' )

      IF (DEBUG(82) == 1) CALL MATMULT_SFF_DEB ( '9', '   ' )

! **********************************************************************************************************************************
      IF (WRT_LOG >= SUBR_BEGEND) THEN
         CALL OURTIM
         tsec_end = tsec
         WRITE(F04,9003) SUBR_NAME,TSEC,tsec_end-tsec_beg
 9003    FORMAT(1X,A,' END  ',F10.3,' (',f6.3,' sec elapsed time for subr MATMULT_SFF)')
      ENDIF
      RETURN

! **********************************************************************************************************************************
12345 FORMAT(5X,'calc row ',I8,' of ',I8,' col ',I8,' of ',I8,A)

22345 FORMAT(5X,'setting up row ',I8,' of ',I8,A)

! **********************************************************************************************************************************

! ##################################################################################################################################

      CONTAINS

! ##################################################################################################################################

      SUBROUTINE MATMULT_SFF_DEB ( WHICH, ALG )

      CHARACTER(LEN=*), INTENT(IN)    :: ALG                    ! Which algorithm is used (#1 for terms above diag when SYM_A='Y'
!                                                                 or #2 for terms in row from diag out)
      CHARACTER( 1*BYTE)              :: WHICH                  ! Decides what to print out for this call to this subr

      INTEGER(LONG)                   :: JJ                     ! Local DO loop indices

! **********************************************************************************************************************************
      IF      (WHICH == '1') THEN

         WRITE(F06,*)
         WRITE(F06,1011)
         WRITE(F06,1012)
         WRITE(F06,1013)
         WRITE(F06,1014) MAT_A_NAME, MAT_B_NAME, MAT_C_NAME
         WRITE(F06,1015) CONS
         WRITE(F06,1016) NROWS_A, NTERM_A, NCOLS_B, NROWS_B, NCOLS_C, NROWS_C
         IF (SYM_A == 'Y') THEN
            WRITE(F06,1017)
         ELSE
            WRITE(F06,1018)
         ENDIF
         WRITE(F06,1019)
         WRITE(F06,*)

      ELSE IF (WHICH == '2') THEN

         WRITE(F06,1021)
         WRITE(F06,1022) I
         WRITE(F06,1023) I, I, A_ROW_BEG, A_ROW_END
         WRITE(F06,1024)
         WRITE(F06,*)

      ELSE IF (WHICH == '3') THEN

      ELSE IF (WHICH == '4') THEN

      ELSE IF (WHICH == '5') THEN

         WRITE(F06,1051) ALG,                     K , II, J_A(K) , A(K), NTERM_AROW, J_AROW(NTERM_AROW), AROW(NTERM_AROW)

      ELSE IF (WHICH == '6') THEN

         WRITE(F06,1061) ALG, K, I, J_A(K), A(K),                         NTERM_AROW, J_AROW(NTERM_AROW), AROW(NTERM_AROW)

      ELSE IF (WHICH == '7') THEN

         IF (NHITS > 0) THEN
            IF (J == 1) THEN
               WRITE(F06,*)
               WRITE(F06,1071) I
            ENDIF
            WRITE(F06,1072) I, J, NHITS, KTERM_C, I, J, C(I,J)
         ENDIF

      ELSE IF (WHICH == '8') THEN

      ELSE IF (WHICH == '9') THEN

         WRITE(F06,*)
         WRITE(F06,1091) MAT_C_NAME
         WRITE(F06,*)
         DO II=1,NROWS_C
            WRITE(F06,9192) II
            WRITE(F06,1093) (C(II,JJ),JJ=1,NCOLS_C)
            WRITE(F06,*)
         ENDDO
         WRITE(F06,1094)

      ENDIF

! **********************************************************************************************************************************
 1011 FORMAT(' __________________________________________________________________________________________________________________',&
             '_________________'                                                                                ,//,&
             ' :::::::::::::::::::::::::::::::::::::::START DEBUG(82) OUTPUT FROM SUBROUTINE MATMULT_SFF:::::::::::::::::::::::::',&
              ':::::::::::::::::',/)

 1012 FORMAT(' SFF SPARSE MATRIX MULTIPLY ROUTINE: Multiply matrix A, stored in sparse Compressed Row Storage (CRS) format, times',&
' matrix B, stored',/,' -----------------------------------',/,' in full format, to obtain matrix C stored in full format',/)

 1013 FORMAT(' A may be stored as symmetric (only terms on and above the diagonal) or with all nonzero terms included.'         ,/,&
' Matrices B and C must be stored with all terms.',/)

 1014 FORMAT(40X,' The name of CRS  formatted matrix A is: ',A                                                                  ,/,&
             40x,' The name of full formatted matrix B is: ',A                                                                  ,/,&
             40x,' The name of full formatted matrix C is: ',A,/)

 1015 FORMAT(' Multiply ',1ES14.6,' times the product of matrix A and matrix B to obtain matrix C',/)

 1016 FORMAT(36X,' Matrix A has       ',I8,' rows and '  ,I12,' nonzero terms'                                                  ,/,&
             36X,' Matrix B has       ',I8,' cols and '  ,I12,' rows'                                                           ,/,&
             36X,' Matrix C will have ',I8,' cols and '  ,I12,' rows'/)

 1017 FORMAT(' Matrix A was input as a symmetric CRS array (only those terms on and above the diagonal are stored in array A)',/)

 1018 FORMAT(' Matrix A was input as a CRS array with all nonzero terms stored in array A',/)

 1019 FORMAT(                                                                                &
' In order to handle symmetric A matrices, which do not have all terms in a row (only those from the diagonal out), arrays AROW' ,/&
' and J_AROW are used. AROW is a 1D array that contains all nonzero terms from one row of A (including those that are not'      ,/,&
' explicitly in array A due to symmetry). The multiplication of matrix A times matrix B is then accomplished (row by row of'    ,/,&
' result matrix C) by multiplying AROW times matrix B. Since AROW is a compact array containing only the nonzero terms from one',/,&
' row of matrix A, integer array J_AROW is also needed to give the col numbers, from matrix A (for one row), for the terms in'  ,/,&
' array AROW.'                                                                                ,//&
' Alg #1 (below) gets data for arrays J_AROW and AROW directly from the Compressed Row Storage (CRS) format of array A'         ,/,&
' Alg #2 (below) is only needed if matrix A is input as symmetric (only terms on and above the diagonal) and gets terms for'    ,/,&
'         J_AROW and AROW from column I of matrix A while working on row I of matrix A. These are the terms that would be below',/,&
'         the diag in matrix A but are not explicitly in the array due to symmetry storage'                                    ,//,&
' For each row of matrix A, the following shows the development of arrays J_AROW and AROW and the result of mult AROW times'      ,&
' matrix B to get one row of result matrix C. Output is only given for non null rows of matrix A and non null cols of matrix B',/)

 1021 FORMAT(' ******************************************************************************************************************',&
              '*****************')

 1022 FORMAT(30X,' W O R K I N G   O N   R O W ',I8,'   O F   O U T P U T   M A T R I X   C',/)

 1023 FORMAT(' Multiply row ',I8,' of matrix A times all columns of matrix B to get row ',I8,' of matrix C'                     ,/,&
             ' This row of A begins in array A(K) at index K  = ',I8,' and ends at index K = ',I8,//)

 1024 FORMAT(16X,'Data from input array A             Data below diag of matrix A not in array A             Data for array AROW',/&
,9X,'----------------------------------------   ------------------------------------------      --------------------------------',/&
,' Alg     Index       Row     Col        Value         Index       Row     Col        Value          Index    Col No        Value'&
,/,13X,'K         I    J_A(K)       A(K)             K        II    J_A(K)       A(K)              M  J_AROW(M)      AROW(M)')

 1051 FORMAT(1X,A3,10X,10X,10X,15X    ,I10,I10,I10,1ES15.6,I11,I11,1ES16.6)

 1061 FORMAT(1X,A3,I10,I10,I10,1ES15.6,10X,10X,10X,15X    ,I11,I11,1ES16.6)

 1071 FORMAT('                                                                          Data for row',I8,' of output matrix C'  ,/,&
             '                                                                       --------------------------------------------' &
          ,/,'                                                                          Index       Row     Col        Value'   ,/,&
             '                                                                              K         I    J_C(K)       C(K)',/)

 1072 FORMAT(' Row ',I8,' of A times col ',I8,' of B gets ',I8,' hits and:   ',I10,I10,i10,1ES16.6)

 1091 FORMAT(' ******************************************************************************************************************',&
              '*****************'                                                                                ,/,&
             ' SUMMARY: Full formatted matrix C = ',A,' is:',/)

 9192 FORMAT(' Row ',I10,/,' --------------')

 1093 FORMAT(10(1ES15.6))

 1094 FORMAT(' ::::::::::::::::::::::::::::::::::::::END DEBUG(82) OUTPUT FROM SUBROUTINE MATMULT_SFF::::::::::::::::::::::::::::',&
              ':::::::::::::::::'                                                                                ,/,&
             ' __________________________________________________________________________________________________________________',&
             '_________________',/)

! **********************************************************************************************************************************

      END SUBROUTINE MATMULT_SFF_DEB

      END SUBROUTINE MATMULT_SFF


      subroutine tdma(n,a,b,c,d,x)

!        a - sub-diagonal (means it is the diagonal below the main diagonal)
!        b - the main diagonal
!        c - sup-diagonal (means it is the diagonal above the main diagonal)
!        d - right part
!        x - the answer
!        n - number of equations

      implicit none

      integer, intent(in) :: n
      double complex, intent(in) ::                  a(n), c(n)
      double complex, intent(inout), dimension(n) :: b, d
      double complex, intent(out) ::                 x(n)
      !  --- Local variables ---
      integer :: i
      double complex :: q

      !  --- Elimination ---
      do i = 2,n
         q = a(i)/b(i - 1)
         b(i) = b(i) - c(i - 1)*q
         d(i) = d(i) - d(i - 1)*q
      enddo

      ! --- Backsubstitution ---
      q = d(n)/b(n)
      x(n) = q
      do i = n - 1,1,-1
         q = (d(i) - c(i)*q)/b(i)
         x(i) = q
      enddo

      return

      end subroutine tdma

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_estdtax(uin,  uin_l1,uin_l2,uin_l3,uin_h1,uin_h2,uin_h3, &
                    uout, uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3, &
                    dt_old, dt_new, delta, maxchange, x)

      use meth_params_module, only : UAXRE, UAXIM
      use fundamental_constants_module
      !use fdm_params_module, only: ax_maxchange,ax_x,ax_y,ax_z

      implicit none

      integer          uin_l1,uin_l2,uin_l3,uin_h1,uin_h2,uin_h3
      integer          uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3
      integer          i, j, k

      ! double precision  uin(  uin_l1:uin_h1,   uin_l2:uin_h2,   uin_l3:uin_h3,  NAXVAR)
      ! double precision uout( uout_l1:uout_h1, uout_l2:uout_h2, uout_l3:uout_h3, NAXVAR)
      double precision  uin(  uin_l1:uin_h1,   uin_l2:uin_h2,   uin_l3:uin_h3, 1)
      double precision uout( uout_l1:uout_h1, uout_l2:uout_h2, uout_l3:uout_h3, 1)
      double precision dt_old, dt_new
      double precision ampin, ampout, maxchange_temp, maxchange
      double precision delta(3), x(3)

      dt_new = dt_old
      maxchange_temp = 0.0d0

      !iterate over physical domain and not over ghost cells
      do k = uout_l3+1, uout_h3-1
        do j = uout_l2+1, uout_h2-1
          do i = uout_l1+1, uout_h1-1

             ampin = sqrt(uin(i,j,k, UAXRE)**2 + uin(i,j,k, UAXIM)**2)
             ampout = sqrt(uout(i,j,k, UAXRE)**2 + uout(i,j,k, UAXIM)**2)
             ! ampin = uin(i,j,k,1)
             ! ampout = uout(i,j,k,1)
             ! phasein = datan2(uin(i,j,k, UAXIM), uin(i,j,k, UAXRE))
             ! phaseout = datan2(uout(i,j,k, UAXIM), uout(i,j,k, UAXRE))
             ! if (abs(phasein - phaseout) .gt. 1.9*PI .or. ampin .lt. 1.0d-5) then
             !    phasein = 1.
             !    phaseout = 1.
             !    !print *, 'oops'
             ! endif
             maxchange_temp = max(maxchange_temp, dabs( ampin/ampout - 1.0 ))!, &
                              !dabs( (phasein - phaseout)/(2.*PI) )) !OLD VERSIONallow phasechange to be 10x larger than ampchange

             ! if (maxchange_temp .gt. maxchange) then
             !    maxchange = maxchange_temp
             !    x(1) = i*delta(1)
             !    x(2) = j*delta(2)
             !    x(3) = k*delta(3)
             ! endif

          enddo
        enddo
      enddo
!      print *, maxchange_temp
      if (maxchange_temp .gt. 1.d-1) then
         dt_new = 1.d-1 * dt_old / maxchange_temp
      else
         dt_new = 2.*dt_old
      endif

      return

      end subroutine fort_estdtax

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_divvel(uin,  uin_l1, uin_l2, uin_l3, uin_h1, uin_h2, uin_h3, &
                             uout, uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3, &
                             vdx, nvar, delta, ProbLo,ProbHi &
                             )

      use fdm_params_module, only : hbaroverm

      implicit none

      integer          uin_l1,uin_l2,uin_l3,uin_h1,uin_h2,uin_h3
      integer          uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3
      integer          i, j, k
      integer          vdx, nvar

      double precision uin(   uin_l1:uin_h1,  uin_l2:uin_h2,   uin_l3:uin_h3,  nvar)
      double precision uout(uout_l1:uout_h1, uout_l2:uout_h2, uout_l3:uout_h3, 1)
      double precision delvx, delvy, delvz
      double precision delta(3), ProbLo(3),ProbHi(3),center(3)

      do i = 1,3
         center(i) = (ProbHi(i)-ProbLo(i))/2.d0
      end do

      !hbar/m expressed in Nyx units [Mpc km/s]
      ! hbaroverm = 0.01917152d0 / m_tt

      ! do k = uout_l3, uout_h3
      !   do j = uout_l2, uout_h2
      !     do i = uout_l1, uout_h1

      !        r = dsqrt( (i*delta(1)-center(1))**2 + (j*delta(2)-center(2))**2 + (k*delta(3)-center(3))**2 )
      !        if (r .lt. 1.d-6) then
      !            r = 1.d-6
      !        endif
      !        uout(i,j,k,1) = exp(-r)/r
      !        ! uout(i,j,k,1) = mod(i+j+k,2)*2-1
      !        ! uout(i,j,k,1) = mod(i,2)*2-1

      !     enddo
      !   enddo
      ! enddo

      ! need 1 ghost zone -> uout_l = uin_l+1, uout_h = uin_h-1
      do k = uout_l3, uout_h3
        do j = uout_l2, uout_h2
          do i = uout_l1, uout_h1

             delvx = ( uin(i+1,j,k,vdx  ) - uin(i-1,j,k,vdx  ) ) / (2.*delta(1))
             delvy = ( uin(i,j+1,k,vdx+1) - uin(i,j-1,k,vdx+1) ) / (2.*delta(2))
             delvz = ( uin(i,j,k+1,vdx+2) - uin(i,j,k-1,vdx+2) ) / (2.*delta(3))
             uout(i,j,k,1) = (delvx + delvy + delvz) / hbaroverm !Such that later on we can calculate uout=Lap(phase

          enddo
        enddo
      enddo

      return

      end subroutine fort_divvel

! :::
! ::: ----------------------------------------------------------------
! :::

      subroutine fort_initcosmoax( &
                             init, i_l1,i_l2,i_l3,i_h1,i_h2,i_h3, &
                             state,s_l1,s_l2,s_l3,s_h1,s_h2,s_h3, &
                             divvel,d_l1,d_l2,d_l3,d_h1,d_h2,d_h3, &
                             phase,p_l1,p_l2,p_l3,p_h1,p_h2,p_h3, &
                             didx, ivar, dx &!, maxchange &
                                 )

      use meth_params_module, only : NAXVAR, UAXDENS, UAXRE, UAXIM
      use comoving_module
      use fundamental_constants_module
      use fdm_params_module

      implicit none

      integer          i_l1,i_l2,i_l3,i_h1,i_h2,i_h3
      integer          s_l1,s_l2,s_l3,s_h1,s_h2,s_h3
      integer          d_l1,d_l2,d_l3,d_h1,d_h2,d_h3
      integer          p_l1,p_l2,p_l3,p_h1,p_h2,p_h3
      integer          didx, ivar

      double precision  init(i_l1:i_h1,i_l2:i_h2,i_l3:i_h3,ivar)
      double precision state(s_l1:s_h1,s_l2:s_h2,s_l3:s_h3,NAXVAR)
      double precision divvel(d_l1:d_h1,d_l2:d_h2,d_l3:d_h3,1)
      double precision phase(p_l1:p_h1,p_l2:p_h2,p_l3:p_h3,1)
      integer          i, j, k

      !double precision mean_ax_dens
      double precision delta, dx(3)!, hbaroverm!, maxchange, maxchange_temp
      ! double precision weights(4)
      ! double precision, allocatable   ::  temp(:,:,:,:)
      ! integer          s

      ! meandens = 3 * (0.7 * 100)**2 * comoving_OmAx &
      !                / ( 8 * PI * Gconst)
      !meandens = 3 * (comoving_h * 100)**2 * comoving_OmAx &
      !               / ( 8 * PI * Gconst)
      !meandens = 2.775d11 * 0.7**2 * comoving_OmAx !background density

      !hbar/m expressed in Nyx units [Mpc km/s]
      ! hbaroverm = 0.01917152d0 / m_tt

      ! weights(:) = (/ 1.0/8.0, 1.0/16.0, 1.0/32.0, 1.0/64.0 /)
      ! s = 1

      ! allocate(temp(  i_l1:i_h1,    i_l2:i_h2,    i_l3:i_h3, 1))

      ! do n = 1,5
      !    do k = i_l3, i_h3
      !       do j = i_l2, i_h2
      !          do i = i_l1, i_h1
      !             temp(i,j,k,1) = init(i,j,k,didx)
      !          end do
      !       end do
      !    end do

      !    do k = i_l3+1, i_h3-1
      !       do j = i_l2+1, i_h2-1
      !          do i = i_l1+1, i_h1-1
      !             init(i,j,k,1) = weights(1) * temp(i,j,k,1) + &         !center
      !                             weights(2) * (temp(i+s,j,k,1) + &     !sides
      !                             temp(i,j+s,k,1) + temp(i,j,k+s,1) + &
      !                             temp(i-s,j,k,1) + temp(i,j-s,k,1) + &
      !                             temp(i,j,k-s,1)) + &
      !                             weights(3) * (temp(i+s,j+s,k,1) + &   !edges
      !                             temp(i,j+s,k+s,1) + temp(i+s,j,k+s,1) + &
      !                             temp(i-s,j+s,k,1) + temp(i,j-s,k+s,1) + &
      !                             temp(i-s,j,k+s,1) + temp(i+s,j-s,k,1) + &
      !                             temp(i,j+s,k-s,1) + temp(i+s,j,k-s,1) + &
      !                             temp(i-s,j-s,k,1) + temp(i,j-s,k-s,1) + &
      !                             temp(i-s,j,k-s,1)) + &                !corners
      !                             weights(4) * (temp(i+s,j+s,k+s,1) + &
      !                             temp(i+s,j+s,k-s,1) + temp(i+s,j-s,k+s,1) + &
      !                             temp(i-s,j+s,k+s,1) + temp(i-s,j-s,k+s,1) + &
      !                             temp(i-s,j+s,k-s,1) + temp(i+s,j-s,k-s,1) + &
      !                             temp(i-s,j-s,k-s,1))
      !          end do
      !       end do
      !    end do
      ! end do
      ! deallocate(temp)

      !init has a row of ghost cells that we don't want to integrate over
      do k = i_l3+1, i_h3-1
         do j = i_l2+1, i_h2-1
            do i = i_l1+1, i_h1-1

               delta = init(i,j,k,didx)
               state(i,j,k,UAXRE)   = dsqrt(delta + 1.)*dcos(phase(i,j,k,1))
               state(i,j,k,UAXIM)   = dsqrt(delta + 1.)*dsin(phase(i,j,k,1))
               !state(i,j,k,UAXDENS) = meandens * (delta + 1.)
               state(i,j,k,UAXDENS) = (delta + 1.)

               ! state(i,j,k,UAXRE)   = dsqrt(delta + 1.)
               ! state(i,j,k,UAXIM)   = 0.0d0
               ! state(i,j,k,UAXDENS) = meandens * (delta + 1.)

               ! state(i,j,k,UAXRE)   = divvel(i,j,k,1)
               ! state(i,j,k,UAXIM)   = phase(i,j,k,1)
               ! state(i,j,k,UAXDENS) = meandens * (state(i,j,k,UAXRE)**2+state(i,j,k,UAXIM)**2)

            enddo
         enddo
      enddo

      ! do k = i_l3+2, i_h3-2
      !    do j = i_l2+2, i_h2-2
      !       do i = i_l1+2, i_h1-2

      !          state(i,j,k,UAXIM)   = (phase(i+1,j,k,1)+phase(i-1,j,k,1)+phase(i,j+1,k,1)+phase(i,j-1,k,1)+phase(i,j,k+1,1)+phase(i,j,k-1,1)-6.d0*phase(i,j,k,1))/dx(1)/dx(1)!phase(i,j,k,1)

      !       enddo
      !    enddo
      ! enddo

      return

      end subroutine fort_initcosmoax

! :::
! ::: ----------------------------------------------------------------
!> Solves the Schroedinger-Newton (Gross-Pitaevskii) equation for a self-gravitating
!! Bose-Einstein condensate of an ultralight scalar field using explicit RK4 and
!! directional splitting. (Also, this is an example of how to document Fortran
!! code, in line 300 of Source/Src_3d/Nyx_adv_FDM_FD.f90)

      subroutine fort_advance_fdm_fd(time,lo,hi,&
           uin,  uin_l1,uin_l2,uin_l3,uin_h1,uin_h2,uin_h3, &
           uout, uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3, &
           ! grav, g_l1,g_l2,g_l3,g_h1,g_h2,g_h3, &
           phi,  p_l1,p_l2,p_l3,p_h1,p_h2,p_h3, &
           delta,prob_lo,prob_hi,dt, &
           courno,a_old,a_half,a_new,verbose)

      use amrex_error_module
      use meth_params_module, only : NAXVAR, UAXDENS, UAXRE, UAXIM, UAXPHAS
      use fdm_params_module, only : hbaroverm, ii
      use fundamental_constants_module
      use probdata_module

      implicit none

      !interface stuff
      integer          lo(3),hi(3),verbose
      integer          uin_l1,uin_l2,uin_l3,uin_h1,uin_h2,uin_h3
      integer          uout_l1,uout_l2,uout_l3,uout_h1,uout_h2,uout_h3
      ! integer          g_l1,g_l2,g_l3,g_h1,g_h2,g_h3
      integer          p_l1,p_l2,p_l3,p_h1,p_h2,p_h3
      double precision  uin(  uin_l1:uin_h1,   uin_l2:uin_h2,   uin_l3:uin_h3,  NAXVAR)
      double precision uout( uout_l1:uout_h1, uout_l2:uout_h2, uout_l3:uout_h3, NAXVAR)
      ! double precision grav(   g_l1:g_h1,     g_l2:g_h2,     g_l3:g_h3,   3)
      double precision  phi(   p_l1:p_h1,     p_l2:p_h2,     p_l3:p_h3)
      double precision delta(3),prob_lo(3),prob_hi(3),dt,time,courno
      double precision a_old, a_half, a_new, temp

      !additional variables
      integer          i,j,k
      double precision invdeltasq_old(3), invdeltasq_half(3), invdeltasq_new(3)
      double precision xn,xp,xc,del,Vo,r

      !(complex) fdm field
      complex, allocatable :: psi(:,:,:),k1(:,:,:),k2(:,:,:),k3(:,:,:),k4(:,:,:),V(:,:,:)

      allocate( psi(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3) )
      allocate(  k1(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3) )
      allocate(  k2(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3) )
      allocate(  k3(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3) )
      allocate(  k4(uin_l1:uin_h1,uin_l2:uin_h2,uin_l3:uin_h3) )
      allocate(   V(  p_l1:p_h1  ,  p_l2:p_h2  ,  p_l3:p_h3  ) )

      psi = cmplx(uin(:,:,:,UAXRE),uin(:,:,:,UAXIM))
!      psi = sqrt(max(0,uin(:,:,:,UAXDENS)))/abs(psi)*psi
!      print *, psi
!      call amrex_error('Aborting fort_advance_fdm_fd')

      !print *, 'uin bounds = ',lbound(uin),ubound(uin),lbound(psi),ubound(psi),uin_l1,uin_h1,uin_l2,uin_h2,uin_l3,uin_h3
      ! psi = sqrt(uin(:,:,:,UAXDENS))/abs(psi)*psi
      do k = uin_l3, uin_h3
         do j = uin_l2, uin_h2
            do i = uin_l1, uin_h1
!!               psi(i,j,k) = cmplx(uin(i,j,k,UAXRE),uin(i,j,k,UAXIM))
!               if(abs(psi(i,j,k)) .gt. 0.0) then
               if( (uin(i,j,k,UAXDENS).gt.0.0).and.(abs(psi(i,j,k)).gt.0.0) ) then
!                  continue
                  psi(i,j,k) = sqrt(uin(i,j,k,UAXDENS))/abs(psi(i,j,k))*psi(i,j,k)
!               else
!                  psi(i,j,k) = 0.d0
!                  print *, 'psi = 0!',abs(psi(i,j,k)),psi(i,j,k),uin(i,j,k,UAXDENS),i,j,k
!                  call amrex_error('Aborting fort_advance_fdm_fd')
               endif
            enddo
         enddo
      enddo

      ! psi = sqrt(uin(:,:,:,UAXDENS))*cmplx(cos(uin(:,:,:,UAXPHAS)),sin(uin(:,:,:,UAXPHAS)))
      k1  = 0.d0
      k2  = 0.d0
      k3  = 0.d0
      k4  = 0.d0
      V   = 0.d0

      ! xn  = prob_hi(1)            ! Need that the center of the physical problem is at (0,0,0)!!
      ! xp  = 7.d0/8.d0*prob_hi(1)  ! Inside this radius the 'sponge' is zero.
      ! !TODO this effectively disables the sponge
      ! xp  = 1.0d10*prob_hi(1)  ! Inside this radius the 'sponge' is zero.
      ! !TODO
      ! xc  = (xn+xp)/2.d0
      ! del = xn-xp
      ! !Vo  = 0.657d0              ! Corresponding to Vo=1 in arXiv:gr-qc/0404014v2 eq.29 when scaled to halo with rho_max=rho_cr
      ! Vo  = 0.d0

!       do k = p_l3, p_h3
!          do j = p_l2, p_h2
!             do i = p_l1, p_h1
!                r = dsqrt((i*delta(1)+prob_lo(1))**2.d0 + (j*delta(2)+prob_lo(2))**2.d0 + (k*delta(3)+prob_lo(3))**2.d0) !Distance from the physical problem center
!                if (r .lt. xp) then
!                   V(i,j,k) = 0.d0
!                else if ((r .ge. xp) .and. (r .lt. xc)) then
! !                  V(i,j,k) = ii*Vo/2.d0 * (2.d0 + dtanh((r-xc)/del) - dtanh(xc/del)) ! Cf. arXiv:gr-qc/0404014v2 eq.29 : we changed the sign so it matches the sign of phi.
!                   V(i,j,k) = ii*Vo/2.d0 * (     ((r-xp)/del)**2.d0*2.d0)
!                else
!                   V(i,j,k) = ii*Vo/2.d0 * (1.d0-((r-xn)/del)**2.d0*2.d0)
!                endif
!             enddo
!          enddo
!       enddo

      !We need this, since single scalars are not saved in checkpoint files and therefore meandens=0 after restart!
      !if (meandens .eq. 0) then
      !   meandens = 2.775d11 * 0.7d0**2 * comoving_OmAx !3 * (100)**2 *0.7d0**2 *  comoving_OmAx / ( 8 * PI * Gconst)
      !endif

      !hbar/m expressed in Nyx units [Mpc km/s]
      !hbaroverm = 0.01917152d0 / m_tt

      do i = 1, 3
       invdeltasq_old(i)  = 1.d0 / ( a_old  * delta(i) )**2 ! differentiate w.r.t. proper distance
       invdeltasq_half(i) = 1.d0 / ( a_half * delta(i) )**2 ! differentiate w.r.t. proper distance
       invdeltasq_new(i)  = 1.d0 / ( a_new  * delta(i) )**2 ! differentiate w.r.t. proper distance
      enddo

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uin_l3+1, uin_h3-1
         do j = uin_l2+1, uin_h2-1
            do i = uin_l1+1, uin_h1-1

               k1(i,j,k) = ii*hbaroverm*(6.d0*psi(i+1,j,k)&
                                        +6.d0*psi(i-1,j,k)&
                                        +6.d0*psi(i,j+1,k)&
                                        +6.d0*psi(i,j-1,k)&
                                        +6.d0*psi(i,j,k+1)&
                                        +6.d0*psi(i,j,k-1)&
                                        +3.d0*psi(i+1,j+1,k)&
                                        +3.d0*psi(i+1,j-1,k)&
                                        +3.d0*psi(i-1,j+1,k)&
                                        +3.d0*psi(i-1,j-1,k)&
                                        +3.d0*psi(i+1,j,k+1)&
                                        +3.d0*psi(i+1,j,k-1)&
                                        +3.d0*psi(i-1,j,k+1)&
                                        +3.d0*psi(i-1,j,k-1)&
                                        +3.d0*psi(i,j+1,k+1)&
                                        +3.d0*psi(i,j+1,k-1)&
                                        +3.d0*psi(i,j-1,k+1)&
                                        +3.d0*psi(i,j-1,k-1)&
                                        +2.d0*psi(i+1,j+1,k+1)&
                                        +2.d0*psi(i+1,j+1,k-1)&
                                        +2.d0*psi(i+1,j-1,k+1)&
                                        +2.d0*psi(i+1,j-1,k-1)&
                                        +2.d0*psi(i-1,j+1,k+1)&
                                        +2.d0*psi(i-1,j+1,k-1)&
                                        +2.d0*psi(i-1,j-1,k+1)&
                                        +2.d0*psi(i-1,j-1,k-1)&
                                        -88.d0*(psi(i,j,k)))&
                   *invdeltasq_old(1)/52.d0 + ii*(phi(i,j,k)+V(i,j,k))/hbaroverm*(psi(i,j,k))

            enddo
         enddo
      enddo
      !$OMP END PARALLEL DO

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uin_l3+1, uin_h3-1
         do j = uin_l2+1, uin_h2-1
            do i = uin_l1+1, uin_h1-1

               k2(i,j,k) = ii*hbaroverm*(6.d0*(psi(i+1,j,k)+k1(i+1,j,k)*dt/2.d0)&
                                        +6.d0*(psi(i-1,j,k)+k1(i-1,j,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j+1,k)+k1(i,j+1,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j-1,k)+k1(i,j-1,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j,k+1)+k1(i,j,k+1)*dt/2.d0)&
                                        +6.d0*(psi(i,j,k-1)+k1(i,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j+1,k)+k1(i+1,j+1,k)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j-1,k)+k1(i+1,j-1,k)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j+1,k)+k1(i-1,j+1,k)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j-1,k)+k1(i-1,j-1,k)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j,k+1)+k1(i+1,j,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j,k-1)+k1(i+1,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j,k+1)+k1(i-1,j,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j,k-1)+k1(i-1,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i,j+1,k+1)+k1(i,j+1,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i,j+1,k-1)+k1(i,j+1,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i,j-1,k+1)+k1(i,j-1,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i,j-1,k-1)+k1(i,j-1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j+1,k+1)+k1(i+1,j+1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j+1,k-1)+k1(i+1,j+1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j-1,k+1)+k1(i+1,j-1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j-1,k-1)+k1(i+1,j-1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j+1,k+1)+k1(i-1,j+1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j+1,k-1)+k1(i-1,j+1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j-1,k+1)+k1(i-1,j-1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j-1,k-1)+k1(i-1,j-1,k-1)*dt/2.d0)&
                                        -88.d0*(psi(i,j,k)+k1(i,j,k)*dt/2.d0))&
                   *invdeltasq_half(1)/52.d0 + ii*(phi(i,j,k)+V(i,j,k))/hbaroverm*(psi(i,j,k)+k1(i,j,k)*dt/2.d0)

            enddo
         enddo
      enddo
      !$OMP END PARALLEL DO

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uin_l3+1, uin_h3-1
         do j = uin_l2+1, uin_h2-1
            do i = uin_l1+1, uin_h1-1

               k3(i,j,k) = ii*hbaroverm*(6.d0*(psi(i+1,j,k)+k2(i+1,j,k)*dt/2.d0)&
                                        +6.d0*(psi(i-1,j,k)+k2(i-1,j,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j+1,k)+k2(i,j+1,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j-1,k)+k2(i,j-1,k)*dt/2.d0)&
                                        +6.d0*(psi(i,j,k+1)+k2(i,j,k+1)*dt/2.d0)&
                                        +6.d0*(psi(i,j,k-1)+k2(i,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j+1,k)+k2(i+1,j+1,k)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j-1,k)+k2(i+1,j-1,k)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j+1,k)+k2(i-1,j+1,k)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j-1,k)+k2(i-1,j-1,k)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j,k+1)+k2(i+1,j,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i+1,j,k-1)+k2(i+1,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j,k+1)+k2(i-1,j,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i-1,j,k-1)+k2(i-1,j,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i,j+1,k+1)+k2(i,j+1,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i,j+1,k-1)+k2(i,j+1,k-1)*dt/2.d0)&
                                        +3.d0*(psi(i,j-1,k+1)+k2(i,j-1,k+1)*dt/2.d0)&
                                        +3.d0*(psi(i,j-1,k-1)+k2(i,j-1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j+1,k+1)+k2(i+1,j+1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j+1,k-1)+k2(i+1,j+1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j-1,k+1)+k2(i+1,j-1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i+1,j-1,k-1)+k2(i+1,j-1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j+1,k+1)+k2(i-1,j+1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j+1,k-1)+k2(i-1,j+1,k-1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j-1,k+1)+k2(i-1,j-1,k+1)*dt/2.d0)&
                                        +2.d0*(psi(i-1,j-1,k-1)+k2(i-1,j-1,k-1)*dt/2.d0)&
                                        -88.d0*(psi(i,j,k)+k2(i,j,k)*dt/2.d0))&
                   *invdeltasq_half(1)/52.d0 + ii*(phi(i,j,k)+V(i,j,k))/hbaroverm*(psi(i,j,k)+k2(i,j,k)*dt/2.d0)

            enddo
         enddo
      enddo
      !$OMP END PARALLEL DO

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uin_l3+1, uin_h3-1
         do j = uin_l2+1, uin_h2-1
            do i = uin_l1+1, uin_h1-1

               k4(i,j,k) = ii*hbaroverm*(6.d0*(psi(i+1,j,k)+k3(i+1,j,k)*dt)&
                                        +6.d0*(psi(i-1,j,k)+k3(i-1,j,k)*dt)&
                                        +6.d0*(psi(i,j+1,k)+k3(i,j+1,k)*dt)&
                                        +6.d0*(psi(i,j-1,k)+k3(i,j-1,k)*dt)&
                                        +6.d0*(psi(i,j,k+1)+k3(i,j,k+1)*dt)&
                                        +6.d0*(psi(i,j,k-1)+k3(i,j,k-1)*dt)&
                                        +3.d0*(psi(i+1,j+1,k)+k3(i+1,j+1,k)*dt)&
                                        +3.d0*(psi(i+1,j-1,k)+k3(i+1,j-1,k)*dt)&
                                        +3.d0*(psi(i-1,j+1,k)+k3(i-1,j+1,k)*dt)&
                                        +3.d0*(psi(i-1,j-1,k)+k3(i-1,j-1,k)*dt)&
                                        +3.d0*(psi(i+1,j,k+1)+k3(i+1,j,k+1)*dt)&
                                        +3.d0*(psi(i+1,j,k-1)+k3(i+1,j,k-1)*dt)&
                                        +3.d0*(psi(i-1,j,k+1)+k3(i-1,j,k+1)*dt)&
                                        +3.d0*(psi(i-1,j,k-1)+k3(i-1,j,k-1)*dt)&
                                        +3.d0*(psi(i,j+1,k+1)+k3(i,j+1,k+1)*dt)&
                                        +3.d0*(psi(i,j+1,k-1)+k3(i,j+1,k-1)*dt)&
                                        +3.d0*(psi(i,j-1,k+1)+k3(i,j-1,k+1)*dt)&
                                        +3.d0*(psi(i,j-1,k-1)+k3(i,j-1,k-1)*dt)&
                                        +2.d0*(psi(i+1,j+1,k+1)+k3(i+1,j+1,k+1)*dt)&
                                        +2.d0*(psi(i+1,j+1,k-1)+k3(i+1,j+1,k-1)*dt)&
                                        +2.d0*(psi(i+1,j-1,k+1)+k3(i+1,j-1,k+1)*dt)&
                                        +2.d0*(psi(i+1,j-1,k-1)+k3(i+1,j-1,k-1)*dt)&
                                        +2.d0*(psi(i-1,j+1,k+1)+k3(i-1,j+1,k+1)*dt)&
                                        +2.d0*(psi(i-1,j+1,k-1)+k3(i-1,j+1,k-1)*dt)&
                                        +2.d0*(psi(i-1,j-1,k+1)+k3(i-1,j-1,k+1)*dt)&
                                        +2.d0*(psi(i-1,j-1,k-1)+k3(i-1,j-1,k-1)*dt)&
                                        -88.d0*(psi(i,j,k)+k3(i,j,k)*dt))&
                   *invdeltasq_new(1)/52.d0 + ii*(phi(i,j,k)+V(i,j,k))/hbaroverm*(psi(i,j,k)+k3(i,j,k)*dt)

            enddo
         enddo
      enddo
      !$OMP END PARALLEL DO

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uin_l3+1, uin_h3-1
         do j = uin_l2+1, uin_h2-1
            do i = uin_l1+1, uin_h1-1

               psi(i,j,k) = psi(i,j,k) + dt*(k1(i,j,k)+2.d0*k2(i,j,k)+2.d0*k3(i,j,k)+k4(i,j,k))/6.d0

            enddo
         enddo
      enddo
      !$OMP END PARALLEL DO

      !$OMP PARALLEL DO PRIVATE(i,j,k)
      do k = uout_l3, uout_h3
        do j = uout_l2, uout_h2
          do i = uout_l1, uout_h1

             uout(i,j,k, UAXRE)   = real(  psi(i,j,k) )
             uout(i,j,k, UAXIM)   = aimag( psi(i,j,k) )
             !uout(i,j,k, UAXDENS) = meandens * cdabs( psi(i,j,k) )**2 !density in Nyx units
             uout(i,j,k, UAXDENS) = abs( psi(i,j,k) )**2
             uout(i,j,k, UAXPHAS) = atan2( uout(i,j,k, UAXIM) , uout(i,j,k, UAXRE) )

             ! temp = uin(i,j,k, UAXPHAS)+mod((atan2(uout(i,j,k, UAXIM),uout(i,j,k, UAXRE))-uin(i,j,k, UAXPHAS)),2.0*PI)
             ! temp = atan2(uout(i,j,k, UAXIM),uout(i,j,k, UAXRE)) !+int(uin(i,j,k, UAXPHAS)/2.0/PI)*2.0*PI
             ! do while ( (temp-uin(i,j,k, UAXPHAS)) .gt. 1.8*PI)
             !    temp = temp-2.0*PI
             ! end do
             ! do while ( (uin(i,j,k, UAXPHAS)-temp) .gt. 1.8*PI)
             !    temp = temp+2.0*PI
             ! end do
             ! uout(i,j,k, UAXPHAS) = temp

             ! temp = min(mod(abs(uout(i,j,k, UAXPHAS)-uin(i,j,k, UAXPHAS)),M_PI),M_PI-mod(abs(uout(i,j,k, UAXPHAS)-uin(i,j,k, UAXPHAS)),M_PI))
             ! if ( mod(abs(uout(i,j,k, UAXPHAS)-uin(i,j,k, UAXPHAS)),M_PI) .gt. 4.0) then
             !    uout(i,j,k, UAXPHAS) = uout(i,j,k, UAXPHAS)-2.0*M_PI
             ! else if ((uin(i,j,k, UAXPHAS)-uout(i,j,k, UAXPHAS)) .gt. 4.0) then
             !    uout(i,j,k, UAXPHAS) = uout(i,j,k, UAXPHAS)+2.0*M_PI
             ! endif

          enddo
        enddo
      enddo
      !$OMP END PARALLEL DO

      deallocate(psi)
      deallocate( k1)
      deallocate( k2)
      deallocate( k3)
      deallocate( k4)
      deallocate(  V)

      end subroutine fort_advance_fdm_fd


*DECK TRIDQ
      SUBROUTINE TRIDQ (MR, A, B, C, Y, D)
C***BEGIN PROLOGUE  TRIDQ
C***SUBSIDIARY
C***PURPOSE  Subsidiary to POIS3D
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (TRIDQ-S)
C***AUTHOR  (UNKNOWN)
C***SEE ALSO  POIS3D
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900308  Renamed routine from TRID to TRIDQ.  (WRB)
C   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  TRIDQ
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,Y(*)       ,
     1                D(*)
C***FIRST EXECUTABLE STATEMENT  TRIDQ
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
      END


program real_dp_param

    integer, parameter :: prec1 = 4, prec2 = 8
    real(prec1) :: u = 1.05
    real(prec2) :: v = 1.05
    real(prec2) :: zero = 0.0_4
    print *, u, v, zero

end program


program mc1
   implicit none

   integer, parameter :: nsets = 1  ! number of 'sets'
   integer, parameter :: nmc = 1  ! number of trials in set
   integer, parameter :: n = 1       ! sample size in trial

   real, dimension(nsets,nmc) :: mu      ! result of each trial
   real :: random_numbers(nmc, n)        ! bunch of random numbers, since GPU doesn't have random_number subroutine...
   real :: mean, stdev                   ! mean and standard deviation
   integer :: k, j, i
   real :: y, u

   do j = 1, nmc
      do i = 1, n
         call random_number(u)            ! draw from Uniform(0,1)
         random_numbers(j, i) = u
      end do
   end do

   ! have to initialize again in kernel, firstprivate doesn't work in OMP45 GPU yet.
   y = 0.d0

!$omp target data map(to:random_numbers) map(from:mu)

!$omp target teams distribute num_teams(nsets) default(none) shared(random_numbers, mu, y, u) private(k)
   do k = 1, nsets
!$omp parallel do default(none) shared(random_numbers, mu) private(u,k,y)
! firstprivate(y)
      do j = 1, nmc
         y = 0.d0
         do i = 1, n
!            u = random_numbers(j, i)
!            y = y + u                        ! sum the draws
         end do
!         mu(k,j) = y / dble(n)                     ! return the sample mean

      end do
!$omp end parallel do
   end do
!$omp end target teams distribute

!$omp end target data

   do k = 1, nsets
      mean = sum(mu) / dble(nmc)
      stdev = sqrt( sum( (mu(k,:) - mean)**2 ) ) / dble(nmc)

      print *, 'mean(', k, ')',mean
      print *, 'stdev(', k, ')',stdev
   end do

end program mc1


module setup_config_mod

use constants_mod

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

real(dp), parameter :: init_time = 0.0_dp
real(dp), parameter :: stop_time = 0.05_dp

real(dp), parameter :: CFL = 0.8_dp

real(dp), parameter :: beta = 0.8_dp

real(dp), parameter :: dt_checkpoint = 0.01_dp

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

real(dp), parameter :: dt_analyze = dt_checkpoint

real(dp), parameter :: chkpt_init_time = init_time
real(dp), parameter :: chkpt_stop_time = stop_time

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

real(dp), parameter :: diameter = 1.0_dp

real(dp), parameter :: xlim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: ylim(2) = diameter * ((/0.0,1.0/) - 0.5)
real(dp), parameter :: zlim(2) = diameter * ((/0.0,1.0/) - 0.5)

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

!real(dp), parameter :: bell_mass  = 0.0_dp
!real(dp), parameter :: bell_mass  = 1.5_dp
!real(dp), parameter :: bell_sigma = 0.1_dp
!real(dp), parameter :: bell_mass_normalized = bell_mass/SQRT((2*pi)**N_DIMS)/bell_sigma**N_DIMS

real(dp), parameter :: blast_energy = 1.0_dp
real(dp), parameter :: blast_sigma = 5*5e-3_dp
real(dp), parameter :: blast_ener_normalized = blast_energy/SQRT((2*pi)**N_DIMS)/blast_sigma**N_DIMS

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

real(dp), parameter :: dens0 = 1e-0_dp
real(dp), parameter :: pres0 = 1e-5_dp

real(dp), parameter :: velx0 = 0.0
real(dp), parameter :: vely0 = 0.0
real(dp), parameter :: velz0 = 0.0

real(dp), parameter :: kappa = 7.0_dp/5.0_dp

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

integer, parameter :: amr_each_ntimesteps = 8

integer, parameter :: mesh_minlevel = 5
integer, parameter :: mesh_maxlevel = 5

real(dp), parameter :: setup_amr_threshold_refine = -6
real(dp), parameter :: setup_amr_threshold_coarsen = -7

real(dp), parameter :: dens_refine_threshold = 1.3*dens0
real(dp), parameter :: dens_coarse_threshold = 1.2*dens0

# if DO_PROFILING
integer, parameter :: prof_report_rate = 64
# endif

end module


!*******************************************************************
!                                                                  *
      SUBROUTINE C0T5S(Q,QM,SM,C,CM,A)
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF FOLLOWING              *
!                                                ---          ---  *
!                                                I  Q  1/2  C   I  *
!     CLEBSCH - GORDAN COEFFICIENT:              I              I  *
!                                                I  QM  SM  CM  I  *
!                                                ---          ---  *
!                                                                  *
!   Written by G. Gaigalas,                                        *
!   Vilnius,  Lithuania                             December 1993  *
!   Transform to fortran 90/95 by G. Gaigalas       December 2012  *
!   The last modification made by G. Gaigalas       October  2017  *
!                                                                  *
!*******************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONS_C,          ONLY: ZERO, TENTH , HALF, ONE, TWO, EPS
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE ittk_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      REAL(DOUBLE), INTENT(IN)  :: Q, QM, SM, C, CM
      REAL(DOUBLE), INTENT(OUT) :: A
!      DIMENSION GC(2)
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER                    :: IIQ, IIC, IE
      REAL(DOUBLE), DIMENSION(2) :: GC
!-----------------------------------------------
      GC(1)=ONE
      GC(2)=-ONE
      A=ZERO
      IIQ=TWO*Q+TENTH
      IIC=TWO*C+TENTH
      IF(ITTK(IIQ,IIC,1) == 0)RETURN
      IF(DABS(QM+SM-CM) > EPS)RETURN
      IF((HALF+TENTH) < DABS(SM))RETURN
      IF((Q+TENTH) < DABS(QM))RETURN
      IF((C+TENTH) < DABS(CM))RETURN
      IE=DABS(HALF-SM)+ONE+TENTH
      IF(DABS(Q+HALF-C) < EPS) THEN
        A=DSQRT((C+GC(IE)*CM)/(TWO*C))
      ELSE
        IF(DABS(Q-HALF-C) > EPS)RETURN
        A=-GC(IE)*DSQRT((C-GC(IE)*CM+ONE)/(TWO*C+TWO))
      ENDIF
      RETURN
      END SUBROUTINE C0T5S


      SUBROUTINE EXPAND(IPAIR,SEMI0)
*
*
*       Expansion (contraction) of KS orbit.
*       ------------------------------------
*
      INCLUDE 'common6.h'
*
*
*       Evaluate square regularized velocity.
      V20 = 0.0
      DO 10 K = 1,4
          V20 = V20 + UDOT(K,IPAIR)**2
   10 CONTINUE
*
*       Form KS coordinate & velocity scaling factors (general point is OK).
      I = N + IPAIR
      IF (SEMI0.GE.0.0D0) THEN
          SEMI = -0.5D0*BODY(I)/H(IPAIR)
      ELSE
          SEMI = SEMI0
      END IF
      C2 = SQRT(SEMI/SEMI0)
      V2 = 0.5*(BODY(I) + H(IPAIR)*R(IPAIR)*(SEMI/SEMI0))
      C1 = SQRT(V2/V20)
*
*       Re-scale KS variables to new energy (H < 0: constant eccentricity).
      R(IPAIR) = 0.0D0
*       Retain sign of radial velocity for unperturbed KS (apo or peri).
*     TDOT2(IPAIR) = 0.0D0
      DO 20 K = 1,4
          U(K,IPAIR) = C2*U(K,IPAIR)
          UDOT(K,IPAIR) = C1*UDOT(K,IPAIR)
          U0(K,IPAIR) = U(K,IPAIR)
          R(IPAIR) = R(IPAIR) + U(K,IPAIR)**2
*         TDOT2(IPAIR) = TDOT2(IPAIR) + 2.0*U(K,IPAIR)*UDOT(K,IPAIR)
   20 CONTINUE
*
*       Re-initialize KS polynomials for perturbed or hyperbolic motion.
      T0(2*IPAIR-1) = TIME
      IF (LIST(1,2*IPAIR-1).GT.0.OR.H(IPAIR).GT.0.0) THEN
          CALL RESOLV(IPAIR,1)
          CALL KSPOLY(IPAIR,1)
      ELSE
*       Determine new interval for unperturbed motion (>= TK).
          TK = TWOPI*SEMI*SQRT(ABS(SEMI)/BODY(I))
          CALL TPERT(IPAIR,GMIN,DT)
*       Adopt c.m. step instead if integer argument exceeds 10**9.
          IF (DT.LT.2.0E+09*TK) THEN
              K = 1 + INT(0.5D0*DT/TK)
*       Restrict Kepler period to c.m. step (case of very wide orbit).
              STEP(2*IPAIR-1) = MIN(FLOAT(K)*TK,STEP(I))
          ELSE
              STEP(2*IPAIR-1) = STEP(I)
          END IF
      END IF
*
      RETURN
*
      END


! 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 cov_cutoff_mod

use     types_mod, only : r8
use utilities_mod, only : register_module, error_handler, E_ERR, E_MSG, &
                          do_output, do_nml_file, do_nml_term, nmlfileunit, &
                          find_namelist_in_file, check_namelist_read
use location_mod,  only : location_type

implicit none
private

public :: comp_cov_factor

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

!============================================================================

!---- namelist with default values
logical :: namelist_initialized = .false.

integer :: select_localization = 1
! Value 1 selects default Gaspari-Cohn cutoff
! Value 2 selects boxcar
! Value 3 selects ramped boxcar

namelist / cov_cutoff_nml / select_localization

!============================================================================

contains

!======================================================================

function comp_cov_factor(z_in, c, obs_loc, obs_type, target_loc, target_kind, &
   localization_override)
!----------------------------------------------------------------------
! function comp_cov_factor(z_in, c)
!
! Computes a covariance cutoff function from Gaspari and Cohn
! QJRMS, 125, 723-757.  (their eqn. 4.10)
!
! z_in is the distance while c is the cutoff distance.
! For distances greater than 2c, the cov_factor returned goes to 0.

! Other ramping shapes are also available and can be selected by a namelist
! parameter. At present, these include a boxcar with the given halfwidth
! and a ramp in which the weight is set at 1.0 up to the half-width
! distance and then decreases linearly to 0 at twice the half-width
! distance.

! Additional information is passed in about the location and specific type of the
! observation and the location and generic kind of the variable being targeted for
! increments. These can be used for more refined algorithms that want to
! make the cutoff a function of these additional arguments.

implicit none

real(r8),                      intent(in) :: z_in, c
type(location_type), optional, intent(in) :: obs_loc, target_loc
integer,             optional, intent(in) :: obs_type, target_kind
integer,             optional, intent(in) :: localization_override
real(r8)                                  :: comp_cov_factor

real(r8) :: z, r
integer  :: iunit, io
integer  :: localization_type

!--------------------------------------------------------
! Initialize namelist if not already done
if(.not. namelist_initialized) then

   call register_module(source, revision, revdate)

   namelist_initialized = .true.

   ! Read the namelist entry
   call find_namelist_in_file("input.nml", "cov_cutoff_nml", iunit)
   read(iunit, nml = cov_cutoff_nml, iostat = io)
   call check_namelist_read(iunit, io, "cov_cutoff_nml")

   if (do_nml_file()) write(nmlfileunit,nml=cov_cutoff_nml)
   if (do_nml_term()) write(     *     ,nml=cov_cutoff_nml)

   if (do_output()) then
      select case (select_localization)
         case (1)
            call error_handler(E_MSG,'comp_cov_factor:', &
               'Standard Gaspari Cohn localization selected')
         case (2)
            call error_handler(E_MSG,'comp_cov_factor:', &
               'Boxcar localization selected')
         case (3)
            call error_handler(E_MSG,'comp_cov_factor:', &
               'Ramped localization selected')
         case default
            call error_handler(E_ERR,'comp_cov_factor', &
               'Illegal value of "select_localization" in cov_cutoff_mod namelist', &
                source, revision, revdate )
      end select
   endif

endif
!---------------------------------------------------------

if(present(localization_override)) then
   localization_type = localization_override
else
   localization_type = select_localization
endif

z = abs(z_in)

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

if(localization_type == 1) then ! Standard Gaspari Cohn localization

   if( z >= c*2.0_r8 ) then

      comp_cov_factor = 0.0_r8

   else if( z <= c ) then
      r = z / c
      comp_cov_factor = &
           ( ( ( -0.25_r8*r +0.5_r8 )*r +0.625_r8 )*r -5.0_r8/3.0_r8 )*r**2 + 1.0_r8
!!$           r**5 * (-0.25_r8 ) + &
!!$           r**4 / 2.0_r8 +              &
!!$           r**3 * 5.0_r8/8.0_r8 -       &
!!$           r**2 * 5.0_r8/3.0_r8 + 1.0_r8
   else

      r = z / c
      comp_cov_factor = &
           ( ( ( ( r/12.0_r8 -0.5_r8 )*r +0.625_r8 )*r +5.0_r8/3.0_r8 )*r -5.0_r8 )*r &
!!$           r**5 / 12.0_r8  -  &
!!$           r**4 / 2.0_r8   +  &
!!$           r**3 * 5.0_r8 / 8.0_r8 + &
!!$           r**2 * 5.0_r8 / 3.0_r8 - 5.0_r8*r &
           + 4.0_r8 - 2.0_r8 / (3.0_r8 * r)
   endif

else if(localization_type == 2) then ! BOXCAR localization

   if(z < 2.0_r8 * c) then
      comp_cov_factor = 1.0_r8
   else
      comp_cov_factor = 0.0_r8
   endif

else if(localization_type == 3) then ! Ramped localization

   if(z >= 2.0_r8 * c) then
      comp_cov_factor = 0.0_r8
   else if(z >= c .and. z < 2.0_r8 * c) then
      comp_cov_factor = (2.0_r8 * c - z) / c
   else
      comp_cov_factor = 1.0_r8
   endif

else ! Otherwise namelist parameter is illegal; this is an error

     call error_handler(E_ERR,'comp_cov_factor', &
              'Illegal value of "localization" in cov_cutoff_mod namelist', &
               source, revision, revdate )

endif

end function comp_cov_factor

end module cov_cutoff_mod

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


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine calcspringforc(imat,elcon,nelcon,ncmat_,ntmat_,t1l,
     &  kode,plicon,nplicon,npmat_,senergy,nener,fk,val)
!
!     calculates the spring forc and the spring energy (node-to-face penalty)
!
      implicit none
!
      integer i,imat,ncmat_,ntmat_,kode,niso,id,nplicon(0:ntmat_,*),
     &    npmat_,nelcon(2,*),nener
!
      real*8 t1l,elcon(0:ncmat_,ntmat_,*),elconloc(21),plconloc(802),
     &  xk,fk,val,xiso(200),yiso(200),plicon(0:2*npmat_,ntmat_,*),
     &  senergy
!
!
!
!     interpolating the material data
!
      call materialdata_sp(elcon,nelcon,imat,ntmat_,i,t1l,
     &     elconloc,kode,plicon,nplicon,npmat_,plconloc,ncmat_)
!
!     calculating the spring force and the spring constant
!
      if(kode.eq.2)then
         xk=elconloc(1)
         fk=xk*val
         if(nener.eq.1) then
            senergy=fk*val/2.d0
         endif
      else
         niso=int(plconloc(801))
         do i=1,niso
            xiso(i)=plconloc(2*i-1)
            yiso(i)=plconloc(2*i)
         enddo
         call ident(xiso,val,niso,id)
         if(id.eq.0) then
            xk=0.d0
            fk=yiso(1)
            if(nener.eq.1) then
               senergy=fk*val
            endif
         elseif(id.eq.niso) then
            xk=0.d0
            fk=yiso(niso)
            if(nener.eq.1) then
               senergy=yiso(1)*xiso(1)
               do i=2,niso
                  senergy=senergy+(xiso(i)-xiso(i-1))*
     &                 (yiso(i)+yiso(i-1))/2.d0
               enddo
               senergy=senergy+(val-xiso(niso))*yiso(niso)
            endif
         else
            xk=(yiso(id+1)-yiso(id))/(xiso(id+1)-xiso(id))
            fk=yiso(id)+xk*(val-xiso(id))
            if(nener.eq.1) then
               senergy=yiso(1)*xiso(1)
               do i=2, id
                  senergy=senergy+(xiso(i)-xiso(i-1))*
     &                 (yiso(i)+yiso(i-1))/2.d0
               enddo
               senergy=senergy+(val-xiso(id))*(fk+yiso(id))/2.d0
            endif
         endif
      endif
!
      return
      end


module constants

use parameters

implicit none

!Universal constants

real(kind=dp), parameter :: Newton_g = 6.67408d-11
real(kind=dp), parameter :: Msolar = 1.989d30
real(kind=dp), parameter :: mu = Newton_g*MBH*Msolar
real(kind=dp), parameter :: light_c = 3.0d8
real(kind=dp), parameter :: convert_m = light_c**2/(Newton_g*MBH*Msolar) !Multiply by this to go TO Natural units
real(kind=dp), parameter :: convert_s = light_c**3/(Newton_g*MBH*Msolar) !Multiply by this to go TO Natural units
real(kind=dp), parameter :: convert_spin= light_c/(Newton_g*(MBH*Msolar)**2.0_dp) !Multiply by this to go TO Natural units
real(kind=dp), PARAMETER :: electron_charge = 4.803204250e-10 !CGS
real(kind=dp), PARAMETER :: electron_mass = 9.109383560e-28 !CGS

!Useful constants
real(kind=dp), parameter :: Rhor = 1.0_dp + sqrt(1.0_dp - a**2) + 1.0d-2 !Horizon + eps
real(kind=dp), parameter :: a2 = a**2

!Target points for intersection search
real(kind=dp) :: xTarget, yTarget, zTarget
real(kind=dp) :: rTarget,thetaTarget, phiTarget,tauTarget

!Set the 'x precision' for intersection search
real(kind=dp) :: dx_eps

!Set the target intersection precision
real(kind=dp) :: ds_eps

!Set the gradient bit
real(kind=dp) :: dg,bit

!Used in pattern search
real(kind=dp) :: decay_factor

!Define Eobs_globally
real(kind=dp) :: Eobs_global

! 4 -velocity of loaded  positions
real(kind=dp), dimension(4) :: uvector

!A globally defined alha beta that new rays can reference
real(kind=dp) :: alpha_previous = 0.0_dp, beta_previous=0.0_dp

!Temporay
real(kind=dp) :: global_t = 10.0_dp
integer(kind=dp) :: global_counter

!Integration constants
real(kind=dp) :: escal !This will be made higher / lower for double vs quad precision
real(kind=dp), parameter :: S = 0.90_dp
real(kind=dp), parameter :: Pgrow = -0.20_dp
real(kind=dp), parameter :: Pshrink = -0.250_dp
real(kind=dp), parameter :: errcon = (5.0_dp/S)**(1.0_dp/Pgrow)

!Related to plasma

!Cash-Karp parameters
real(kind = dp) :: B21=1.0_dp/5.0_dp
real(kind = dp) :: B31 = 3.0_dp/40.0_dp , B32 = 9.0_dp/40.0_dp
real(kind = dp) :: B41 = 3.0_dp/10.0_dp, B42 = -9.0_dp/10.0_dp, B43 = 6.0_dp/5.0_dp
real(kind = dp) :: B51 = -11.0_dp/54.0_dp, B52 = 5.0_dp/2.0_dp, B53 = -70.0_dp/27.0_dp
real(kind = dp) :: B54 = 35.0_dp/27.0_dp
real(kind = dp) :: B61 = 1631.0_dp/55296.0_dp, B62 = 175.0_dp/512.0_dp, B63 = 575.0_dp/13824.0_dp
real(kind = dp) :: B64 = 44275.0_dp/110592.0_dp, B65 = 253.0_dp/4096.0_dp
real(kind = dp) :: c1 = 37.0_dp/378.0_dp, c3 = 250.0_dp/621.0_dp, c4 = 125.0_dp/594.0_dp
real(kind = dp) :: c6=512.0_dp/1771.0_dp
real(kind = dp) :: cbar1 = 2825.0_dp/27648.0_dp, cbar3 = 18575.0_dp/48384.0_dp
real(kind = dp) :: cbar4=13525.0_dp/55296.0_dp, cbar5 = 277.0_dp/14336.0_dp, cbar6 = 1.0_dp/4.0_dp

end module constants


      FUNCTION DAY2(YMD)
      IMPLICIT REAL*8 (A-H,O-Z)
C PROGRAM NAME
C     DAY2
C
C PURPOSE
C     CALCULATES THE NUMBER OF DAYS WHICH HAVE ELAPSED SINCE
C     1 JANUARY 1962 TO ANY INPUT CALENDAR DATE.
C
C METHOD
C     NOT APPLICABLE
C CALLING SEQUENCE
C     NDAYS=DAY2(YMD)
C
C     DAYS   (OUTPUT,R8,1)  - NUMBER OF DAYS SINCE JANUARY 1,1962
C     YMD    (INPUT,R8,1)   - PACK CALENDAR DATE (YYMMDD)
C
C COMMON VARIABLES
C     NONE
C
C INPUT/OUTPUT DEVICES
C     NONE
C
C EXTERNAL REFERNCES
C     NONE
C
C RESTRICTIONS
C     NONE
C ORGINATOR
C     OBTAINED FROM STANDARD ATS SOFTWARE (DAY1)
C
C MODIFCATIONS
C
C        CJP. 8/81. UPACKING YMD MAY GIVE WRONG 'D'. FIXED.
C
C     UNPACK CALENDAR DATE INTERNALLY
C
      REAL*8 DUM(3),TEMP(3)
      DIMENSION MM(12)
      DATA MM/0,31,59,90,120,151,181,212,243,273,304,334/
C
      CALL UNPACK(YMD,TEMP,DUM)
      NYR=TEMP(1)-1900.D0
      NMO=TEMP(2)
      NDA=TEMP(3)
C
      DAY2=0.0D0
      K=NYR-62
      K4=(12*K+NMO+21)/48
      IF(NMO .GT. 0  .AND.  NMO .LE. 12)
     1 DAY2=365*K+K4+MM(NMO)+NDA-1
C
      RETURN
      END


!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
module MLP
private
integer,parameter :: Nq=32
public :: get_k_mlp_1,get_k_mlp_2
save
CONTAINS
subroutine get_k_mlp_1(Mix_Info,Tref,k)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! subroutine to calculate the k-values for a given state
! by data interpolation using NEW DEVELOPED look-up table
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
use commonData, only : GasMixInfo
use MLP_network
USE MLP_structure_1
use MLP_layer

implicit none

  TYPE(GasMixInfo),INTENT(IN) :: Mix_Info ! Local mixture information
  real(8),intent(in) :: Tref ! reference temperature
  real(8),dimension(Nq),intent(out) :: k ! k-values
  real(8) ::input_data_1(6),output_data_1(32)
  INTEGER :: i,j,n
  INTEGER :: number
  real(8) ,DIMENSION(:),ALLOCATABLE ::b(:)
!-------------------------------------------------
  type(network_type) :: net
  net%layers_size =hidden_layer_sizes
  net%number_of_layer=number_of_layer
!-------------------------------------------------
  input_data_1(1)=Mix_Info%P
  input_data_1(2)=Tref
  input_data_1(3)=Mix_Info%T
  input_data_1(4)=Mix_Info%xCO2
  input_data_1(5)=Mix_Info%xH2O
  input_data_1(6)=Mix_Info%xCO
!--------------------
  DO i=1,6
      input_data_1(i)=(input_data_1(i)-u(i))/s(i)
  END DO
!--------------------
  net%layers(1)%W=coefs_0
  net%layers(1)%b=intercepts_0
  net%layers(2)%W=coefs_1
  net%layers(2)%b=intercepts_1
  net%layers(3)%W=coefs_2
  net%layers(3)%b=intercepts_2
  net%layers(4)%W=coefs_3
  net%layers(4)%b=intercepts_3
  net%layers(5)%W=coefs_4
  net%layers(5)%b=intercepts_4
  net%layers(6)%W=coefs_5
  net%layers(6)%b=intercepts_5

!--------------------input layers----------------
  net%layers(1)%a=input_data_1
!-------------------hidden layers----------------
  do n=2,net%number_of_layer+2
       net%layers(n)%z = matmul(transpose(net%layers(n-1)%W),net%layers(n-1)%a)+ net%layers(n-1)%b
       if (n /=  net%number_of_layer+2)   then
              number=net%layers_size(n)
              ALLOCATE(b(number))
              call sub1(net%layers(n)%z,b)
              net%layers(n)%a=b
              DEALLOCATE(b)
       end if
  end do
!-------------------ouput layer-----------------
  DO i=1,32
    k(i)=10**(net%layers(net%number_of_layer+2)%z(i)*sy(i)+uy(i))
  END DO
!-----------------------------------------------
RETURN
END SUBROUTINE get_k_mlp_1
!-------------------------------------------------------------------------

subroutine get_k_mlp_2(Mix_Info,Tref,k)
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! subroutine to calculate the k-values for a given state
! by data interpolation using NEW DEVELOPED look-up table
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
use commonData, only : GasMixInfo
use MLP_network
USE MLP_structure_2
use MLP_layer

implicit none

  TYPE(GasMixInfo),INTENT(IN) :: Mix_Info ! Local mixture information
  real(8),intent(in) :: Tref ! reference temperature
  real(8),dimension(Nq),intent(out) :: k ! k-values
  real(8) ::input_data_1(6),output_data_1(32)
  INTEGER :: i,j,n
  INTEGER :: number
  real(8) ,DIMENSION(:),ALLOCATABLE ::b(:)
!-------------------------------------------------
  type(network_type) :: net
  net%layers_size =hidden_layer_sizes
  net%number_of_layer=number_of_layer
!-------------------------------------------------
  input_data_1(1)=Mix_Info%P
  input_data_1(2)=Tref
  input_data_1(3)=Mix_Info%T
  input_data_1(4)=Mix_Info%xCO2
  input_data_1(5)=Mix_Info%xH2O
  input_data_1(6)=Mix_Info%xCO
!--------------------
  DO i=1,6
      input_data_1(i)=(input_data_1(i)-u(i))/s(i)
  END DO
!--------------------
  net%layers(1)%W=coefs_0
  net%layers(1)%b=intercepts_0
  net%layers(2)%W=coefs_1
  net%layers(2)%b=intercepts_1
  net%layers(3)%W=coefs_2
  net%layers(3)%b=intercepts_2
  net%layers(4)%W=coefs_3
  net%layers(4)%b=intercepts_3
  net%layers(5)%W=coefs_4
  net%layers(5)%b=intercepts_4
  net%layers(6)%W=coefs_5
  net%layers(6)%b=intercepts_5
  net%layers(7)%W=coefs_6
  net%layers(7)%b=intercepts_6

!--------------------input layers----------------
  net%layers(1)%a=input_data_1
!-------------------hidden layers----------------
  do n=2,net%number_of_layer+2
       net%layers(n)%z = matmul(transpose(net%layers(n-1)%W),net%layers(n-1)%a)+ net%layers(n-1)%b
       if (n /=  net%number_of_layer+2)   then
              number=net%layers_size(n)
              ALLOCATE(b(number))
              call sub1(net%layers(n)%z,b)
              net%layers(n)%a=b
              DEALLOCATE(b)
       end if
  end do
!-------------------ouput layer-----------------
  DO i=1,32
    k(i)=10**(net%layers(net%number_of_layer+2)%z(i)*sy(i)+uy(i))
  END DO
!-----------------------------------------------
RETURN
END SUBROUTINE get_k_mlp_2
!-------------------------------------------------------------------------

subroutine sub1(x,res)
IMPLICIT NONE
    real(8), intent(in) :: x(:)
    real(8) ::O=0.0, res(size(x))
    res = max(O, x)
return
end subroutine
!--------------------
end module MLP


program selectCase
  implicit none

  integer :: month, ndays, year
  logical :: leap_year

 print*, 'Enter a year'
 read*, year
 print*, 'Enter a month Enter a month (1-12)'
 read*, month

 if( ((year/4*4     .eq. year) .and. &
      (year/100*100 .ne. year)) .or. &
      (year/400*400 .eq. year) ) then
   leap_year = .true.
 else
   leap_year = .false.
 end if

 select case(month)
   case(4,6,9,11)
     ndays = 30
   case(1,3,5,7:8,10,12)
     ndays = 31
   case(2)
!----------------------------------
     fevrier: select case(leap_year)
       case(.true.)
         ndays = 29
       case(.false.)
         ndays = 28
     end select fevrier
!-----------------------------------
   case DEFAULT
     print*, 'Invalid month'
 end select

 print*, "There are ", ndays, " days in this month."

end program selectCase


*DECK EZFFT1
      SUBROUTINE EZFFT1 (N, WA, IFAC)
C***BEGIN PROLOGUE  EZFFT1
C***SUBSIDIARY
C***PURPOSE  EZFFTI calls EZFFT1 with appropriate work array
C            partitioning.
C***LIBRARY   SLATEC (FFTPACK)
C***TYPE      SINGLE PRECISION (EZFFT1-S)
C***AUTHOR  Swarztrauber, P. N., (NCAR)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   790601  DATE WRITTEN
C   830401  Modified to use SLATEC library source file format.
C   860115  Modified by Ron Boisvert to adhere to Fortran 77 by
C           (a) changing dummy array size declarations (1) to (*),
C           (b) changing references to intrinsic function FLOAT
C               to REAL, and
C           (c) changing definition of variable TPI by using
C               FORTRAN intrinsic function ATAN instead of a DATA
C               statement.
C   881128  Modified by Dick Valent to meet prologue standards.
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   900402  Added TYPE section.  (WRB)
C***END PROLOGUE  EZFFT1
      DIMENSION WA(*), IFAC(*), NTRYH(4)
      SAVE NTRYH
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C***FIRST EXECUTABLE STATEMENT  EZFFT1
      TPI = 8.*ATAN(1.)
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      IFAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         IFAC(IB+2) = IFAC(IB+1)
  106 CONTINUE
      IFAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      IFAC(1) = N
      IFAC(2) = NF
      ARGH = TPI/N
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 111 K1=1,NFM1
         IP = IFAC(K1+2)
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         ARG1 = L1*ARGH
         CH1 = 1.
         SH1 = 0.
         DCH1 = COS(ARG1)
         DSH1 = SIN(ARG1)
         DO 110 J=1,IPM
            CH1H = DCH1*CH1-DSH1*SH1
            SH1 = DCH1*SH1+DSH1*CH1
            CH1 = CH1H
            I = IS+2
            WA(I-1) = CH1
            WA(I) = SH1
            IF (IDO .LT. 5) GO TO 109
            DO 108 II=5,IDO,2
               I = I+2
               WA(I-1) = CH1*WA(I-3)-SH1*WA(I-2)
               WA(I) = CH1*WA(I-2)+SH1*WA(I-3)
  108       CONTINUE
  109       IS = IS+IDO
  110    CONTINUE
         L1 = L2
  111 CONTINUE
      RETURN
      END


*       Compute The Average Score For Each Student
          Read(*,*)N
100       Read(*,*)S1,S2,S3,S4
          Sum=S1+S2+S3+S4
          Average=Sum/4
          write(*,*) S1,S2,S3,S4, Average
          N=N-1
          If(N.eq.0)go to 10
          Go to 100
10        Stop
          End


! { dg-do run }
! { dg-options "-Warray-temporaries" }
! PR fortran/56937 - unnecessary temporaries with vector indices
program main
  real :: q(4), r(4), p(3)
  integer :: idx(3)
  p = [0.5, 1.0, 2.0]
  idx = [4,3,1]
  r = 1.0
  r(idx) = r(idx) + p
  q = 1.0
  q(4) = q(4) + p(1)
  q(3) = q(3) + p(2)
  q(1) = q(1) + p(3)
  if (any (q - r /= 0)) call abort
end


      PROGRAM SPLIT_PRAGMA2

      INTEGER NX,NY,NZ,AX,ISH,JSH,KSH,I,J,K,IP1,JP1,KP1
      REAL*8 KT,KX,KY,KZ,GM,RE,PR,AL0,AL1,AL2,AL3,AL4,AL5,AL6,STEP

      REAL*8 Q(5,10,10,10)

      REAL*8 JE(5,5,10,10,10),JV(5,5,10,10,10)

      REAL*8 U,V,W,FI2,ALF,THT,A1,MU,RO,US,VS,WS,ROS

      DO I = 1, NX
         IP1 = MOD(I, NX+1-ISH)+ISH
         ROS = Q(1,IP1,JP1,KP1)
         US = Q(2,IP1,JP1,KP1)/ROS
         VS = Q(3,IP1,JP1,KP1)/ROS
         WS = Q(4,IP1,JP1,KP1)/ROS
         RO = Q(1,I,J,K)
         U = Q(2,I,J,K)/RO
         V = Q(3,I,J,K)/RO
         JE(2,3,I,J,K) = KY*U-(GM-1.0D0)*KX*V
         W = Q(4,I,J,K)/RO
         FI2 = 0.5D0*(GM-1.0D0)*(U*U+V*V+W*W)
         THT = KX*U+KY*V+KZ*W
         MU = ((GM-1.0D0)*(Q(5,I,J,K)/RO-0.5D0*(U*U+V*V+W*W)))
     &        **0.75D0
         JV(2,1,I,J,K) = MU/STEP*(AL1*(U/RO-US/ROS)+AL2*(V/RO-
     &        VS/ROS)+AL3*(W/RO-WS/ROS))
         ALF = GM*Q(5,I,J,K)/RO
         A1 = ALF-FI2
      ENDDO
      END


MODULE m_statorbit

! ----------------------------------------------------------------------
! MODULE: m_statorbit.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for calling statorbit subroutine
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	6 November 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE statorbit (ds1, ds2, dorb_XYZ, dorb_RTN, dorb_Kepler, stat_XYZ, stat_RTN, stat_Kepler)

! ----------------------------------------------------------------------
! SUBROUTINE: statorbit.f03
! ----------------------------------------------------------------------
! Purpose:
!  Numerical comparison and statistics between two orbits in inertial frame (ICRF)
! ----------------------------------------------------------------------
! Input arguments:
! - orb_ref:		1st data series matrix (used as reference)
! - orb_det: 		2nd data series matrix
!
! Output arguments:
! - dorb_XYZ:		Orbit differences in the intertial frame (position and velocity vector differences)
!        			dorb_XYZ = [Time_MJD Time_Seconds00h r(X) r(Y) r(Z) v(X) v(Y) v(Z)]
! - dorb_RTN:		Orbit differences in the orbital frame (RTN: radial, along-track and cross-track differences)
!        			dorb_RTN = [Time_MJD Time_Seconds00h R(X) T(Y) N(Z) R(vX) T(vY) N(vZ)]
! - dorb_Kepler:	Orbit differences for the Keplerian elements
!        			dorb_Kepler = [Time_MJD Time_Seconds00h a e i Omega omega E]
!   				a: 		semi-major axis  (m)
!   				e: 		eccentricity
!   				i: 		inclination (degrees)
!   				Omega:	right ascension of the ascending node (degrees)
!   				omega:	argument of perigee (degrees)
!   				E: 		eccentric anomaly (degrees)
! - stat_XYZ:		Statistical quantities of dorb_XYZ (see Note 1)
! - stat_RTN:		Statistical quantities of dorb_RTN (see Note 1)
! - stat_Kepler:	Statistical quantities of dorb_Kepler (see Note 1)
! ----------------------------------------------------------------------
! Note 1
! The arrays of the statistical quantities of the orbital differences
! are formed as follows:
! stat_XYZ(1,:) : RMS value for each of the orbital elements e.g. X,Y,Z,Vx,Vy,Vz
! stat_XYZ(2,:) : Standard Deviation (sigma) for each of the orbital elements e.g. X,Y,Z,Vx,Vy,Vz
! stat_XYZ(3,:) : Mean value for each of the orbital elements e.g. X,Y,Z,Vx,Vy,Vz
! stat_XYZ(4,:) : MIN value for each of the orbital elements e.g. X,Y,Z,Vx,Vy,Vz
! stat_XYZ(5,:) : MAX value for each of the orbital elements e.g. X,Y,Z,Vx,Vy,Vz
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	11 October 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE m_statist
      USE mdl_config
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN), ALLOCATABLE, DIMENSION(:,:) :: ds1, ds2
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:,:), ALLOCATABLE :: dorb_XYZ, dorb_RTN, dorb_Kepler
      ! REAL (KIND = prec_d), INTENT(OUT), DIMENSION(:), ALLOCATABLE :: RMSdsr, MINdsr, MAXdsr
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(5,6) :: stat_XYZ, stat_RTN, stat_Kepler
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), ALLOCATABLE, DIMENSION(:,:) :: dsr
      REAL (KIND = prec_d), ALLOCATABLE, DIMENSION(:) :: dx
      REAL (KIND = prec_d), DIMENSION(6) :: RMSdsr, Sigmadsr, MEANdsr, MINdsr, MAXdsr
      REAL (KIND = prec_d) :: RMSdx, Sigmadx, MEANdx, MINdx, MAXdx
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: delta_t, dt_limit
      INTEGER (KIND = prec_int8) :: Nepochs, Nepochs2, Nelements, Nepochs_delta
      INTEGER (KIND = prec_int8) :: i, j, j1, k, looptest, l
      INTEGER (KIND = prec_int8) :: sz1, sz2, sz3, sz4
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------
      REAL (KIND = prec_d), DIMENSION(3) :: r1i, v1i, r2i, v2i
      REAL (KIND = prec_d), DIMENSION(3) :: dr, dv, dr_RTN, dv_RTN
      REAL (KIND = prec_d) :: Rrtn(3,3)
      REAL (KIND = prec_d) :: GM
      REAL (KIND = prec_d) :: kepler1(6), kepler2(6), kepler_9(9)
      CHARACTER (LEN=100) :: mesg
      logical   allzero

      integer iy, im, id, jflag, ih, imin
      double precision    fd, fsec
! ----------------------------------------------------------------------

! Set the numerical differences digits limit for the common epochs
dt_limit = 1.D-08

! Gravitational constant
GM = 0.39860044150D+15

sz1 = size(ds1, DIM = 1)
sz2 = size(ds1, DIM = 2)
Nepochs = sz1

sz3 = size(ds2, DIM = 1)
sz4 = size(ds2, DIM = 2)
Nepochs2 = sz3
!print*,'statorbit: sz1, sz2 = ',sz1, sz2
!print*,'statorbit: sz3, sz4 = ',sz3, sz4
! ----------------------------------------------------------------------
! Test columns dimension
If (sz2 .NE. sz4) Then
write(mesg, *) "Input matrices dimension(DIM=2) do not agree. DIM = 2 (", &
        sz2, ",", sz4, ")"
call report ('WARNING', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f03', 1)
End If
! ----------------------------------------------------------------------

!debug: print out the integrated orbit values
if (.false.) then
    do j = 1, Nepochs2
        print *, "mjd = ", ds2(j,1) !mjd
        call iau_JD2CAL (2400000.5d0, ds2(j,1), Iy, Im, Id, Fd, JFLAG)
        Fd = fd * 86400.0d0
        ih = fd / 3600.0d0
        fd = fd - ih * 3600.0d0
        imin = fd / 60.0d0
        fsec = fd - imin * 60.0d0
        print *, Iy, Im, Id, ih, imin, fsec
        print *, "ICRF: ", ds2(j,3), ds2(j,4), ds2(j,5)
        ! TODO: convert to ITRF?
    end do
end if

! ----------------------------------------------------------------------
! Find the number of the common epochs
Nepochs_delta = 0
i = 0
j = 0
Do i = 1 , Nepochs
   ! Test the time argument:
   Do j = 1 , Nepochs2
      delta_t = ABS(ds2(j,1) - ds1(i,1))
      IF (delta_t < dt_limit) then
         ! Counter of the common epochs
         Nepochs_delta = Nepochs_delta + 1
         exit
      End if
   End Do
End Do
! ----------------------------------------------------------------------
!print *,"Nepochs_delta", Nepochs_delta
!print *,"Nepochs", Nepochs
!print *,"delta_t", delta_t

! Dynamic allocatable array
! Allocate the array of the numerical orbit comparison
ALLOCATE (dsr(Nepochs_delta,sz2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write (mesg, *) "failed to allocate dsr, dimensions = (", &
                Nepochs_delta, ",", sz2, ")"
call report ('FATAL', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f95', 1)
end if
ALLOCATE (dorb_XYZ(Nepochs_delta,sz2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write (mesg, *) "failed to allocate dorb_XYZ, dimensions = (", &
                Nepochs_delta, ",", sz2, ")"
call report ('FATAL', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f95', 1)
end if
ALLOCATE (dorb_RTN(Nepochs_delta,sz2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write (mesg, *) "failed to allocate dorb_RTN, dimensions = (", &
                Nepochs_delta, ",", sz2, ")"
call report ('FATAL', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f95', 1)
end if
ALLOCATE (dorb_Kepler(Nepochs_delta,sz2), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write (mesg, *) "failed to allocate dorb_Kepler, dimensions = (", &
                Nepochs_delta, ",", sz2, ")"
call report ('FATAL', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f95', 1)
end if
!initialise
dsr = 0.d0
dorb_XYZ = 0.d0
dorb_RTN = 0.d0
dorb_kepler = 0.d0

! ----------------------------------------------------------------------
! Compute the numerical differences
i = 0
j = 0
k = 0
Do i = 1 , Nepochs
   ! Test the time argument:
   Do j = 1 , Nepochs2
      delta_t = ABS(ds2(j,1) - ds1(i,1))
      IF (delta_t < dt_limit) then
         k = k + 1
         if (.false.) then !debugging
         if (i==14 .and. j==74) then
             print *, "i = 14, j = 74, k = ", k
             print *, ds1(i, 3), ds1(i, 4), ds1(i, 5)
             print *, ds2(j, 3), ds2(j, 4), ds2(j, 5)
         end if
         end if !end debugging
	     ! State vector numerical differences at common epochs
		 dsr(k,1:2) = ds1(i,1:2)
         ! check ds1 and ds2 for allzeros - move on if so
         allzero = .true.
         do l = 3, sz2
             if (ds1(1, l) .ne. 0.0d0) then
                  allzero = .false.
             end if
         end do
         if (allzero) then
             k = k-1
             cycle
         end if
         allzero = .true.
         do l = 3, sz2
             if (ds2(j,l) .ne. 0.0d0) then
                     allzero = .false.
             endif
         end do
         if (allzero) then
             k = k-1
             cycle
         end if
         dsr(k,3:sz2) = ds2(j,3:sz2) - ds1(i,3:sz2)
IF(dsr(k,3)> 1.D+4.OR.dsr(k,4)> 1.D+4.OR.dsr(k,5)>1.D+4)THEN
PRINT*,'Something wrong with the numerical integration'
PRINT*,'Please adjust the integration step or maybe check your time system against the sp3 file being used'
print*,"Nepochs=",Nepochs, ", Nepochs2=", Nepochs2
print*, "previous values"
if (i > 1) then
        print*, ds1(i-1,3), ds1(i-1,4), ds1(i-1,5)
else
        print*, "no previous ds1 values"
endif
if (j > 1) then
        print*, ds2(j-1,3), ds2(j-1,4), ds2(j-1,5)
else
        print*, "no previous ds2 values"
end if
if (k>1) then
        print*, dsr(k-1,3), dsr(k-1,4), dsr(k-1,5)
else
        print*, "no previous difference values"
end if
PRINT*, "i=", i, ", j=", j, ", k=", k
print*, ds1(i,3), ds1(i,4), ds1(i,5)
print*, ds2(j,3), ds2(j,4), ds2(j,5)
print*, dsr(k,3), dsr(k,4), dsr(k,5)
print*, "next values"
if (i .ne. Nepochs) print*, ds1(i+1,3), ds1(i+1,4), ds1(i+1,5)
if (j .ne. Nepochs2) print*, ds2(j+1,3), ds2(j+1,4), ds2(j+1,5)
STOP
END IF
	     ! Orbital frame numerical differences at common epochs
		 r1i = ds1(i,3:5)
		 v1i = ds1(i,6:8)
		 dr = ds2(j,3:5) - ds1(i,3:5)
		 dv = ds2(j,6:8) - ds1(i,6:8)
		 CALL orb_frame(r1i, v1i, Rrtn)
		 CALL matrix_Rr(Rrtn, dr, dr_RTN)
		 CALL matrix_Rr(Rrtn, dv, dv_RTN)
		 dorb_RTN(k,1:2) = ds1(i,1:2)
         dorb_RTN(k,3:5) = dr_RTN
         dorb_RTN(k,6:8) = dv_RTN

	     ! Kepler elements numerical differences at common epochs
		 CALL kepler_z2k (r1i, v1i, GM, kepler_9)
		 kepler1(1:5) = kepler_9(1:5)
		 kepler1(6) = kepler_9(7)

		 r2i = ds2(j,3:5)
		 v2i = ds2(j,6:8)
		 CALL kepler_z2k (r2i, v2i, GM, kepler_9)
		 kepler2(1:5) = kepler_9(1:5)
		 kepler2(6) = kepler_9(7)

		 dorb_Kepler(k,1:2) = ds1(i,1:2)
         dorb_Kepler(k,3:8) = kepler2 - kepler1

	  End IF
   End Do
End Do
! ----------------------------------------------------------------------
!print *,"k", k

dorb_XYZ = dsr
sz1 = size(dsr, DIM = 1)

! ----------------------------------------------------------------------
! Statistics
! ----------------------------------------------------------------------

! Allocate arrays
ALLOCATE (dx(sz1), STAT = AllocateStatus)
if (AllocateStatus .ne. 0) then
        write (mesg, *) "failed to allocate dx, dimension = ", &
                Nepochs_delta
call report ('FATAL', pgrm_name, 'statorbit', mesg, 'src/fortran/m_statorbit.f95', 1)
end if
dx = 0.d0

! Inertial frame
dsr = dorb_XYZ
i = 0
j = 0
Do i = 3 , sz2
   dx(:) = dsr(:,i)
   Call statist(dx, RMSdx, Sigmadx, MEANdx, MINdx, MAXdx)
   j = j + 1
   RMSdsr(j) = RMSdx
   MINdsr(j) = MINdx
   MAXdsr(j) = MAXdx
   Sigmadsr(j) = Sigmadx
   MEANdsr(j) = MEANdx
End Do
stat_XYZ(1,:) = RMSdsr
stat_XYZ(2,:) = Sigmadsr
stat_XYZ(3,:) = MEANdsr
stat_XYZ(4,:) = MINdsr
stat_XYZ(5,:) = MAXdsr

! Orbital frame
dsr = dorb_RTN
i = 0
j = 0
Do i = 3 , sz2
   dx(:) = dsr(:,i)
   Call statist(dx, RMSdx, Sigmadx, MEANdx, MINdx, MAXdx)
   j = j + 1
   RMSdsr(j) = RMSdx
   MINdsr(j) = MINdx
   MAXdsr(j) = MAXdx
   Sigmadsr(j) = Sigmadx
   MEANdsr(j) = MEANdx
End Do
stat_RTN(1,:) = RMSdsr
stat_RTN(2,:) = Sigmadsr
stat_RTN(3,:) = MEANdsr
stat_RTN(4,:) = MINdsr
stat_RTN(5,:) = MAXdsr

! Kepler frame
dsr = dorb_Kepler
i = 0
j = 0
Do i = 3 , sz2
   dx(:) = dsr(:,i)
   Call statist(dx, RMSdx, Sigmadx, MEANdx, MINdx, MAXdx)
   j = j + 1
   RMSdsr(j) = RMSdx
   MINdsr(j) = MINdx
   MAXdsr(j) = MAXdx
   Sigmadsr(j) = Sigmadx
   MEANdsr(j) = MEANdx
End Do
stat_Kepler(1,:) = RMSdsr
stat_Kepler(2,:) = Sigmadsr
stat_Kepler(3,:) = MEANdsr
stat_Kepler(4,:) = MINdsr
stat_Kepler(5,:) = MAXdsr
! ----------------------------------------------------------------------

 100 END SUBROUTINE

End Module


program block_matrix
    implicit none
    integer :: matrix_size, block_size
    integer, dimension(:, :), allocatable :: data

    call get_parameters(matrix_size, block_size)
    data = create_block_matrix(matrix_size, block_size)
    call print_matrix(data)
    deallocate (data)

contains

    subroutine get_parameters(matrix_size, block_size)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, intent(out) :: matrix_size, block_size
        character(len=1024) :: buffer, msg
        integer :: status

        if (command_argument_count() == 2) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) matrix_size
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
            end if
            call get_command_argument(2, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) block_size
            if (status /= 0) then
                write (unit=error_unit, fmt='(2A)') 'error: ', msg
            end if
        else
            matrix_size = 9
            block_size = 3
        end if
    end subroutine get_parameters

    function create_block_matrix(matrix_size, block_size) result(B)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, value :: matrix_size, block_size
        integer, dimension(:, :), allocatable :: B
        integer :: i, j, k, status

        allocate (B(matrix_size, matrix_size), stat=status)
        if (status /= 0) then
            write (unit=error_unit, fmt='(2A)') &
                'error: can not allocate matrix'
            stop 2
        end if
        B = 0
        forall (i = 1:size(B, 1):block_size, &
                j = 0:block_size - 1, &
                k = 0:block_size - 1, &
                i + j <= size(B, 1) .and. i + k <= size(B, 2))
            B(i + j, i + k) = 1
        end forall
    end function create_block_matrix

    subroutine print_matrix(A)
        implicit none
        integer, dimension(:, :), intent(in) :: A
        integer :: i

        do i = 1, size(A, 1)
            print '(*(I3))', A(i, :)
        end do
    end subroutine print_matrix

end program block_matrix


************************************************************************
* Constant <-> nonconforming interpolation
*
* This converts between constant and nonconforming piecewise linear
* FE pressure functions.
* IPAR=0 : convert piecewise constant DPC to piecewise linear DPL
* IPAR=1 : convert piecewise linear DPL to piecewise constant DPC
*
* DPC    : array [1..NEL] of double
* DPL    : array [1..NMT] of double
************************************************************************

      SUBROUTINE C2N2DM (DPC,DPL,KMID,KADJ,NEL,NMT,NVT,IPAR)

      IMPLICIT NONE

      INCLUDE 'cbasictria.inc'

C parameters

      DOUBLE PRECISION DPC(*),DPL(*)
      INTEGER KMID(NNVE,*),KADJ(NNVE,*)
      INTEGER NEL,NMT,NVT,IPAR

C local variables

      DOUBLE PRECISION DPH
      INTEGER IEL, IVE, IADJ, IMID

C-----------------------------------------------------------------------
C
C *** constant to nonconforming = 0
      IF (IPAR.EQ.0) THEN
C
       DO 10 IEL=1,NEL
       DPH  =DPC(IEL)
C
       DO 20 IVE=1,4
       IADJ=KADJ(IVE,IEL)
       IMID=KMID(IVE,IEL)-NVT
C
       IF (IADJ.EQ.0)   DPL(IMID)=DPH
       IF (IADJ.GT.IEL) DPL(IMID)=0.5D0*(DPH+DPC(IADJ))
C
20     CONTINUE
10     CONTINUE
C
      ELSE
C
       DO 110 IEL=1,NEL
       DPC(IEL)=0.25D0*( DPL(KMID(1,IEL)-NVT)+DPL(KMID(2,IEL)-NVT)
     *                  +DPL(KMID(3,IEL)-NVT)+DPL(KMID(4,IEL)-NVT))
110    CONTINUE
C
      ENDIF

      END