C     LAST UPDATE 18/03/96
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE FDEXP(X,A,Y,DYDA)
      IMPLICIT NONE
C
C Purpose: Y(X;A) is double exponential. The amplitude. centre and widths
C          of the double exponential are stored in consecutive locations
C          of A:
C          A(1) = B,  A(2) = E,  A(3) = G1, A(4) = G2
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Parameters:
C
      DOUBLE PRECISION TINY
      PARAMETER(TINY=1.0D-10)
C
C Arguments:
C
      DOUBLE PRECISION A(10),DYDA(10)
      DOUBLE PRECISION X,Y
C
C Local variables:
C
      DOUBLE PRECISION  ARG1,ARG2,EX1,EX2,FAC
C
C-----------------------------------------------------------------------
      IF(A(3).LT.TINY)A(3) = TINY
      IF(A(4).LT.TINY)A(4) = TINY
      ARG1 = (X-A(2))/A(3)
      ARG2 = (X-A(2))/A(4)
      EX1 = EXP(-ARG1)
      EX2 = EXP(ARG2)
      FAC = EX1 + EX2
      Y = 2.0D0*A(1)/FAC
      DYDA(1) = 2.0D0/FAC
      DYDA(2) = Y*(EX2/A(4)-EX1/A(3))/FAC
      DYDA(3) = -Y*ARG1*EX1/(FAC*A(3))
      DYDA(4) = Y*ARG2*EX2/(FAC*A(4))
C
      RETURN
      END


program problem_14
    implicit none
    integer:: collatzSequence
    integer(kind = 8):: longest, i, current, longest_start

    longest = 0

    do i = 999999, 2, -1
        current = collatzSequence(i)
        if (current > longest) then
            longest = current
            longest_start = i
        endif
    enddo

    print *, longest_start

end program problem_14

integer function collatzSequence(number)
    implicit none
    integer(kind=8):: number, current
    integer:: count
    count = 0
    current = number

    do while (current .NE. 1)
        if (modulo(current, 2) .EQ. 0) then
            current = current / 2
        else
            current = (3 * current) + 1
        endif
        count = count + 1
    enddo

    collatzSequence = count + 1
    return

end function collatzSequence


!Array Two Dimension

program Array_Two_D
    implicit none
    INTEGER :: i, j
    INTEGER :: matA(2, 2) !Matrix of  2 X 2
    INTEGER :: matB(2, 3) !Matrix of  2 X 3

    !Assigning value to 2 D Array
    matA(1, 1) = 1
    matA(1, 2) = 2
    matA(2, 1) = 3
    matA(2, 2) = 4

    !Next method of assigning
    matB = reshape((/100, 200, 300, 400, 500, 600/), (/2, 3/))

    !Printing value of Two D array
    print *, "Method One MATRIX A"
    do i = 1, 2
        do j = 1, 2
            print *, matA(i, j)
        end do
    end do

    !Next way of printing 2 d array
    print *, "Method Two MATRIX B"
    do i = 1, 2
        print *, (matB(i, j), j=1, 3)
    end do

end program Array_Two_D


C     SUBROUTINE SVDRS (A, MDA, M1, N1, B, MDB, NB, S, WORK)
C
C  SINGULAR VALUE DECOMPOSITION ALSO TREATING RIGHT SIDE VECTOR.
C
C  The original version of this code was developed by
C  Charles L. Lawson and Richard J. Hanson at Jet Propulsion Laboratory
C  1974 SEP 25, and published in the book
C  "SOLVING LEAST SQUARES PROBLEMS", Prentice-HalL, 1974.
C  Revised FEB 1995 to accompany reprinting of the book by SIAM.
C     ------------------------------------------------------------------
C  This 1995 version differs from the original 1974 version by adding
C  the argument WORK().
C  WORK() provides 2*N1 locations of work space.  Originally S() was
C  required to have 3*N1 elements, of which the last 2*N1 were used for
C  work space.  Now S() only needs N1 elements.
C     ------------------------------------------------------------------
C  This subroutine computes the singular value decomposition of the
C  given M1 x N1 matrix, A, and optionally applys the transformations
C  from the left to the NB column vectors of the M1 x NB matrix B.
C  Either M1 .ge. N1  or  M1 .lt. N1 is permitted.
C
C       The singular value decomposition of A is of the form
C
C                  A  =  U * S * V**t
C
C  where U is M1 x M1 orthogonal, S is M1 x N1 diagonal with the
C  diagonal terms nonnegative and ordered from large to small, and
C  V is N1 x N1 orthogonal.  Note that these matrices also satisfy
C
C                  S = (U**t) * A * V
C
C       The matrix V is returned in the leading N1 rows and
C  columns of the array A(,).
C
C       The singular values, i.e. the diagonal terms of the matrix S,
C  are returned in the array S().  If M1 .lt. N1, positions M1+1
C  through N1 of S() will be set to zero.
C
C       The product matrix  G = U**t * B replaces the given matrix B
C  in the array B(,).
C
C       If the user wishes to obtain a minimum length least squares
C  solution of the linear system
C
C                        A * X ~=~ B
C
C  the solution X can be constructed, following use of this subroutine,
C  by computing the sum for i = 1, ..., R of the outer products
C
C          (Col i of V) * (1/S(i)) * (Row i of G)
C
C  Here R denotes the pseudorank of A which the user may choose
C  in the range 0 through Min(M1, N1) based on the sizes of the
C  singular values.
C     ------------------------------------------------------------------
C                    Subroutine Arguments
C
C  A(,)     (In/Out)  On input contains the M1 x N1 matrix A.
C           On output contains the N1 x N1 matrix V.
C
C  LDA      (In)  First dimensioning parameter for A(,).
C           Require LDA .ge. Max(M1, N1).
C
C  M1       (In)  No. of rows of matrices A, B, and G.
C           Require M1 > 0.
C
C  N1       (In)  No. of cols of matrix A, No. of rows and cols of
C           matrix V.  Permit M1 .ge. N1  or  M1 .lt. N1.
C           Require N1 > 0.
C
C  B(,)     (In/Out)  If NB .gt. 0 this array must contain an
C           M1 x NB matrix on input and will contain the
C           M1 x NB product matrix, G = (U**t) * B on output.
C
C  LDB      (In)  First dimensioning parameter for B(,).
C           Require LDB .ge. M1.
C
C  NB       (In)  No. of cols in the matrices B and G.
C           Require NB .ge. 0.
C
C  S()      (Out)  Must be dimensioned at least N1.  On return will
C           contain the singular values of A, with the ordering
C                S(1) .ge. S(2) .ge. ... .ge. S(N1) .ge. 0.
C           If M1 .lt. N1 the singular values indexed from M1+1
C           through N1 will be zero.
C           If the given integer arguments are not consistent, this
C           subroutine will return immediately, setting S(1) = -1.0.
C
C  WORK()  (Scratch)  Work space of total size at least 2*N1.
C           Locations 1 thru N1 will hold the off-diagonal terms of
C           the bidiagonal matrix for subroutine QRBD.  Locations N1+1
C           thru 2*N1 will save info from one call to the next of
C           H12.
C     ------------------------------------------------------------------
C  This code gives special treatment to rows and columns that are
C  entirely zero.  This causes certain zero sing. vals. to appear as
C  exact zeros rather than as about MACHEPS times the largest sing. val.
C  It similarly cleans up the associated columns of U and V.
C
C  METHOD..
C   1. EXCHANGE COLS OF A TO PACK NONZERO COLS TO THE LEFT.
C      SET N = NO. OF NONZERO COLS.
C      USE LOCATIONS A(1,N1),A(1,N1-1),...,A(1,N+1) TO RECORD THE
C      COL PERMUTATIONS.
C   2. EXCHANGE ROWS OF A TO PACK NONZERO ROWS TO THE TOP.
C      QUIT PACKING IF FIND N NONZERO ROWS.  MAKE SAME ROW EXCHANGES
C      IN B.  SET M SO THAT ALL NONZERO ROWS OF THE PERMUTED A
C      ARE IN FIRST M ROWS.  IF M .LE. N THEN ALL M ROWS ARE
C      NONZERO.  IF M .GT. N THEN      THE FIRST N ROWS ARE KNOWN
C      TO BE NONZERO,AND ROWS N+1 THRU M MAY BE ZERO OR NONZERO.
C   3. APPLY ORIGINAL ALGORITHM TO THE M BY N PROBLEM.
C   4. MOVE PERMUTATION RECORD FROM A(,) TO S(I),I=N+1,...,N1.
C   5. BUILD V UP FROM  N BY N  TO  N1 BY N1  BY PLACING ONES ON
C      THE DIAGONAL AND ZEROS ELSEWHERE.  THIS IS ONLY PARTLY DONE
C      EXPLICITLY.  IT IS COMPLETED DURING STEP 6.
C   6. EXCHANGE ROWS OF V TO COMPENSATE FOR COL EXCHANGES OF STEP 2.
C   7. PLACE ZEROS IN  S(I),I=N+1,N1  TO REPRESENT ZERO SING VALS.
C     ------------------------------------------------------------------
      subroutine SVDRS (A, MDA, M1, N1, B, MDB, NB, S, WORK)
      integer I, IPASS, J, K, L, M, MDA, MDB, M1
      integer N, NB, N1, NP1, NS, NSP1
C     double precision A(MDA,N1),B(MDB,NB), S(N1)
      double precision A(MDA, *),B(MDB, *), S( *)
      double precision ONE, T, WORK(N1,2), ZERO
      parameter(ONE = 1.0d0, ZERO = 0.0d0)
C     -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
C                             BEGIN.. SPECIAL FOR ZERO ROWS AND COLS.
C
C                             PACK THE NONZERO COLS TO THE LEFT
C
      N=N1
      IF (N.LE.0.OR.M1.LE.0) RETURN
      J=N
   10 CONTINUE
         DO 20 I=1,M1
            IF (A(I,J) .ne. ZERO) go to 50
   20    CONTINUE
C
C           COL J  IS ZERO. EXCHANGE IT WITH COL N.
C
         IF (J .ne. N) then
            DO 30 I=1,M1
   30       A(I,J)=A(I,N)
         endif
         A(1,N)=J
         N=N-1
   50    CONTINUE
         J=J-1
      IF (J.GE.1) GO TO 10
C                             IF N=0 THEN A IS ENTIRELY ZERO AND SVD
C                             COMPUTATION CAN BE SKIPPED
      NS=0
      IF (N.EQ.0) GO TO 240
C                             PACK NONZERO ROWS TO THE TOP
C                             QUIT PACKING IF FIND N NONZERO ROWS
      I=1
      M=M1
   60 IF (I.GT.N.OR.I.GE.M) GO TO 150
      IF (A(I,I)) 90,70,90
   70     DO 80 J=1,N
          IF (A(I,J)) 90,80,90
   80     CONTINUE
      GO TO 100
   90 I=I+1
      GO TO 60
C                             ROW I IS ZERO
C                             EXCHANGE ROWS I AND M
  100 IF(NB.LE.0) GO TO 115
          DO 110 J=1,NB
          T=B(I,J)
          B(I,J)=B(M,J)
  110     B(M,J)=T
  115     DO 120 J=1,N
  120     A(I,J)=A(M,J)
      IF (M.GT.N) GO TO 140
          DO 130 J=1,N
  130     A(M,J)=ZERO
  140 CONTINUE
C                             EXCHANGE IS FINISHED
      M=M-1
      GO TO 60
C
  150 CONTINUE
C                             END.. SPECIAL FOR ZERO ROWS AND COLUMNS
C                             BEGIN.. SVD ALGORITHM
C     METHOD..
C     (1)     REDUCE THE MATRIX TO UPPER BIDIAGONAL FORM WITH
C     HOUSEHOLDER TRANSFORMATIONS.
C          H(N)...H(1)AQ(1)...Q(N-2) = (D**T,0)**T
C     WHERE D IS UPPER BIDIAGONAL.
C
C     (2)     APPLY H(N)...H(1) TO B.  HERE H(N)...H(1)*B REPLACES B
C     IN STORAGE.
C
C     (3)     THE MATRIX PRODUCT W= Q(1)...Q(N-2) OVERWRITES THE FIRST
C     N ROWS OF A IN STORAGE.
C
C     (4)     AN SVD FOR D IS COMPUTED.  HERE K ROTATIONS RI AND PI ARE
C     COMPUTED SO THAT
C          RK...R1*D*P1**(T)...PK**(T) = DIAG(S1,...,SM)
C     TO WORKING ACCURACY.  THE SI ARE NONNEGATIVE AND NONINCREASING.
C     HERE RK...R1*B OVERWRITES B IN STORAGE WHILE
C     A*P1**(T)...PK**(T)  OVERWRITES A IN STORAGE.
C
C     (5)     IT FOLLOWS THAT,WITH THE PROPER DEFINITIONS,
C     U**(T)*B OVERWRITES B, WHILE V OVERWRITES THE FIRST N ROW AND
C     COLUMNS OF A.
C
      L=min(M,N)
C             THE FOLLOWING LOOP REDUCES A TO UPPER BIDIAGONAL AND
C             ALSO APPLIES THE PREMULTIPLYING TRANSFORMATIONS TO B.
C
          DO 170 J=1,L
          IF (J.GE.M) GO TO 160
          CALL H12 (1,J,J+1,M,A(1,J),1,T,A(1,J+1),1,MDA,N-J)
          CALL H12 (2,J,J+1,M,A(1,J),1,T,B,1,MDB,NB)
  160     IF (J.GE.N-1) GO TO 170
          CALL H12 (1,J+1,J+2,N,A(J,1),MDA,work(J,2),A(J+1,1),MDA,1,M-J)
  170     CONTINUE
C
C     COPY THE BIDIAGONAL MATRIX INTO S() and WORK() FOR QRBD.
C 1986 Jan 8. C. L. Lawson. Changed N to L in following 2 statements.
      IF (L.EQ.1) GO TO 190
          DO 180 J=2,L
          S(J)=A(J,J)
  180     WORK(J,1)=A(J-1,J)
  190 S(1)=A(1,1)
C
      NS=N
      IF (M.GE.N) GO TO 200
      NS=M+1
      S(NS)=ZERO
      WORK(NS,1)=A(M,M+1)
  200 CONTINUE
C
C     CONSTRUCT THE EXPLICIT N BY N PRODUCT MATRIX, W=Q1*Q2*...*QL*I
C     IN THE ARRAY A().
C
          DO 230 K=1,N
          I=N+1-K
          IF (I .GT. min(M,N-2)) GO TO 210
          CALL H12 (2,I+1,I+2,N,A(I,1),MDA,WORK(I,2),A(1,I+1),1,MDA,N-I)
  210         DO 220 J=1,N
  220         A(I,J)=ZERO
  230     A(I,I)=ONE
C
C          COMPUTE THE SVD OF THE BIDIAGONAL MATRIX
C
      CALL QRBD (IPASS,S(1),WORK(1,1),NS,A,MDA,N,B,MDB,NB)
C
      if(IPASS .eq. 2) then
         write (*,'(/a)')
     *      ' FULL ACCURACY NOT ATTAINED IN BIDIAGONAL SVD'
      endif

  240 CONTINUE
      IF (NS.GE.N) GO TO 260
      NSP1=NS+1
          DO 250 J=NSP1,N
  250     S(J)=ZERO
  260 CONTINUE
      IF (N.EQ.N1) RETURN
      NP1=N+1
C                                  MOVE RECORD OF PERMUTATIONS
C                                  AND STORE ZEROS
          DO 280 J=NP1,N1
          S(J)=A(1,J)
              DO 270 I=1,N
  270         A(I,J)=ZERO
  280     CONTINUE
C                             PERMUTE ROWS AND SET ZERO SINGULAR VALUES.
          DO 300 K=NP1,N1
          I=S(K)
          S(K)=ZERO
              DO 290 J=1,N1
              A(K,J)=A(I,J)
  290         A(I,J)=ZERO
          A(I,K)=ONE
  300     CONTINUE
C                             END.. SPECIAL FOR ZERO ROWS AND COLUMNS
      RETURN
      END


RECURSIVE FUNCTION fact(n) RESULT (fact_n)
  IMPLICIT none
  real :: fact_n
  integer, intent (in) :: n
  select case(n)
  case(0)
     fact_n=1.0
  case(1:)
     fact_n=n*fact(n-1)
  case default
     fact_n=0.0
  end select
end function fact

program main
  if(fact(6).EQ.720) then
     print *, "OK"
  else
     print *, fact(6)," should be 720"
  end if
end program main


 subroutine linear_interpolation( &
    xa, ya, na, xb, yb, nb)

!-----------------------------------------------------------
! Subroutine:
!   linear_interpolation
!
! Input:
!   na
!   nb
!   array xa, ya
!   array xb
!
! Output:
!   array yb
!-----------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: na, nb

  real(kind=dp),intent(in):: &
    xa(na), &
    ya(na), &
    xb(nb)

  real(kind=dp),intent(out):: &
    yb(nb)

  integer:: i, j, j0

  j0 = 2
  do i = 1, nb
     do j = j0, na
        if(xb(i).lt.xa(j))then
           yb(i) = ya(j-1) + (xb(i)-xa(j-1))/(xa(j)-xa(j-1)) * &
                               (ya(j)-ya(j-1))
           j0 = j
           goto 110
        endif
     enddo
     j = na
     yb(i) = ya(j-1) + (xb(i)-xa(j-1))/(xa(j)-xa(j-1))*(ya(j)-ya(j-1))
     j0 = na + 1
110  continue
 enddo

 return
 end subroutine linear_interpolation


C
C PAGE 277-278: NUMERICAL MATHEMATICS AND COMPUTING, CHENEY/KINCAID, 1985
C
C FILE: SPL3.FOR
C
C NATURAL CUBIC SPLINE FUNCTION FOR SIN(X) AT EQUIDISTANT POINTS (SPL3,ZSPL3)
C

      SUBROUTINE ZSPL3(N,T,Y,H,B,U,V,Z)
      DIMENSION  T(N),Y(N),H(N),B(N),U(N),V(N),Z(N)
      DO 2 I = 1,N-1
        H(I) = T(I+1) - T(I)
        B(I) = (Y(I+1) -Y(I))/H(I)
   2  CONTINUE
      U(2) = 2.0*(H(1) + H(2))
      V(2) = 6.0*(B(2) - B(1))
      DO 3 I = 3,N-1
        U(I) = 2.0*(H(I) + H(I-1)) - H(I-1)**2/U(I-1)
        V(I) = 6.0*(B(I) - B(I-1)) - H(I-1)*V(I-1)/U(I-1)
   3  CONTINUE
      Z(N) = 0.0
      DO 4 I = N-1,2,-1
        Z(I) = (V(I) - H(I)*Z(I+1))/U(I)
   4  CONTINUE
      Z(1) = 0.0
      RETURN
      END

      FUNCTION SPL3(N,T,Y,Z,X)
      DIMENSION  T(N),Y(N),Z(N)
      DO 2 I = N-1,1,-1
        DIFF = X - T(I)
        IF(DIFF .GE. 0.0)  GO TO 3
   2  CONTINUE
      I = 1
   3  H = T(I+1) - T(I)
      B = (Y(I+1) - Y(I))/H - H*(Z(I+1) + 2.0*Z(I))/6.0
      P = 0.5*Z(I) + DIFF*(Z(I+1) - Z(I))/(6.0*H)
      P = B + DIFF*P
      SPL3 = Y(I) + DIFF*P
      RETURN
      END

      SUBROUTINE TRI(N,A,D,C,B,X)
      DIMENSION  A(N),D(N),C(N),B(N),X(N)
      DO 2 I = 2,N
        XMULT = A(I-1)/D(I-1)
        D(I) = D(I) - XMULT*C(I-1)
        B(I) = B(I) - XMULT*B(I-1)
   2  CONTINUE
      X(N) = B(N)/D(N)
      DO 3 I = N-1,1,-1
        X(I) = (B(I) - C(I)*X(I+1))/D(I)
   3  CONTINUE
      RETURN
      END


          program demo_random_number
          use, intrinsic :: iso_fortran_env, only : dp=>real64
          implicit none
          integer, allocatable :: seed(:)
          integer              :: n
          integer              :: first,last
          integer              :: i
          integer              :: rand_int
          integer,allocatable  :: count(:)
          real(kind=dp)        :: rand_val
          call random_seed(size = n)
          allocate(seed(n))
          call random_seed(get=seed)
          first=1
          last=10
          allocate(count(last-first+1))
          ! To have a discrete uniform distribution on the integers {first, first+1,
          ! ..., last-1, last} carve the continuous distribution up into last+1-first
          ! equal sized chunks, mapping each chunk to an integer.
          !
          ! One way is:
          !   call random_number(rand_val)
          ! choose one from last-first+1 integers
          !   rand_int = first + FLOOR((last+1-first)*rand_val)
             count=0
          ! generate a lot of random integers from 1 to 10 and count them.
          ! with a large number of values you should get about the same number
          ! of each value
             do i=1,100000000
                call random_number(rand_val)
                rand_int=first+floor((last+1-first)*rand_val)
                if(rand_int.ge.first.and.rand_int.le.last)then
                   count(rand_int)=count(rand_int)+1
                else
                   write(*,*)rand_int,' is out of range'
                endif
             enddo
             write(*,'(i0,1x,i0)')(i,count(i),i=1,size(count))
          end program demo_random_number


program cal_derteminant
    implicit none

    integer :: i,j,io
    integer :: m,n
    real, dimension(:,:), allocatable :: matrix
    real :: determinan,caldet

    ! -------------------------------------------------
    ! Mengidentifikasi banyak data matrix
    ! -------------------------------------------------
    ! IOSTAT adalah atribut pada fortran untuk
    ! mengidentifikasi banyakanya suatu data dalam
    ! sebuah file.
    !
    ! IOSTAT adalah tipe data integer.
    !
    ! Jika IOSTAT bernilai nol (0), maka mengindikasikan
    ! bahwa data diidentifikasi dengan baik dalam file
    ! terkait.
    !
    ! Jika IOSTAT bernilai -1, maka mengindikasikan
    ! akhir dari data dalam file terkait.
    !
    ! Info lebih lanjut tentang IOSTAT
    ! https://pages.mtu.edu/~shene/COURSES/cs201/NOTES/chap04/iostatus.html
    !
    write(*,*) 'Status IOSTAT'
    open(1, file='data_matrix.txt')
    m = 0
    do
        read(1,*,iostat=io)
        write(*,*)'Baris ke-',m+1, io
        if (io /= 0) exit
        m = m + 1
    end do
    close(1)

    ! -------------------------------------------------
    ! Menghitung akar dari banyak data matrix.
    ! -------------------------------------------------
    ! Misalnya bnayak data matrix = 4, maka
    ! banyaknya baris dan kolom matrix adalah akar 4
    ! atau sama dengan 2. Dengan kata lain, data matrix
    ! yang digunakan memiliki 2 baris dan 2 kolom.
    !
    m = int(m**0.5)
    n = m
    write(*,*)
    write(*,*) 'Banyak baris dan kolom:',n

    ! ALLOCATE adalah fungsi dalam fortran yang digunakan
    ! untuk mengalokasikan ukuran/banyak/dimensi suatu data
    ! dengan nilai yang tertentu ke dalam memori perangkat
    ! tanpa harus mendeklarasikan nilai tersebut di awal
    allocate(matrix(m,n))

    ! Membaca file/data matrix
    open(2,file='data_matrix.txt')
    do i = 1,m
        do j = 1,n
            read(2,*) matrix(i,j)
        end do
    end do

    ! Menampilkan matrix
    write(*,*)
    write(*,*) 'Matrix 2x2'
    do i = 1,m
        write(*,*) (matrix(i,j), j = 1,n)
    end do
    close(2)

    ! Menghitung determinan dengan memanggil fungsi caldet
    determinan = caldet(matrix,m,n)
    write(*,*)
    write(*,*) 'Determinan:'
    write(*,*) determinan

    ! DEALLOCATE adalah menonaktifkan alokasi data yang
    ! dibuat sebelumnya.
    deallocate(matrix)

end program

real function caldet(matrix,m,n)
! ----------------------------------------------------------
! Fungsi perhitungan determinan matrix 2x2
! ----------------------------------------------------------
    real, dimension(m,n) :: matrix
    caldet = matrix(1,1)*matrix(2,2) - matrix(1,2)*matrix(2,1)
    return
end function caldet


! Area of a triangle - Heron's formula
!    input - the lengths of the three sides
!    output -
!        the semiperimeter and the area
!        type of triangle

      program triangle
      print*,"Enter the lengths of the three sides:"
      read(*,*) a, b, c
      if(a.le.0.0 .or. b.le.0.0 .or. c.le.0.0) stop 1
      write(6,*) "sides:", a, b, c

! output semiperimeter and area
      s = (a + b + c) / 2.0
      area = sqrt(s * (s-a) * (s-b) * (s-c))
      write(6,*) "semiperimeter:", s

! triangle inequality
      if (max(a,b,c) .ge. s) then
          print*,"Error: max(a,b,c) >= s (Triangle)"
      end if

      write(6,*) "area:", area

! Nesbitt's inequality
      symsum = a/(b+c) + b/(a+c) + c/(a+b)
      print*,"Nesbitt's symmetric sum:", symsum
      if (symsum.lt.1.5) then
          print*,"   Error: sum < 1.5"
      end if
      if (symsum.ge.2) then
          print*,"   Error: sum > 2"
      end if

! acute, right or obtuse
      if (c.ge.a .and. c.ge.b) then
          x = a
          y = b
          z = c
      else if (a.ge.b .and. a.ge.c) then
          x = b
          y = c
          z = a
      else
          x = c
          y = a
          z = b
      end if
      print*, "longest side:", z
      sumsq = z*z - x*x - y*y
      print*, "Pythagorean sum:", sumsq
      if(sumsq.lt.0.0) then
          print*,"Acute angle opposite", z
      else if(sumsq.gt.0.0) then
          print*,"Obtuse angle opposite", z
      else
          print*,"Right angle opposite", z
      end if

      end program


! ##############################################################################
! normal (gaussian) distribution

module normal

  use types ! set type precision
  use error_function
  use rng

  ! user has default access to all functions
  public

  contains

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

    function pdf(mu, sig, x) result(o)
      ! Numerical Recipes 3Ed 6.14.1

      real(dp) mu, sig, x, o

      o = 0.398942280401432678_dp / sig * exp( -0.5_dp * ( (x - mu) / sig )**2 )

      return

    end function pdf

    subroutine pdfv(mu, sig, xx, output, n)
      ! wrapper for python

      real(dp) mu, sig, xx(n), output(n)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = pdf(mu, sig, xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = pdf(mu, sig, xx(i)) ! function reference
      end do

    end subroutine pdfv

    subroutine pdfv2(mu, sig, xx, output, n, m)
      ! wrapper for python

      real(dp) mu, sig, xx(n, m), output(n, m)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = pdf(mu, sig, xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = pdf(mu, sig, xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = pdf(mu, sig, xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = pdf(mu, sig, xx(i, i2)) ! function reference
        end do

      end do

    end subroutine pdfv2

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

    function cdf(mu, sig, x) result(o)
      ! Numerical Recipes 3Ed 6.14.1

      real(dp) mu, sig, x, o

      o = 0.5_dp * erfc( -0.707106781186547524_dp * (x - mu) / sig)

      return

    end function cdf

    subroutine cdfv(mu, sig, xx, output, n)
      ! wrapper for python

      real(dp) mu, sig, xx(n), output(n)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = cdf(mu, sig, xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = cdf(mu, sig, xx(i)) ! function reference
      end do

    end subroutine cdfv

    subroutine cdfv2(mu, sig, xx, output, n, m)
      ! wrapper for python

      real(dp) mu, sig, xx(n, m), output(n, m)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = cdf(mu, sig, xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = cdf(mu, sig, xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = cdf(mu, sig, xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = cdf(mu, sig, xx(i, i2)) ! function reference
        end do

      end do

    end subroutine cdfv2

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

    function invcdf(mu, sig, p) result(o)
      ! Numerical Recipes 3Ed 6.14.1

      real(dp) mu, sig, p, o

      o = -1.41421356237309505_dp * sig * inverfc( 2.0_dp * p) + mu

      return

    end function invcdf

    subroutine invcdfv(mu, sig, xx, output, n)
      ! wrapper for python

      real(dp) mu, sig, xx(n), output(n)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0)
      !f2py intent(out) :: output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = invcdf(mu, sig, xx(i+j-1)) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = invcdf(mu, sig, xx(i)) ! function reference
      end do

    end subroutine invcdfv

    subroutine invcdfv2(mu, sig, xx, output, n, m)
      ! wrapper for python

      real(dp) mu, sig, xx(n, m), output(n, m)

      !f2py intent(in) :: mu, sig, xx
      !f2py intent(in), depend(xx) :: n = shape(xx, 0), m = shape(xx, 1)
      !f2py intent(out) :: output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = invcdf(mu, sig, xx(i+j-1, i2+j2-1)) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = invcdf(mu, sig, xx(i+j-1, i2)) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = invcdf(mu, sig, xx(i, i2+j2-1)) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = invcdf(mu, sig, xx(i, i2)) ! function reference
        end do

      end do

    end subroutine invcdfv2

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

    function draw(mu, sig, state) result(o)
      ! Numerical Recipes 3Ed 6.14.1

      integer(dp) state(state_size)
      real(dp) mu, sig, o

      o = invcdf(mu, sig, ran(state))

    end function draw

    subroutine drawv(mu, sig, state, new_state, output, n)
      ! wrapper for python

      integer(dp) state(state_size), new_state(state_size)
      real(dp) mu, sig, output(n)

      !f2py intent(in) :: mu, sig, state, n
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, remainder
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1
          output(i+j-1) = draw(mu, sig, state) ! function reference
        end do
      end do
      do i = n - remainder + 1, n, 1
        output(i) = draw(mu, sig, state) ! function reference
      end do

      new_state  = state

    end subroutine drawv

    subroutine drawv2(mu, sig, state, new_state, output, n, m)
      ! wrapper for python

      integer(dp) state(35), new_state(35) ! seed size
      real(dp) mu, sig, output(n, m)

      !f2py intent(in) :: mu, sig, state, n, m
      !f2py intent(out) :: new_state, output

      integer(sp) :: n, m, remainder, remainder2
      integer(sp), parameter :: unroll = 8, unroll_minus_one = 7

      remainder = iand(n, unroll_minus_one)
      remainder2 = iand(m, unroll_minus_one)

      do i = 1, n - remainder, unroll
        do j = 1, unroll, 1

          do i2 = 1, m - remainder, unroll
            do j2 = 1, unroll, 1
              output(i+j-1, i2+j2-1) = draw(mu, sig, state) ! function reference
            end do
          end do

          do i2 = m - remainder + 1, m, 1
            output(i+j-1, i2) = draw(mu, sig, state) ! function reference
          end do

        end do
      end do

      do i = n - remainder + 1, n, 1

        do i2 = 1, m - remainder, unroll
          do j2 = 1, unroll, 1
            output(i, i2+j2-1) = draw(mu, sig, state) ! function reference
          end do
        end do

        do i2 = m - remainder + 1, m, 1
          output(i, i2) = draw(mu, sig, state) ! function reference
        end do

      end do

      new_state  = state

    end subroutine drawv2

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

end module normal


subroutine sub_one(ix, oy, ioz)
   real, intent(in) :: ix ! input
   real, intent(out)  :: oy ! output
   real, intent(inout) :: ioz ! input and output

   oy = sqrt(real(ix)) + ioz
   ioz = max(ix, oy)

end subroutine

function func(i) result(j)
   integer, intent(in) :: i ! input
   integer              :: j ! output

   j = sqrt(real(i)) + log(real(i))
end function

program main

   implicit none

   integer :: i
   integer :: func
   real :: ix, oy, ioz

   ix = 10.0
   ioz = 20.0

   i = huge(1)
   print *, "i=", i, char(10), " sqrt(i) + log(i) =", func(i)

   print *, 'Before:', ix, oy, ioz
   call sub_one(ix, oy, ioz)
   print *, 'After :', ix, oy, ioz

end program


! Licensed under a 3-clause BSD style license - see LICENSE

! This file provides the Fortran code for shared functions used by other fortran
! files, allowing them to share the linked subroutines.

subroutine haversine(lon1, lon2, lat1, lat2, hav_dist)
    ! Function to calculate the haversine formula.

    implicit none

    integer, parameter :: dp = kind(0.0d0)  ! double precision
    real(dp), parameter :: pi = 4.0_dp*atan(1.0_dp)

    ! The longitudes and latitudes (orthogonal celestial sphere coordinates, in a consistent frame)
    ! to compute the great-circle distance of, in degrees.
    real(dp), intent(in) :: lon1, lon2, lat1, lat2
    ! Longitude and latitude separations, and individual latitudes, but in radians.
    real(dp) :: dlon_rad, dlat_rad, lat1_rad, lat2_rad
    ! Haversine distance, in degrees.
    real(dp), intent(out) :: hav_dist

    dlon_rad = (lon1 - lon2) / 180.0_dp * pi
    dlat_rad = (lat1 - lat2) / 180.0_dp * pi
    lat1_rad = lat1 / 180.0_dp * pi
    lat2_rad = lat2 / 180.0_dp * pi

    hav_dist = 2.0_dp * asin(min(1.0_dp, sqrt((sin(dlat_rad/2.0_dp))**2 + cos(lat1_rad)*cos(lat2_rad)*(sin(dlon_rad/2.0_dp)**2))))
    hav_dist = hav_dist * 180.0_dp / pi  ! convert radians to degrees

end subroutine haversine

subroutine jy01a_j0 (x, bj0)
    ! JY01A_J0 computes Bessel function J0(x).
    !
    !
    !
    !  Licensing:
    !
    !    This routine is copyrighted by Shanjie Zhang and Jianming Jin. However,
    !    they give permission to incorporate this routine into a user program
    !    provided that the copyright is acknowledged.
    !
    !  Modified:
    !
    !    01 August 2012
    !
    !  Author:
    !
    !    Shanjie Zhang, Jianming Jin
    !
    !  Reference:
    !
    !    Shanjie Zhang, Jianming Jin,
    !    Computation of Special Functions,
    !    Wiley, 1996,
    !    ISBN: 0-471-11963-6,
    !    LC: QA351.C45.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument.
    !
    !    Output, real ( kind = 8 ) BJ0,
    !    the value of J0(x).
    !
    !  Modified slightly by TJW, 2020.
    !
    implicit none

    real ( kind = 8 ), save, dimension(12) :: a = (/ &
      -0.7031250000000000D-01, 0.1121520996093750D+00, &
      -0.5725014209747314D+00, 0.6074042001273483D+01, &
      -0.1100171402692467D+03, 0.3038090510922384D+04, &
      -0.1188384262567832D+06, 0.6252951493434797D+07, &
      -0.4259392165047669D+09, 0.3646840080706556D+11, &
      -0.3833534661393944D+13, 0.4854014686852901D+15 /)
    real ( kind = 8 ), save, dimension(12) :: b = (/ &
      0.7324218750000000D-01, -0.2271080017089844D+00, &
      0.1727727502584457D+01, -0.2438052969955606D+02, &
      0.5513358961220206D+03, -0.1825775547429318D+05, &
      0.8328593040162893D+06, -0.5006958953198893D+08, &
      0.3836255180230433D+10, -0.3649010818849833D+12, &
      0.4218971570284096D+14, -0.5827244631566907D+16 /)
    real ( kind = 8 ) bj0
    real ( kind = 8 ) cu

    integer ( kind = 4 ) k
    integer ( kind = 4 ) k0
    real ( kind = 8 ) p0
    real ( kind = 8 ) pi
    real ( kind = 8 ) q0
    real ( kind = 8 ) r
    real ( kind = 8 ) rp2
    real ( kind = 8 ) t1
    real ( kind = 8 ) x
    real ( kind = 8 ) x2

    pi = 3.141592653589793D+00
    rp2 = 0.63661977236758D+00
    x2 = x * x

    if ( abs( x ) <= 1.0D-05 ) then
      bj0 = 1.0D+00
      return
    end if

    if ( x <= 12.0D+00 ) then

      bj0 = 1.0D+00
      r = 1.0D+00
      do k = 1,30
        r = -0.25D+00 * r * x2 / ( k * k )
        bj0 = bj0 + r
        if ( abs ( r ) < abs ( bj0 ) * 1.0D-15 ) then
          exit
        end if
      end do

    else

      if ( x < 35.0D+00 ) then
        k0 = 12
      else if ( x < 50.0D+00 ) then
        k0 = 10
      else
        k0 = 8
      end if

      t1 = x - 0.25D+00 * pi
      p0 = 1.0D+00
      q0 = -0.125D+00 / x
      do k = 1, k0
        p0 = p0 + a(k) * x ** ( - 2 * k )
        q0 = q0 + b(k) * x ** ( - 2 * k - 1 )
      end do
      cu = sqrt ( rp2 / x )
      bj0 = cu * ( p0 * cos ( t1 ) - q0 * sin ( t1 ) )

    end if
    return
end

subroutine jy01a_j1 (x, bj1)
    ! JY01A_J1 computes Bessel function J1(x).
    !
    !
    !
    !  Licensing:
    !
    !    This routine is copyrighted by Shanjie Zhang and Jianming Jin. However,
    !    they give permission to incorporate this routine into a user program
    !    provided that the copyright is acknowledged.
    !
    !  Modified:
    !
    !    01 August 2012
    !
    !  Author:
    !
    !    Shanjie Zhang, Jianming Jin
    !
    !  Reference:
    !
    !    Shanjie Zhang, Jianming Jin,
    !    Computation of Special Functions,
    !    Wiley, 1996,
    !    ISBN: 0-471-11963-6,
    !    LC: QA351.C45.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) X, the argument.
    !
    !    Output, real ( kind = 8 ) BJ1,
    !    the value of J1(x).
    !
    !  Modified slightly by TJW, 2021.
    !
    implicit none

    real ( kind = 8 ), save, dimension(12) :: a1 = (/ &
      0.1171875000000000D+00, -0.1441955566406250D+00, &
      0.6765925884246826D+00, -0.6883914268109947D+01, &
      0.1215978918765359D+03, -0.3302272294480852D+04, &
      0.1276412726461746D+06, -0.6656367718817688D+07, &
      0.4502786003050393D+09, -0.3833857520742790D+11, &
      0.4011838599133198D+13, -0.5060568503314727D+15 /)
    real ( kind = 8 ), save, dimension(12) :: b1 = (/ &
      -0.1025390625000000D+00, 0.2775764465332031D+00, &
      -0.1993531733751297D+01, 0.2724882731126854D+02, &
      -0.6038440767050702D+03, 0.1971837591223663D+05, &
      -0.8902978767070678D+06, 0.5310411010968522D+08, &
      -0.4043620325107754D+10, 0.3827011346598605D+12, &
      -0.4406481417852278D+14, 0.6065091351222699D+16 /)
    real ( kind = 8 ) bj1
    real ( kind = 8 ) cu

    integer ( kind = 4 ) k
    integer ( kind = 4 ) k0
    real ( kind = 8 ) p1
    real ( kind = 8 ) pi
    real ( kind = 8 ) q1
    real ( kind = 8 ) r
    real ( kind = 8 ) rp2
    real ( kind = 8 ) t2
    real ( kind = 8 ) x
    real ( kind = 8 ) x2

    pi = 3.141592653589793D+00
    rp2 = 0.63661977236758D+00
    x2 = x * x

    if ( abs( x ) <= 1.0D-05 ) then
      bj1 = 0.0D+00
      return
    end if

    if ( x <= 12.0D+00 ) then

      bj1 = 1.0D+00
      r = 1.0D+00
      do k = 1, 30
        r = -0.25D+00 * r * x2 / ( k * ( k + 1.0D+00 ) )
        bj1 = bj1 + r
        if ( abs ( r ) < abs ( bj1 ) * 1.0D-15 ) then
          exit
        end if
      end do

      bj1 = 0.5D+00 * x * bj1

    else

      if ( x < 35.0D+00 ) then
        k0 = 12
      else if ( x < 50.0D+00 ) then
        k0 = 10
      else
        k0 = 8
      end if

      t2 = x - 0.75D+00 * pi
      p1 = 1.0D+00
      q1 = 0.375D+00 / x
      do k = 1, k0
        p1 = p1 + a1(k) * x ** ( - 2 * k )
        q1 = q1 + b1(k) * x ** ( - 2 * k - 1 )
      end do
      cu = sqrt ( rp2 / x )
      bj1 = cu * ( p1 * cos ( t2 ) - q1 * sin ( t2 ) )

    end if
    return
end


	!--------------------------------------------------------------------
	!
	!
	! PURPOSE
	!
	! This program solves nonlinear Schrodinger equation in 2 dimensions
	! i*u_t+Es*|u|^2u+u_{xx}+u_{yy}=0
	! using a second order time spectral splitting scheme
	!
	! The boundary conditions are u(x=0,y)=u(2*Lx*\pi,y),
	!	u(x,y=0)=u(x,y=2*Ly*\pi)
	! The initial condition is u=exp(-x^2-y^2)
	!
	! .. Parameters ..
	!  Nx				= number of modes in x - power of 2 for FFT
	!  Ny				= number of modes in y - power of 2 for FFT
	!  Nt				= number of timesteps to take
	!  Tmax				= maximum simulation time
	!  plotgap			= number of timesteps between plots
	!  FFTW_IN_PLACE 	= value for FFTW input
	!  FFTW_MEASURE 	= value for FFTW input
	!  FFTW_EXHAUSTIVE 	= value for FFTW input
	!  FFTW_PATIENT 	= value for FFTW input
	!  FFTW_ESTIMATE 	= value for FFTW input
	!  FFTW_FORWARD     = value for FFTW input
	!  FFTW_BACKWARD	= value for FFTW input
	!  pi = 3.14159265358979323846264338327950288419716939937510d0
	!  Lx				= width of box in x direction
	!  Ly				= width of box in y direction
	!  ES				= +1 for focusing and -1 for defocusing
	! .. Scalars ..
	!  i				= loop counter in x direction
	!  j				= loop counter in y direction
	!  n				= loop counter for timesteps direction
	!  allocatestatus	= error indicator during allocation
	!  start			= variable to record start time of program
	!  finish			= variable to record end time of program
	!  count_rate		= variable for clock count rate
	!  planfx			= Forward 1d fft plan in x
	!  planbx			= Backward 1d fft plan in x
	!  planfy			= Forward 1d fft plan in y
	!  planby			= Backward 1d fft plan in y
	!  dt				= timestep
	! .. Arrays ..
	!  u				= approximate solution
	!  v				= Fourier transform of approximate solution
	!  unax 			= temporary field
	!  vnax 			= temporary field
	!  vnbx 			= temporary field
	!  vnay 			= temporary field
	!  vnby 			= temporary field
	!  potx 			= potential
	! .. Vectors ..
	!  kx				= fourier frequencies in x direction
	!  ky				= fourier frequencies in y direction
	!  x				= x locations
	!  y				= y locations
	!  time				= times at which save data
	!  name_config		= array to store filename for data to be saved
	!  fftfx			= array to setup x Fourier transform
	!  fftbx			= array to setup x Fourier transform
	!  fftfy			= array to setup y Fourier transform
	!  fftby			= array to setup y Fourier transform
	!
	! REFERENCES
	!
	! ACKNOWLEDGEMENTS
	!
	! ACCURACY
	!
	! ERROR INDICATORS AND WARNINGS
	!
	! FURTHER COMMENTS
	! Check that the initial iterate is consistent with the
	! boundary conditions for the domain specified
	!--------------------------------------------------------------------
	! External routines required
	!
	! External libraries required
	! FFTW3	 -- Fast Fourier Transform in the West Library
	!			(http://www.fftw.org/)
	! OpenMP library

	PROGRAM main
	USE omp_lib
	IMPLICIT NONE
	! Declare variables
	INTEGER(kind=4), PARAMETER 	::  Nx=2**8
	INTEGER(kind=4), PARAMETER 	::  Ny=2**8
	INTEGER(kind=4), PARAMETER	::  Nt=20
	INTEGER(kind=4), PARAMETER	::  plotgap=5
	REAL(kind=8), PARAMETER		:: &
		pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER		::  Lx=2.0d0
	REAL(kind=8), PARAMETER		::  Ly=2.0d0
	REAL(kind=8), PARAMETER		::  Es=0.0d0
	REAL(kind=8)				::  dt=0.10d0/Nt
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE	::  kx,ky
	REAL(kind=8),  	 DIMENSION(:), ALLOCATABLE	::  x,y
	COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE::  unax,vnax,vnbx,potx
	COMPLEX(kind=8), DIMENSION(:,:), ALLOCATABLE::  vnay,vnby
	REAL(kind=8), 	 DIMENSION(:), ALLOCATABLE	::  time
	INTEGER(kind=4)				::  i,j,k,n,allocatestatus
	INTEGER(kind=4)			 	::  start, finish, count_rate
	INTEGER(kind=8), PARAMETER  ::  FFTW_IN_PLACE=8, FFTW_MEASURE=0,&
									FFTW_EXHAUSTIVE=8, FFTW_PATIENT=32,&
                   	 				FFTW_ESTIMATE=64
	INTEGER(kind=8),PARAMETER   ::  FFTW_FORWARD=-1, FFTW_BACKWARD=1
	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE :: fftfx,fftbx,fftfy,fftby
	INTEGER(kind=8)				::  planfx,planbx,planfy,planby
   	CHARACTER*100			 	::  name_config

	ALLOCATE(kx(1:Nx),ky(1:Nx),x(1:Nx),y(1:Nx),unax(1:Nx,1:Ny),&
			vnax(1:Nx,1:Ny),vnbx(1:Nx,1:Ny),potx(1:Nx,1:Ny),fftfx(1:Nx),&
			fftbx(1:Nx),fftfy(1:Nx),fftby(1:Nx),vnay(1:Ny,1:Nx),&
			vnby(1:Ny,1:Nx),time(1:1+Nt/plotgap),stat=allocatestatus)
	IF (allocatestatus .ne. 0) stop
	PRINT *,'allocated memory'
		! set up ffts
	CALL dfftw_plan_dft_1d_(planfx,Nx,fftfx(1:Nx),fftbx(1:Nx),&
			FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_1d_(planbx,Nx,fftbx(1:Nx),fftfx(1:Nx),&
 			FFTW_BACKWARD,FFTW_ESTIMATE)
	CALL dfftw_plan_dft_1d_(planfy,Ny,fftfy(1:Ny),fftby(1:Ny),&
			FFTW_FORWARD,FFTW_ESTIMATE)
 	CALL dfftw_plan_dft_1d_(planby,Ny,fftby(1:Ny),fftfy(1:Ny),&
 			FFTW_BACKWARD,FFTW_ESTIMATE)
	PRINT *,'Setup FFTs'

	! setup fourier frequencies
	!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,1+Nx/2
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	!$OMP END PARALLEL DO
	kx(1+Nx/2)=0.0d0
	!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
  	DO i=1,Nx
		x(i)=(-1.0d0+2.0d0*REAL(i-1,kind(0d0))/REAL(Nx,kind(0d0)) )*pi*Lx
	END DO
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,1+Ny/2
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	!$OMP END PARALLEL DO
	ky(1+Ny/2)=0.0d0
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	!$OMP END PARALLEL DO
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
  	DO j=1,Ny
		y(j)=(-1.0d0+2.0d0*REAL(j-1,kind(0d0))/REAL(Ny,kind(0d0)) )*pi*Ly
	END DO
	!$OMP END PARALLEL DO
	PRINT *,'Setup grid and fourier frequencies'
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		DO i=1,Nx
			unax(i,j)=exp(-1.0d0*(x(i)**2 +y(j)**2))
		END DO
	END DO
	!$OMP END PARALLEL DO
	name_config = 'uinitial.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		DO i=1,Nx
			WRITE(11,*) abs(unax(i,j))**2
		END DO
	END DO
	CLOSE(11)
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		DO i=1,Nx
			CALL dfftw_execute_dft_(planfx,unax(i,j),vnax(i,j))
		END DO
	END DO
	!$OMP END PARALLEL DO
	vnay(1:Ny,1:Nx)=TRANSPOSE(vnax(1:Nx,1:Ny))
	! transform initial data and do first half time step
	!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		CALL dfftw_execute_dft_(planfy,vnay(1:Ny,i),vnby(1:Ny,i))
		DO j=1,Ny
			vnby(j,i)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(j)*ky(j))&
					*cmplx(0.0d0,1.0d0))*vnby(j,i)
		END DO
		CALL dfftw_execute_dft_(planby,vnby(j,i),vnay(j,i))
	END DO
	!$OMP END PARALLEL DO
	PRINT *,'Got initial data, starting timestepping'
	time(1)=0.0d0
	CALL system_clock(start,count_rate)
	DO n=1,Nt
		vnbx(1:Nx,1:Ny)=TRANSPOSE(vnay(1:Ny,1:Nx))/REAL(Ny,kind(0d0))
		!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
		DO j=1,Ny
			CALL dfftw_execute_dft_(planbx,vnbx(1:Nx,j),unax(1:Nx,j))
			DO i=1,Nx
				unax(i,j)=unax(1:Nx,j)/REAL(Nx,kind(0d0))
				potx(i,j)=Es*unax(i,j)*conjg(unax(i,j))
				unax(i,j)=exp(cmplx(0.0d0,-1.0d0)*dt*potx(i,j))&
							*unax(i,j)
			END DO
			CALL dfftw_execute_dft_(planfx,unax(1:Nx,j),vnax(1:Nx,j))
		END DO
		!$OMP END PARALLEL DO
		vnby(1:Ny,1:Nx)=TRANSPOSE(vnax(1:Nx,1:Ny))
		!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
		DO i=1,Nx
			CALL dfftw_execute_dft_(planfy,vnby(1:Ny,i),vnay(1:Ny,i))
			DO j=1,Ny
				vnby(j,i)=exp(dt*(kx(i)*kx(i) + ky(j)*ky(j))&
						*cmplx(0.0d0,1.0d0))*vnay(j,i)
			END DO
			CALL dfftw_execute_dft_(planby,vnby(1:Ny,i),vnay(1:Ny,i))
		END DO
		!$OMP END PARALLEL DO
		IF (mod(n,plotgap)==0) then
			time(1+n/plotgap)=n*dt
			PRINT *,'time',n*dt
		END IF
	END DO
	PRINT *,'Finished time stepping'
	CALL system_clock(finish,count_rate)
	PRINT*,'Program took ',REAL(finish-start)/REAL(count_rate),&
		'for Time stepping'

	! transform back final data and do another half time step
	vnbx(1:Nx,1:Ny)=transpose(vnay(1:Ny,1:Nx))/REAL(Ny,kind(0d0))
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		CALL dfftw_execute_dft_(planbx,vnbx(1:Nx,j),unax(1:Nx,j))
		unax(1:Nx,j)=unax(1:Nx,j)/REAL(Nx,kind(0d0))
		potx(1:Nx,j)=Es*unax(1:Nx,j)*conjg(unax(1:Nx,j))
		unax(1:Nx,j)=exp(cmplx(0,-1)*dt*potx(1:Nx,j))*unax(1:Nx,j)
		CALL dfftw_execute_dft_(planfx,unax(1:Nx,j),vnax(1:Nx,j))
	END DO
	!$OMP END PARALLEL DO
	vnby(1:Ny,1:Nx)=TRANSPOSE(vnax(1:Nx,1:Ny))
	!$OMP PARALLEL DO PRIVATE(i) SCHEDULE(static)
	DO i=1,Nx
		CALL dfftw_execute_dft_(planfy,vnby(1:Ny,i),vnay(1:Ny,i))
		vnby(1:Ny,i)=exp(0.5d0*dt*(kx(i)*kx(i) + ky(1:Ny)*ky(1:Ny))&
					*cmplx(0,1))*vnay(1:Ny,i)
		CALL dfftw_execute_dft_(planby,vnby(1:Ny,i),vnay(1:Ny,i))
	END DO
	!$OMP END PARALLEL DO
	vnbx(1:Nx,1:Ny)=TRANSPOSE(vnay(1:Ny,1:Nx))/REAL(Ny,kind(0d0))
	!$OMP PARALLEL DO PRIVATE(j) SCHEDULE(static)
	DO j=1,Ny
		CALL dfftw_execute_dft_(planbx,vnbx(1:Nx,j),unax(1:Nx,j))
		unax(1:Nx,j)=unax(1:Nx,j)/REAL(Nx,kind(0d0))
	END DO
	!$OMP END PARALLEL DO
	name_config = 'ufinal.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		DO i=1,Nx
			WRITE(11,*) abs(unax(i,j))**2
		END DO
	END DO
	CLOSE(11)

	name_config = 'tdata.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,1+Nt/plotgap
		WRITE(11,*) time(j)
	END DO
	CLOSE(11)

	name_config = 'xcoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO i=1,Nx
		WRITE(11,*) x(i)
	END DO
	CLOSE(11)

	name_config = 'ycoord.dat'
	OPEN(unit=11,FILE=name_config,status="UNKNOWN")
	REWIND(11)
	DO j=1,Ny
		WRITE(11,*) y(j)
	END DO
	CLOSE(11)
	PRINT *,'Saved data'

	CALL dfftw_destroy_plan_(planbx)
	CALL dfftw_destroy_plan_(planfx)
	CALL dfftw_destroy_plan_(planby)
	CALL dfftw_destroy_plan_(planfy)
	CALL dfftw_cleanup_()

	DEALLOCATE(unax,vnax,vnbx,potx, vnay,vnby,stat=allocatestatus)
	IF (allocatestatus .ne. 0) STOP
	PRINT *,'Deallocated memory'

   	PRINT *,'Program execution complete'
	END PROGRAM main


PROGRAM rect_polar
IMPLICIT NONE
  REAL, DIMENSION(2) :: rect, polar
  REAL, PARAMETER :: PI = 3.1416

  WRITE(*, *) "Enter the magnitude:"
  READ(*, *) polar(1)
  WRITE(*, *) "Enter the angle in degrees:"
  READ(*, *) polar(2)

  rect(1) = polar(1) * COS(polar(2) * PI / 180.0)
  rect(2) = polar(1) * SIN(polar(2) * PI / 180.0)

  WRITE(*, '(A,F7.4,A,F7.4)') "Rectangular coordinates are ", rect(1), ", ", rect(2)

END PROGRAM rect_polar


program element_operations
  implicit none

  real(kind=4), dimension(3,3) :: a,b
  integer :: i

  a=reshape([(i,i=1,9)],shape(a))

  print*,'addition'
  b=a+a
  call print_arr(b)

  print*,'multiplication'
  b=a*a
  call print_arr(b)

  print*,'division'
  b=a/b
  call print_arr(b)

  print*,'exponentiation'
  b=a**a
  call print_arr(b)

  print*,'trignometric'
  b=cos(a)
  call print_arr(b)

  print*,'mod'
  b=mod(int(a),3)
  call print_arr(b)

  print*,'element selection'
  b=0
  where(a>3) b=1
  call print_arr(b)

  print*,'elemental functions can be applied to single values:'
  print*,square(3.0)
  print*,'or element wise to arrays:'
  b=square(a)
  call print_arr(b)

contains

  elemental real function square(a)
    real, intent(in) :: a
    square=a*a
  end function square

  subroutine print_arr(arr)
    real, intent(in) :: arr(:,:)
    integer :: i
    do i=1,size(arr,dim=2)
       print*,arr(:,i)
    end do
  end subroutine print_arr

end program element_operations


module laplace2d_double

  interface apply_laplacian
    module procedure apply_laplacian_double, apply_lap_double
  end interface

  interface set_laplacian_matrix
    module procedure set_laplacian_matrix_double
  end interface

  interface apply_gauss_seidel_step
    module procedure apply_gauss_seidel_step_double, apply_gs_double
  end interface

contains

  subroutine apply_laplacian_double( mx, my, nx, x, Ax)

    implicit none

    integer, intent(in) :: mx, my, nx
    double precision, intent(in) :: x(mx*my, nx)
    double precision, intent(out) :: Ax(mx*my, nx)

    call apply_lap_double( mx, my, nx, x, Ax)

  end subroutine apply_laplacian_double

  subroutine apply_lap_double( mx, my, nx, x, Ax)
! Multiply x by Laplacian matrix for a square of size mx by my

    implicit none

    integer, intent(in) :: mx, my, nx
    double precision, intent(in) :: x(mx, my, nx)
    double precision, intent(out) :: Ax(mx, my, nx)
    integer :: i, j, k
    double precision :: z

    do k = 1, nx
      do i = 1, mx
        do j = 1, my
          z = 4*x(i, j, k)
          if ( i > 1 ) z = z - x(i - 1, j, k)
          if ( j > 1 ) z = z - x(i, j - 1, k)
          if ( i < mx ) z = z - x(i + 1, j, k)
          if ( j < my ) z = z - x(i, j + 1, k)
          Ax(i, j, k) = z
        end do
      end do
    end do

  end subroutine apply_lap_double

  subroutine set_laplacian_matrix_double( nx, ny, a, lda )
! Laplacian matrix for a rectangle of size nx x ny
    implicit none
    integer, intent(in) :: nx, ny, lda
    double precision, intent(out) :: a(lda, nx*ny)
    integer :: i, ix, iy
    a = 0
    do ix = 1, nx
      do iy = 1, ny
        i = ix + (iy - 1)*nx
        a(i, i) = 4
        if ( ix >  1 ) a(i, i -  1) = -1
        if ( ix < nx ) a(i, i +  1) = -1
        if ( iy > 1  ) a(i, i - nx) = -1
        if ( iy < ny ) a(i, i + nx) = -1
      end do
    end do
  end subroutine set_laplacian_matrix_double

  subroutine apply_gauss_seidel_step_double( mx, my, nx, x, Tx )
! Apply one Gauss-Seidel step for preconditioning

    implicit none

    integer, intent(in) :: mx, my, nx
    double precision, intent(in) :: x(mx*my, nx)
    double precision, intent(out) :: Tx(mx*my, nx)

    call apply_gs_double( mx, my, nx, x, Tx )

  end subroutine apply_gauss_seidel_step_double

  subroutine apply_gs_double( mx, my, nx, x, Tx )
! Apply one Gauss-Seidel step for preconditioning

    implicit none

    integer, intent(in) :: mx, my, nx
    double precision, intent(in) :: x(mx, my, nx)
    double precision, intent(out) :: Tx(mx, my, nx)
    integer :: i, j, k
    double precision :: z
    Tx = x/4
    do k = 1, nx
      do i = 1, mx ! forward update
        do j = 1, my
          z = 0
          if ( i > 1 ) z = z + Tx(i - 1, j, k)
          if ( j > 1 ) z = z + Tx(i, j - 1, k)
          if ( i < mx ) z = z + Tx(i + 1, j, k)
          if ( j < my ) z = z + Tx(i, j + 1, k)
          Tx(i, j, k) = (Tx(i, j, k) + z/4)/4
        end do
      end do
      do i = mx, 1, -1 ! backward update
        do j = my, 1, -1
          z = 0
          if ( i > 1 ) z = z + Tx(i - 1, j, k)
          if ( j > 1 ) z = z + Tx(i, j - 1, k)
          if ( i < mx ) z = z + Tx(i + 1, j, k)
          if ( j < my ) z = z + Tx(i, j + 1, k)
          Tx(i, j, k) = (Tx(i, j, k) + z/4)/4
        end do
      end do
    end do
  end subroutine apply_gs_double

end module laplace2d_double

module laplace2d

  use laplace2d_double

end module laplace2d


!Autor: Claudio Iván Esparza Castañeda
!Título: Birge-Vieta
!Descripción: El método se basa en el método de Newton-Raphson implementando el esquema de Horner para la evaluación del polinomio y su derivada
!Fecha: 22/03/2020

Program birvie
  implicit none
  REAL::e, er, x, xe, b, c, r
  INTEGER::n, i, j
  REAL, allocatable, dimension(:)::A
  WRITE(*, *) "Grado del polinomio"
  READ(*, *) n
  allocate(A(0:n))
  WRITE(*, *) "Coeficientes del polinomio a0+a1x+a2x²+...anx^n"
  do i=0, n
     READ(*, *) A(i)
  end do
  WRITE(*, *) "Valor inicial" !Preguntar final del intervalo
  READ(*, *) x !Ingresar final del intervalo
  WRITE(*, *) "Error esperado" !Preguntar el error
  READ(*, *) er !Ingresar el error
  i=0
  do
     i=i+1
     xe=x
     b=A(n)
     c=A(n)
     do j=n-1, 1, -1
        b=b*x+a(j)
        c=c*x+b
     end do
     b=b*x+A(0)
     r=x-b/c
     x=r
     if (x .NE. 0) then
        e=abs((x-xe)/x)*100
     end if
     WRITE(*, *) x
     if (e<er) then
        EXIT
     end if
  end do
  WRITE(*, *) "Hola"
  deallocate(A)
end Program birvie


! jacobi2d_main_omp.f90

program jacobi2d_main
    implicit none
    real(kind=8) :: tol, dumax
    integer :: n,iter,maxiter,nthreads

    n = 120
    !tol = 0.1 / (n+1)**2
    tol = 1.d-6
    ! The letter "d" for double precision numbers has the same meaning as "e" for single precision numbers.
    maxiter = 100000

    write (*,"('Solving Laplace equation on',i4,' by',i4,' grid by Jacobi iteration')") n,n
    ! i4 - 4 characters wide
    ! print "('Solving Laplace equation on',i4,' by',i4,' grid by Jacobi iteration')", n,n
    ! print "('Note: This is a lousy numerical method but illustrates OpenMP speedup')"
    write (*, 100)
	100 format ('Note: This is a lousy numerical method but illustrates OpenMP speedup')
    print *,' '

    ! Specify number of threads to use:
    nthreads = 1
    call jacobi2d_sub(n, tol, maxiter, iter, dumax, nthreads)

    nthreads = 2
    call jacobi2d_sub(n, tol, maxiter, iter, dumax, nthreads)

end program jacobi2d_main


program intrinsics_17
use iso_fortran_env, only: sp=>real32, dp=>real64
real(sp) :: x
real(dp) :: y

x = exp(1.5_sp)
print *, x
y = exp(1.5_dp)
print *, y

x = log(1.5_sp)
print *, x
y = log(1.5_dp)
print *, y

x = erf(1.5_sp)
print *, x
y = erf(1.5_dp)
print *, y

x = atan2(1.5_sp, 2.5_sp)
print *, x
y = atan2(1.5_dp, 2.5_dp)
print *, y

end


! Cálculo da razão áurea (phi)
program aurea

        implicit none

        real(kind=8) :: phi = 3
        real(kind=8) :: tmp = -1

        integer(kind=1) :: iter = 0

        do while (abs(phi - tmp) > epsilon(phi))
                tmp = phi
                phi = sqrt(phi + 1)
                iter = iter + 1
        end do

        write (*,'(i2,a,f17.15)') iter,' iterações: ϕ = ',phi

end program aurea


!     .................................................
!             ____  _       _   ____  _____   _
!            |  _ \| |     |_| |  _ \|  ___| |_|
!            | |_) | |___   _  | |_) | |___   _
!            |  _ /|  _  | | | |  _ /|___  | | |
!            | |   | | | | | | | |    ___| | | |
!            |_|   |_| |_| |_| |_|   |_____| |_|
!     .................................................
!     PhiPsi:     a general-purpose computational
!                 mechanics program written in Fortran.
!     Website:    http://phipsi.top
!     Author:     Shi Fang from Huaiyin Institute of
!                 Technology, HuaiAn, JiangSu, China
!     Contact me: shifang@hyit.edu.cn
!     ------------------------------------------------
!     Please cite the following papers:
!     (1)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based method with reduction technique
!        for modeling hydraulic fracture propagation
!        in formations containing frictional natural
!        fractures. Engineering Fracture Mechanics,
!        2017, 173: 64-90.
!     (2)Shi F, Wang X L, Liu C, Liu H, Wu H A. A
!        coupled extended finite element approach
!        for modeling hydraulic fracturing in
!        consideration of proppant. Journal of
!        Natural Gas Science and Engineering, 2016,
!        33: 885-897.
!     (3)Shi F, Wang X L, Liu C, Liu H, Wu H A. An
!        XFEM-based numerical model to calculate
!        conductivity of propped fracture considering
!        proppant transport, embedment and crushing.
!        Journal of Petroleum Science and Engineering,
!        2018, 167: 615-626..

      subroutine Cal_Signed_Distance(Line_AB,Point_C,S_Distance)
c     This function calculates the signed distance from the Point_C to the Line_AB.

      implicit none
      double precision,intent(in)::Line_AB(2,2),Point_C(2)
      double precision,intent(out)::S_Distance

      double precision tem_1(2,2), tem_2(2)
      double precision tem_Det,tem_Norm

      tem_1(1,:) = Line_AB(2,:)-  Line_AB(1,:)
      tem_1(2,:) = Point_C     -  Line_AB(1,:)
      tem_2(:)   = Line_AB(2,:)-Line_AB(1,:)
      tem_Det = tem_1(1,1)*tem_1(2,2) - tem_1(2,1)*tem_1(1,2)

      call Vector_Norm2(2,tem_2,tem_Norm)

      S_Distance = tem_Det / tem_Norm

      return
      end SUBROUTINE Cal_Signed_Distance


module module_grid

contains
!==================================================================
!> SUBROUTINE TO GENERATE 1D STRETCHED GRID WITH N1 POINTS
!> This subroutine basically divides the domain of length 1 unit from 0 to 1 in N1 number points
!> According to the requirement, the discretized points have to be multiplied with length H to have a grid of size H. If this is not multiplied, it wil simply create the mesh from 0 to 1
!> modified version of original code by Dr. Laval
!> Original code : http://imp-turbulence.ec-lille.fr/Webpage/Laval/Lectures/TD-Programs.tar
!==================================================================
SUBROUTINE sGrid_Generator(H,N1,ALPHA,YPAD,YHAD)

IMPLICIT NONE

REAL(8),INTENT(IN)				::ALPHA
INTEGER,INTENT(IN)				::N1
REAL(8),DIMENSION(N1),INTENT(INOUT)		::YPAD,YHAD
INTEGER						::J,I
REAL(8)						::ALPHA1,ALPHA2
INTEGER						::N05,N06
REAL(8)						::COEF
REAL(8),INTENT(IN)				::H

ALPHA1=ALPHA
ALPHA2=ALPHA

N05=(N1+1)/2
N06=N05+1

!---  MESH FOR HALF LOWER CHANNEL ---

COEF=DEXP(ALPHA1*(1.-N05))
DO J=2,N05
   YPAD(J)=(.5*(DEXP(ALPHA1*(J-N05))-COEF)/(1.-COEF))*(H) 	!Multiplying by H
ENDDO

!---  MESH FOR HALF UPPER CHANNEL ---

COEF=DEXP(ALPHA2*(N05-N1))
DO J=N06,N1-1
  YPAD(J)=(1.-.5*(DEXP(ALPHA2*(N05-J))-COEF)/(1.-COEF))*(H) 	!Multiplying by H
ENDDO

!---  NEAR WALL POINTS ---

YPAD(1)=-YPAD(2)
YPAD(N1)=(2.*H)-YPAD(N1-1)

YHAD(1)=0.
DO J=2,N1
  YHAD(J)=YPAD(J)-YPAD(J-1)
ENDDO

!Print *, "# The first grid point out of the domain is:  ", YPAD(1)  !First grid point out of FVM domain
!Print *, "# The last grid point out of the domain is:  ", YPAD(N1)  !Last grid point out of FVM domain

        OPEN(12,file='GRID.dat')
        WRITE(12,"(A26,I4,A31,1ES16.8)") '# GRID: NUMBER OF POINTS: ',N1,' STRETCHING COEFFICIENT ALPHA: ',ALPHA
        WRITE(12,*) "#I        YPAD              YHAD"
	DO I=1,N1
	   WRITE(12,11)I,YPAD(I),YHAD(I)
	ENDDO
	11 FORMAT(I3,2x,2(F16.8,2x))
	!DEALLOCATE(YPAD,YHAD)
	CLOSE(12)

end subroutine

end module module_grid


	SUBROUTINE VC_THTA  ( p, t, nxy, thta, iret )
C************************************************************************
C* VC_THTA								*
C*									*
C* This subroutine computes theta coordinate values.			*
C*									*
C* VC_THTA ( P, T, NXY, THTA,  IRET )					*
C*									*
C* Input parameters:							*
C*	P  (NXY)	REAL		Pressure			*
C*	T  (NXY)	REAL		Temperature			*
C*	NXY		INTEGER		Number of grid points		*
C*									*
C* Output parameters:							*
C*	THTA (NXY)	REAL		Output theta values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      06/92						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		p (*), t (*), thta (*)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C
C*	Compute the theta coordinate values.
C
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( p (i) ) .or. ERMISS ( t (i) ) ) THEN
		thta (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		thta (i) = t (i) * ( 1000. / p (i) ) ** RKAPPA
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


      double precision function psi(x,y,z)
      implicit none

      double precision x,y,z,pi,r
      common /compi/ pi

c      psi = ((sin(pi*x))**2 * (sin(pi*y))**2) / pi

      r = sqrt((x-1.d0)**2 + (y-1.d0)**2)

c     # Rigid body rotation
c      psi = r**2

c     # Filament formation (negative for clockwise rotation)
      psi = (4.d0/3.d0)*r**3

c      psi = x + y

      return
      end

      subroutine get_psi_vel(xd1,xd2,ds,vn,t)
      implicit none

      double precision xd1(3),xd2(3), ds, vn, psi,t

      vn = (psi(xd1(1),xd1(2),xd1(3)) -
     &      psi(xd2(1),xd2(2),xd2(3)))/ds

      end


      subroutine pl_rootfr
	!! This subroutine distributes dead root mass through the soil profile
	!! code developed by Armen R. Kemanian in 2008
	!! March, 2009 further adjustments expected

    use hru_module, only : ihru
    use soil_module
    use plant_module

    implicit none

	real :: sol_thick(soil(ihru)%nly) !            |
	real :: cum_rd                    !            |
    real :: cum_d                     !            |
    real :: cum_rf                    !            |
    real :: x1                        !            |
    real :: x2                        !            |
	integer :: k                      !            |
    integer :: l                      !none        |number of soil layer that manure applied
    integer :: jj                     !none        |counter
    real :: a                         !            |
    real :: b                         !            |
    real :: c                         !            |
    real :: d                         !            |
    real :: rtfr                      !none        |root fraction
    real :: xx1                       !            |
    real :: xx2                       !            |
    real :: xx                        !            |

	jj = ihru

      if (pcom(jj)%plg(1)%root_dep < 1.e-6) then
         soil(jj)%ly(1)%rtfr = 1
         return
      endif

	! Normalized Root Density = 1.15*exp[-11.7*NRD] + 0.022, where NRD = normalized rooting depth
	! Parameters of Normalized Root Density Function from Dwyer et al 19xx
	a = 1.15
	b = 11.7
	c = 0.022
	d = 0.12029 ! Integral of Normalized Root Distribution Function
				! from 0 to 1 (normalized depth) = 0.12029

	l = 0
	k = 0
	cum_d = 0.
	cum_rf = 0.
         sol_thick(:) = 0.
         rtfr = 0.

	do l = 1, soil(jj)%nly
	  if (l == 1) then
	    sol_thick(l) = soil(jj)%phys(l)%d
	  else
	    sol_thick(l) = soil(jj)%phys(l)%d - soil(jj)%phys(l-1)%d
	  end if

	  cum_d = cum_d + sol_thick(l)
	  if (cum_d >= pcom(jj)%plg(1)%root_dep) cum_rd = pcom(jj)%plg(1)%root_dep
	  if (cum_d < pcom(jj)%plg(1)%root_dep) cum_rd = cum_d
	  x1 = (cum_rd - sol_thick(l)) / pcom(jj)%plg(1)%root_dep
	  x2 = cum_rd / pcom(jj)%plg(1)%root_dep
           xx1 = -b * x1
	  if (xx1 > 20.) xx1 = 20.
           xx2 = -b * x2
           if (xx2 > 20.) xx2 = 20.
	     soil(jj)%ly(l)%rtfr = (a/b*(Exp(xx1) - Exp(xx2)) + c *(x2 - x1))/d
           xx = cum_rf
	  cum_rf = cum_rf + soil(jj)%ly(l)%rtfr
           if (cum_rf > 1.) then
	       soil(jj)%ly(l)%rtfr = 1. - xx
             cum_rf = 1.0
           end if
	  k = l
	  if (cum_rd >= pcom(jj)%plg(1)%root_dep) Exit

	end do

	!!	 ensures that cumulative fractional root distribution = 1
	do l = 1, soil(jj)%nly
		soil(jj)%ly(l)%rtfr = soil(jj)%ly(l)%rtfr / cum_rf
		If (l == k) Exit ! exits loop on the same layer as the previous loop
    end do

    return

	end subroutine pl_rootfr


program test_polynomial
  Use ieee_arithmetic
  Use iso_c_binding
  Use mlf_utils
  Use mlf_poly
  Use mlf_cfuns
  integer:: info
  call test_root([0.2d0, 0.3d0])
  call test_root([0.5d0, 0.5d0])
  call test_root([0.2d0, 0.3d0, 0.8d0])
  call test_root([0.2d0, 0.2d0, 0.8d0])
  call test_root([0.2d0, 0.2d0, 0.8d0, 1.0d0])
  call test_root([-2d0, -0.6d0, 0.9d0, 1.5d0])
  call test_root([4d0, -2d0, 12d0, -25d0])
  call test_poly([-1d0, 0d0, 0d0, 1d0])
  call test_poly([1d0, 0d0, 1d0])
  call test_poly([1d0, -3d0, 2d0, -6d0, 1d0])
  call test_2DInterp(1d0, -0.5d0, 0.5d0)
  call test_2DInterp(10d0, -0.1d0, 0.8d0)
  call test_2DInterp(-1d0, -10d0, 0.2d0)
  call test_2DInterp(0.5d0, 0.2d0, 2d0)
contains
  Subroutine test_2DInterp(a, r0, r1)
    real(c_double), intent(in) :: a, r0, r1
    real(c_double) :: x
    x = FindRoot2DInterp(a*r0*r1, a*(1d0-r0)*(1d0-r1), a*(2d0-r0-r1))
    PRINT *, a, r0, r1, x
  End Subroutine test_2DInterp
  Subroutine test_root(R)
    real(c_double), intent(in) :: R(:)
    real(c_double) :: P(size(R)+1), Q(size(R))
    integer :: nr, i
    print *,  "----------------------------------------"
    print *,"Initial roots:", R
    call mlf_polyFromRoots(R,P)
    print *, "P coefficients: ", P
    forall(i=1:size(R)) Q(i) = mlf_polyVal(P, R(i))
    print *, "P(root) shall be 0: ", Q
    nr = mlf_rootsPoly(P,Q, 1d-12)
    print *, "Estimated roots:", Q(1:nr)
  End Subroutine test_root
  Subroutine test_poly(P)
    real(c_double), intent(in) :: P(:)
    real(c_double) :: Q(size(P)-1), V(size(P)-1)
    integer :: nr,i
    print *,  "----------------------------------------"
    print *, "Polynomial: ",P
    nr = mlf_rootsPoly(P,Q, 1d-12)
    print *, "Estimated roots:", Q(1:nr)
    forall(i=1:nr) V(i) = mlf_polyVal(P, Q(i))
    print *, "P(root) shall be 0: ", V(1:nr)
  End Subroutine test_poly
end


! Name: ARPIT KUMAR JAIN, Roll No: 180122009
! Home Assignment Programme-2
! Radial Distribution function (RDF) for 1s, 2s, 3s

MODULE RadialDistributionFunction
    ! Declaration of variables
    IMPLICIT NONE
    REAL, PARAMETER :: pi = acos(-1.0)
    INTEGER:: i, size
    REAL, DIMENSION(:), ALLOCATABLE:: RDF

    CONTAINS
    SUBROUTINE CalculateRDF(orbitalNumber, r, deltaR)
        IMPLICIT NONE
        INTEGER:: orbitalNumber
        REAL:: r, deltaR, psi
        CHARACTER*10:: filename

        size = INT(r/deltaR) + 1
        ALLOCATE(RDF(size))

        r = 0.0
        DO i = 1, size
            psi = waveFunction(orbitalNumber, r)
            RDF(i) = (psi * psi) * 4.0 * pi * r * r
            r = r + 0.05
        ENDDO

        CALL SCALE(RDF, size)
        WRITE(filename, fmt = "(a, i1, a)") "output.", orbitalNumber, "s"
        OPEN(UNIT = 20, FILE = filename, FORM = "formatted")
            r = 0.0
            DO i = 1, size
                WRITE(20, *) r, RDF(i)
                r = r + 0.050
            ENDDO
        CLOSE(20)
    END SUBROUTINE CalculateRDF

    REAL FUNCTION waveFunction(orbitalNumber, r)
        IMPLICIT NONE
        REAL:: r
        INTEGER:: orbitalNumber
        IF(orbitalNumber .EQ. 1) waveFunction = EXP(-r/2.0)
        IF(orbitalNumber .EQ. 2) waveFunction = (1.0/SQRT(32.0)) * (2.0-R) * EXP(-R/2.0)
        IF(orbitalNumber .EQ. 3) waveFunction = (1.0/SQRT(972.0)) * (6 - 6 * R + R * R) * EXP(-R/2.0)
    END FUNCTION waveFunction

    SUBROUTINE SCALE(RDF, size)
        IMPLICIT NONE
        INTEGER:: size
        REAL, DIMENSION(size):: RDF
        REAL:: BIGGEST = 0.0
        DO i = 1, size
            IF(BIGGEST .LT. RDF(i)) BIGGEST = RDF(i)
        ENDDO

        DO i = 1, size
            RDF(i) = RDF(i) / BIGGEST
        ENDDO
    END SUBROUTINE SCALE

END MODULE RadialDistributionFunction

! Main Program
PROGRAM HA_Q2
    USE RadialDistributionFunction

    IMPLICIT NONE
    INTEGER:: orbitalNumber
    REAL:: radius = 2.0                 ! Change this r value to 20 then you can see full graph
    REAL:: deltaR = 0.05

    1 PRINT *, "Enter Orbital Number to Calculate RDF...."
    PRINT *, "For 1s orbital Enter:  1"
    PRINT *, "For 2s orbital Enter:  2"
    PRINT *, "For 3s orbital Enter:  3"
    READ (*, *) orbitalNumber

    IF((orbitalNumber >= 1) .AND. (orbitalNumber <= 3)) then
        CALL CalculateRDF(orbitalNumber, radius, deltaR)
    ELSE
        Print *, "Please Enter Correct Orbital Number ... "
        Print *
        GOTO 1
    ENDIF
END PROGRAM HA_Q2


! Program to test the DOT_PRODUCT intrinsic
program testforall
   implicit none
   integer, dimension (3) :: a
   integer, dimension (3) :: b
   real, dimension(3) :: c
   real r
   complex, dimension (2) :: z1
   complex, dimension (2) :: z2
   complex z

   a = (/1, 2, 3/);
   b = (/4, 5, 6/);
   c = (/4, 5, 6/);

   if (dot_product(a, b) .ne. 32) call abort

   r = dot_product(a, c)
   if (abs(r - 32.0) .gt. 0.001) call abort

   z1 = (/(1.0, 2.0), (2.0, 3.0)/)
   z2 = (/(3.0, 4.0), (4.0, 5.0)/)
   z = dot_product (z1, z2)
   if (abs (z - (34.0, -4.0)) .gt. 0.001) call abort
end program


PROGRAM F002

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER :: N
    REAL    :: BINETS_FORMULA, FN_MAX, FN_SUM, FN_SUM_EVEN

    FN_MAX = 4E+6
    N      = INT( LOG((FN_MAX * SQRT(5.0)) + 0.5) / LOG((1 + SQRT(5.0)) / 2) )
    FN_SUM = (BINETS_FORMULA(N + 2) - 1)

    FN_SUM_EVEN = FN_SUM / 2;

    PRINT ('(I0)'), INT(FN_SUM_EVEN)

END PROGRAM F002

REAL FUNCTION BINETS_FORMULA (N_VAL)

    IMPLICIT NONE

    INTEGER, INTENT(IN) :: N_VAL

    BINETS_FORMULA = REAL( (1 / SQRT(5.D0))                                    &
                     * ( (((1 + SQRT(5.D0)) / 2) ** N_VAL)                     &
                        - (((1 - SQRT(5.D0)) / 2) ** N_VAL) ), 4)

END FUNCTION BINETS_FORMULA


!
! Project Euler Problem 3: Largest Prime Factor
!
! D. C. Groothuizen Dijkema - November, 2019
!

subroutine run
  implicit none
  integer :: itr
  integer(kind=8) :: val
  integer(kind=8),parameter :: n=600851475143

  val=n
  itr=2

  do while(itr*itr<val)
    if (mod(val,itr).eq.0) then
      val=val/itr
    else
      itr=itr+1
    end if
  end do

  if (val>itr) then
    itr=val
  end if

  print *,"largest prime factor of ",n," is:",itr

end subroutine run

program prime
  implicit none
  integer :: beginning,end,rate

  call system_clock(beginning,rate)
  call run
  call system_clock(end)
  print *,"Elapsed time:",real(end-beginning)/real(rate)

end program


! Copyright (c) 2019 Daniel de Vries
! This code is licensed under MIT license (see LICENSE for details)
module sellar
    use, intrinsic :: iso_c_binding, only: c_double
    implicit none
    private
        integer, parameter :: dp = kind(0.d0)
    public d1, d2
contains
    !> @brief calculate y1 = d1(z1, z2, x1, y2) = z1^2 + z2 + x1 - 0.2*y2
    !!
    !! This function defines the mathematical equation for the first discipline (D1) of the Sellar problem.
    !!
    !! @param[in]    z1, z2, x1, y2    doubles
    !! @return    the result of the equation as a double
    pure function d1(z1, z2, x1, y2) result(y1) bind(c, name='d1')
        real(c_double), intent(in) :: z1, z2, x1, y2
        real(c_double)             :: y1
        y1 = z1**2_dp + z2 + x1 - 0.2_dp*y2
    end function d1

    !> @brief calculate y2 = d2(z1, z2, y1) = sqrt(y1) + z1 + z2
    !!
    !! This function defines the mathematical equation for the second discipline (D2) of the Sellar problem.
    !!
    !! @param[in]    z1, z2, x1, y2    doubles
    !! @return    the result of the equation as a double
    pure function d2(z1, z2, y1) result(y2) bind(c, name='d2')
        real(c_double), intent(in) :: z1, z2, y1
        real(c_double)             :: y2
        y2 = y1**0.5_dp + z1 + z2
    end function d2
end module sellar


 subroutine Fourier_init( &
      m,        ngeomax,  phi,     &
      one_d0m,  dfac,     EpDelta, &
      EmDelta,  Bmplus,   Bmmin)

!-----------------------------------------------------------
! Subroutine:
!   fourinit
!
! Purpose:
!   Some quantitities needde for Fourier expansion
!
! Output:
!
!-------------------------------------------------------------------

  implicit none

  integer,parameter::dp=selected_real_kind(8)!double precision

  integer,intent(in):: &
     m,       &
     ngeomax

  real(kind=dp),intent(in):: &
     phi(ngeomax)

  integer:: &
     iv

  real(kind=dp):: &
     d0m,     &
     deg2rad, &
     pi,      &
     Delta(4)

  real(kind=dp),intent(out):: &
     one_d0m,            &
     dfac,               &
     Bmplus(4,ngeomax),  &
     Bmmin(4,ngeomax),   &
     EpDelta(4),         &
     EmDelta(4)

  pi = 2.d0*asin(1.d0)
  deg2rad = pi/180.d0

! one_d0m = 1+d0m
  d0m = 0.d0
  if(m.eq.0) d0m = 1.d0
  one_d0m = 1.d0 + d0m

! dfac = 0.5 * (2-d0m)
  dfac = 0.5d0 * 2.d0
  if(m.eq.0) dfac = 0.5d0 * 1.d0

  Delta(1) =  1.d0
  Delta(2) =  1.d0
  Delta(3) = -1.d0
  Delta(4) = -1.d0

  EpDelta(1:4) = 1.d0+Delta(1:4)
  EmDelta(1:4) = 1.d0-Delta(1:4)

  do iv=1,ngeomax
     Bmplus(1,iv) = cos(dble(m)*(phi(iv)*deg2rad))
     Bmplus(2,iv) = cos(dble(m)*(phi(iv)*deg2rad))
     Bmplus(3,iv) = sin(dble(m)*(phi(iv)*deg2rad))
     Bmplus(4,iv) = sin(dble(m)*(phi(iv)*deg2rad))

     Bmmin(1,iv) = -sin(dble(m)*(phi(iv)*deg2rad))
     Bmmin(2,iv) = -sin(dble(m)*(phi(iv)*deg2rad))
     Bmmin(3,iv) =  cos(dble(m)*(phi(iv)*deg2rad))
     Bmmin(4,iv) =  cos(dble(m)*(phi(iv)*deg2rad))
  enddo

  return
  end subroutine Fourier_init


print *,sqrt( sum(x**2)/size(x) )


module ParticleSimulation

    integer, parameter :: dp = kind(0.0d0)

contains

elemental real(dp) function wrap(x,side)
    implicit none
    real(dp), intent(in) :: x, side
    wrap = mod(x,side)
    if (wrap >= side/2) then
        wrap = wrap - side
    else if (wrap < -side/2) then
        wrap = wrap + side
    end if
end function wrap

real(dp) function norm(ndim,x)
    integer :: ndim
    real(dp) :: x(ndim)
    norm = 0.0_dp
    do i = 1, ndim
        norm = norm + x(i)**2
    end do
    norm  = sqrt(norm)
end function norm

subroutine force_pair(ndim,fx,x,y,cutoff,side)
    implicit none
    integer :: ndim
    real(dp) :: fx(ndim), d
    real(dp) :: x(ndim), y(ndim), cutoff, side, dv(ndim)
    dv = wrap(y-x,side)
    d = norm(ndim,dv)
    if (d > cutoff) then
        fx = 0.0_dp
    else
        fx = 2*(d - cutoff)*(dv/d)
    end if
end subroutine force_pair

subroutine forces(n,ndim,f,x,cutoff,side)
    implicit none
    integer :: n, ndim, i, j
    real(dp) :: f(ndim,n), x(ndim,n)
    real(dp) :: fx(ndim)
    real(dp) :: cutoff, side
    f = 0.0_dp
    do i = 1, n-1
        do j = i+1, n
            call force_pair(ndim,fx,x(:,i),x(:,j),cutoff,side)
            f(:,i) = f(:,i) + fx
            f(:,j) = f(:,j) - fx
        end do
    end do
end subroutine forces

real(dp) function dp_rand()
    call random_number(dp_rand)
end function dp_rand

subroutine md(n,ndim,x0,v0,mass,dt,nsteps,isave,trajectory,cutoff,side)
    implicit none
    integer :: n, ndim, i, step, nsteps, isave, isaved
    real(dp) :: dt
    real(dp) :: x0(ndim,n), v0(ndim,n), mass(n)
    real(dp) :: x(ndim,n), v(ndim,n), f(ndim,n), a(ndim,n)
    real(dp) :: trajectory(ndim,n,nsteps/isave+1)
    real(dp) :: cutoff, side
    ! Save initial positions
    trajectory(:,:,1) = x0
    x = x0
    v = v0
    isaved = 1
    do step = 1, nsteps
        ! Compute forces
        call forces(n,ndim,f,x,cutoff,side)
        ! Update positions and velocities
        do i = 1, n
           a(:,i) = f(:,i) / mass(i)
           x(:,i) = x(:,i) + v(:,i)*dt + a(:,i)*dt**2/2
           v(:,i) = v(:,i) + a(:,i)*dt
        end do
        ! Save if required
        if (mod(step,isave) == 0) then
            isaved = isaved + 1
            trajectory(:,:,isaved) = x
        end if
    end do
end subroutine md

end module ParticleSimulation

program main
    use ParticleSimulation
    implicit none
    integer, parameter :: n = 100, ndim = 2
    integer :: i, j, k, nsteps, isave
    real(dp) :: x0(ndim,n), v0(ndim,n), mass(n)
    real(dp) :: dt
    real(dp) :: cutoff, side
    real(dp), allocatable :: trajectory(:,:,:)
    ! Initialize positions and velocities
    do i = 1, n
        do j = 1, ndim
            x0(j,i) = -50.0_dp + 100_dp*dp_rand()
            v0(j,i) = -1.0_dp + 2.0_dp*dp_rand()
        end do
        mass(i) = 10.0_dp
    end do
    ! Parameters
    dt = 0.001_dp
    nsteps = 200000
    isave = 1000
    cutoff = 5.0_dp
    side = 100.0_dp
    allocate(trajectory(ndim,n,nsteps/isave + 1))
    ! Run simulation
    call md(n,ndim,x0,v0,mass,dt,nsteps,isave,trajectory,cutoff,side)
    open(10,file="traj_fortran.xyz")
    k = 0
    do i = 1, nsteps/isave + 1
        k = k + 1
        write(10,*) n
        write(10,*) " step = ", k
        do j = 1, n
            write(10,*) "He", wrap(trajectory(1,j,k),side), wrap(trajectory(2,j,k),side), 0.0_dp
        end do
    end do
    close(10)
end program main


! Main program for quartic function

program test_quartic

    use newton, only: solve, tol
    use functions, only: f_quartic, fprime_quartic, epsilon

    implicit none
    real(kind=8) :: x, x0, fx, xstar
    real(kind=8) :: tolvals(3), epsvals(3)
    integer :: iters, itest1, itest2
	logical :: debug

    x0 = 4.d0
    print 10 ,x0
10  format("Starting with initial guess ", es22.15,/)
    debug = .false.

    ! values to test as epsilon:
    epsvals = (/1.d-4, 1.d-8, 1.d-12/)

    ! values to test as tol:
    tolvals = (/1.d-5, 1.d-10, 1.d-14/)

    print *, '    epsilon        tol    iters          x                 f(x)        x-xstar'

    do itest1=1,3
        epsilon = epsvals(itest1)
        xstar = 1.d0 + epsilon**(0.25d0)
        do itest2=1,3

        tol = tolvals(itest2)

        call solve(f_quartic, fprime_quartic, x0, x, iters, debug)

        fx = f_quartic(x)
        print 11, epsilon, tol, iters, x, fx, x-xstar
11      format(2es13.3, i4, es24.15, 2es13.3)

        enddo
		print *, ' '  ! blank line
        enddo

end program test_quartic


C$Procedure      RECSPH ( Rectangular to spherical coordinates )

      SUBROUTINE RECSPH ( RECTAN, R, COLAT, LONG  )

C$ Abstract
C
C     Convert from rectangular coordinates to spherical coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,  COORDINATES
C
C$ Declarations

      DOUBLE PRECISION   RECTAN ( 3 )
      DOUBLE PRECISION   R
      DOUBLE PRECISION   COLAT
      DOUBLE PRECISION   LONG

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  --------------------------------------------------
C     RECTAN     I   Rectangular coordinates of a point.
C     R          O   Distance of the point from the origin.
C     COLAT      O   Angle of the point from the Z-axis (radians)
C     LONG       O   Longitude of the point (radians).
C
C$ Detailed_Input
C
C     RECTAN     The rectangular coordinates of a point.
C
C$ Detailed_Output
C
C     R          Distance of the point from the origin.
C
C     COLAT      Angle between the point and the positive z-axis in
C                radians. The range of COLAT is [0, pi].
C
C     LONG       Longitude of the point in radians. This is the angle
C                between the positive X-axis and the orthogonal
C                projection of the point onto the XY plane.  LONG
C                increases in the counterclockwise sense about the
C                positive Z-axis. The range of LONG is [-pi, pi].
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine returns the spherical coordinates of a point
C     whose position is input in rectangular coordinates.
C
C     Spherical coordinates are defined by a distance from a central
C     reference point, an angle from a reference meridian, and an angle
C     from the z-axis.
C
C$ Examples
C
C     Below are two tables.
C
C     Listed in the first table (under X(1), X(2) and X(3) ) are a
C     number of points whose rectangular coordinates are
C     taken from the set {-1, 0, 1}.
C
C     The result of the code fragment
C
C          CALL RECSPH ( X, R, COLAT, LONG )
C
C          Use the SPICELIB routine CONVRT to convert the angular
C          quantities to degrees
C
C          CALL CONVRT ( COLAT, 'RADIANS', 'DEGREES', COLAT )
C          CALL CONVRT ( LONG,  'RADIANS', 'DEGREES', LONG  )
C
C     are listed to 4 decimal places in the second parallel table under
C     R (radius), COLAT (co-latitude), and  LONG (longitude).
C
C       X(1)       X(2)     X(3)        R         COLAT       LONG
C       --------------------------      ----------------------------
C       0.0000     0.0000   0.0000      0.0000     0.0000     0.0000
C       1.0000     0.0000   0.0000      1.0000    90.0000     0.0000
C       0.0000     1.0000   0.0000      1.0000    90.0000    90.0000
C       0.0000     0.0000   1.0000      1.0000     0.0000     0.0000
C      -1.0000     0.0000   0.0000      1.0000    90.0000   180.0000
C       0.0000    -1.0000   0.0000      1.0000    90.0000   -90.0000
C       0.0000     0.0000  -1.0000      1.0000   180.0000     0.0000
C       1.0000     1.0000   0.0000      1.4142    90.0000    45.0000
C       1.0000     0.0000   1.0000      1.4142    45.0000     0.0000
C       0.0000     1.0000   1.0000      1.4142    45.0000    90.0000
C       1.0000     1.0000   1.0000      1.7320    54.7356    45.0000
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber      (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.3, 26-JUL-2016 (BVS)
C
C        Minor headers edits.
C
C-    SPICELIB Version 1.0.2, 07-JAN-2002 (NJB)
C
C        Fixed description of LONG in Brief_I/O and Detailed_I/O
C        header sections.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     rectangular to spherical coordinates
C
C-&

C$ Revisions
C
C-    Beta Version 1.0.1, 1-Feb-1989 (WLT)
C
C        Example section of header upgraded.
C
C-&

      DOUBLE PRECISION X
      DOUBLE PRECISION Y
      DOUBLE PRECISION Z
      DOUBLE PRECISION BIG

C
C     Store rectangular coordinates in temporary variables
C
      BIG = MAX ( DABS(RECTAN(1)), DABS(RECTAN(2)), DABS(RECTAN(3)) )

      IF ( BIG .GT. 0 ) THEN

         X      = RECTAN(1) / BIG
         Y      = RECTAN(2) / BIG
         Z      = RECTAN(3) / BIG

         R      = BIG * DSQRT (X*X + Y*Y + Z*Z)

         COLAT  = DATAN2 ( DSQRT(X*X + Y*Y), Z )

         X      = RECTAN(1)
         Y      = RECTAN(2)

         IF (X.EQ.0.0D0 .AND. Y.EQ.0.0D0) THEN
            LONG  = 0.0D0
         ELSE
            LONG  = DATAN2 (Y,X)
         END IF

      ELSE
         R     = 0.0D0
         COLAT = 0.0D0
         LONG  = 0.0D0
      END IF

      RETURN
      END


*
* tempconv - Converts temperature from Farenheight to Centigrade
* and Kelvin
*
*  Written by: C. Severance 16Mar92
*
* Declare the variables:
*
      REAL CENT,FAREN,KELVIN
*
* Prompt the user for the Farenheight temperature
*
      PRINT *,'Enter the farenheight temperature - '
      READ *,FAREN
*
* Calculate the centigrade temperature
*
      CENT = ( FAREN - 32.0 ) * ( 5.0 / 9.0 )
      PRINT *,'Centigrade temperature is - ',CENT
*
* Calculate the kelvin temperature
*
      KELVIN = CENT + 273.0
      PRINT *,' Kelvin temperature is - ',KELVIN
      END


C$Procedure      VDISTG ( Vector distance, general dimension )

      DOUBLE PRECISION FUNCTION VDISTG ( V1, V2, NDIM )

C$ Abstract
C
C     Return the distance between two vectors of arbitrary dimension.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V1   ( * )
      DOUBLE PRECISION      V2   ( * )
      INTEGER               NDIM

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     V1,
C     V2         I   Two vectors of arbitrary dimension.
C     NDIM       I   The common dimension of V1 and V2
C
C     The function returns the distance between V1 and V2.
C
C$ Detailed_Input
C
C     V1,
C     V2         are two vectors of arbitrary dimension, the
C                distance between which is desired.
C
C     NDIM       is the common dimension of V1 and V2.  NDIM must be
C                non-negative and must not exceed the minimum of the
C                declared sizes of the actual arguments corresponding
C                to V1 and V2.
C
C$ Detailed_Output
C
C     The function returns the distance between V1 and V2.  This is
C     defined as
C
C              ||  V1 - V2  ||,
C
C     where || x || indicates the Euclidean norm of the vector x.
C
C     If NDIM is less than 1, the function value is set to 0.D0.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     The Euclidean norm of an n-dimensional vector
C
C        (x ,  x , ... , x )
C          1    2         n
C
C     is defined as
C
C                                                1/2
C              2        2                  2
C        (   x    +   x    +  . . .  +   x     ).
C             1        2                  n
C
C     This number is the distance of the point (x, y, z) from the
C     origin.  If n = 3, and A and B are two vectors whose components
C     are
C
C        ( A(1), A(2), A(3) )    and    ( B(1), B(2), B(3) ),
C
C     then the distance between A and B is the norm of the difference
C     A - B, which has components
C
C        (  A(1) - B(1),  A(2) - B(2),  A(3) - B(3)  ).
C
C     A related routine is VDIST, which computes the distance between
C     two 3-vectors.
C
C$ Examples
C
C     1)  If V1 is
C
C            ( 2.0D0,  3.0D0 )
C
C         and V2 is
C
C            ( 5.0D0,  7.0D0 ),
C
C         and NDIM is 2, then
C
C            VDISTG (V1, V2, NDIM )
C
C         will be 5.D0.
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 17-JUL-1990 (NJB)
C
C-&

C$ Index_Entries
C
C     distance between n-dimensional vectors
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      SCALE
      INTEGER               I

C
C     We find the norm of a scaled version of the difference vector,
C     and then rescale this norm.  This method helps prevent overflow
C     due to squaring the components of the difference vector.
C
C     The code here is almost identical to that of VNORMG.  We'd love
C     to just call VNORMG, but that would require storage for the
C     difference vector.  So we do the job ourselves.
C

C
C     Find the scale factor.
C
      SCALE = 0.D0

      DO I = 1, NDIM
         SCALE = MAX (  SCALE,  DABS ( V1(I) - V2(I) )  )
      END DO

      IF ( SCALE .EQ. 0.D0 ) THEN

         VDISTG = 0.D0
         RETURN

      ELSE

         VDISTG = 0.D0

         DO I = 1, NDIM
            VDISTG = VDISTG  +  (  ( V1(I) - V2(I) ) / SCALE  ) ** 2
         END DO

         VDISTG = SCALE  *  SQRT ( VDISTG )

      END IF

      RETURN
      END


program implict_heat
    implicit none
    integer :: i, k
    integer, parameter :: M = 10
    ! we store only values at x_2, ..., x_M
    real, dimension(M - 1) :: u, b
    real :: h, c, tau, pi = 4. * atan(1.), x, t
    real :: a0, a1

    ! set boundary data
    a0 = 0.
    a1 = 0.
    ! initiialize parameters
    h = 1. / M      ! space resolution
    tau = h         ! time step

    c = tau / (h * h)

    ! initial data
    do k = 1, M - 1
        x = k * h
        u(k) = sin(pi * x)
    end do
    ! now u = u_0

    ! print initial data u_0
    write(*,*)0., 0., a0
    do k = 1, M - 1
        write(*,*)0., k * h, u(k)
    end do
    write(*,*)0., 1., a1
    write(*,*)

    do i = 1, M
        ! now u = u_{i-1}
        ! set up the right-hand side of the linear system
        b = u
        ! adjust for boundary data
        b(1) = b(1) + c * a0;
        b(M - 1) = b(M - 1) + c * a1;

        ! find the solution of the linear system
        u = tridiag_solve(-c, 1. + 2. * c, -c, b, size(b))
        ! now u = u_i

        ! print u_i
        write(*,*)i * tau, 0., a0
        do k = 1, M - 1
            write(*,*)i * tau, k * h, u(k)
        end do
        write(*,*)i * tau, 1., a1
        write(*,*)
    end do

contains
    ! this function returns the solution x of the system Ax = b
    ! where A is a tridiagonal matrix with entries l, d, r on
    ! the three diagonals
function tridiag_solve(l, d, r, b, n)
    implicit none
    integer, intent(in) :: n
    ! input array
    real,  dimension(n), intent(in) :: b
    real, intent(in) :: l, d, r
    ! return value will be stored in this array
    real, dimension(n) :: tridiag_solve

    real,  dimension(n) :: bhat, rhat
    integer :: i

    rhat(1) = r / d
    bhat(1) = b(1) / d
    do i=2,n
        rhat(i) = r / (d - l * rhat(i - 1))
        bhat(i) = (b(i) - l * bhat(i-1)) / (d - l * rhat(i-1))
    enddo

    ! compute the solution, starting from n, then n-1, n-2, ...
    tridiag_solve(n) = bhat(n)
    do i=1,n-1
        tridiag_solve(n - i) = bhat(n - i) - rhat(n - i) * tridiag_solve(n - i + 1)
    end do

end function
end program


PROGRAM test_internal
IMPLICIT NONE
REAL, PARAMETER :: PI = 3.141592
REAL :: theta ! Angle in degrees
WRITE(*, *) 'Enter the desired angle in degrees: '
READ(*, *) theta
WRITE(*, '(A,F10.4)') 'The secant is ', secant(theta)
CONTAINS
  REAL FUNCTION secant(angle_in_degrees)
  REAL :: angle_in_degrees
  secant = 1. / COS(angle_in_degrees * PI / 180.)
  END FUNCTION secant
END PROGRAM test_internal


      Module mba3d_calVol
C
      contains
C
C ================================================================
      Real*8 Function calVol(xy1, xy2, xy3, xy4)
C ================================================================
C The oriented volume of the tetrahedron given by 4 vertices
C ================================================================
      Real*8 xy1(3), xy2(3), xy3(3), xy4(3)

C group (Local variables)
      Real*8 v(3, 3)

      Do i = 1, 3
         v(i, 1) = xy1(i) - xy4(i)
      End do

      Do i = 1, 3
         v(i, 2) = xy2(i) - xy4(i)
      End do

      Do i = 1, 3
         v(i, 3) = xy3(i) - xy4(i)
      End do

      calVol = (v(1, 1) * (v(2, 2) * v(3, 3) - v(3, 2) * v(2, 3)) +
     &          v(2, 1) * (v(3, 2) * v(1, 3) - v(1, 2) * v(3, 3)) +
     &          v(3, 1) * (v(1, 2) * v(2, 3) - v(2, 2) * v(1, 3))) /
     &          6D0
      Return
      End Function calVol
C
      End Module mba3d_calVol


SUBROUTINE concar(con,car,j,flag)
!*********************************************************
!     transform a tensor from convected to cartesian & viceversa
!     covariant (strain, note that the third element is twice the tensor value)
!         FLAG = 1  from convected to cartesian
!         FLAG = 2  from cartesian to convected
!     contravariant (stress)
!         FLAG = 3  from convected to cartesian
!         FLAG = 4  from cartesian to convected
!     DATA
!         CON in convected system
!         CAR in cartesian system
!         J   inverse of the jacobian matrix
!*********************************************************
IMPLICIT NONE
INTEGER (kind=4),INTENT(IN) :: flag
REAL (kind=8),INTENT(IN) :: j(2,2)
REAL (kind=8),INTENT(IN OUT) :: con(3),car(3)

REAL (kind=8) :: value

SELECT CASE (flag)
CASE (1)
  car(1) =  con(1)*j(1,1)*j(1,1)+                                 &
            con(2)*j(1,2)*j(1,2)+                                 &
            con(3)*j(1,1)*j(1,2)
  car(2) =  con(1)*j(2,1)*j(2,1)+                                 &
            con(2)*j(2,2)*j(2,2)+                                 &
            con(3)*j(2,1)*j(2,2)
  car(3)=2*(con(1)*j(2,1)*j(1,1)+                                 &
            con(2)*j(2,2)*j(1,2))+                                &
            con(3)*(j(1,1)*j(2,2)+j(1,2)*j(2,1))
CASE (2)
  value  =  1d0/(j(1,1)*j(2,2)-j(1,2)*j(2,1))**2
  con(1) = (car(1)*j(2,2)*j(2,2)+                                 &
            car(2)*j(1,2)*j(1,2)-                                 &
            car(3)*j(2,2)*j(1,2))*value
  con(2) = (car(1)*j(2,1)*j(2,1)+                                 &
            car(2)*j(1,1)*j(1,1)-                                 &
            car(3)*j(2,1)*j(1,1))*value
  con(3) = (-2*(car(1)*j(2,1)*j(2,2)+                             &
                car(2)*j(1,1)*j(1,2))+                            &
                car(3)*(j(1,1)*j(2,2)+j(1,2)*j(2,1)))*value
CASE (3)
  value  =  1d0/(j(1,1)*j(2,2)-j(1,2)*j(2,1))**2
  car(1) = (con(1)*j(2,2)*j(2,2)+                                 &
            con(2)*j(2,1)*j(2,1)-                                 &
            con(3)*j(2,2)*j(2,1)*2d0)*value
  car(2) = (con(1)*j(1,2)*j(1,2)+                                 &
            con(2)*j(1,1)*j(1,1)-                                 &
            con(3)*j(1,2)*j(1,1)*2d0)*value
  car(3) =(-con(1)*j(2,2)*j(1,2)-                                 &
            con(2)*j(2,1)*j(1,1)+                                 &
            con(3)*(j(1,1)*j(2,2)+j(1,2)*j(2,1)))*value
CASE (4)
  con(1) =  car(1)*j(1,1)*j(1,1)+                                 &
            car(2)*j(2,1)*j(2,1)+                                 &
            car(3)*j(1,1)*j(2,1)*2d0
  con(2) =  car(1)*j(1,2)*j(1,2)+                                 &
            car(2)*j(2,2)*j(2,2)+                                 &
            car(3)*j(1,2)*j(2,2)*2d0
  con(3) =  car(1)*j(1,1)*j(1,2)+                                 &
            car(2)*j(2,1)*j(2,2)+                                 &
            car(3)*(j(1,1)*j(2,2)+j(1,2)*j(2,1))
END SELECT
RETURN

END SUBROUTINE concar