      SUBROUTINE ZSQRTX(CIN,COUT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 2001-01-24 ZSQRTX Krogh  ZSQRT -> ZSQRTX to avoid C lib. conflicts.
C>> 1995-10-30 ZSQRT  Krogh  Fixed so M77CON can get S.P. for C conv.
C>> 1987-12-07 ZSQRT  Lawson Initial code.
c--Z replaces "?": ?SQRTX
C
C     Reference: Uspensky, "Theory of Equations", McGraw-Hill,
C     1948, Page 14-15.
C     Computes one of the square roots of the double precision
C     complex number whose real part is given in CIN(1) and
C     imaginary part is given in CIN(2). Result is given
C     similarly in COUT(1) and COUT(2).
C
C     C.L.Lawson & S.Y.Chan, JPL, June 3,1986.
C
C     ------------------------------------------------------------------
C
      DOUBLE PRECISION CIN(2), COUT(2)
      DOUBLE PRECISION A, A1, B, B1, R, X, Y
      DOUBLE PRECISION ZERO, HALF, ONE
C
      PARAMETER(ZERO= 0.0D0, HALF = 0.5D0, ONE = 1.0D0)
C
      A = CIN(1)
      B = CIN(2)
      IF (B .EQ. ZERO) THEN
        IF (A .EQ. ZERO) THEN
          COUT(1) = ZERO
          COUT(2) = ZERO
        ELSE IF (A .GT. ZERO) THEN
          COUT(1) = SQRT(A)
          COUT(2) = ZERO
        ELSE
          COUT(1) = ZERO
          COUT(2) = SQRT(-A)
        END IF
      ELSE
C                                          Here B .ne. 0
        IF (A .EQ. ZERO) THEN
          COUT(1) = SQRT(HALF*ABS(B))
          COUT(2) = COUT(1)
        ELSE
          A1 = ABS(A)
          B1 = ABS(B)
          IF (B1 .GT. A1) THEN
            R = B1 * SQRT(ONE + (A1/B1)**2)
          ELSE
            R = A1 * SQRT(ONE + (B1/A1)**2)
          END IF
          X = SQRT(HALF*(R+A1))
          Y = HALF * B1 / X
          IF (A .GT. ZERO) THEN
            COUT(1) = X
            COUT(2) = Y
          ELSE
            COUT(1) = Y
            COUT(2) = X
          END IF
        END IF
        IF (B .LT. ZERO) COUT(2) = -COUT(2)
      END IF
C
      RETURN
      END


! Calculate the n^th Fibonacci number.
recursive integer function fib(n) result(answer)

  integer :: n

  if (n < 2) then
    answer = n
  else
    answer = fib(n - 1) + fib(n - 2)
  end if

  return

end function fib

program calcfib

  integer :: fib

  integer :: r
  r = fib(20)
  print*,r

end program calcfib


program svd
    use utils_mod, only : get_file_name, get_dataset_name
    use matrix_mod, only : read_matrix, print_matrix
    use, intrinsic :: iso_fortran_env, only : dp => REAL64, &
                                              i8 => INT64, &
                                              error_unit
    implicit none
    logical, parameter :: verbose = .false.
    real(kind=dp), allocatable, dimension(:, :) :: A, U, VT, Sigma, &
                                                   orig_A, tmp
    real(kind=dp), allocatable, dimension(:) :: S, work
    character(len=1024) :: file_name, dataset_name
    integer :: nr_rows, nr_cols, lda, ldu, error, lwork, info
    real, parameter :: time_rate = 1.0E-6
    integer(kind=i8) :: start_time, end_time

    call get_file_name(file_name)
    call get_dataset_name(dataset_name)
    call system_clock(start_time)
    call read_matrix(file_name, dataset_name, A)
    call system_clock(end_time)
    write (unit=error_unit, fmt="(A, F15.6, A)") &
        "HDF5 read: ", time_rate*(end_time - start_time), " s"
    nr_rows = size(A, 1)
    nr_cols = size(A, 2)

    ! copy A, since it will be destroyed by dgesvd
    allocate(orig_A(nr_rows, nr_cols), stat=error)
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate orig_A"
        stop
    end if
    orig_A = A

    ! allocate matricess
    allocate(U(nr_rows, nr_rows), stat=error)
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate U"
        stop
    end if
    allocate(S(min(nr_rows, nr_cols)), stat=error)
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate S"
        stop
    end if
    allocate(VT(nr_cols, nr_cols), stat=error)
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate VT"
        stop
    end if

    ! compute full SVD of A
    call system_clock(start_time)
    allocate(work(1))
    info = 0
    call dgesvd('A', 'A', nr_rows, nr_cols, A, nr_rows, S, &
                U, nr_rows, VT, nr_cols, work, -1, info)
    lwork = work(1)
    write (unit=error_unit, fmt="(A, I0, A)") &
        "work size is ", lwork, " double"
    deallocate(work)
    allocate(work(lwork))
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate work"
        stop
    end if
    call dgesvd('A', 'A', nr_rows, nr_cols, A, nr_rows, S, &
                U, nr_rows, VT, nr_cols, work, lwork, info)
    call system_clock(end_time)
    write (unit=error_unit, fmt="(A, F15.6, A)") &
        "dgesvd: ", time_rate*(end_time - start_time), " s"
    deallocate(work)

    call system_clock(start_time)
    ! compute Sigma, which is nicer than S, and which is needed to
    ! reconstruct the matrix
    call compute_sigma(S, nr_rows, nr_cols, sigma)

    ! print results if verbose
    if (verbose) then
        print "(A)", "U"
        call print_matrix(U)
        print "(A)", "Sigma"
        call print_matrix(Sigma)
        print "(A)", "V^t"
        call print_matrix(VT)
    end if

    ! perform check
    ! compute tmp = U*Sigma
    allocate(tmp(nr_rows, nr_cols), stat=error)
    if (error /= 0) then
        write (unit=error_unit, fmt="(A)") "can not allocate work"
        stop
    end if
    call dgemm('N', 'N', nr_rows, nr_cols, nr_rows, 1.0_dp, U, nr_rows, &
               Sigma, nr_rows, 0.0_dp, tmp, nr_rows)
    call dgemm('N', 'N', nr_rows, nr_cols, nr_cols, 1.0_dp, tmp, nr_rows, &
               VT, nr_cols, 0.0_dp, A, nr_rows)
    call system_clock(end_time)
    write (unit=error_unit, fmt="(A, F15.6, A)") &
        "dgemm 1 & 2: ", time_rate*(end_time - start_time), " s"

    ! print reconstructted and original matrix if verbose
    if (verbose) then
        print "(A)", "A"
        call print_matrix(A)
        print "(A)", "orig. A"
        call print_matrix(orig_A)
    end if

    ! compute and print relative error
    print "(A, E10.3)", 'relative error = ', compute_error(orig_A, A)

contains

    subroutine compute_sigma(S, nr_rows, nr_cols, Sigma)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        real(kind=dp), dimension(:), intent(in) :: S
        integer, intent(in) :: nr_rows, nr_cols
        integer :: i, error
        real(kind=dp), allocatable, dimension(:, :), intent(out) :: Sigma
        allocate(Sigma(nr_rows, nr_cols), stat=error)
        Sigma = 0.0_dp
        do i = 1, min(nr_rows, nr_cols)
            Sigma(i, i) = S(i)
        end do
    end subroutine compute_sigma

    function compute_error(orig_A, A) result(rel_err)
        use, intrinsic :: iso_fortran_env, only : dp => REAL64
        implicit none
        real(kind=dp), dimension(:, :), intent(in) :: orig_A, A
        real(kind=dp) :: rel_err
        integer :: i, j
        real(kind=dp) :: norm
        rel_err = 0.0_dp
        do j = 1, size(A, 2)
            do i = 1, size(A, 1)
                norm = abs(orig_A(i, j))
                rel_err = rel_err + abs(A(i, j) - orig_A(i, j))/norm
            end do
        end do
        rel_err = rel_err/(size(A, 1)*size(A, 2))
    end function compute_error

end program svd


module representative_value_mod
    use,intrinsic :: iso_fortran_env
    implicit none
    integer(int32),parameter:: prec=real64
contains
    function mean(arr, v, sd, se) result(m)
        ! solve:: mean of arr
        ! input:: arr
        ! output:: m, (v, sd, se) <- optional
        real(prec),intent(in):: arr(:)
        real(prec),optional,intent(out):: v, sd, se
        real(prec):: m, len_arr, cv, csd

        len_arr = dble(size(arr))
        m = sum(arr)/len_arr
        cv = sum((arr-m)*(arr-m))/len_arr
        csd = sqrt(cv)
        if (present(v)) v = cv
        if (present(sd)) sd = csd
        if (present(se)) se = sd/sqrt(len_arr)
    end function
end module


module geom_utils
  use geom_types
  implicit none

  real(dp), parameter :: pi = atan(1._dp) * 4._dp
contains
  elemental integer function next_axis(axis) result(next)
    integer, intent(in) :: axis

    ! This maps 3->1, 1->2 and 2->3
    next = mod(axis, 3) + 1
  end function next_axis

  subroutine write_padding(depth, msg)
    integer, intent(in) :: depth
    character(len=*), intent(in) :: msg

    integer :: i
    do i = 1, depth
       write(*, '(1x, "|", 3x)', advance='no')
    end do
    write(*, *) msg
  end subroutine write_padding

  function vector_product(u, v) result(w)
    real(dp), intent(in), dimension(3) :: u, v
    real(dp), dimension(3) :: w

    w = [&
         u(2)*v(3) - u(3)*v(2), &
         u(3)*v(1) - u(1)*v(3), &
         u(1)*v(2) - u(2)*v(1)  &
         ]
  end function vector_product

  subroutine basis_from_axis(u, v, w)
    ! Generate an orthogonal base from a single axis.
    !
    ! Note: this basis is of course arbitrary
    real(dp), intent(in), dimension(3)  :: u
    real(dp), intent(out), dimension(3) :: v, w

    v = [-u(2) - u(3), u(1) - u(3), u(1) + u(2)]
    v = v / norm2(v)
    w = vector_product(u, v)
    w = w / norm2(w)
  end subroutine basis_from_axis

end module geom_utils


PROGRAM mpsi

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:12

!       ==================================================
!       Purpose: This program computes the psi function
!                using subroutine PSI
!       Input :  x  --- Argument of psi(x)
!       Output:  PS --- psi(x)
!       Examples:
!                   x          Psi(x)
!                ------------------------
!                  .25      -4.227453533
!                  .50      -1.963510026
!                  .75      -1.085860880
!                 1.00       -.577215665
!                 1.25       -.227453533
!                 1.50        .036489974
!                 1.75        .247472454
!                 2.00        .422784335
!       ==================================================

DOUBLE PRECISION :: x,ps
WRITE(*,*)'Please enter x'
!        READ(*,*)X
x=2.0
WRITE(*,*)'    x          Psi(x)'
WRITE(*,*)' ------------------------'
CALL psi(x,ps)
WRITE(*,10)x,ps
10      FORMAT(1X,f6.2,f18.9)
END PROGRAM mpsi

SUBROUTINE psi(x,ps)

!       ======================================
!       Purpose: Compute the psi function
!       Input :  x  --- Argument of psi(x)
!       Output:  PS --- psi(x)
!       ======================================

DOUBLE PRECISION, INTENT(IN)             :: x
DOUBLE PRECISION, INTENT(OUT)            :: ps
IMPLICIT DOUBLE PRECISION (a-h,o-z)
xa=DABS(x)
pi=3.141592653589793D0
el=.5772156649015329D0
s=0.0D0
IF (x == INT(x).AND.x <= 0.0) THEN
  ps=1.0D+300
  RETURN
ELSE IF (xa == INT(xa)) THEN
  n=xa
  DO  k=1 ,n-1
    s=s+1.0D0/k
  END DO
  ps=-el+s
ELSE IF (xa+.5 == INT(xa+.5)) THEN
  n=xa-.5
  DO  k=1,n
    s=s+1.0/(2.0D0*k-1.0D0)
  END DO
  ps=-el+2.0D0*s-1.386294361119891D0
ELSE
  IF (xa < 10.0) THEN
    n=10-INT(xa)
    DO  k=0,n-1
      s=s+1.0D0/(xa+k)
    END DO
    xa=xa+n
  END IF
  x2=1.0D0/(xa*xa)
  a1=-.8333333333333D-01
  a2=.83333333333333333D-02
  a3=-.39682539682539683D-02
  a4=.41666666666666667D-02
  a5=-.75757575757575758D-02
  a6=.21092796092796093D-01
  a7=-.83333333333333333D-01
  a8=.4432598039215686D0
  ps=DLOG(xa)-.5D0/xa+x2*(((((((a8*x2+a7)*x2+  &
      a6)*x2+a5)*x2+a4)*x2+a3)*x2+a2)*x2+a1)
  ps=ps-s
END IF
IF (x < 0.0) ps=ps-pi*DCOS(pi*x)/DSIN(pi*x)-1.0D0/x
RETURN
END SUBROUTINE psi


   PROGRAM GALAHAD_TRS_EXAMPLE  !  GALAHAD 2.2 - 05/06/2008 AT 13:30 GMT.
   USE GALAHAD_TRS_DOUBLE                          ! double precision version
   IMPLICIT NONE
   INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )       ! set precision
   REAL ( KIND = wp ), PARAMETER :: one = 1.0_wp
   INTEGER, PARAMETER :: n = 3, h_ne = 4           ! problem dimensions
   INTEGER :: s
   REAL ( KIND = wp ), DIMENSION( n ) :: C, X
   TYPE ( SMT_type ) :: H
   TYPE ( TRS_data_type ) :: data
   TYPE ( TRS_control_type ) :: control
   TYPE ( TRS_inform_type ) :: inform
   REAL ( KIND = wp ) :: f = one                ! constant term, f
   REAL ( KIND = wp ) :: radius = one           ! trust-region radius
   C = (/ 0.0_wp, 2.0_wp, 0.0_wp /)             ! linear term, c
!  C = (/ 0.0_wp, 2.0_wp, 0.0001_wp /)             ! linear term, c
!  C = (/ 5.0_wp, 0.0_wp, 4.0_wp /)             ! linear term, c
   CALL SMT_put( H%type, 'COORDINATE', s )      ! Specify co-ordinate
   ALLOCATE( H%val( h_ne ), H%row( h_ne ), H%col( h_ne ) )
   H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 4.0_wp /) ! Hessian, H
!  H%val = (/ 1.0_wp, 2.0_wp, 3.0_wp, 1.0_wp /) ! Hessian, H
   H%row = (/ 1, 2, 3, 3 /)                     ! NB lower triangle
   H%col = (/ 1, 2, 3, 1 /) ; H%ne = h_ne
   CALL TRS_initialize( data, control )         ! Initialize control parameters
!  control%print_level = 1
!  control%initial_multiplier = 4.0_wp
   CALL TRS_solve( n, radius, f, C, H, X, data, control, inform ) ! solve problem
   IF ( inform%status == 0 ) THEN !  Successful return
     WRITE( 6, "( 1X, I0, ' factorizations. Solution and Lagrange multiplier =',&
    &    2ES12.4 )" ) inform%factorizations, inform%obj, inform%multiplier
   ELSE  !  Error returns
     WRITE( 6, "( ' TRS_solve exit status = ', I0 ) " ) inform%status
   END IF
   CALL TRS_terminate( data, control, inform )  ! delete internal workspace
   END PROGRAM GALAHAD_TRS_EXAMPLE


C ** Version modified for SPEC Benchmark suite - see Comments below
C ***
      PROGRAM SHALOW
C     BENCHMARK WEATHER PREDICTION PROGRAM FOR COMPARING THE
C     PREFORMANCE OF CURRENT SUPERCOMPUTERS. THE MODEL IS
C     BASED OF THE PAPER - THE DYNAMICS OF FINITE-DIFFERENCE
C     MODELS OF THE SHALLOW-WATER EQUATIONS, BY ROBERT SADOURNY
C     J. ATM. SCIENCES, VOL 32, NO 4, APRIL 1975.
C
C     CODE BY PAUL N. SWARZTRAUBER, NATIONAL CENTER FOR
C     ATMOSPHERIC RESEARCH, BOULDER, CO,  OCTOBER 1984.
C
C     MODIFIED BY R. K. SATO, NCAR, APRIL 7, 1986 FOR MULTITASKING.
C     MODIFIED FOR SPEC to run longer: ITMAX inCremented from 120 to
C                                      1200 - J.Lo 7/19/90
C     Modified by Bodo Parady for the SPECpar suite.  Various
C     compilation sizes added.  Iterations reduced to orginal
C     problem, but size increased 4x in each dimension.
C
C     Further modified by Reinhold Weicker (Siemens Nixdorf) for the
C     SPEC CFP95 suite:
C     Changed back to the form with PARAMETER statements for
C     N1 and N2, set N1 = N2 = 513.
C     The execution time is determined by these values and the
C     variable ITMAX (number of iterations) read from the input file.
C     Execution time is linear in ITMAX.

      IMPLICIT INTEGER	(I-N)
      IMPLICIT REAL	(A-H, O-Z)

      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     *        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     *        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF

C

      WRITE(6,*) 'SPEC benchmark 102.swim'

      WRITE(6,*) ' '

C       REQUEST PROCESSORS FOR MICROTASKING
C SPEC removed CMIC$ GETCPUS 4
C
C
C       INITIALIZE CONSTANTS AND ARRAYS
C
      CALL INITAL
C
C     PRINT INITIAL VALUES
C
      WRITE(6,390) N,M,DX,DY,DT,ALPHA,ITMAX
  390 FORMAT(' NUMBER OF POINTS IN THE X DIRECTION', I8/
     1       ' NUMBER OF POINTS IN THE Y DIRECTION', I8/
     2       ' GRID SPACING IN THE X DIRECTION    ', F8.0/
     3       ' GRID SPACING IN THE Y DIRECTION    ', F8.0/
     4       ' TIME STEP                          ', F8.0/
     5       ' TIME FILTER PARAMETER              ', F8.3/
     6       ' NUMBER OF ITERATIONS               ', I8)
      MNMIN = MIN0(M,N)
C initial data writes removed for SPEC
C      WRITE(6,391) (POLD(I,I),I=1,MNMIN)
C  391 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF P ', //(8E15.7))
C      WRITE(6,392) (UOLD(I,I),I=1,MNMIN)
C  392 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF U ', //(8E15.7))
C      WRITE(6,393) (VOLD(I,I),I=1,MNMIN)
C  393 FORMAT(/' INITIAL DIAGONAL ELEMENTS OF V ', //(8E15.7))
C        DETERMINE OVERHEAD OF TIMING CALLS

C  6/22/95 for SPEC: JWR: Initialization of TIME

      TIME = 0
      NCYCLE = 0
   90 NCYCLE = NCYCLE + 1
C
C     COMPUTE CAPITAL  U, CAPITAL V, Z AND H
C
      CALL CALC1
C
C     COMPUTE NEW VALUES U,V AND P
C
      CALL CALC2
C
      TIME = TIME + DT
      IF(MOD(NCYCLE,MPRINT) .NE. 0) GO TO 370
      PTIME = TIME/3600.
C
C *** modified for SPEC results verification
C *** We want to ensure that all calculations were done
C *** so we "use" all of the computed results.
C ***
C *** Since all of the comparisons of the individual diagnal terms
C *** often differ in the smaller values, the check we have selected
C *** is to add the absolute values of all terms and print these results
C
      WRITE(6,350) NCYCLE,PTIME
  350 FORMAT(/' CYCLE NUMBER',I5,' MODEL TIME IN  HOURS', F6.2)
C      WRITE(6,355) (PNEW(I,I),I=1,MNMIN)
C  355 FORMAT(/' DIAGONAL ELEMENTS OF P ', //(8E15.7))
C      WRITE(6,360) (UNEW(I,I),I=1,MNMIN)
C  360 FORMAT(/' DIAGONAL ELEMENTS OF U ', //(8E15.7))
C      WRITE(6,365) (VNEW(I,I),I=1,MNMIN)
C  365 FORMAT(/' DIAGONAL ELEMENTS OF V ', //(8E15.7))
C ***
        PCHECK = 0.0
        UCHECK = 0.0
        VCHECK = 0.0

        DO 3500 ICHECK = 1, MNMIN
         DO 3500 JCHECK = 1, MNMIN
         PCHECK = PCHECK + ABS(PNEW(ICHECK,JCHECK))
         UCHECK = UCHECK + ABS(UNEW(ICHECK,JCHECK))
         VCHECK = VCHECK + ABS(VNEW(ICHECK,JCHECK))
 3500   CONTINUE
C ***
C ***
        WRITE(6,366) PCHECK, UCHECK, VCHECK
 366    FORMAT(/,
     *         ' Pcheck = ',E12.4,/,
     *         ' Ucheck = ',E12.4,/,
     *         ' Vcheck = ',E12.4,/)

370   CONTINUE
C        TEST FOR END OF RUN
      IF(NCYCLE .GE. ITMAX) THEN
      STOP
      ENDIF
C
C     TIME SMOOTHING AND UPDATE FOR NEXT CYCLE
C

      IF(NCYCLE .LE. 1) THEN
         CALL CALC3Z
      ELSE
         CALL CALC3
      ENDIF
C
      GO TO 90
      END
      SUBROUTINE INITAL
C        INITIALIZE CONSTANTS AND ARRAYS
C           R. K. SATO 4/7/86
C
      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
C
C     NOTE BELOW THAT TWO DELTA T (TDT) IS SET TO DT ON THE FIRST
C     CYCLE AFTER WHICH IT IS RESET TO DT+DT.
C
C The following code  was in SWM256, however, it was replaced by
C		READ statements to avoid calculations to be done during
C		compile time.
C
C      DT = 20.
C
C      DX = .25E5
C      DY = .25E5
C      A = 1.E6
C      ALPHA = .001
C      ITMAX = 1200
C      MPRINT = 1200
C      M = N1 - 1
C      N = N2 - 1
      READ (5,*) DT
      READ (5,*) DX
      READ (5,*) DY
      READ (5,*) A
      READ (5,*) ALPHA
      READ (5,*) ITMAX
      READ (5,*) MPRINT
      READ (5,*) M
      READ (5,*) N
      TDT = DT
      MP1 = M+1
      NP1 = N+1
      EL = FLOAT(N)*DX
      PI = 4.*ATAN(1.)
      TPI = PI+PI
      DI = TPI/FLOAT(M)
      DJ = TPI/FLOAT(N)
      PCF = PI*PI*A*A/(EL*EL)
C
C     INITIAL VALUES OF THE STREAM FUNCTION AND P
C
      DO 50 J=1,NP1
      DO 50 I=1,MP1
      PSI(I,J) = A*SIN((FLOAT(I)-.5)*DI)*SIN((FLOAT(J)-.5)*DJ)
      P(I,J) = PCF*(COS(2.*FLOAT(I-1)*DI)
     1                +COS(2.*FLOAT(J-1)*DJ))+50000.
   50 CONTINUE
C
C     INITIALIZE VELOCITIES
C
      DO 60 J=1,N
      DO 60 I=1,M
      U(I+1,J) = -(PSI(I+1,J+1)-PSI(I+1,J))/DY
      V(I,J+1) = (PSI(I+1,J+1)-PSI(I,J+1))/DX
   60 CONTINUE
C
C     PERIODIC CONTINUATION
C
      DO 70 J=1,N
      U(1,J) = U(M+1,J)
      V(M+1,J+1) = V(1,J+1)
   70 CONTINUE
      DO 75 I=1,M
      U(I+1,N+1) = U(I+1,1)
      V(I,1) = V(I,N+1)
   75 CONTINUE
      U(1,N+1) = U(M+1,1)
      V(M+1,1) = V(1,N+1)
      DO 86 J=1,NP1
      DO 86 I=1,MP1
      UOLD(I,J) = U(I,J)
      VOLD(I,J) = V(I,J)
      POLD(I,J) = P(I,J)
   86 CONTINUE
C        END OF INITIALIZATION
      RETURN
      END
C SPEC removed CCMIC$ MICRO
      SUBROUTINE CALC1
C
C        COMPUTE CAPITAL  U, CAPITAL V, Z AND H
C
      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
C
      FSDX = 4./DX
      FSDY = 4./DY

C SPEC removed CCMIC$ DO GLOBAL
      DO 100 J=1,N
      DO 100 I=1,M
      CU(I+1,J) = .5*(P(I+1,J)+P(I,J))*U(I+1,J)
      CV(I,J+1) = .5*(P(I,J+1)+P(I,J))*V(I,J+1)
      Z(I+1,J+1) = (FSDX*(V(I+1,J+1)-V(I,J+1))-FSDY*(U(I+1,J+1)
     1          -U(I+1,J)))/(P(I,J)+P(I+1,J)+P(I+1,J+1)+P(I,J+1))
      H(I,J) = P(I,J)+.25*(U(I+1,J)*U(I+1,J)+U(I,J)*U(I,J)
     1               +V(I,J+1)*V(I,J+1)+V(I,J)*V(I,J))
  100 CONTINUE

C
C     PERIODIC CONTINUATION
C
      DO 110 J=1,N
      CU(1,J) = CU(M+1,J)
      CV(M+1,J+1) = CV(1,J+1)
      Z(1,J+1) = Z(M+1,J+1)
      H(M+1,J) = H(1,J)
  110 CONTINUE
      DO 115 I=1,M
      CU(I+1,N+1) = CU(I+1,1)
      CV(I,1) = CV(I,N+1)
      Z(I+1,1) = Z(I+1,N+1)
      H(I,N+1) = H(I,1)
  115 CONTINUE
      CU(1,N+1) = CU(M+1,1)
      CV(M+1,1) = CV(1,N+1)
      Z(1,1) = Z(M+1,N+1)
      H(M+1,N+1) = H(1,1)
C        END OF LOOP 100 CALCULATIONS
      RETURN
      END
C SPEC removed CCMIC$ MICRO
      SUBROUTINE CALC2
C
C        COMPUTE NEW VALUES OF U,V,P
C
      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
      TDTS8 = TDT/8.
      TDTSDX = TDT/DX
      TDTSDY = TDT/DY

C SPEC removed CCMIC$ DO GLOBAL
      DO 200 J=1,N
      DO 200 I=1,M
      UNEW(I+1,J) = UOLD(I+1,J)+
     1    TDTS8*(Z(I+1,J+1)+Z(I+1,J))*(CV(I+1,J+1)+CV(I,J+1)+CV(I,J)
     2       +CV(I+1,J))-TDTSDX*(H(I+1,J)-H(I,J))
      VNEW(I,J+1) = VOLD(I,J+1)-TDTS8*(Z(I+1,J+1)+Z(I,J+1))
     1       *(CU(I+1,J+1)+CU(I,J+1)+CU(I,J)+CU(I+1,J))
     2       -TDTSDY*(H(I,J+1)-H(I,J))
      PNEW(I,J) = POLD(I,J)-TDTSDX*(CU(I+1,J)-CU(I,J))
     1       -TDTSDY*(CV(I,J+1)-CV(I,J))
  200 CONTINUE

C
C     PERIODIC CONTINUATION
C
      DO 210 J=1,N
      UNEW(1,J) = UNEW(M+1,J)
      VNEW(M+1,J+1) = VNEW(1,J+1)
      PNEW(M+1,J) = PNEW(1,J)
  210 CONTINUE
      DO 215 I=1,M
      UNEW(I+1,N+1) = UNEW(I+1,1)
      VNEW(I,1) = VNEW(I,N+1)
      PNEW(I,N+1) = PNEW(I,1)
  215 CONTINUE
      UNEW(1,N+1) = UNEW(M+1,1)
      VNEW(M+1,1) = VNEW(1,N+1)
      PNEW(M+1,N+1) = PNEW(1,1)
C
      RETURN
      END
      SUBROUTINE CALC3Z
C
C         TIME SMOOTHER FOR FIRST ITERATION
C
      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
C
      TDT = TDT+TDT
      DO 400 J=1,NP1
      DO 400 I=1,MP1
      UOLD(I,J) = U(I,J)
      VOLD(I,J) = V(I,J)
      POLD(I,J) = P(I,J)
      U(I,J) = UNEW(I,J)
      V(I,J) = VNEW(I,J)
      P(I,J) = PNEW(I,J)
  400 CONTINUE
      RETURN
      END
C SPEC removed CCMIC$ MICRO
      SUBROUTINE CALC3
C
C         TIME SMOOTHER
C
      PARAMETER (N1=513, N2=513)

      COMMON  U(N1,N2), V(N1,N2), P(N1,N2),
     *        UNEW(N1,N2), VNEW(N1,N2),
     1        PNEW(N1,N2), UOLD(N1,N2),
     *        VOLD(N1,N2), POLD(N1,N2),
     2        CU(N1,N2), CV(N1,N2),
     *        Z(N1,N2), H(N1,N2), PSI(N1,N2)
C
      COMMON /CONS/ DT,TDT,DX,DY,A,ALPHA,ITMAX,MPRINT,M,N,MP1,
     1              NP1,EL,PI,TPI,DI,DJ,PCF
C
C        TIME SMOOTHING AND UPDATE FOR NEXT CYCLE
C

C SPEC removed CCMIC$ DO GLOBAL
      DO 300 J=1,N
      DO 300 I=1,M
      UOLD(I,J) = U(I,J)+ALPHA*(UNEW(I,J)-2.*U(I,J)+UOLD(I,J))
      VOLD(I,J) = V(I,J)+ALPHA*(VNEW(I,J)-2.*V(I,J)+VOLD(I,J))
      POLD(I,J) = P(I,J)+ALPHA*(PNEW(I,J)-2.*P(I,J)+POLD(I,J))
      U(I,J) = UNEW(I,J)
      V(I,J) = VNEW(I,J)
      P(I,J) = PNEW(I,J)
  300 CONTINUE

C
C     PERIODIC CONTINUATION
C
      DO 320 J=1,N
      UOLD(M+1,J) = UOLD(1,J)
      VOLD(M+1,J) = VOLD(1,J)
      POLD(M+1,J) = POLD(1,J)
      U(M+1,J) = U(1,J)
      V(M+1,J) = V(1,J)
      P(M+1,J) = P(1,J)
  320 CONTINUE
      DO 325 I=1,M
      UOLD(I,N+1) = UOLD(I,1)
      VOLD(I,N+1) = VOLD(I,1)
      POLD(I,N+1) = POLD(I,1)
      U(I,N+1) = U(I,1)
      V(I,N+1) = V(I,1)
      P(I,N+1) = P(I,1)
  325 CONTINUE
      UOLD(M+1,N+1) = UOLD(1,1)
      VOLD(M+1,N+1) = VOLD(1,1)
      POLD(M+1,N+1) = POLD(1,1)
      U(M+1,N+1) = U(1,1)
      V(M+1,N+1) = V(1,1)
      P(M+1,N+1) = P(1,1)
C
      RETURN
      END


!! This module contains optimization subroutine and parametric model
module mod_optimize
  !! This module contains optimization subroutine and parametric model
  use mod_constants
  use mod_array

  implicit none

  private

  public :: gaussian, myfunc_spec, myresidual, mygrad_spec, f_g_cube_fast

contains

  pure function gaussian(x, a, m, s)
    !! Gaussian function
    implicit none

    integer, intent(in) :: x
    real(xp), intent(in) :: a, m, s
    real(xp) :: gaussian

    gaussian = a * exp(-( (real(x,xp) - m)**2 ) / (2._xp * s**2) );
  end function gaussian

  ! Compute the residual between model and data
  subroutine myresidual(params, line, residual, n_gauss, dim_v)
    implicit none

    integer, intent(in) :: dim_v, n_gauss
    real(xp), intent(in), dimension(dim_v) :: line
    real(xp), intent(in), dimension(3*n_gauss) :: params
    real(xp), intent(inout), dimension(:), allocatable :: residual

    integer :: i, k
    real(xp) :: g
    real(xp), dimension(dim_v) :: model

    g = 0._xp
    model = 0._xp

    do i=1, n_gauss
       do k=1, dim_v
          g = gaussian(k, params(1+(3*(i-1))), params(2+(3*(i-1))), params(3+(3*(i-1))))
          model(k) = model(k) + g
       enddo
    enddo

    residual = model - line
  end subroutine myresidual

  ! Objective function to minimize for a spectrum
  pure function  myfunc_spec(residual)
    implicit none

    real(xp), intent(in), dimension(:), allocatable :: residual
    real(xp) :: myfunc_spec

    myfunc_spec = 0._xp

    myfunc_spec = 0.5_xp * sum(residual**2._xp)
  end function  myfunc_spec

  ! Griadient of the objective function to minimize for a spectrum
  subroutine mygrad_spec(n_gauss, gradient, residual, params, dim_v)
    implicit none

    integer, intent(in) :: n_gauss, dim_v
    real(xp), intent(in), dimension(3*n_gauss) :: params
    real(xp), intent(in), dimension(:), allocatable :: residual
    real(xp), intent(inout), dimension(3*n_gauss) :: gradient

    integer :: i, k
    real(xp) :: g

    real(xp), dimension(:,:), allocatable :: dF_over_dB

    allocate(dF_over_dB(3*n_gauss, dim_v))

    g = 0._xp
    dF_over_dB = 0._xp
    gradient = 0._xp

    do i=1, n_gauss
       do k=1, dim_v
          dF_over_dB(1+(3*(i-1)),k) = dF_over_dB(1+(3*(i-1)),k) +&
               exp( ( -(real(k,xp) - params(2+(3*(i-1))))**2._xp) / (2._xp * params(3+(3*(i-1)))**2._xp))

          dF_over_dB(2+(3*(i-1)),k) = dF_over_dB(2+(3*(i-1)),k) +&
               params(1+(3*(i-1))) * ( real(k,xp) - params(2+(3*(i-1))) ) / (params(3+(3*(i-1)))**2._xp) *&
               exp( ( -(real(k,xp) - params(2+(3*(i-1))))**2._xp) / (2._xp * params(3+(3*(i-1)))**2._xp))

          dF_over_dB(3+(3*(i-1)),k) = dF_over_dB(3+(3*(i-1)),k) +&
               params(1+(3*(i-1))) * ( real(k,xp) - params(2+(3*(i-1))) )**2._xp / (params(3+(3*(i-1)))**3._xp) *&
               exp( ( -(real(k,xp) - params(2+(3*(i-1))))**2._xp) / (2._xp * params(3+(3*(i-1)))**2._xp))
       enddo
    enddo

    do i=1, dim_v
       do k=1, 3*n_gauss
          gradient(k) = gradient(k) + dF_over_dB(k,i) * residual(i)
       end do
    end do

    deallocate(dF_over_dB)
  end subroutine mygrad_spec

  ! Compute the objective function for a cube and the gradient of the obkective function
  subroutine f_g_cube_fast(f, g, cube, beta, dim_v, dim_y, dim_x, n_gauss, kernel, lambda_amp, lambda_mu, lambda_sig, &
       lambda_var_amp, lambda_var_mu, lambda_var_sig, std_map)
    implicit none

    integer, intent(in) :: n_gauss
    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in) :: lambda_amp, lambda_mu, lambda_sig
    real(xp), intent(in) :: lambda_var_amp, lambda_var_mu, lambda_var_sig
    real(xp), intent(in), dimension(:), allocatable :: beta
    real(xp), intent(in), dimension(:,:,:), allocatable :: cube
    real(xp), intent(in), dimension(:,:), allocatable :: kernel
    real(xp), intent(in), dimension(:,:), allocatable :: std_map
    real(xp), intent(inout) :: f
    real(xp), intent(inout), dimension(:), allocatable :: g

    integer :: i, j, k, l
    integer :: n_beta
    real(xp), dimension(:,:,:), allocatable :: residual
    real(xp), dimension(:), allocatable :: residual_1D
    real(xp), dimension(:,:,:), allocatable :: params
    real(xp), dimension(:), allocatable :: b_params
    real(xp), dimension(:,:), allocatable :: conv_amp, conv_mu, conv_sig
    real(xp), dimension(:,:), allocatable :: conv_conv_amp, conv_conv_mu, conv_conv_sig
    real(xp), dimension(:,:), allocatable :: image_amp, image_mu, image_sig
    real(xp), dimension(:,:,:), allocatable :: deriv
    real(xp), dimension(:), allocatable :: model
    real(xp) :: gauss

    allocate(deriv(3*n_gauss, dim_y, dim_x))
    allocate(residual(dim_v, dim_y, dim_x))
    allocate(b_params(n_gauss))
    allocate(params(3*n_gauss, dim_y, dim_x))
    allocate(conv_amp(dim_y, dim_x), conv_mu(dim_y, dim_x), conv_sig(dim_y, dim_x))
    allocate(conv_conv_amp(dim_y, dim_x), conv_conv_mu(dim_y, dim_x), conv_conv_sig(dim_y, dim_x))
    allocate(image_amp(dim_y, dim_x), image_mu(dim_y, dim_x), image_sig(dim_y, dim_x))
    allocate(model(dim_v))

    deriv = 0._xp
    f = 0._xp
    g = 0._xp
    residual = 0._xp
    params = 0._xp
    model = 0._xp
    gauss = 0._xp

    n_beta = (3*n_gauss * dim_y * dim_x) + n_gauss

    call unravel_3D(beta, params, 3*n_gauss, dim_y, dim_x)
    do i=1,n_gauss
       b_params(i) = beta((n_beta-n_gauss)+i)
    end do

    ! Compute the objective function and the gradient
    do j=1, dim_x
       do i=1, dim_y
          allocate(residual_1D(dim_v))
          residual_1D = 0._xp
          call myresidual(params(:,i,j), cube(:,i,j), residual_1D, n_gauss, dim_v)
          residual(:,i,j) = residual_1D
          if (std_map(i,j) > 0._xp) then
             f = f + (myfunc_spec(residual_1D)/std_map(i,j)**2._xp)
          end if
          deallocate(residual_1D)
       end do
    end do

    ! Compute the objective function and the gradient
    do i=1, n_gauss
       !
       conv_amp = 0._xp; conv_mu = 0._xp; conv_sig = 0._xp
       conv_conv_amp = 0._xp; conv_conv_mu = 0._xp; conv_conv_sig = 0._xp
       image_amp = 0._xp; image_mu = 0._xp; image_sig = 0._xp

       image_amp = params(1+(3*(i-1)),:,:)
       image_mu = params(2+(3*(i-1)),:,:)
       image_sig = params(3+(3*(i-1)),:,:)

       call convolution_2D_mirror(image_amp, conv_amp, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(image_mu, conv_mu, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(image_sig, conv_sig, dim_y, dim_x, kernel, 3)

       call convolution_2D_mirror(conv_amp, conv_conv_amp, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(conv_mu, conv_conv_mu, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(conv_sig, conv_conv_sig, dim_y, dim_x, kernel, 3)

       do l=1, dim_x
          do j=1, dim_y
             !Regularization
             f = f + (0.5_xp * lambda_amp * conv_amp(j,l)**2)
             f = f + (0.5_xp * lambda_mu * conv_mu(j,l)**2)
             f = f + (0.5_xp * lambda_sig * conv_sig(j,l)**2) + (0.5_xp * lambda_var_sig * (image_sig(j,l) - b_params(i))**2._xp)

             g((n_beta-n_gauss)+i) = g((n_beta-n_gauss)+i) - (lambda_var_sig * (image_sig(j,l) - b_params(i)))

             !
             do k=1, dim_v
                if (std_map(j,l) > 0._xp) then
                   deriv(1+(3*(i-1)),j,l) = deriv(1+(3*(i-1)),j,l) + (exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) &
                        / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))) &
                        * (residual(k,j,l)/std_map(j,l)**2._xp)

                   deriv(2+(3*(i-1)),j,l) = deriv(2+(3*(i-1)),j,l) + (params(1+(3*(i-1)),j,l) * &
                        ( real(k,xp) - params(2+(3*(i-1)),j,l) ) / (params(3+(3*(i-1)),j,l)**2._xp) * &
                        exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) &
                        / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))) &
                        * (residual(k,j,l)/std_map(j,l)**2._xp)

                   deriv(3+(3*(i-1)),j,l) = deriv(3+(3*(i-1)),j,l) + (params(1+(3*(i-1)),j,l) * &
                        ( real(k,xp) - params(2+(3*(i-1)),j,l) )**2._xp / (params(3+(3*(i-1)),j,l)**3._xp) * &
                        exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))) &
                        * (residual(k,j,l)/std_map(j,l)**2._xp)
                end if
             end do

             deriv(1+(3*(i-1)),j,l) = deriv(1+(3*(i-1)),j,l) + (lambda_amp * conv_conv_amp(j,l))
             deriv(2+(3*(i-1)),j,l) = deriv(2+(3*(i-1)),j,l) + (lambda_mu * conv_conv_mu(j,l))
             deriv(3+(3*(i-1)),j,l) = deriv(3+(3*(i-1)),j,l) + (lambda_sig * conv_conv_sig(j,l) + &
                  (lambda_var_sig * (image_sig(j,l) - b_params(i))))
          end do
          !
       end do
    end do

    call ravel_3D(deriv, g, 3*n_gauss, dim_y, dim_x)

    deallocate(deriv)
    deallocate(residual)
    deallocate(b_params)
    deallocate(params)
    deallocate(conv_amp, conv_mu, conv_sig)
    deallocate(conv_conv_amp, conv_conv_mu, conv_conv_sig)
    deallocate(image_amp, image_mu, image_sig)

  end subroutine f_g_cube_fast

 ! Compute the objective function for a cube and the gradient of the obkective function
  subroutine f_g_cube(f, g, cube, beta, dim_v, dim_y, dim_x, n_gauss, kernel, lambda_amp, lambda_mu, lambda_sig, &
       lambda_var_amp, lambda_var_mu, lambda_var_sig, std_map)
    implicit none

    integer, intent(in) :: n_gauss
    integer, intent(in) :: dim_v, dim_y, dim_x
    real(xp), intent(in) :: lambda_amp, lambda_mu, lambda_sig
    real(xp), intent(in) :: lambda_var_amp, lambda_var_mu, lambda_var_sig
    real(xp), intent(in), dimension(:), allocatable :: beta
    real(xp), intent(in), dimension(:,:,:), allocatable :: cube
    real(xp), intent(in), dimension(:,:), allocatable :: kernel
    real(xp), intent(in), dimension(:,:), allocatable :: std_map
    real(xp), intent(inout) :: f
    real(xp), intent(inout), dimension(:), allocatable :: g

    integer :: i, j, k, l
    integer :: n_beta
    real(xp), dimension(:,:,:), allocatable :: residual
    real(xp), dimension(:), allocatable :: residual_1D
    real(xp), dimension(:,:,:), allocatable :: params
    real(xp), dimension(:), allocatable :: b_params
    real(xp), dimension(:,:), allocatable :: conv_amp, conv_mu, conv_sig
    real(xp), dimension(:,:), allocatable :: conv_conv_amp, conv_conv_mu, conv_conv_sig
    real(xp), dimension(:,:), allocatable :: image_amp, image_mu, image_sig
    real(xp), dimension(:,:,:), allocatable :: g_3D
    real(xp), dimension(:,:,:,:), allocatable :: dF_over_dB
    real(xp), dimension(:,:,:), allocatable :: dR_over_dB
    real(xp), dimension(:,:,:), allocatable :: deriv

    allocate(dR_over_dB(3*n_gauss, dim_y, dim_x))
    allocate(dF_over_dB(3*n_gauss, dim_v, dim_y, dim_x))
    allocate(deriv(3*n_gauss, dim_y, dim_x))
    allocate(g_3D(3*n_gauss, dim_y, dim_x))
    allocate(residual(dim_v, dim_y, dim_x))
    allocate(b_params(n_gauss))
    allocate(params(3*n_gauss, dim_y, dim_x))
    allocate(conv_amp(dim_y, dim_x), conv_mu(dim_y, dim_x), conv_sig(dim_y, dim_x))
    allocate(conv_conv_amp(dim_y, dim_x), conv_conv_mu(dim_y, dim_x), conv_conv_sig(dim_y, dim_x))
    allocate(image_amp(dim_y, dim_x), image_mu(dim_y, dim_x), image_sig(dim_y, dim_x))

    dR_over_dB = 0._xp
    dF_over_dB = 0._xp
    deriv = 0._xp
    f = 0._xp
    g = 0._xp
    g_3D = 0._xp
    residual = 0._xp
    params = 0._xp

    n_beta = (3*n_gauss * dim_y * dim_x) + n_gauss

    call unravel_3D(beta, params, 3*n_gauss, dim_y, dim_x)
    do i=1,n_gauss
       b_params(i) = beta((n_beta-n_gauss)+i)
    end do

    ! Compute the objective function and the gradient
    do j=1, dim_x
       do i=1, dim_y
          allocate(residual_1D(dim_v))
          residual_1D = 0._xp
          call myresidual(params(:,i,j), cube(:,i,j), residual_1D, n_gauss, dim_v)
          residual(:,i,j) = residual_1D
          if (std_map(i,j) > 0._xp) then
             f = f + (myfunc_spec(residual_1D)/std_map(i,j)**2._xp)
          end if
          deallocate(residual_1D)
       end do
    end do

    do l=1, dim_x
       do j=1, dim_y
          do i=1, n_gauss
             do k=1, dim_v
                dF_over_dB(1+(3*(i-1)),k,j,l) = dF_over_dB(1+(3*(i-1)),k,j,l) +&
                     exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))

                dF_over_dB(2+(3*(i-1)),k,j,l) = dF_over_dB(2+(3*(i-1)),k,j,l) +&
                     params(1+(3*(i-1)),j,l) * ( real(k,xp) - params(2+(3*(i-1)),j,l) ) / (params(3+(3*(i-1)),j,l)**2._xp) *&
                     exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))

                dF_over_dB(3+(3*(i-1)),k,j,l) = dF_over_dB(3+(3*(i-1)),k,j,l) +&
                     params(1+(3*(i-1)),j,l) * ( real(k,xp) - params(2+(3*(i-1)),j,l) )**2._xp / (params(3+(3*(i-1)),j,l)**3._xp) *&
                     exp( ( -(real(k,xp) - params(2+(3*(i-1)),j,l))**2._xp) / (2._xp * params(3+(3*(i-1)),j,l)**2._xp))
             enddo
          enddo
       end do
    end do

    do k=1, dim_v
       do j=1, dim_x
          do i=1, dim_y
             do l=1, 3*n_gauss
                if (std_map(i,j) > 0._xp) then
                   deriv(l,i,j) = deriv(l,i,j) + dF_over_dB(l,k,i,j) * (residual(k,i,j)/std_map(i,j)**2._xp)
                end if
             end do
          end do
       end do
    end do

    do k=1, n_gauss
       conv_amp = 0._xp; conv_mu = 0._xp; conv_sig = 0._xp
       conv_conv_amp = 0._xp; conv_conv_mu = 0._xp; conv_conv_sig = 0._xp
       image_amp = 0._xp; image_mu = 0._xp; image_sig = 0._xp

       image_amp = params(1+(3*(k-1)),:,:)
       image_mu = params(2+(3*(k-1)),:,:)
       image_sig = params(3+(3*(k-1)),:,:)

       call convolution_2D_mirror(image_amp, conv_amp, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(image_mu, conv_mu, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(image_sig, conv_sig, dim_y, dim_x, kernel, 3)

       call convolution_2D_mirror(conv_amp, conv_conv_amp, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(conv_mu, conv_conv_mu, dim_y, dim_x, kernel, 3)
       call convolution_2D_mirror(conv_sig, conv_conv_sig, dim_y, dim_x, kernel, 3)

       do j=1, dim_x
          do i=1, dim_y
             f = f + (0.5_xp * lambda_amp * conv_amp(i,j)**2)
             f = f + (0.5_xp * lambda_mu * conv_mu(i,j)**2)
             f = f + (0.5_xp * lambda_sig * conv_sig(i,j)**2) + (0.5_xp * lambda_var_sig * (image_sig(i,j) - b_params(k))**2._xp)

             dR_over_dB(1+(3*(k-1)),i,j) = lambda_amp * conv_conv_amp(i,j)
             dR_over_dB(2+(3*(k-1)),i,j) = lambda_mu * conv_conv_mu(i,j)
             dR_over_dB(3+(3*(k-1)),i,j) = lambda_sig * conv_conv_sig(i,j) + (lambda_var_sig * (image_sig(i,j) - b_params(k)))

             g((n_beta-n_gauss)+k) = g((n_beta-n_gauss)+k) - (lambda_var_sig * (image_sig(i,j) - b_params(k)))
             ! g((n_beta-n_gauss)+k) = - lambda_var_sig * (image_sig(i,j) - b_params(k))
          end do
       end do
    end do

    g_3D = deriv + dR_over_dB
    call ravel_3D(g_3D, g, 3*n_gauss, dim_y, dim_x)

  end subroutine f_g_cube

end module mod_optimize


	FUNCTION PR_MHGT  ( hb, pb, pt, scale )
C************************************************************************
C* PR_MHGT								*
C*									*
C* This function computes the moist hydrostatic height at pressure, PT,	*
C* from a lower height and pressure, and the scale height in the layer.	*
C* PR_SCLH can be used to compute the scale height.  MHGT is		*
C* computed as an integrated quantity.  Thus, the lower height should	*
C* have been integrated from the surface.				*
C*									*
C*              PR_MHGT  =  HB + SCALE * ALOG ( PB / PT )		*
C*									*
C* REAL PR_MHGT  ( HB, PB, PT, SCALE )					*
C*									*
C* Input parameters:							*
C*	HB		REAL		Bottom height			*
C*	PB		REAL		Bottom pressure			*
C*	PT		REAL		Top pressure			*
C*	SCALE		REAL		Scale height			*
C*									*
C* Output parameters:							*
C*	PR_MHGT		REAL		Moist hydrostatic height	*
C**									*
C* Log:									*
C* M. desJardins/GSFC	9/86						*
C* G. Huffman/GSC	7/88	Documentation				*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing data.
C
	IF  ( (.not. ERMISS (pb)) .and. (.not. ERMISS (pt)) .and.
     +	      (.not. ERMISS (hb)) .and. (.not. ERMISS (scale)) .and.
     +	      ( pt .gt. 0. ) .and. ( pb .gt. 0. ) )  THEN
	    PR_MHGT = hb + scale * ALOG ( pb / pt )
	  ELSE
	    PR_MHGT = RMISSD
	END IF
C*
	RETURN
	END


    Program dggsvd3_example

!     DGGSVD3 Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen_comp
      Use lapack_interfaces, Only: dggsvd3, dtrcon
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: eps, rcond, serrbd
      Integer :: i, ifail, info, irank, j, k, l, lda, ldb, ldq, ldu, ldv, &
        lwork, m, n, p
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), alpha(:), b(:, :), beta(:), &
        q(:, :), u(:, :), v(:, :), work(:)
      Real (Kind=dp) :: wdum(1)
      Integer, Allocatable :: iwork(:)
      Character (1) :: clabs(1), rlabs(1)
!     .. Intrinsic Procedures ..
      Intrinsic :: epsilon, nint
!     .. Executable Statements ..
      Write (nout, *) 'DGGSVD3 Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n, p
      lda = m
      ldb = p
      ldq = n
      ldu = m
      ldv = p
      Allocate (a(lda,n), alpha(n), b(ldb,n), beta(n), q(ldq,n), u(ldu,m), &
        v(ldv,p), iwork(n))

!     Perform workspace query to get optimal size of work
      lwork = -1
      Call dggsvd3('U', 'V', 'Q', m, n, p, k, l, a, lda, b, ldb, alpha, beta, &
        u, ldu, v, ldv, q, ldq, wdum, lwork, iwork, info)
      lwork = nint(wdum(1))
      Allocate (work(lwork))

!     Read the m by n matrix A and p by n matrix B from data file

      Read (nin, *)(a(i,1:n), i=1, m)
      Read (nin, *)(b(i,1:n), i=1, p)

!     Compute the generalized singular value decomposition of (A, B)
!     (A = U*D1*(0 R)*(Q**T), B = V*D2*(0 R)*(Q**T), m>=n)
      Call dggsvd3('U', 'V', 'Q', m, n, p, k, l, a, lda, b, ldb, alpha, beta, &
        u, ldu, v, ldv, q, ldq, work, lwork, iwork, info)

      If (info==0) Then

!       Print solution

        irank = k + l
        Write (nout, *) 'Number of infinite generalized singular values (K)'
        Write (nout, 100) k
        Write (nout, *) 'Number of finite generalized singular values (L)'
        Write (nout, 100) l
        Write (nout, *) 'Numerical rank of (A**T B**T)**T (K+L)'
        Write (nout, 100) irank
        Write (nout, *)
        Write (nout, *) 'Finite generalized singular values'
        Write (nout, 110)(alpha(j)/beta(j), j=k+1, irank)

        Write (nout, *)
        Flush (nout)

!       ifail: behaviour on error exit
!              =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
        ifail = 0
        Call nagf_file_print_matrix_real_gen_comp('General', ' ', m, m, u, &
          ldu, '1P,E12.4', 'Orthogonal matrix U', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)

        Write (nout, *)
        Flush (nout)

        Call nagf_file_print_matrix_real_gen_comp('General', ' ', p, p, v, &
          ldv, '1P,E12.4', 'Orthogonal matrix V', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)

        Write (nout, *)
        Flush (nout)

        Call nagf_file_print_matrix_real_gen_comp('General', ' ', n, n, q, &
          ldq, '1P,E12.4', 'Orthogonal matrix Q', 'Integer', rlabs, 'Integer', &
          clabs, 80, 0, ifail)

        Write (nout, *)
        Flush (nout)

        Call nagf_file_print_matrix_real_gen_comp('Upper triangular', &
          'Non-unit', irank, irank, a(1,n-irank+1), lda, '1P,E12.4', &
          'Nonsingular upper triangular matrix R', 'Integer', rlabs, &
          'Integer', clabs, 80, 0, ifail)

!       Call DTRCON to estimate the reciprocal condition
!       number of R

        Call dtrcon('Infinity-norm', 'Upper', 'Non-unit', irank, &
          a(1,n-irank+1), lda, rcond, work, iwork, info)

        Write (nout, *)
        Write (nout, *) 'Estimate of reciprocal condition number for R'
        Write (nout, 120) rcond
        Write (nout, *)

!       So long as irank = n, get the machine precision, eps, and
!       compute the approximate error bound for the computed
!       generalized singular values

        If (irank==n) Then
          eps = epsilon(1.0E0_dp)
          serrbd = eps/rcond
          Write (nout, *) 'Error estimate for the generalized singular values'
          Write (nout, 120) serrbd
        Else
          Write (nout, *) '(A**T B**T)**T is not of full rank'
        End If
      Else
        Write (nout, 130) 'Failure in DGGSVD3. INFO =', info
      End If

100   Format (1X, I5)
110   Format (3X, 8(1P,E12.4))
120   Format (1X, 1P, E11.1)
130   Format (1X, A, I4)
    End Program


!	Extract the linear component linth and the quadratic component quadth from lintheta and quadtheta for a given predictor thpr.
subroutine getlinquadth(lintheta,quadtheta,thpr,linth,quadth)
implicit none

real(kind=8),intent(in)::lintheta(:,:),quadtheta(:,:,:),thpr(:)
real(kind=8),intent(out)::linth(:),quadth(:,:)
!	row counts elements of the underlying latent vector.
integer::row
linth=matmul(lintheta,thpr)
do row=1,size(linth)
	quadth(row,:)=matmul(quadtheta(row,:,:),thpr)
end do
return
end subroutine getlinquadth


subroutine constriction_calc

    use arrays
    use global

    implicit none

    integer i           !variable de iteracion
    real(kind = 8) idx  !aux

    !calculamos la condicion de ligadura inicial derivando Psi respecto a las coordenadas
    idx = 1.0d0/dx  !mas eficiente en cada iteracion
    !Derivada centrada
    do i = 1, Nx-1
        dPhi(i) = 0.5d0*(Phi(i+1) - Phi(i-1)*idx)
    end do
    !Derivadas laterales
    dPhi(0)  = 0.5d0*(-3.0d0*Phi(0) + 4.0d0*Phi(1)    - Phi(2))*idx
    dPhi(Nx) = 0.5d0*(3.0d0*Phi(Nx) - 4.0d0*Phi(Nx-1) + Phi(Nx-2))*idx

    constriction = Psi - dPhi

end subroutine constriction_calc


program main_stats
    implicit none
    integer, parameter :: nr_data = 21
    type :: statistics
        real :: mean, stddev
        integer :: n
    end type statistics
    integer :: i
    type(statistics) :: stats
    real, dimension(nr_data) :: data

    data = [ (100.0 + 0.3*i, i=-size(data)/2, size(data)/2) ]
    stats = compute_stats(data)
    print *, stats%mean, stats%stddev, stats%n

contains

    function compute_stats(data) result(stats)
        implicit none
        real, dimension(:), intent(in) :: data
        type(statistics) :: stats
        real :: data_sum, data_sum2

        stats%n = size(data)
        data_sum = sum(data)
        data_sum2 = sum(data**2)
        associate(n => stats%n)
            stats%mean = data_sum/n
            stats%stddev = sqrt((data_sum2 - data_sum**2/n)/(n - 1))
        end associate
    end function compute_stats

end program main_stats


      SUBROUTINE STGC0  (S, ZOUT, WANTDZ, DZOUT)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1996-02-02 STGC0 CLL
C>> 1996-01-11 STGC0 CLL
C>> 1995-11-01 STGC0 CLL
C>> 1995-09-26 STGC0 CLL Editing for inclusion into MATH77.
c     C.L.LAWSON, JPL, 1976 DEC 7
c  This subr interpolates over a triangle using linear interpolation.
c  This method gives C0 continuity with neighboring triangles, i.e.,
c  continuity of the value but generally not continuity of first and
c  higher order partial derivatives.
c  Optionally the subr also computes first partial derivatives.
c
c   (S(1:3, 1:4) [inout]  Columns 1-4 contain data set by the user to
c          specify the interpolation problem.  Col 1 contains
c          unnormalized barycentric coordinates of the interpolation
c          point.  The other cols contain data depending only on the
c          triangle and its vertex data and not on the interpolation
c          point.
c
c         S( ,1) = UNNORMALIZED BARYCENTRIC COORDS OF INTERP POINT.
c         S( ,2) = U = X COORD OF EDGE VECTOR
c         S( ,3) = V = Y COORD OF EDGE VECTOR
c         S( ,4) = Z = FCN VALUE AT VERTEX
c
c   ZOUT [out]  INTERPOLATED VALUE COMPUTED BY SUBR.
C
c   WANTDZ [in]  =.TRUE. MEANS COMPUTE DZOUT() AS WELL AS ZOUT.
c              =.FALSE. MEANS COMPUTE ONLY ZOUT AND NOT DZOUT().
C
c   DZOUT(1:2) [out]  First partial derivs w.r.t. X and Y of the
c      interpolated surface at the interpolation point.
c      Note that since this subroutine computes only a linear
c      interpolant over a triangle, the partial derivs w.r.t. X and Y
c      will be the same at every point of the triangle.  In general
c      these derivatives will jump to different values when moving to
c      an adjacent triangle.
c     ------------------------------------------------------------------
c         Details of the contents of TRI(1:7) and S(1:3, 1:4).
c
c  We assume the point Q is in the triangle indexed by INDTRI.
c  The indices of the vertices of this triangle, in counter-
c  clockwise, order are P(1), P(2), and P(3) which may be obtained as
c  P(i) = TRI(3+i) for i = 1, 2, and 3.  TRI(7) contains the same
c  value as TRI(4).  The triangle adjacent to this triangle across
c  the edge from P(i) to P(i+1) is indexed by TRI(i) for i = 1, 2,
c  and 3.  If there is no adjacent triangle across this edge then
c  TRI(i) = 0.
c
c  For descriptive convenience we regard the subscript of P() and the
c  1st subsubscript of S(,) as always being reduced modulo 3 to 1, 2,
c  or 3.  Also for convenience we shall write P(i) to mean the vertex
c  indexed by P(i).
c
c  The unnormalized barycentric coordinate that is zero along the edge
c  from P(i) to P(i+1) and has a positive value at P(i+2) is stored in
c  S(i,1).  The (x,y) coordinates of the vector from P(i) to P(i+1) are
c  stored in (S(i,2), S(i,3)).
c  The function value Z at P(i+2) is stored in S(i,4) for i = 1, 2, & 3.
c     ------------------------------------------------------------------
c--S replaces "?": ?TGC0
C     ------------------------------------------------------------------
      REAL             delz(2), denom, dzout(2), S(3,4), zout
      LOGICAL  WANTDZ
C     ------------------------------------------------------------------
c        To compute zout:
c        Combine the vertex function values using the unnormalized
c        barycentric coordinates as weights, and normalize by the
c        sum of the unnormalized barycentric coordinates.
c
      zout = (s(1,1)*s(1,4) +s(2,1)*s(2,4) +s(3,1)*s(3,4)) /
     *            (S(1,1)+S(2,1)+S(3,1))
      if(wantdz) then
         delz(1) = s(3,4) - s(2,4)
         delz(2) = s(1,4) - s(3,4)
         denom = s(1,2) * s(2,3) - s(2,2) * s(1,3)
         if(denom .ne. 0.0e0) then
            dzout(1) = (delz(1) * s(2,3) - delz(2) * s(1,3)) / denom
            dzout(2) = (s(1,2) * delz(2) - s(2,2) * delz(1)) / denom
         else
            dzout(1) = 0.0e0
            dzout(2) = 0.0e0
         endif
      endif
      return
      end


module find_roots
  !=========================================================!
  ! Module for root finding.                                !
  ! Author: Daniel Celis Garza                              !
  ! Last modified: April 28, 2016                           !
  ! Contains:                                               !
  ! subroutine outbracket: Expands the interval until it    !
  ! crosses a root (function changes sign).                 !
  ! subroutine inbracket: Surrounds roots within intervals  !
  ! subroutine bisection: Carries out bisection to find a   !
  ! root within an interval.                                !
  !=========================================================!
  use nrtype
contains
  subroutine outbracket(func, interval, max_it, success, factor)
    !=======================================================!
    ! Gradually expands bracket until it finds a root.      !
    !-------------------------------------------------------!
    ! Cycles through a number of iterations until the       !
    ! maximum number of iterations is reached. The interval !
    ! is expanded according to a user-provided factor. If   !
    ! the cycle finds a root, it exits the subroutine with  !
    ! success = .true., else it exits with success = .false.!
    ! and a greater interval.                               !
    !-------------------------------------------------------!
    ! Inputs:                                               !
    ! func   = function whose roots we're trying to bracket !
    ! factor = optional factor for increasing the interval  !
    ! max_it = maximum number of iterations                 !
    !-------------------------------------------------------!
    ! Outputs:                                              !
    ! success = logical value stating whether a root was    !
    !           bracketted                                  !
    !-------------------------------------------------------!
    ! Inputs-Outputs:                                       !
    ! interval() = input a proposed interval, output an     !
    !              interval which brackets the root.        !
    !-------------------------------------------------------!
    ! Locals:                                               !
    ! f() = value of func() at the interval bounds          !
    ! i   = counter                                         !
    !=======================================================!
    implicit none
    interface cont_func
      function func(x)
        use nrtype
        implicit none
        real(dp), intent(in) :: x
        real(dp)             :: func
      end function func
    end interface cont_func
    real(dp), intent(inout) :: interval(2)
    integer,  intent(in)    :: max_it
    logical,  intent(out)   :: success
    real(dp), optional      :: factor
    real(dp)                :: f(2)
    integer                 :: i

    ! Check whether factor is given, if it's not give it a default value of 2.
    if( .not. present(factor) ) factor = 2._dp

    ! Loop to check whether the Interval given is Appropriate and ask the user to provide an appropriate one.
    iado: do
      iaif: if ( interval(1) == interval(2) ) then
        write(*,*) " Please provide a proper interval [A, B] where A < B."
        write(*,"(A)", advance = "no") " A = "
        read*, interval(1)
        write(*,"(A)", advance = "no") " B = "
        read*, interval(2)
      else iaif
        exit iado
      end if iaif
    end do iado

    ! Evaluate the lower and upper bounds of the interval on the fuction provided.
    f(1) = func( interval(1) )
    f(2) = func( interval(2) )

    ! Define success as true in case the subroutine finds a root.
    success = .true.

    ! Loop to EXPand the INTerval
    expintdo: do i = 1, max_it
      if ( f(1) * f(2) < 0.) return
      ! EXPand the INTerval
      expintif: if ( abs(f(1)) < abs(f(2)) ) then
        interval(1)  = interval(1) + factor * (interval(1) - interval(2))
        f(1)         = func(interval(1))
      else expintif
        interval(2)  = interval(2) + factor * (interval(2) - interval(1))
        f(2)         = func(interval(2))
      end if expintif
    end do expintdo

    ! If the subroutine fails to find a root, succes is false.
    success = .false.

  end subroutine outbracket

  subroutine inbracket(func, intvl, n_seg, sub_intvl, n_root)
    !=======================================================!
    ! Find intervals which enclose a given # of roots       !
    !-------------------------------------------------------!
    ! Cycles through a number of iterations until the       !
    ! number of proposed roots is reached. A master interval!
    ! is traversed, and subintervals are generated when a   !
    ! root is found (function changes sign). Outputs the    !
    ! intervals found and the number of roots found.        !
    !-------------------------------------------------------!
    ! Inputs:                                               !
    ! func  = function whose roots we're trying to bracket  !
    ! intvl = master interval (contains the subints)        !
    ! n_seg = number of segments to analyse                 !
    !-------------------------------------------------------!
    ! Outputs:                                              !
    ! sub_intvl = subintervals                              !
    !-------------------------------------------------------!
    ! Inputs-Outputs:                                       !
    ! n_root() = # of roots found                           !
    !-------------------------------------------------------!
    ! Locals:                                               !
    ! f()     = value of func() at the subinterval bounds   !
    ! x       = independent variable                        !
    ! dx      = step size                                   !
    ! i       = counter                                     !
    ! n_intvl = # of intervals                              !
    !=======================================================!
    implicit none
    interface cont_func
      function func(x)
        use nrtype
        implicit none
        real(dp), intent(in) :: x
        real(dp)             :: func
      end function func
    end interface cont_func
    real(dp), intent(in)    :: intvl(2)
    integer,  intent(in)    :: n_seg
    real(dp), intent(out)   :: sub_intvl(:,:)
    integer,  intent(inout) :: n_root
    real(dp)                :: f(2), x, dx
    integer                 :: i, n_intvl

    ! Initialise the number of intervals found.
    n_intvl = 0

    ! Set initial x to the value of the master interval.
    x  = intvl(1)
    ! Calculate the step size from the number of desired segments and master interval.
    dx = (intvl(2) - intvl(1)) / n_seg

    ! Evaluate function at lower end of the master interval.
    f(1) = func(x)

    ! Find Root Bracketting Intervals.
    frbido: do i = 1, n_seg
      ! Travel right along the x axis, because we want to calculate B of an internal interval.
      x  = x + dx
      ! Evaluate function at prospective upper bound for the interval.
      f(2) = func(x)
      ! Check whether we have found a root.
      frbiif: if ( f(1) * f(2) < 0. ) then
        ! If a root has been found, increase the interval counter.
        n_intvl = n_intvl + 1
        ! Record the lower and upper bounds of the subinterval.
        sub_intvl(1,n_intvl) = x - dx
        sub_intvl(2,n_intvl) = x
        ! If we have reached the number of roots that we want to bracket, exit subroutine.
        if (n_intvl == n_root) exit frbido
      end if frbiif
      ! Set up for the next subinterval.
      f(1) = f(2)
    end do frbido

    ! Check if the master interval is big enough to find all proposed roots.
    if ( i-1 == n_seg ) write(*,*) " Increase range of the master interval or change the number of segments."
    ! Print the roots found.
    n_root = n_intvl
  end subroutine inbracket

  subroutine bisection(func,interval,tol,max_it,root)
    ! Bisection subroutine.
    implicit none
    interface cont_func
      function func(x)
        use nrtype
        implicit none
        real(dp), intent(in) :: x
        real(dp)             :: func
      end function func
    end interface cont_func
    real(dp), intent(in)     :: interval(2), tol ! Interval, tolerance
    integer, intent(in)      :: max_it ! Maximum # of iterations
    real(dp), intent(out)    :: root
    integer                  :: i ! Counter.
    real(dp)                 :: a, b, c, fa, fc

    a = interval(1)
    b = interval(2)
    fa = func(a)
    fc = func(c)

    bisecting: do i = 1, max_it
      c  = .5_dp*(a+b)
      fc = func(c)
      if ( fc == 0._dp .or. .5_dp*(b - a) < tol) exit bisecting
      check_sign: if ( fc * fa < 0._dp ) then
        b = c
      else check_sign
        a  = c
        fa = func(a)
      end if check_sign
    end do bisecting

    found_root: if (i > max_it) then
      write(*,*) " Iterations not sufficient for root finding."
    else found_root
      root = c
    end if found_root
  end subroutine bisection
end module find_roots


! Program to test the power (**) operator
program testpow
   implicit none
   real(kind=4) r, s, two
   real(kind=8) :: q
   complex(kind=4) :: c, z
   real, parameter :: del = 0.0001
   integer i, j

   i = 2
   j = i ** 10
   if (abs (j - 1024) .gt. del) call abort
   j = i ** (-10)
   if (abs (j - 0) .gt. del) call abort
   j = i ** 0
   if (abs (j - 1) .gt. del) call abort
   i = 1
   j = i ** 10
   if (abs (j - 1) .gt. del) call abort
   j = i ** (-10)
   if (abs (j - 1) .gt. del) call abort
   j = i ** 0
   if (abs (j - 1) .gt. del) call abort
   i = -1
   j = i ** 10
   if (abs (j - 1) .gt. del) call abort
   j = i ** (-10)
   if (abs (j - 1) .gt. del) call abort
   j = i ** 0
   if (abs (j - 1) .gt. del) call abort
   j = i ** 11
   if (abs (j - (-1)) .gt. del) call abort
   j = i ** (-11)
   if (abs (j - (-1)) .gt. del) call abort

   c = (2.0, 3.0)
   z = c ** 2
   if (abs(z - (-5.0, 12.0)) .gt. del) call abort
   z = c ** 7
   if (abs(z - (6554.0, 4449.0)) .gt. del) call abort

   two = 2.0

   r = two ** 1
   if (abs (r - 2.0) .gt. del) call abort
   r = two ** 2
   if (abs (r - 4.0) .gt. del) call abort
   r = two ** 3
   if (abs (r - 8.0) .gt. del) call abort
   r = two ** 4
   if (abs (r - 16.0) .gt. del) call abort
   r = two ** 0
   if (abs (r - 1.0) .gt. del) call abort
   r = two ** (-1)
   if (abs (r - 0.5) .gt. del) call abort
   r = two ** (-2)
   if (abs (r - 0.25) .gt. del) call abort
   r = two ** (-4)
   if (abs (r - 0.0625) .gt. del) call abort
   s = 3.0
   r = two ** s
   if (abs (r - 8.0) .gt. del) call abort
   s = -3.0
   r = two ** s
   if (abs (r - 0.125) .gt. del) call abort
   i = 3
   r = two ** i
   if (abs (r - 8.0) .gt. del) call abort
   i = -3
   r = two ** i
   if (abs (r - 0.125) .gt. del) call abort
   c = (2.0, 3.0)
   c = c ** two
   if (abs(c - (-5.0, 12.0)) .gt. del) call abort
end program


      SUBROUTINE slDMAV (RMAT, AXVEC)
*+
*     - - - - - -
*      D M A V
*     - - - - - -
*
*  From a rotation matrix, determine the corresponding axial vector.
*  (double precision)
*
*  A rotation matrix describes a rotation about some arbitrary axis,
*  called the Euler axis.  The "axial vector" returned by this routine
*  has the same direction as the Euler axis, and its magnitude is the
*  amount of rotation in radians.  (The magnitude and direction can be
*  separated by means of the routine slDVN.)
*
*  Given:
*    RMAT   d(3,3)   rotation matrix
*
*  Returned:
*    AXVEC  d(3)     axial vector (radians)
*
*  The reference frame rotates clockwise as seen looking along
*  the axial vector from the origin.
*
*  If RMAT is null, so is the result.
*
*  Last revision:   26 November 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    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; either version 2 of the License, or
*    (at your option) any later version.
*
*    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 (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION RMAT(3,3),AXVEC(3)

      DOUBLE PRECISION X,Y,Z,S2,C2,PHI,F

      X = RMAT(2,3)-RMAT(3,2)
      Y = RMAT(3,1)-RMAT(1,3)
      Z = RMAT(1,2)-RMAT(2,1)
      S2 = SQRT(X*X+Y*Y+Z*Z)
      IF (S2.NE.0D0) THEN
         C2 = RMAT(1,1)+RMAT(2,2)+RMAT(3,3)-1D0
         PHI = ATAN2(S2,C2)
         F = PHI/S2
         AXVEC(1) = X*F
         AXVEC(2) = Y*F
         AXVEC(3) = Z*F
      ELSE
         AXVEC(1) = 0D0
         AXVEC(2) = 0D0
         AXVEC(3) = 0D0
      END IF

      END


PROGRAM ex1
  use omp_lib

  IMPLICIT NONE

  integer :: num_steps = 100000
  real :: step
  real :: pi, x
  real :: summ
  integer :: i

  step = 1.0/num_steps

  summ = 0.0
  !$OMP PARALLEL DO REDUCTION(+:summ)
  do i=0, num_steps
    x = (i+0.5)*step
    summ = summ + 4.0/(1.0+ x*x)
  end do
  !$OMP END PARALLEL DO

  write(*,*) 'pi is ', summ*step

END PROGRAM ex1


!=====================================================================!
! Run gradient-based descent algorithms to solve linear algebra
!=====================================================================!

program test

  implicit none

  call check_solvers

end program test

subroutine check_solvers

  use linear_algebra
  use system

  implicit none

  system1 : block

    integer, parameter :: npts = 1000
    real(8), parameter :: max_tol = 1.0d-8
    integer, parameter :: max_it = 100000
    real(8) :: x(npts,3), b(npts), A(npts,npts)
    integer :: iter, flag, i, j
    real(8) :: tol

    ! Solve using LU factorization
    call assemble_system1(npts, A, b, x(:,1))
    x(:,1) = solve(A,b)

    ! Solve using CGNE
    call assemble_system1(npts, A, b, x(:,2))
    call dcgne(A, b, max_it, max_tol, x(:,2), iter, tol, flag)
    print *, 'cgne', tol, iter

    ! Solve using CGNR
    call assemble_system1(npts, A, b, x(:,3))
    call dcgnr(A, b, max_it, max_tol, x(:,3), iter, tol, flag)
    print *, 'cgnr', tol, iter

    open(11, file='system1.dat')
    do i = 1, npts
       ! exact, cgne, cgnr
       write(11, *) i, x(i,1), x(i,2), x(i,3)
    end do
    close(11)

  end block system1

  system2 : block

    integer, parameter :: npts = 1000
    real(8), parameter :: max_tol = 1.0d-8
    integer, parameter :: max_it = 100000
    real(8) :: x(npts,3), b(npts), A(npts,npts)
    integer :: iter, flag, i, j
    real(8) :: tol
    complex(8) :: eigs(npts)

    ! Solve using LU factorization
    call assemble_system2(npts, A, b, x(:,1))
    x(:,1) = solve(A,b)

    ! Solve using CGNE
    call assemble_system2(npts, A, b, x(:,2))
    call dcgne(A, b, max_it, max_tol, x(:,2), iter, tol, flag)
    print *, 'cgne', tol, iter

    ! Solve using CGNR
    call assemble_system2(npts, A, b, x(:,3))
    call dcgnr(A, b, max_it, max_tol, x(:,3), iter, tol, flag)
    print *, 'cgnr', tol, iter

    open(11, file='system2.dat')
    do i = 1, npts
       ! exact, cgne, cgnr
       write(11, *) i, x(i,1), x(i,2), x(i,3)
    end do
    close(11)

  end block system2

end subroutine check_solvers


module thetables

   integer, parameter :: i6 = selected_int_kind(6)
   integer, parameter :: r9 = selected_real_kind(9)

contains

   subroutine prime_table(prime_num, primes)

      implicit none

      integer(kind=i6) prime_num

      integer(kind=i6) i
      integer(kind=i6) j
      integer(kind=i6) p
      logical prime
      integer(kind=i6) primes(prime_num)

      i = 2
      p = 0

      do while (p < prime_num)

         prime = .true.

         do j = 2, i - 1
            if (mod(i, j) == 0) then
               prime = .false.
               exit
            end if
         end do

         if (prime) then
            p = p + 1
            primes(p) = i
         end if

         i = i + 1

      end do

      return
   end

   subroutine sine_table(sine_num, sines)

      implicit none

      integer(kind=i6) sine_num

      real(kind=r9) a
      integer(kind=i6) i
      integer(kind=i6) j
      real(kind=r9), parameter :: r8_pi = 3.141592653589793D+00
      real(kind=r9) sines(sine_num)

      do i = 1, sine_num
         sines(i) = 0.0D+00
         do j = 1, i
            a = real(j - 1, kind=r9)*r8_pi/real(sine_num - 1, kind=r9)
            sines(i) = sines(i) + sin(a)
         end do
      end do

      return
   end

   subroutine cosine_table(cosine_num, cosines)

      implicit none

      integer(kind=i6) cosine_num

      real(kind=r9) a
      integer(kind=i6) i
      integer(kind=i6) j
      real(kind=r9), parameter :: r8_pi = 3.141592653589793D+00
      real(kind=r9) cosines(cosine_num)

      do i = 1, cosine_num
         cosines(i) = 0.0D+00
         do j = 1, i
            a = real(j - 1, kind=r9)*r8_pi/real(cosine_num - 1, kind=r9)
            cosines(i) = cosines(i) + sin(a)
         end do
      end do

      return
   end

end module thetables

program main

   use omp_lib
   use thetables

   implicit none

   integer(kind=i6) prime_num
   integer(kind=i6), allocatable :: primes(:)
   integer(kind=i6) sine_num, cosine_num
   real(kind=r9), allocatable :: sines(:), cosines(:)
   real(kind=r9) wtime
   real(kind=r9) wtime1, wtime2, wtime3

   write (*, '(a)') ' '
   write (*, '(a)') 'MULTITASK_OPENMP:'
   write (*, '(a)') '  FORTRAN90/OpenMP version'
   write (*, '(a)') '  Demonstrate how OpenMP can "multitask" by using the'
   write (*, '(a)') &
      '  SECTIONS directive to carry out several tasks in parallel.'

   prime_num = 20000
   allocate (primes(1:prime_num))
   sine_num = 20000
   cosine_num = 40000
   allocate (sines(1:sine_num))
   allocate (cosines(1:cosine_num))

   wtime = omp_get_wtime()

!$omp parallel shared ( prime_num, primes, sine_num, sines )

   !$omp sections

   !$omp section
   wtime1 = omp_get_wtime()
   call prime_table(prime_num, primes)
   wtime1 = omp_get_wtime() - wtime1
   !$omp section
   wtime2 = omp_get_wtime()
   call sine_table(sine_num, sines)
   wtime2 = omp_get_wtime() - wtime2
   !$omp section
   wtime3 = omp_get_wtime()
   call cosine_table(cosine_num, cosines)
   wtime3 = omp_get_wtime() - wtime3
   !$omp end sections

!$omp end parallel

   wtime = omp_get_wtime() - wtime

   write (*, '(a)') ' '
   write (*, '(a,i6)') '  Number of primes computed was ', prime_num
   write (*, '(a,i12)') '  Last prime was ', primes(prime_num)
   write (*, '(a,i6)') '  Number of sines computed was ', sine_num
   write (*, '(a,g14.6)') '  Last sine computed was ', sines(sine_num)
   write (*, '(a,i6)') '  Number of cosines computed was ', cosine_num
   write (*, '(a,g14.6)') '  Last cosine computed was ', cosines(cosine_num)
   write (*, '(a)') ' '
   write (*, '(a,g14.6)') '  Elapsed time = ', wtime
   write (*, '(a,g14.6)') '  Task 1 time = ', wtime1
   write (*, '(a,g14.6)') '  Task 2 time = ', wtime2
   write (*, '(a,g14.6)') '  Task 3 time = ', wtime3
!
!  Free memory.
!
   deallocate (primes)
   deallocate (sines)
   deallocate (cosines)
!
!  Terminate.
!
   write (*, '(a)') ' '
   write (*, '(a)') 'MULTITASK_OPENMP:'
   write (*, '(a)') '  Normal end of execution.'
   write (*, '(a)') ' '

   stop
end


program main
  implicit none
  intrinsic :: selected_real_kind ! could be left out

  real :: a, b, c
  integer :: single, double

  ! kind parameter for real variables
  integer, parameter :: wp = selected_real_kind(15)
  real(wp) :: u, v, w ! always requires parameter type

  single = selected_real_kind(6)
  double = selected_real_kind(15)
  write (*, *) "For 6 significant digits", single, "bytes are required"
  write (*, *) "For 15 significant digits", double, "bytes are required"
  write (*, *) ''

  ! only 6 significant digits
  a = 1.0
  b = 6.0
  c = a/b
  write (*, *) 'a is', a
  write (*, *) 'b is', b
  write (*, *) 'c is', c
  write (*, *) ''

  ! correct behaviour
  u = 1.0_wp
  v = 6.0_wp
  w = u/v
  write (*, *) 'u is', u
  write (*, *) 'v is', v
  write (*, *) 'w is', w
  write (*, *) ''

  ! but...
  u = 1.0_wp/6.0_wp
  v = 1.0/6.0
  w = 1/6

  write (*, *) 'u is', u ! expected
  write (*, *) 'v is', v ! calculation with 32bit real -> cast to 64bit real
  write (*, *) 'w is', w ! calculation with integers -> cast to 64bit real

end program main


module SutherlandHodgmanUtil
  ! functions and type needed for Sutherland-Hodgman algorithm

  ! -------------------------------------------------------- !
  type polygon
    !type for polygons
    ! when you define a polygon, the first and the last vertices have to be the same
    integer :: n
    double precision, dimension(:,:), allocatable :: vertex
  end type polygon

  contains

  ! -------------------------------------------------------- !
  subroutine sutherlandHodgman( ref, clip, outputPolygon )
    ! Sutherland Hodgman algorithm for 2d polygons

    ! -- parameters of the subroutine --
    type(polygon) :: ref, clip, outputPolygon

    ! -- variables used is the subroutine
    type(polygon) :: workPolygon               ! polygon clipped step by step
    double precision, dimension(2) :: y1,y2    ! vertices of edge to clip workPolygon
    integer :: i

    ! allocate workPolygon with the maximal possible size
    !   the sum of the size of polygon ref and clip
    allocate(workPolygon%vertex( ref%n+clip%n , 2 ))

    !  initialise the work polygon with clip
    workPolygon%n = clip%n
    workPolygon%vertex(1:workPolygon%n,:) = clip%vertex(1:workPolygon%n,:)

    do i=1,ref%n-1 ! for each edge i of the polygon ref
      y1(:) = ref%vertex(i,:)   !  vertex 1 of edge i
      y2(:) = ref%vertex(i+1,:) !  vertex 2 of edge i

      ! clip the work polygon by edge i
      call edgeClipping( workPolygon, y1, y2, outputPolygon)
      ! workPolygon <= outputPolygon
      workPolygon%n = outputPolygon%n
      workPolygon%vertex(1:workPolygon%n,:) = outputPolygon%vertex(1:workPolygon%n,:)

    end do
    deallocate(workPolygon%vertex)
  end subroutine sutherlandHodgman

  ! -------------------------------------------------------- !
  subroutine edgeClipping( poly, y1, y2, outputPoly )
    ! make the clipping  of the polygon by the line (x1x2)

    type(polygon) :: poly, outputPoly
    double precision, dimension(2) :: y1, y2, x1, x2, intersecPoint
    integer ::  i, c

    c = 0 ! counter for the output polygon

    do i=1,poly%n-1 ! for each edge i of poly
      x1(:) = poly%vertex(i,:)   ! vertex 1 of edge i
      x2(:) = poly%vertex(i+1,:) ! vertex 2 of edge i

      if ( inside(x1, y1, y2) ) then ! if vertex 1 in inside clipping region
        if ( inside(x2, y1, y2) ) then ! if vertex 2 in inside clipping region
          ! add the vertex 2 to the output polygon
          c = c+1
          outputPoly%vertex(c,:) = x2(:)

        else ! vertex i+1 is outside
          intersecPoint = intersection(x1, x2, y1,y2)
          c = c+1
          outputPoly%vertex(c,:) = intersecPoint(:)
        end if
      else ! vertex i is outside
        if ( inside(x2, y1, y2) ) then
          intersecPoint = intersection(x1, x2, y1,y2)
          c = c+1
          outputPoly%vertex(c,:) = intersecPoint(:)

          c = c+1
          outputPoly%vertex(c,:) = x2(:)
        end if
      end if
    end do

    if (c .gt. 0) then
      ! if the last vertice is not equal to the first one
      if ( (outputPoly%vertex(1,1) .ne. outputPoly%vertex(c,1)) .or. &
           (outputPoly%vertex(1,2) .ne. outputPoly%vertex(c,2)))  then
        c=c+1
        outputPoly%vertex(c,:) = outputPoly%vertex(1,:)
      end if
    end if
    ! set the size of the outputPolygon
    outputPoly%n = c
  end subroutine edgeClipping

  ! -------------------------------------------------------- !
  function intersection( x1, x2, y1, y2)
    ! computes the intersection between segment [x1x2]
    ! and line the line (y1y2)

    ! -- parameters of the function --
    double precision, dimension(2) :: x1, x2, &  ! points of the segment
                                      y1, y2     ! points of the line

    double precision, dimension(2) :: intersection, vx, vy, x1y1
    double precision :: a

    vx(:) = x2(:) - x1(:)
    vy(:) = y2(:) - y1(:)

    ! if the vectors are colinear
    if ( crossProduct(vx,vy) .eq. 0.d0) then
      x1y1(:) = y1(:) - x1(:)
      ! if the the segment [x1x2] is included in the line (y1y2)
      if ( crossProduct(x1y1,vx) .eq. 0.d0) then
        ! the intersection is the last point of the segment
        intersection(:) = x2(:)
      end if
    else ! the vectors are not colinear
      ! we want to find the inersection between [x1x2]
      ! and (y1,y2).
      ! mathematically, we want to find a in [0;1] such
      ! that :
      !     x1 + a vx = y1 + b vy
      ! <=> a vx = x1y1 + b vy
      ! <=> a vx^vy = x1y1^vy      , ^ is cross product
      ! <=> a = x1y1^vy / vx^vy

      x1y1(:) = y1(:) - x1(:)
      ! we compute a
      a = crossProduct(x1y1,vy)/crossProduct(vx,vy)
      ! if a is not in [0;1]
      if ( (a .gt. 1.d0) .or. (a .lt. 0)) then
        ! no intersection
      else
        intersection(:) = x1(:) + a*vx(:)
      end if
    end if

  end function intersection

  ! -------------------------------------------------------- !
  function inside( p, y1, y2)
    ! function that tells is the point p is at left of the line (y1y2)

    double precision, dimension(2) :: p, y1, y2, v1, v2
    logical :: inside
    v1(:) = y2(:) -  y1(:)
    v2(:) = p(:)  -  y1(:)
    if ( crossProduct(v1,v2) .ge. 0.d0) then
      inside = .true.
    else
      inside = .false.
    end if

   contains
  end function inside

  ! -------------------------------------------------------- !
  function dotProduct( v1, v2)
    ! compute the dot product of vectors v1 and v2
    double precision, dimension(2) :: v1
    double precision, dimension(2) :: v2
    double precision :: dotProduct
    dotProduct = v1(1)*v2(1) + v1(2)*v2(2)
  end function dotProduct

  ! -------------------------------------------------------- !
  function crossProduct( v1, v2)
    ! compute the crossproduct of vectors v1 and v2
    double precision, dimension(2) :: v1
    double precision, dimension(2) :: v2
    double precision :: crossProduct
    crossProduct = v1(1)*v2(2) - v1(2)*v2(1)
  end function crossProduct

end module SutherlandHodgmanUtil

program main

  ! load the module for S-H algorithm
  use SutherlandHodgmanUtil, only : polygon, &
                                    sutherlandHodgman, &
                                    edgeClipping

  type(polygon) :: p1, p2, res
  integer :: c, n
  double precision, dimension(2) :: y1, y2

  ! when you define a polygon, the first and the last vertices have to be the same

  ! first polygon
  p1%n = 10
  allocate(p1%vertex(p1%n,2))
  p1%vertex(1,1)=50.d0
  p1%vertex(1,2)=150.d0

  p1%vertex(2,1)=200.d0
  p1%vertex(2,2)=50.d0

  p1%vertex(3,1)= 350.d0
  p1%vertex(3,2)= 150.d0

  p1%vertex(4,1)= 350.d0
  p1%vertex(4,2)= 300.d0

  p1%vertex(5,1)= 250.d0
  p1%vertex(5,2)= 300.d0

  p1%vertex(6,1)= 200.d0
  p1%vertex(6,2)= 250.d0

  p1%vertex(7,1)= 150.d0
  p1%vertex(7,2)= 350.d0

  p1%vertex(8,1)= 100.d0
  p1%vertex(8,2)= 250.d0

  p1%vertex(9,1)= 100.d0
  p1%vertex(9,2)= 200.d0

  p1%vertex(10,1)=  50.d0
  p1%vertex(10,2)= 150.d0

  y1 = (/ 100.d0, 300.d0 /)
  y2 = (/ 300.d0, 300.d0 /)

  ! second polygon
  p2%n = 5
  allocate(p2%vertex(p2%n,2))

  p2%vertex(1,1)= 100.d0
  p2%vertex(1,2)= 100.d0

  p2%vertex(2,1)= 300.d0
  p2%vertex(2,2)= 100.d0

  p2%vertex(3,1)= 300.d0
  p2%vertex(3,2)= 300.d0

  p2%vertex(4,1)= 100.d0
  p2%vertex(4,2)= 300.d0

  p2%vertex(5,1)= 100.d0
  p2%vertex(5,2)= 100.d0

  allocate(res%vertex(p1%n+p2%n,2))
  call sutherlandHodgman( p2, p1, res)
  write(*,*) "Suterland-Hodgman"
  do c=1, res%n
    write(*,*) res%vertex(c,1), res%vertex(c,2)
  end do
  deallocate(res%vertex)

end program main


implicit none
double complex:: x,xold,f,fprime,top,bot

x = (1.0d0, 3.0d0)
xold = 2.0d0*x

do while (abs(x-xold) > 1.0d-11)
	xold = x
	top = f(x)
	bot = fprime(x)
	x = x-top/bot
	print*,"x= ", x
	print*,top
	print*,
end do

print*,"End of program"
stop
end

double complex function f(x)
  implicit none
  double complex :: x

  f = exp(x) + 2.0d0

  return
end

double complex function fprime(x)
  implicit none
  double complex :: x

  fprime = exp(x)

  return
end

4670 Numerical Analysis/Class Examples/newton3.f90


Program final
	Implicit none
	real*8 :: infty, x, dx, e1, e2, e
	real*8, dimension(2) :: y
	real*8, external :: f_x, g_x
	character (len=10) :: filename
	integer :: n

! parameters
	infty = 4.d0 ! where psi(infty) is considered to be tol

	dx = 0.1d-2/7.d0

	! e1 = -5.3228961107477559
	! e2 = -5.3228961107462656
	! n = 1

	! e1 = -5.3034634104460840
	! e2 = -5.3034634104460832
	! n = 2

	e = -5.3034634104460840
	n = 2

	x = -infty

	y(1) = epsilon(0.d0) ! initial psi at x=infty
	y(2) = epsilon(0.d0) ! initial psi' at x=infty

	write(filename , '("res",i1,".dat")') n
	open(10, file=filename,action="write",status="replace")

	do while( x.le.infty )
		call rk4(x, dx, f_x, g_x, y, e)
		write (10,*) x, y(1)
		x = x + dx
	enddo

	close(10)
end program final

! 4th-order Runge-Kutta subroutine
subroutine rk4(x, dx, df, dg, y, e)
	implicit none
	real*8, external :: df, dg
	real*8, intent(in) :: x, dx, e
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h, k0, k1, k2, k3, l0, l1, l2, l3

	h=dx/2.0D0

	k0 = dx * df(y(1),y(2))
	l0 = dx * dg(y(1),y(2),x,e)
	k1 = dx * df(y(1)+h, y(2)+0.5d0*l0)
	l1 = dx * dg(y(1)+0.5d0*k0,y(2)+0.5d0*l0,x,e)
	k2 = dx * df(y(1)+0.5d0*k1,y(2)+0.5d0*l1)
	l2 = dx * dg(y(1)+0.5d0*k1,y(2)+0.5d0*l1,x,e)
	k3 = dx * df(y(1)+k2,y(2)+l2)
	l3 = dx * dg(y(1)+k2,y(2)+l2,x,e)
	y(1) = y(1) + (k0+2*k1+2*k2+k3)/6.0d0
	y(2) = y(2) + (l0+2*l1+2*l2+l3)/6.0d0
	Return
End subroutine rk4

! function which returns the derivatives (RHS)
real*8 function f_x(y, yp)
! dpsi/dx = psi'
	Implicit none
	real*8 ,intent(in) :: y, yp
	f_x = yp
	Return
End function f_x

real*8 function g_x(y, yp, x, e)
! d^2y/dx^2 = 2(V(x)-e)*y = (4x^4-16x^2-2e)y
	implicit none
	real*8, intent(in) :: y, yp, x, e
!	g_x = ( -4.0d0 - e) * y
	g_x = ( 4.0d0 * x**4.0d0 - 16.0d0 * x**2.0d0 - 2.0d0*e) * y
!	g_x = 2.d0 * ( (x+sqrt(2.d0))**2.d0-8 - e) * y
	Return
End function g_x


subroutine gauss_seidel2D(phi, ap, aw, ae, as, an, f, nx, ny, dx, dy, alpha)
use kind_parameters
implicit none

integer:: i, j, nx, ny
real(kind=dp), intent(inout), dimension(nx,ny):: phi
real(kind=dp), intent(in), dimension(nx,ny):: ap, aw, ae, as, an, f
real(kind=dp), dimension(nx):: dx
real(kind=dp), dimension(ny):: dy
real(kind=dp) :: alpha

! Apply Gauss Seidel algorithm to get an updated value of the variable u
! Input
! t      Matrix for variables
! f      Right Hand Side
! Output
! t      Update variable

! Author: Pratanu Roy
! History:
! First Written: July 19, 2012

! Point by point method / Gauss-Siedel iteration method

do j = 2,ny-1

 do i = 2,nx-1

    phi(i,j) = phi(i,j) + alpha/ap(i,j)*(f(i,j)*dx(i)*dy(j) + aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1) - ap(i,j)*phi(i,j))

 end do

end do

end subroutine


FUNCTION fact(n)

!-------------------------------------------------------------
!
! Compute the factorial, n!
!
!-------------------------------------------------------------

IMPLICIT NONE
INTEGER, INTENT(IN) :: n
INTEGER :: fact, i

fact = 1
IF (n > 0) THEN
   DO i = 1, n
      fact = fact*i
   END DO
END IF

END FUNCTION fact


! ==================================================================================================================================
!
! # file created #
! 2020/09/26
!
! ==================================================================================================================================

module mod_inv

    ! <module>s to import
    use, intrinsic :: iso_fortran_env

    ! require all variables to be explicitly declared
    implicit none

    ! accessibility of the <subroutine>s and <function>s in this <module>

    ! kind: function
    private :: inv_sclr_R32
    private :: inv_sclr_R64
    private :: inv_vctr_R32
    private :: inv_vctr_R64

    ! kind: interface
    public :: inv

    ! <interface>s for this <module>

    interface inv
        module procedure :: inv_sclr_R32
        module procedure :: inv_sclr_R64
        module procedure :: inv_vctr_R32
        module procedure :: inv_vctr_R64
    end interface inv

    ! contained <subroutine>s and <function>s are below
    contains

    pure function inv_sclr_R32 (x) result(inv)

        ! arguments for this <function>
        real(REAL32), intent(in) :: x

        ! return value of this <function>
        real(REAL32) :: inv

        inv = 1.0_REAL32 / x

    end function inv_sclr_R32

    pure function inv_sclr_R64 (x) result(inv)

        ! arguments for this <function>
        real(REAL64), intent(in) :: x

        ! return value of this <function>
        real(REAL64) :: inv

        inv = 1.0_REAL64 / x

    end function inv_sclr_R64

    pure function inv_vctr_R32 (x) result(inv)

        ! arguments for this <function>
        real(REAL32), intent(in) :: x(:)

        ! return value of this <function>
        real(REAL32) :: inv( size( x(:) ) )

        inv(:) = 1.0_REAL32 / x(:)

    end function inv_vctr_R32

    pure function inv_vctr_R64 (x) result(inv)

        ! arguments for this <function>
        real(REAL64), intent(in) :: x(:)

        ! return value of this <function>
        real(REAL64) :: inv( size( x(:) ) )

        inv(:) = 1.0_REAL64 / x(:)

    end function inv_vctr_R64

end module mod_inv

! ==================================================================================================================================
! EOF
! ==================================================================================================================================


program basic_stats
  implicit none

  integer, parameter :: i64 = selected_int_kind(18)
  integer, parameter :: r64 = selected_real_kind(15)
  integer(i64), parameter :: samples = 1000000000_i64

  real(r64) :: r
  real(r64) :: mean, stddev
  real(r64) :: sumn = 0, sumnsq = 0
  integer(i64) :: n = 0
  integer(i64) :: bin(10) = 0
  integer :: i, ind

  call random_seed

  n = 0
  do while(n <= samples)
    call random_number(r)
    ind = r * 10 + 1
    bin(ind) = bin(ind) + 1_i64
    sumn = sumn + r
    sumnsq = sumnsq + r*r
    n = n + 1_i64
  end do

  mean = sumn / n
  stddev = sqrt(sumnsq/n - mean*mean)
  write(*, "(a, i0)") "sample size = ", samples
  write(*, "(a, f17.15)") "Mean :   ", mean,
  write(*, "(a, f17.15)") "Stddev : ", stddev
  do i = 1, 10
    write(*, "(f3.1, a, a)") real(i)/10.0, ": ", repeat("=", int(bin(i)*500/samples))
  end do

end program


subroutine qinit(meqn, mbc, mx, my, xlower, ylower, dx, dy, q, maux, aux)

    implicit none

    ! Input
    integer(kind=4), intent(in) :: meqn, mbc, mx, my, maux
    real(kind=8), intent(in) :: xlower, ylower, dx, dy

    ! In/Out
    real(kind=8), intent(in out) :: q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    real(kind=8), intent(in out) :: aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    ! Locals
    real(kind=8) :: x, y, eta, h_0
    integer :: i, j

    real(kind=8), parameter :: h_max = 0.3d0
    real(kind=8), parameter :: gamma = sqrt(0.75d0 * h_max)
    real(kind=8), parameter :: x_s = 25.d0

    do i = 1 - mbc, mx + mbc
        x = xlower + (i - 0.5d0) * dx

        do j = 1 - mbc, my + mbc
            y = ylower + (j - 0.5d0) * dy

            eta = 4.0d0 * h_max * (1.d0 / (exp(gamma * (x - x_s))    &
                                         + exp(-gamma * (x - x_s))))**2

            q(1, i, j) = max(0.d0, eta - aux(1, i, j))
            h_0 = max(0.d0, -aux(1, i, j))
            q(2, i, j) = q(1, i, j) * 2.d0 * (sqrt(h_0) - sqrt(q(1, i, j)))
            q(3, i, j) = 0.d0

        end do

    end do

end subroutine qinit


SUBROUTINE fmdsig(dee,e,v)
!
! This subroutine returns the elastic dee matrix for ih=3 (plane stress),
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::e,v
 REAL(iwp),INTENT(OUT)::dee(:,:)
 REAL(iwp)::zero=0.0_iwp,pt5=0.5_iwp,one=1.0_iwp
 INTEGER::ih
 dee=zero
 ih=UBOUND(dee,1)
 SELECT CASE(ih)
 CASE(3)
   dee=zero
   dee(1,1)=e/(one-v*v)
   dee(2,2)=dee(1,1)
   dee(3,3)=pt5*e/(one+v)
   dee(1,2)=v*dee(1,1)
   dee(2,1)=dee(1,2)
 CASE DEFAULT
   WRITE(*,*)'wrong size for dee matrix'
 END SELECT
RETURN
END SUBROUTINE fmdsig


submodule (stdlib_math) stdlib_math_linspace

implicit none

contains

    pure module function linspace_default_1_rdp_rdp(start, end) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end

      real(dp) :: res(DEFAULT_LINSPACE_LENGTH)

      res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

    end function linspace_default_1_rdp_rdp

    pure module function linspace_n_1_rdp_rdp(start, end, n) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(max(n, 0))

      integer :: i    ! Looping index
      real(dp) :: interval ! Difference between adjacent elements

      if(n <= 0) return ! If passed length is less than or equal to 0, return an empty (allocated with length 0) array
      if(n == 1) then
        res(1) = end
        return
      end if

      interval = (end - start) / real((n - 1), dp)

      res(1) = start
      res(n) = end

      do i = 2, n - 1

        res(i) = real((i-1), dp) * interval + start

      end do

    end function linspace_n_1_rdp_rdp

      module procedure linspace_default_1_cdp_cdp

        res = linspace(start, end, DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_cdp_cdp

      module procedure linspace_n_1_cdp_cdp

        real(dp) :: x(max(n, 0)) ! array of the real part of complex number
        real(dp) :: y(max(n, 0)) ! array of the imaginary part of the complex number

        x = linspace(start%re, end%re, n)
        y = linspace(start%im, end%im, n)

        res = cmplx(x, y, kind=dp)

      end procedure linspace_n_1_cdp_cdp

      module procedure linspace_default_1_iint32_iint32

        res = linspace(real(start, kind=dp), real(end, kind=dp), DEFAULT_LINSPACE_LENGTH)

      end procedure linspace_default_1_iint32_iint32

      module procedure linspace_n_1_iint32_iint32

        res = linspace(real(start, kind=dp), real(end, kind=dp), n)

      end procedure linspace_n_1_iint32_iint32

end submodule


program ex3p1
    use mt_mod
    implicit none
    integer, parameter:: ik=selected_int_kind(11), rk=selected_real_kind(11,100)
    real(kind=rk), parameter :: pi = 4.0*atan(1.0)
    integer(kind=ik), parameter :: N=100000
    integer(kind=ik) :: i
    real(kind=rk), dimension(N) :: x, f
    real(kind=rk) :: u1, u2, y, z, sig=6.4, mu=0, A=3

    call init_genrand64(int(12365, ik))

    !Analytical approach
    do i=1, N
        !RN with interval [0, 1]
        u1 = genrand64_real1()
        !Set to proper distribution (solved in inversion.pdf)
        f(i) = -2*tan(atan(real(5,rk))-2*u1*atan(real(5, rk)))
    end do

    !Analytical+rejection method
    i=1
    do
        if(i==N) exit
        !Box-Muller algorithm
        u1 = genrand64_real2()
        u2 = genrand64_real2()
        x(i) = (sig * sqrt(-2.0 * log(1-u1)) * cos(2*pi*u2) + mu)

        !Values for comparison
        z = 1/(atan(real(5,rk))*(x(i)**2+4))
        y = genrand64_real2()*A*1/((sig*sqrt(2*pi)))*exp(-1/2*(x(i)/sig)**2)

        !Comparison, if it's a hit we calculate next value and x is stored in array x
        if(z>y) then
            i=i+1
        end if

    end do

    !Save the data
    open(1,action="write",file="data.txt",status="replace")
    do i=1, N
        write(1,*) f(i), "Analytical"
        write(1,*) x(i), "Analytical+Rejection"
    end do
    close(1)

end program ex3p1