  integer function julian_day(yr,mo,da)

  implicit none

  integer yr,mo,da

  integer mon(12)
  integer lpyr
  data mon /0,31,59,90,120,151,181,212,243,273,304,334/

  julian_day = da + mon(mo)
  if(mo>2) julian_day = julian_day + lpyr(yr)

  end function julian_day

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

  integer function lpyr(yr)

  implicit none

  integer yr
!
!---- returns 1 if leap year
!
  lpyr=0
  if(mod(yr,400) == 0) then
    lpyr=1
  else if(mod(yr,4) == 0) then
    lpyr=1
    if(mod(yr,100) == 0) lpyr=0
  endif

  end function lpyr

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

! function to determine if year is a leap year
  logical function is_leap_year(yr)

  implicit none

  integer yr

  integer, external :: lpyr

!---- function lpyr above returns 1 if leap year
  if(lpyr(yr) == 1) then
    is_leap_year = .true.
  else
    is_leap_year = .false.
  endif

  end function is_leap_year

!----------------------------------------------------------------------------------------------
! open-source subroutines below taken from ftp://ftp.met.fsu.edu/pub/ahlquist/calendar_software
!----------------------------------------------------------------------------------------------

  integer function idaywk(jdayno)

! IDAYWK = compute the DAY of the WeeK given the Julian Day number,
!          version 1.0.

  implicit none

! Input variable
  integer, intent(in) :: jdayno
! jdayno = Julian Day number starting at noon of the day in question.

! Output of the function:
! idaywk = day of the week, where 0=Sunday, 1=Monday, ..., 6=Saturday.

!----------
! Compute the day of the week given the Julian Day number.
! You can find the Julian Day number given (day,month,year)
! using subroutine calndr below.
! Example: For the first day of the Gregorian calendar,
! Friday 15 October 1582, compute the Julian day number (option 3 of
! subroutine calndr) and compute the day of the week.
!     call calndr (3, 15, 10, 1582, jdayno)
!     write(*,*) jdayno, idaywk(jdayno)
! The numbers printed should be 2299161 and 5, where 5 refers to Friday.
!
! Copyright (C) 1999 Jon Ahlquist.
! Issued under the second GNU General Public License.
! See www.gnu.org for details.
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
! If you find any errors, please notify:
! Jon Ahlquist <ahlquist@met.fsu.edu>
! Dept of Meteorology
! Florida State University
! Tallahassee, FL 32306-4520
! 15 March 1999.
!
!-----

! converted to Fortran90 by Dimitri Komatitsch,
! University of Pau, France, January 2008.

! jdSun is the Julian Day number starting at noon on any Sunday.
! I arbitrarily chose the first Sunday after Julian Day 1,
! which is Julian Day 6.
  integer, parameter :: jdSun = 6

  idaywk = mod(jdayno-jdSun,7)

! If jdayno-jdSun < 0, then we are taking the modulus of a negative
! number. Fortran's built-in mod function returns a negative value
! when the argument is negative.  In that case, we adjust the result
! to a positive value.
  if (idaywk < 0) idaywk = idaywk + 7

  end function idaywk

!
!----
!

  subroutine calndr(iday,month,iyear,idayct)

! CALNDR = CALeNDaR conversions, version 1.0

  implicit none

! specify the desired calendar conversion option.
! in order to return the julian day number, compatible with function idaywk from above,
! we choose option 3
! (tested with dates: Feb, 23 2010 -> idaywk = Tue
!                               Dec, 24 2009 -> idaywk = Thu
!                               Oct, 15 1582  -> idaywk = Fri ...which all look o.k. )
  integer, parameter :: ioptn = 3

! Input/Output variables
  integer, intent(inout) :: iday,month,iyear,idayct

!----------
!
! Subroutine calndr() performs calendar calculations using either
! the standard Gregorian calendar or the old Julian calendar.
! This subroutine extends the definitions of these calendar systems
! to any arbitrary year.  The algorithms in this subroutine
! will work with any date in the past or future,
! but overflows will occur if the numbers are sufficiently large.
! For a computer using a 32-bit integer, this routine can handle
! any date between roughly 5.8 million BC and 5.8 million AD
! without experiencing overflow during calculations.
!
! No external functions or subroutines are called.
!
!----------
!
! INPUT/OUTPUT ARGUMENTS FOR SUBROUTINE CALNDR()
!
! "ioptn" is the desired calendar conversion option explained below.
! Positive option values use the standard modern Gregorian calendar.
! Negative option values use the old Julian calendar which was the
! standard in Europe from its institution by Julius Caesar in 45 BC
! until at least 4 October 1582.  The Gregorian and Julian calendars
! are explained further below.
!
! (iday,month,iyear) is a calendar date where "iday" is the day of
! the month, "month" is 1 for January, 2 for February, etc.,
! and "iyear" is the year.  If the year is 1968 AD, enter iyear=1968,
! since iyear=68 would refer to 68 AD.
! For BC years, iyear should be negative, so 45 BC would be iyear=-45.
! By convention, there is no year 0 under the BC/AD year numbering
! scheme.  That is, years proceed as 2 BC, 1 BC, 1 AD, 2 AD, etc.,
! without including 0.  Subroutine calndr() will print an error message
! and stop if you specify iyear=0.
!
! "idayct" is a day count.  It is either the day number during the
! specified year or the Julian Day number, depending on the value
! of ioptn.  By day number during the specified year, we mean
! idayct=1 on 1 January, idayct=32 on 1 February, etc., to idayct=365
! or 366 on 31 December, depending on whether the specified year
! is a leap year.
!
! The values of input variables are not changed by this subroutine.
!
!
! ALLOWABLE VALUES FOR "IOPTN" and the conversions they invoke.
! Positive option values ( 1 to  5) use the standard Gregorian calendar.
! Negative option values (-1 to -5) use the old      Julian    calendar.
!
! Absolute
!  value
! of ioptn   Input variable(s)     Output variable(s)
!
!    1       iday,month,iyear      idayct
! Given a calendar date (iday,month,iyear), compute the day number
! (idayct) during the year, where 1 January is day number 1 and
! 31 December is day number 365 or 366, depending on whether it is
! a leap year.
!
!    2       idayct,iyear          iday,month
! Given the day number of the year (idayct) and the year (iyear),
! compute the day of the month (iday) and the month (month).
!
!    3       iday,month,iyear      idayct
! Given a calendar date (iday,month,iyear), compute the Julian Day
! number (idayct) that starts at noon of the calendar date specified.
!
!    4       idayct                iday,month,iyear
! Given the Julian Day number (idayct) that starts at noon,
! compute the corresponding calendar date (iday,month,iyear).
!
!    5       idayct                iday,month,iyear
! Given the Julian Day number (idayct) that starts at noon,
! compute the corresponding day number for the year (iday)
! and year (iyear).  On return from calndr(), "month" will always
! be set equal to 1 when ioptn=5.
!
! No inverse function is needed for ioptn=5 because it is
! available through option 3.  One simply calls calndr() with:
! ioptn = 3,
! iday  = day number of the year instead of day of the month,
! month = 1, and
! iyear = whatever the desired year is.
!
!----------
!
! EXAMPLES
! The first 6 examples are for the standard Gregorian calendar.
! All the examples deal with 15 October 1582, which was the first day
! of the Gregorian calendar.  15 October is the 288-th day of the year.
! Julian Day number 2299161 began at noon on 15 October 1582.
!
! Find the day number during the year on 15 October 1582
!     ioptn = 1
!     call calndr (ioptn, 15, 10, 1582,  idayct)
! calndr() should return idayct=288
!
! Find the day of the month and month for day 288 in year 1582.
!     ioptn = 2
!     call calndr (ioptn, iday, month, 1582, 288)
! calndr() should return iday=15 and month=10.
!
! Find the Julian Day number for 15 October 1582.
!     ioptn = 3
!     call calndr (ioptn, 15, 10, 1582, julian)
! calndr() should return julian=2299161
!
! Find the Julian Day number for day 288 during 1582 AD.
! When the input is day number of the year, one should specify month=1
!     ioptn = 3
!     call calndr (ioptn, 288, 1, 1582, julian)
! calndr() should return dayct=2299161
!
! Find the date for Julian Day number 2299161.
!     ioptn = 4
!     call calndr (ioptn, iday, month, iyear, 2299161)
! calndr() should return iday=15, month=10, and iyear=1582
!
! Find the day number during the year (iday) and year
! for Julian Day number 2299161.
!     ioptn = 5
!     call calndr (ioptn, iday, month, iyear, 2299161)
! calndr() should return iday=288, month=1, iyear=1582
!
! Given 15 October 1582 under the Gregorian calendar,
! find the date (idayJ,imonthJ,iyearJ) under the Julian calendar.
! To do this, we call calndr() twice, using the Julian Day number
! as the intermediate value.
!     call calndr ( 3, 15,        10, 1582,    julian)
!     call calndr (-4, idayJ, monthJ, iyearJ,  julian)
! The first call to calndr() should return julian=2299161, and
! the second should return idayJ=5, monthJ=10, iyearJ=1582
!
!----------
!
! BASIC CALENDAR INFORMATION
!
! The Julian calendar was instituted by Julius Caesar in 45 BC.
! Every fourth year is a leap year in which February has 29 days.
! That is, the Julian calendar assumes that the year is exactly
! 365.25 days long.  Actually, the year is not quite this long.
! The modern Gregorian calendar remedies this by omitting leap years
! in years divisible by 100 except when the year is divisible by 400.
! Thus, 1700, 1800, and 1900 are leap years under the Julian calendar
! but not under the Gregorian calendar.  The years 1600 and 2000 are
! leap years under both the Julian and the Gregorian calendars.
! Other years divisible by 4 are leap years under both calendars,
! such as 1992, 1996, 2004, 2008, 2012, etc.  For BC years, we recall
! that year 0 was omitted, so 1 BC, 5 BC, 9 BC, 13 BC, etc., and 401 BC,
! 801 BC, 1201 BC, etc., are leap years under both calendars, while
! 101 BC, 201 BC, 301 BC, 501 BC, 601 BC, 701 BC, 901 BC, 1001 BC,
! 1101 BC, etc., are leap years under the Julian calendar but not
! the Gregorian calendar.
!
! The Gregorian calendar is named after Pope Gregory XIII.  He declared
! that the last day of the old Julian calendar would be Thursday,
! 4 October 1582 and that the following day, Friday, would be reckoned
! under the new calendar as 15 October 1582.  The jump of 10 days was
! included to make 21 March closer to the spring equinox.
!
! Only a few Catholic countries (Italy, Poland, Portugal, and Spain)
! switched to the Gregorian calendar on the day after 4 October 1582.
! It took other countries months to centuries to change to the
! Gregorian calendar.  For example, England's first day under the
! Gregorian calendar was 14 September 1752.  The same date applied to
! the entire British empire, including America.  Japan, Russia, and many
! eastern European countries did not change to the Gregorian calendar
! until the 20th century.  The last country to change was Turkey,
! which began using the Gregorian calendar on 1 January 1927.
!
! Therefore, between the years 1582 and 1926 AD, you must know
! the country in which an event was dated to interpret the date
! correctly.  In Sweden, there was even a year (1712) when February
! had 30 days.  Consult a book on calendars for more details
! about when various countries changed their calendars.
!
! DAY NUMBER DURING THE YEAR
! The day number during the year is simply a counter equal to 1 on
! 1 January, 32 on 1 February, etc., thorugh 365 or 366 on 31 December,
! depending on whether the year is a leap year.  Sometimes this is
! called the Julian Day, but that term is better reserved for the
! day counter explained below.
!
! JULIAN DAY NUMBER
! The Julian Day numbering system was designed by Joseph Scaliger
! in 1582 to remove ambiguity caused by varying calendar systems.
! The name "Julian Day" was chosen to honor Scaliger's father,
! Julius Caesar Scaliger (1484-1558), an Italian scholar and physician
! who lived in France.  Because Julian Day numbering was especially
! designed for astronomers, Julian Days begin at noon so that the day
! counter does not change in the middle of an astronmer's observing
! period.  Julian Day 0 began at noon on 1 January 4713 BC under the
! Julian calendar.  A modern reference point is that 23 May 1968
! (Gregorian calendar) was Julian Day 2,440,000.
!
! JULIAN DAY NUMBER EXAMPLES
!
! The table below shows a few Julian Day numbers and their corresponding
! dates, depending on which calendar is used.  A negative 'iyear' refers
! to BC (Before Christ).
!
!                     Julian Day under calendar:
! iday  month   iyear     Gregorian   Julian
!  24     11   -4714            0        -38
!   1      1   -4713           38          0
!   1      1       1      1721426    1721424
!   4     10    1582      2299150    2299160
!  15     10    1582      2299161    2299171
!   1      3    1600      2305508    2305518
!  23      5    1968      2440000    2440013
!   5      7    1998      2451000    2451013
!   1      3    2000      2451605    2451618
!   1      1    2001      2451911    2451924
!
! From this table, we can see that the 10 day difference between the
! two calendars in 1582 grew to 13 days by 1 March 1900, since 1900 was
! a leap year under the Julian calendar but not under the Gregorian
! calendar.  The gap will widen to 14 days after 1 March 2100 for the
! same reason.
!
!----------
!
! PORTABILITY
!
! This subroutine is written in standard FORTRAN 90.
! It calls no external functions or subroutines and should run
! without problem on any computer having a 32-bit word or longer.
!
!----------
!
! ALGORITHM
!
! The goal in coding calndr() was clear, clean code, not efficiency.
! Calendar calculations usually take a trivial fraction of the time
! in any program in which dates conversions are involved.
! Data analysis usually takes the most time.
!
! Standard algorithms are followed in this subroutine.  Internal to
! this subroutine, we use a year counter "jyear" such that
!  jyear=iyear   when iyear is positive
!       =iyear+1 when iyear is negative.
! Thus, jyear does not experience a 1 year jump like iyear does
! when going from BC to AD.  Specifically, jyear=0 when iyear=-1,
! i.e., when the year is 1 BC.
!
! For simplicity in dealing with February, inside this subroutine,
! we let the year begin on 1 March so that the adjustable month,
! February is the last month of the year.
! It is clear that the calendar used to work this way because the
! months September, October, November, and December refer to
! 7, 8, 9, and 10.  For consistency, jyear is incremented on 1 March
! rather than on 1 January.  Of course, everything is adjusted back to
! standard practice of years beginning on 1 January before answers
! are returned to the routine that calls calndr().
!
! Lastly, we use a trick to calculate the number of days from 1 March
! until the end of the month that precedes the specified month.
! That number of days is int(30.6001*(month+1))-122,
! where 30.6001 is used to avoid the possibility of round-off and
! truncation error.  For example, if 30.6 were used instead,
! 30.6*5 should be 153, but round-off error could make it 152.99999,
! which would then truncated to 152, causing an error of 1 day.
!
! Algorithm reference:
! Dershowitz, Nachum and Edward M. Reingold, 1990: Calendrical
! Calculations.  Software-Practice and Experience, vol. 20, number 9
! (September 1990), pp. 899-928.
!
! Copyright (C) 1999 Jon Ahlquist.
! Issued under the second GNU General Public License.
! See www.gnu.org for details.
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
! If you find any errors, please notify:
! Jon Ahlquist <ahlquist@met.fsu.edu>
! Dept of Meteorology
! Florida State University
! Tallahassee, FL 32306-4520
! 15 March 1999.
!
!-----

! converted to Fortran90 by Dimitri Komatitsch,
! University of Pau, France, January 2008.

! Declare internal variables.
  integer jdref, jmonth, jyear, leap, n1yr, n4yr, n100yr, n400yr, ndays, ndy400, ndy100, nyrs, yr400, yrref
!
! Explanation of all internal variables.
! jdref   Julian Day on which 1 March begins in the reference year.
! jmonth  Month counter which equals month+1 if month > 2
!          or month+13 if month <= 2.
! jyear   Year index,  jyear=iyear if iyear > 0, jyear=iyear+1
!            if iyear < 0.  Thus, jyear does not skip year 0
!            like iyear does between BC and AD years.
! leap    =1 if the year is a leap year, =0 if not.
! n1yr    Number of complete individual years between iyear and
!            the reference year after all 4, 100,
!            and 400 year periods have been removed.
! n4yr    Number of complete 4 year cycles between iyear and
!            the reference year after all 100 and 400 year periods
!            have been removed.
! n100yr  Number of complete 100 year periods between iyear and
!            the reference year after all 400 year periods
!            have been removed.
! n400yr  Number of complete 400 year periods between iyear and
!            the reference year.
! ndays   Number of days since 1 March during iyear.  (In intermediate
!            steps, it holds other day counts as well.)
! ndy400  Number of days in 400 years.  Under the Gregorian calendar,
!            this is 400*365 + 100 - 3 = 146097.  Under the Julian
!            calendar, this is 400*365 + 100 = 146100.
! ndy100  Number of days in 100 years,  Under the Gregorian calendar,
!            this is 100*365 + 24 = 36524.   Under the Julian calendar,
!            this is 100*365 + 25 = 36525.
! nyrs    Number of years from the beginning of yr400
!              to the beginning of jyear.  (Used for option +/-3).
! yr400   The largest multiple of 400 years that is <= jyear.
!
!
!----------------------------------------------------------------
! Do preparation work.
!
! Look for out-of-range option values.
  if ((ioptn == 0) .or. (abs(ioptn) >= 6)) then
   write(*,*)'For calndr(), you specified ioptn = ', ioptn
   write(*,*) 'Allowable values are 1 to 5 for the Gregorian calendar'
   write(*,*) 'and -1 to -5 for the Julian calendar.'
   stop
  endif
!
! Options 1-3 have "iyear" as an input value.
! Internally, we use variable "jyear" that does not have a jump
! from -1 (for 1 BC) to +1 (for 1 AD).
  if (abs(ioptn) <= 3) then
   if (iyear > 0) then
      jyear = iyear
   else if (iyear == 0) then
      write(*,*) 'For calndr(), you specified the nonexistent year 0'
      stop
   else
      jyear = iyear + 1
   endif
!
!        Set "leap" equal to 0 if "jyear" is not a leap year
!        and equal to 1 if it is a leap year.
   leap = 0
   if ((jyear/4)*4 == jyear) then
      leap = 1
   endif
   if ((ioptn > 0)               .and. &
         ((jyear/100)*100 == jyear) .and. &
         ((jyear/400)*400 /= jyear)      ) then
         leap = 0
   endif
  endif
!
! Options 3-5 involve Julian Day numbers, which need a reference year
! and the Julian Days that began at noon on 1 March of the reference
! year under the Gregorian and Julian calendars.  Any year for which
! "jyear" is divisible by 400 can be used as a reference year.
! We chose 1600 AD as the reference year because it is the closest
! multiple of 400 to the institution of the Gregorian calendar, making
! it relatively easy to compute the Julian Day for 1 March 1600
! given that, on 15 October 1582 under the Gregorian calendar,
! the Julian Day was 2299161.  Similarly, we need to do the same
! calculation for the Julian calendar.  We can compute this Julian
! Day knwoing that on 4 October 1582 under the Julian calendar,
! the Julian Day number was 2299160.  The details of these calculations
! is next.
!    From 15 October until 1 March, the number of days is the remainder
! of October plus the days in November, December, January, and February:
! 17+30+31+31+28 = 137, so 1 March 1583 under the Gregorian calendar
! was Julian Day 2,299,298.  Because of the 10 day jump ahead at the
! switch from the Julian calendar to the Gregorian calendar, 1 March
! 1583 under the Julian calendar was Julian Day 2,299,308.  Making use
! of the rules for the two calendar systems, 1 March 1600 was Julian
! Day 2,299,298 + (1600-1583)*365 + 5 (due to leap years) =
! 2,305,508 under the Gregorian calendar and day 2,305,518 under the
! Julian calendar.
!    We also set the number of days in 400 years and 100 years.
! For reference, 400 years is 146097 days under the Gregorian calendar
! and 146100 days under the Julian calendar.  100 years is 36524 days
! under the Gregorian calendar and 36525 days under the Julian calendar.
  if (abs(ioptn) >= 3) then
!
!        Julian calendar values.
   yrref  =    1600
   jdref  = 2305518
!               = Julian Day reference value for the day that begins
!                 at noon on 1 March of the reference year "yrref".
   ndy400 = 400*365 + 100
   ndy100 = 100*365 +  25
!
!        Adjust for Gregorian calendar values.
   if (ioptn > 0) then
      jdref  = jdref  - 10
      ndy400 = ndy400 -  3
      ndy100 = ndy100 -  1
   endif
  endif
!
!----------------------------------------------------------------
! OPTIONS -1 and +1:
! Given a calendar date (iday,month,iyear), compute the day number
! of the year (idayct), where 1 January is day number 1 and 31 December
! is day number 365 or 366, depending on whether it is a leap year.
  if (abs(ioptn) == 1) then
!
!     Compute the day number during the year.
  if (month <= 2) then
   idayct = iday + (month-1)*31
  else
   idayct = iday + int(30.6001 * (month+1)) - 63 + leap
  endif
!
!----------------------------------------------------------------
! OPTIONS -2 and +2:
! Given the day number of the year (idayct) and the year (iyear),
! compute the day of the month (iday) and the month (month).
  else if (abs(ioptn) == 2) then
!
  if (idayct < 60+leap) then
   month  = (idayct-1)/31
   iday   = idayct - month*31
   month  = month + 1
  else
   ndays  = idayct - (60+leap)
!               = number of days past 1 March of the current year.
   jmonth = (10*(ndays+31))/306 + 3
!               = month counter, =4 for March, =5 for April, etc.
   iday   = (ndays+123) - int(30.6001*jmonth)
   month  = jmonth - 1
  endif
!
!----------------------------------------------------------------
! OPTIONS -3 and +3:
! Given a calendar date (iday,month,iyear), compute the Julian Day
! number (idayct) that starts at noon.
  else if (abs(ioptn) == 3) then
!
!     Shift to a system where the year starts on 1 March, so January
!     and February belong to the preceding year.
!     Define jmonth=4 for March, =5 for April, ..., =15 for February.
  if (month <= 2) then
    jyear  = jyear -  1
    jmonth = month + 13
  else
    jmonth = month +  1
  endif
!
!     Find the closest multiple of 400 years that is <= jyear.
  yr400 = (jyear/400)*400
!           = multiple of 400 years at or less than jyear.
  if (jyear < yr400) then
   yr400 = yr400 - 400
  endif
!
  n400yr = (yr400 - yrref)/400
!            = number of 400-year periods from yrref to yr400.
  nyrs   = jyear - yr400
!            = number of years from the beginning of yr400
!              to the beginning of jyear.
!
!     Compute the Julian Day number.
  idayct = iday + int(30.6001*jmonth) - 123 + 365*nyrs + nyrs/4 &
         + jdref + n400yr*ndy400
!
!     If we are using the Gregorian calendar, we must not count
!     every 100-th year as a leap year.  nyrs is less than 400 years,
!     so we do not need to consider the leap year that would occur if
!     nyrs were divisible by 400, i.e., we do not add nyrs/400.
  if (ioptn > 0) then
   idayct = idayct - nyrs/100
  endif
!
!----------------------------------------------------------------
! OPTIONS -5, -4, +4, and +5:
! Given the Julian Day number (idayct) that starts at noon,
! compute the corresponding calendar date (iday,month,iyear)
! (abs(ioptn)=4) or day number during the year (abs(ioptn)=5).
  else
!
!     Create a new reference date which begins on the nearest
!     400-year cycle less than or equal to the Julian Day for 1 March
!     in the year in which the given Julian Day number (idayct) occurs.
  ndays  = idayct - jdref
  n400yr = ndays / ndy400
!            = integral number of 400-year periods separating
!              idayct and the reference date, jdref.
  jdref  = jdref + n400yr*ndy400
  if (jdref > idayct) then
   n400yr = n400yr - 1
   jdref  = jdref  - ndy400
  endif
!
  ndays  = idayct - jdref
!            = number from the reference date to idayct.
!
  n100yr = min(ndays/ndy100, 3)
!            = number of complete 100-year periods
!              from the reference year to the current year.
!              The min() function is necessary to avoid n100yr=4
!              on 29 February of the last year in the 400-year cycle.
!
  ndays  = ndays - n100yr*ndy100
!            = remainder after removing an integral number of
!              100-year periods.
!
  n4yr   = ndays / 1461
!            = number of complete 4-year periods in the current century.
!              4 years consists of 4*365 + 1 = 1461 days.
!
  ndays  = ndays - n4yr*1461
!            = remainder after removing an integral number
!              of 4-year periods.
!
  n1yr   = min(ndays/365, 3)
!            = number of complete years since the last leap year.
!              The min() function is necessary to avoid n1yr=4
!              when the date is 29 February on a leap year,
!              in which case ndays=1460, and 1460/365 = 4.
!
  ndays  = ndays - 365*n1yr
!            = number of days so far in the current year,
!              where ndays=0 on 1 March.
!
  iyear  = n1yr + 4*n4yr + 100*n100yr + 400*n400yr + yrref
!            = year, as counted in the standard way,
!              but relative to 1 March.
!
! At this point, we need to separate ioptn=abs(4), which seeks a
! calendar date, and ioptn=abs(5), which seeks the day number during
! the year.  First compute the calendar date if desired (abs(ioptn)=4).
  if (abs(ioptn) == 4) then
   jmonth = (10*(ndays+31))/306 + 3
!               = offset month counter.  jmonth=4 for March, =13 for
!                 December, =14 for January, =15 for February.
   iday   = (ndays+123) - int(30.6001*jmonth)
!               = day of the month, starting with 1 on the first day
!                 of the month.
!
!        Now adjust for the fact that the year actually begins
!        on 1 January.
   if (jmonth <= 13) then
      month = jmonth - 1
   else
      month = jmonth - 13
      iyear = iyear + 1
   endif
!
! This code handles abs(ioptn)=5, finding the day number during the year.
  else
!        ioptn=5 always returns month=1, which we set now.
   month = 1
!
!        We need to determine whether this is a leap year.
   leap = 0
   if ((jyear/4)*4 == jyear) then
      leap = 1
   endif
   if ((ioptn > 0)               .and. &
      ((jyear/100)*100 == jyear) .and. &
      ((jyear/400)*400 /= jyear)      ) then
         leap = 0
   endif
!
!        Now find the day number "iday".
!        ndays is the number of days since the most recent 1 March,
!        so ndays=0 on 1 March.
   if (ndays <=305) then
      iday  = ndays + 60 + leap
   else
      iday  = ndays - 305
      iyear = iyear + 1
   endif
  endif
!
!     Adjust the year if it is <= 0, and hence BC (Before Christ).
  if (iyear <= 0) then
   iyear = iyear - 1
  endif
!
! End the code for the last option, ioptn.
  endif

  end subroutine calndr


PROGRAM mlegzo

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

!       ============================================================
!       Purpose : This program computes the zeros of Legendre
!                 polynomial Pn(x) in the interval [-1,1] and the
!                 corresponding weighting coefficients for Gauss-
!                 Legendre integration using subroutine LEGZO
!       Input :   n    --- Order of the Legendre polynomial
!       Output:   X(n) --- Zeros of the Legendre polynomial
!                 W(n) --- Corresponding weighting coefficients
!       ============================================================

IMPLICIT DOUBLE PRECISION (a-h,o-z)
DIMENSION x(120),w(120)
WRITE(*,*)'Please enter the order of Pn(x), n '
!        READ(*,*)N
n=5
WRITE(*,15)n
CALL legzo(n,x,w)
WRITE(*,*)'  Nodes and weights for Gauss-Legendre integration'
WRITE(*,*)
WRITE(*,*)'  i              xi                   Wi'
WRITE(*,*)' ------------------------------------------------'
DO  i=1,n
  WRITE(*,20)i,x(i),w(i)
END DO
15      FORMAT(1X,'n =',i3)
20      FORMAT(1X,i3,1X,f22.13,d22.13)
END PROGRAM mlegzo

SUBROUTINE legzo(n,x,w)

!       =========================================================
!       Purpose : Compute the zeros of Legendre polynomial Pn(x)
!                 in the interval [-1,1], and the corresponding
!                 weighting coefficients for Gauss-Legendre
!                 integration
!       Input :   n    --- Order of the Legendre polynomial
!       Output:   X(n) --- Zeros of the Legendre polynomial
!                 W(n) --- Corresponding weighting coefficients
!       =========================================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(IN OUT)         :: x(n)
DOUBLE PRECISION, INTENT(OUT)            :: w(n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

n0=(n+1)/2
DO  nr=1,n0
  z=DCOS(3.1415926D0*(nr-0.25D0)/n)
  DO
    10       z0=z
    p=1.0D0
    DO  i=1,nr-1
      p=p*(z-x(i))
    END DO
    f0=1.0D0
    IF (nr == n0.AND.n /= 2*INT(n/2)) z=0.0D0
    f1=z
    DO  k=2,n
      pf=(2.0D0-1.0D0/k)*z*f1-(1.0D0-1.0D0/k)*f0
      pd=k*(f1-z*pf)/(1.0D0-z*z)
      f0=f1
      f1=pf
    END DO
    IF (z == 0.0) EXIT
    fd=pf/p
    q=0.0D0
    DO  i=1,nr-1
      wp=1.0D0
      DO  j=1,nr-1
        IF (j /= i) wp=wp*(z-x(j))
      END DO
      q=q+wp
    END DO
    gd=(pd-q*fd)/p
    z=z-fd/gd
    IF (.NOT.(DABS(z-z0) > DABS(z)*1.0D-15)) EXIT
  END DO
  40      x(nr)=z
  x(n+1-nr)=-z
  w(nr)=2.0D0/((1.0D0-z*z)*pd*pd)
  w(n+1-nr)=w(nr)
END DO
RETURN
END SUBROUTINE legzo


! Code by: Jostein Brandshoi

PROGRAM advection_solver
    IMPLICIT NONE
    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    double precision, parameter :: L = 50000.0                      ! Location (L/2) where initial bell is max [m]
    double precision, parameter :: sigma = L / 10.0                 ! Measure of with of initial Gaussian bell [m]
    double precision, parameter :: theta_0 = 10.0                   ! Max temperature value of initial bell [deg C]
    double precision, parameter :: u_0 = 1.0                        ! Advection speed (constant here) [m/s]
    double precision, parameter :: epsilon = 1E-5

    double precision, parameter :: C = 0.50                         ! Courant number [u_0 * delta_t / delta_x] [m/s]
    double precision, parameter :: delta_x = sigma / 10.0           ! Distance between spatial gridpoints [m]
    double precision, parameter :: delta_t = C * delta_x / u_0      ! Time between temporal gridpoints [s]
    double precision :: x_j

    integer :: j, n                                                 ! Counter variables (j: space, n: time)
    integer :: n_temp, n_curr = 1, n_next = 2                       ! Indices to represent curr and next time stetp
    integer, parameter :: j_max = idint(L / delta_x + 1)            ! Max number of space points in [0: j = 1, L: j = j_max]
    integer, parameter :: n_max = idint((25 * L) / (u_0 * delta_t)) ! Max number of time points needed for 25 cycles
    integer, parameter :: n_05c = idint((5 * L) / (u_0 * delta_t))  ! Number of time points needed for 5 cycles
    integer, parameter :: n_10c = idint((10 * L) / (u_0 * delta_t)) ! Number of time points needed for 10 cycles
    integer, parameter :: n_15c = idint((15 * L) / (u_0 * delta_t)) ! Number of time points needed for 15 cycles
    integer, parameter :: n_20c = idint((20 * L) / (u_0 * delta_t)) ! Number of time points needed for 20 cycles

    double precision :: theta_j_star, theta_jp1_star
    double precision :: theta_jm1_star, theta_jm2_star
    double precision :: u_j_star, u_jm1_star, F_j_star, F_jm1_star
    double precision, dimension(j_max, 2) :: theta = 0.0            ! 2D-array to store solution at time points n and n + 1

    character(len = 32) :: output_filename                          ! Variable to hold output filename for results
    ! -------------------------------------------------------------------------------------

    ! -------------------------------- INITIAL CONDITION ----------------------------------
    do j = 1, j_max                 ! Loop over all space points in the defined region [0, L]
        x_j = (j - 1) * delta_x     ! x-value corresponding to the j'th gridpoint in space
        theta(j, n_curr) = theta_0 * dexp(-((2 * x_j - L) / sigma) ** 2)    ! Init. con.
    end do
    ! -------------------------------------------------------------------------------------

    ! -------- GETTING FILENAME FROM CMD-LINE AND OPEN .DAT FILE FOR RESULT OUTPUT --------
    CALL GET_COMMAND_ARGUMENT(1, output_filename)                   ! Get cmd-line arg for output file
    open(unit = 10, file = output_filename, form = "formatted")  ! Open file that will store results
    ! -------------------------------------------------------------------------------------

    ! --------------------------- USING UPWIND SCHEME AND BC'S ----------------------------
    do n = 0, n_max     ! Loop, in time as long as necessary to complete requested number of cycles
        theta(1, n_curr) = theta(j_max, n_curr)     ! Cyclic boundary condition (theta(0, t) = theta(L, t))

        do j = 2, j_max ! Loop over all space points in the defined region [0, L]
            theta_j_star = theta(j, n_curr) - C * (theta(j, n_curr) - theta(j - 1, n_curr))  ! Upwind scheme
            F_j_star = 0.0
            F_jm1_star = 0.0

            if (j >= 4 .and. j <= j_max - 3) then
                theta_jp1_star = theta(j + 1, n_curr) - C * (theta(j + 1, n_curr) - theta(j, n_curr))
                theta_jm1_star = theta(j - 1, n_curr) - C * (theta(j - 1, n_curr) - theta(j - 2, n_curr))
                theta_jm2_star = theta(j - 2, n_curr) - C * (theta(j - 2, n_curr) - theta(j - 3, n_curr))
                u_j_star = 1.3 * 0.25 * (1 - C) * u_0 * ((theta_jp1_star - theta_jm1_star) / (theta_j_star + epsilon))
                u_jm1_star = 1.3 * 0.25 * (1 - C) * u_0 * ((theta_j_star - theta_jm2_star) / (theta_jm1_star + epsilon))
                F_j_star = 0.5 * ((u_j_star + dabs(u_j_star)) * theta_j_star + (u_j_star - &
                    dabs(u_j_star)) * theta_jp1_star) * (delta_t / delta_x)
                F_jm1_star = 0.5 * ((u_jm1_star + dabs(u_jm1_star)) * theta_jm1_star + &
                    (u_jm1_star - dabs(u_jm1_star)) * theta_j_star) * (delta_t / delta_x)
            end if

            theta(j, n_next) = theta_j_star - (F_j_star - F_jm1_star)
        end do

        ! Write theta to file for time steps corresponding to the requested cycles.
        if (n == 0 .or. n == n_05c .or. n == n_10c .or. n == n_15c .or. n == n_20c .or. n == n_max) then
            write(unit = 10, fmt = "(102f20.14)") float(n), theta(:, n_curr) / theta_0  ! Write line-wise
        end if

        n_temp = n_next     ! Set help index to second theta column (2)
        n_next = n_curr     ! Set next time step index to first theta column (1)
        n_curr = n_temp     ! Set current time step index to second column (2)
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = 10)    ! Close file after writing

END PROGRAM advection_solver


  Program Main
!====================================================================
!  eigenvalues and eigenvectors of a real symmetric matrix
!  Method: calls Jacobi
!====================================================================
implicit none
integer, parameter :: n=3
double precision :: a(n,n), x(n,n)
double precision, parameter:: abserr=1.0e-09
integer i, j

! matrix A
  data (a(1,i), i=1,3) /   1.0,  2.0,  3.0 /
  data (a(2,i), i=1,3) /   2.0,  2.0, -2.0 /
  data (a(3,i), i=1,3) /   3.0, -2.0,  4.0 /

! print a header and the original matrix
  write (*,200)
  do i=1,n
     write (*,201) (a(i,j),j=1,n)
  end do

  call Jacobi(a,x,abserr,n)

! print solutions
  write (*,202)
  write (*,201) (a(i,i),i=1,n)
  write (*,203)
  do i = 1,n
     write (*,201)  (x(i,j),j=1,n)
  end do

200 format (' Eigenvalues and eigenvectors (Jacobi method) ',/, &
            ' Matrix A')
201 format (6f12.6)
202 format (/,' Eigenvalues')
203 format (/,' Eigenvectors')
end program main

subroutine Jacobi(a,x,abserr,n)
!===========================================================
! Evaluate eigenvalues and eigenvectors
! of a real symmetric matrix a(n,n): a*x = lambda*x
! method: Jacoby method for symmetric matrices
! Alex G. (December 2009)
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - number of equations
! abserr - abs tolerance [sum of (off-diagonal elements)^2]
! output ...
! a(i,i) - eigenvalues
! x(i,j) - eigenvectors
! comments ...
!===========================================================
implicit none
integer i, j, k, n
double precision a(n,n),x(n,n)
double precision abserr, b2, bar
double precision beta, coeff, c, s, cs, sc

! initialize x(i,j)=0, x(i,i)=1
! *** the array operation x=0.0 is specific for Fortran 90/95
x = 0.0
do i=1,n
  x(i,i) = 1.0
end do

! find the sum of all off-diagonal elements (squared)
b2 = 0.0
do i=1,n
  do j=1,n
    if (i.ne.j) b2 = b2 + a(i,j)**2
  end do
end do

if (b2 <= abserr) return

! average for off-diagonal elements /2
bar = 0.5*b2/float(n*n)

do while (b2.gt.abserr)
  do i=1,n-1
    do j=i+1,n
      if (a(j,i)**2 <= bar) cycle  ! do not touch small elements
      b2 = b2 - 2.0*a(j,i)**2
      bar = 0.5*b2/float(n*n)
! calculate coefficient c and s for Givens matrix
      beta = (a(j,j)-a(i,i))/(2.0*a(j,i))
      coeff = 0.5*beta/sqrt(1.0+beta**2)
      s = sqrt(max(0.5+coeff,0.0))
      c = sqrt(max(0.5-coeff,0.0))
! recalculate rows i and j
      do k=1,n
        cs =  c*a(i,k)+s*a(j,k)
        sc = -s*a(i,k)+c*a(j,k)
        a(i,k) = cs
        a(j,k) = sc
      end do
! new matrix a_{k+1} from a_{k}, and eigenvectors
      do k=1,n
        cs =  c*a(k,i)+s*a(k,j)
        sc = -s*a(k,i)+c*a(k,j)
        a(k,i) = cs
        a(k,j) = sc
        cs =  c*x(k,i)+s*x(k,j)
        sc = -s*x(k,i)+c*x(k,j)
        x(k,i) = cs
        x(k,j) = sc
      end do
    end do
  end do
end do
return
end


      SUBROUTINE DF01MD( SICO, N, DT, A, DWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the sine transform or cosine transform of a real
C     signal.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     SICO    CHARACTER*1
C             Indicates whether the sine transform or cosine transform
C             is to be computed as follows:
C             = 'S':  The sine transform is computed;
C             = 'C':  The cosine transform is computed.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The number of samples.  N must be a power of 2 plus 1.
C             N >= 5.
C
C     DT      (input) DOUBLE PRECISION
C             The sampling time of the signal.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (N)
C             On entry, this array must contain the signal to be
C             processed.
C             On exit, this array contains either the sine transform, if
C             SICO = 'S', or the cosine transform, if SICO = 'C', of the
C             given signal.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N+1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     Let A(1), A(2),..., A(N) be a real signal of N samples.
C
C     If SICO = 'S', the routine computes the sine transform of A as
C     follows. First, transform A(i), i = 1,2,...,N, into the complex
C     signal B(i), i = 1,2,...,(N+1)/2, where
C
C        B(1) = -2*A(2),
C        B(i) = {A(2i-2) - A(2i)} - j*A(2i-1) for i = 2,3,...,(N-1)/2,
C        B((N+1)/2) = 2*A(N-1) and j**2 = -1.
C
C     Next, perform a discrete inverse Fourier transform on B(i) by
C     calling SLICOT Library Routine DG01ND, to give the complex signal
C     Z(i), i = 1,2,...,(N-1)/2, from which the real signal C(i) may be
C     obtained as follows:
C
C        C(2i-1) = Re(Z(i)),  C(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.
C
C     Finally, compute the sine transform coefficients S ,S ,...,S
C                                                       1  2      N
C     given by
C
C        S  = 0,
C         1
C                {                     [C(k) + C(N+1-k)]     }
C        S  = DT*{[C(k) - C(N+1-k)] - -----------------------},
C         k      {                    [2*sin(pi*(k-1)/(N-1))]}
C
C           for k = 2,3,...,N-1, and
C
C        S = 0.
C         N
C
C     If SICO = 'C', the routine computes the cosine transform of A as
C     follows. First, transform A(i), i = 1,2,...,N, into the complex
C     signal B(i), i = 1,2,...,(N+1)/2, where
C
C        B(1) = 2*A(1),
C        B(i) = 2*A(2i-1) + 2*j*{[A(2i-2) - A(2i)]}
C        for i = 2,3,...,(N-1)/2 and B((N+1)/2) = 2*A(N).
C
C     Next, perform a discrete inverse Fourier transform on B(i) by
C     calling SLICOT Library Routine DG01ND, to give the complex signal
C     Z(i), i = 1,2,...,(N-1)/2, from which the real signal D(i) may be
C     obtained as follows:
C
C        D(2i-1) = Re(Z(i)),  D(2i) = Im(Z(i)) for i = 1,2,...,(N-1)/2.
C
C     Finally, compute the cosine transform coefficients S ,S ,...,S
C                                                         1  2      N
C     given by
C
C        S  = 2*DT*[D(1) + A0],
C         1
C                {                     [D(k) - D(N+1-k)]     }
C        S  = DT*{[D(k) + D(N+1-k)] - -----------------------},
C         k      {                    [2*sin(pi*(k-1)/(N-1))]}
C
C
C           for k = 2,3,...,N-1, and
C
C        S  = 2*DT*[D(1) - A0],
C         N
C                 (N-1)/2
C     where A0 = 2*SUM   A(2i).
C                  i=1
C
C     REFERENCES
C
C     [1] Rabiner, L.R. and Rader, C.M.
C         Digital Signal Processing.
C         IEEE Press, 1972.
C
C     [2] Oppenheim, A.V. and Schafer, R.W.
C         Discrete-Time Signal Processing.
C         Prentice-Hall Signal Processing Series, 1989.
C
C     NUMERICAL ASPECTS
C
C     The algorithm requires 0( N*log(N) ) operations.
C
C     CONTRIBUTORS
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Feb. 1997.
C     Supersedes Release 2.0 routine DF01AD by F. Dumortier, and
C     R.M.C. Dekeyser, State University of Gent, Belgium.
C
C     REVISIONS
C
C     V. Sima, Jan. 2003.
C
C     KEYWORDS
C
C     Digital signal processing, fast Fourier transform, complex
C     signals.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO, FOUR
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
     $                    FOUR = 4.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         SICO
      INTEGER           INFO, N
      DOUBLE PRECISION  DT
C     .. Array Arguments ..
      DOUBLE PRECISION  A(*), DWORK(*)
C     .. Local Scalars ..
      LOGICAL           LSICO, LSIG
      INTEGER           I, I2, IND1, IND2, M, MD2
      DOUBLE PRECISION  A0, PIBYM, W1, W2, W3
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DG01ND, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ATAN, DBLE, MOD, SIN
C     .. Executable Statements ..
C
      INFO = 0
      LSICO = LSAME( SICO, 'S' )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LSICO .AND. .NOT.LSAME( SICO, 'C' ) ) THEN
         INFO = -1
      ELSE
         M = 0
         IF( N.GT.4 ) THEN
            M = N - 1
C           WHILE ( MOD( M, 2 ).EQ.0 ) DO
   10       CONTINUE
            IF ( MOD( M, 2 ).EQ.0 ) THEN
               M = M/2
               GO TO 10
            END IF
C           END WHILE 10
         END IF
         IF ( M.NE.1 ) INFO = -2
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'DF01MD', -INFO )
         RETURN
      END IF
C
C     Initialisation.
C
      M = N - 1
      MD2 = ( N + 1 )/2
      PIBYM = FOUR*ATAN( ONE )/DBLE( M )
      I2 = 1
      DWORK(MD2+1) = ZERO
      DWORK(2*MD2) = ZERO
C
      IF ( LSICO ) THEN
C
C        Sine transform.
C
         LSIG = .TRUE.
         DWORK(1)  = -TWO*A(2)
         DWORK(MD2) = TWO*A(M)
C
         DO 20 I = 4, M, 2
            I2 = I2 + 1
            DWORK(I2) = A(I-2) - A(I)
            DWORK(MD2+I2) = -A(I-1)
   20    CONTINUE
C
      ELSE
C
C        Cosine transform.
C
         LSIG = .FALSE.
         DWORK(1)   = TWO*A(1)
         DWORK(MD2) = TWO*A(N)
         A0 = A(2)
C
         DO 30 I = 4, M, 2
            I2 = I2 + 1
            DWORK(I2) = TWO*A(I-1)
            DWORK(MD2+I2) = TWO*( A(I-2) - A(I) )
            A0 = A0 + A(I)
   30    CONTINUE
C
         A0 = TWO*A0
      END IF
C
C     Inverse Fourier transform.
C
      CALL DG01ND( 'Inverse', MD2-1, DWORK(1), DWORK(MD2+1), INFO )
C
C     Sine or cosine coefficients.
C
      IF ( LSICO ) THEN
         A(1) = ZERO
         A(N) = ZERO
      ELSE
         A(1) = TWO*DT*( DWORK(1) + A0 )
         A(N) = TWO*DT*( DWORK(1) - A0 )
      END IF
C
      IND1 = MD2 + 1
      IND2 = N
C
      DO 40 I = 1, M - 1, 2
         W1 = DWORK(IND1)
         W2 = DWORK(IND2)
         IF ( LSIG ) W2 = -W2
         W3 = TWO*SIN( PIBYM*DBLE( I ) )
         A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 )
         IND1 = IND1 + 1
         IND2 = IND2 - 1
   40 CONTINUE
C
      IND1 = 2
      IND2 = MD2 - 1
C
      DO 50 I = 2, M - 2, 2
         W1 = DWORK(IND1)
         W2 = DWORK(IND2)
         IF ( LSIG ) W2 = -W2
         W3 = TWO*SIN( PIBYM*DBLE( I ) )
         A(I+1) = DT*( W1 + W2 - ( W1 - W2 )/W3 )
         IND1 = IND1 + 1
         IND2 = IND2 - 1
   50 CONTINUE
C
      RETURN
C *** Last line of DF01MD ***
      END


SUBROUTINE tridiag(a,b,c,r,u,N)
!  solves a tridiagonal linear system  Au = r

!  algorithm comes from Numerical Recipes book

!  a,b,c are vectors of length N giving the non-zero elements of matrix A
!  a(2:N) are the entries to the left of the main diagonal (a(1) is ignored)
!  b(1:N) are main diagonal elements
!  c(1:N-1) are to the right of main diagonal (c(N) is ignored)
!  r is a vector of length N giving RHS of matrix equation
!  u is the unknown vector we are solving for
	INTEGER N,j
	REAL*8, DIMENSION(N) :: a,b,c,r,u
	REAL*8, DIMENSION(N) :: gam
	REAL*8 bet

	bet = b(1)
	IF (bet == 0.) THEN
		PRINT *, 'First diagonal element is zero'
		STOP
	END IF
	u(1) = r(1)/bet
	DO j=2,N
		gam(j) = c(j-1)/bet
		bet = b(j)-a(j)*gam(j)
		IF (bet == 0.) THEN
			PRINT *, 'tridiag trying to divide by zero'
			STOP
		END IF
		u(j) = (r(j)-a(j)*u(j-1))/bet
	END DO
	DO j=N-1,1,-1
		u(j) = u(j) - gam(j+1)*u(j+1)
	END DO
	RETURN
END SUBROUTINE tridiag

subroutine polyfit(n,X,Y,m,coeffs)

integer n, m  ! number of points and degree of polynomial

integer i,ij,j,k,n1,m1,m2
real*8  C(m+2,m+2), A(m+2), B(m+2), Xc(m+2), Yx(m+2)
real*8  p,xx,s,yc
real*8  X(n), Y(n), coeffs(m+1)

coeffs = 0.d0
  n1=n; m1=m+1; m2=m+2
  do k=1, m2
    Xc(k)=0.d0
    do i=1, n1
	  Xc(k) = Xc(k) + X(i)**k
    end do
  end do
  yc=0.d0
  do i=1, n1
    yc = yc + Y(i)
  end do
  do k=1, m
    Yx(k)=0.d0
    do i=1, n1
	  Yx(k) =  Yx(k) + Y(i)*X(i)**k
    end do
  end do
  do i=1, m1
	do j=1, m1
      ij=i+j-2
      if (i==1.and.j==1)  then
	    C(1,1) = n1
      else
	    C(i,j)=Xc(ij)
      end if
    end do
  end do
  B(1)=yc;
  do i=2,m1
    B(i)=Yx(i-1)
  end do
  do k=1, m
    do i=k+1, m1
      B(i) = B(i) - C(i,k)/C(k,k)*B(k)
      do j=k+1, m1
        C(i,j) = C(i,j) - C(i,k)/C(k,k)*C(k,j)
      end do
    end do
  end do
  coeffs(m1)=B(m1)/C(m1,m1)
  do i=m, 1, -1
    s=0.d0
    do k=i+1, m1
	  s = s + C(i,k)*coeffs(k)
    end do
    coeffs(i) = (B(i)-s)/C(i,i)
  end do
end subroutine polyfit


program insertion
implicit none
!-----------------------------------------------------------------
! This programme sorts a series of values in increasing order,
! using insertion sort, implemented with one working array
!
! It works like this:
! unsorted: A = [5, 3, 4, 1, 2, 6]
! sorting:
! pass 1: A = [3, 5, 4, 1, 2, 6]
! pass 2: A = [3, 4, 5, 1, 2, 6]
! pass 3: A = [1, 3, 4, 5, 2, 6]
! pass 4: A = [1, 2, 3, 4, 5, 6]
! pass 5: B = [1, 2, 3, 4, 5, 6]
!------------------------------------------------------

real(kind=8), allocatable, dimension(:) :: A
real :: temp
integer :: i, j, k, n

!------------------------------------------------------------
! Make some random array of size n:
!------------------------------------------------------------
write(*,*) 'size od array?'
read(*,*) n
allocate (A(n))

call random_seed()
do i = 1, n
   call random_number(A(i))
   A(i) = (A(i) * 100.0)
   A(i) = real(nint(A(i)*1000)) / 1000.0 !rounding off to 3 decimal places
end do
write(*,'(A3,10F7.3)') ' A ', A

!------------------------------------------------------------
! The actual sorting:
!------------------------------------------------------------
do i = 2, n
   do j = 1, i-1
      if (A(j) .ge. A(i)) then
         temp = A(i)
         do k = i-1, j, -1 !from the first smaller than i to j
            A(k+1) = A(k) !move every element by one
         end do
         A(j) = temp
         exit
      end if
   end do
end do
write(*,'(A3,10F7.3)') ' A ', A
end program insertion


MODULE m_trapz
   !General Purpose trapezian method integration
   !Used in green's function calculations because the
   !integrands are very spiky

   IMPLICIT NONE

   INTERFACE trapz
      PROCEDURE :: trapzr, trapzc
   END INTERFACE

   CONTAINS

   PURE REAL FUNCTION trapzr(y,h,n)

      REAL,          INTENT(IN)     :: y(:)

      INTEGER,       INTENT(IN)     :: n
      REAL,          INTENT(IN)     :: h

      INTEGER i

      trapzr = y(1)
      DO i = 2, n-1
         trapzr = trapzr + 2*y(i)
      ENDDO
      trapzr = trapzr + y(n)

      trapzr = trapzr*h/2.0

   END FUNCTION trapzr

   PURE COMPLEX FUNCTION trapzc(y,h,n)

      COMPLEX,       INTENT(IN)     :: y(:)

      INTEGER,       INTENT(IN)     :: n
      REAL,          INTENT(IN)     :: h

      INTEGER i

      trapzc = y(1)
      DO i = 2, n-1
         trapzc = trapzc + 2*y(i)
      ENDDO
      trapzc = trapzc + y(n)

      trapzc = trapzc*h/2.0

   END FUNCTION trapzc

END MODULE m_trapz


! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU, Mathematics
! Math 6370
! 9 January 2009
!=================================================================

subroutine chem_solver(T,u,v,w,lam,eps,maxit,its,res)
  !-----------------------------------------------------------------
  ! Description:
  !    Computes the equilibrium chemical concentrations, given a
  !    background temperature field, of a simple reaction network:
  !        u + x -> v  with rate k1
  !        u + x <- v  with rate k2
  !        v -> w      with rate k3
  !        v <- w      with rate k4,
  !    where we have assumed that the total concentration
  !    (x+u+v+w) = 1, and where k1(T), k2(T), k3(T), and k4(T) are
  !    the temperature-dependent coefficient functions,
  !        k1(T) = exp(-5*T),
  !        k2(T) = atan(5*(T-1/2))/3 + 1/2,
  !        k3(T) = 1/cosh(5*(T-1/2)),
  !        k4(T) = tanh(5*(T-1/2)^2).
  !    Using the conservation relation, we write the constrained
  !    ODE system
  !          x = 1 - u - v - w,
  !        u_t = k2*v - k1*u*x,
  !        v_t = k1*u*x - (k2+k3)*v + k4*w,
  !        w_t = k3*v - k4*w.
  !    Inserting the constraint equation into the rate equations,
  !    and setting the time derivatives equal to zero (to find
  !    equilibrium concentrations), we have the system
  !        0 = k2*v + k1*u*(u+v+w-1)              = fu(u,v,w),
  !        0 = k1*u*(1-u-v-w) - (k2+k3)*v + k4*w  = fv(u,v,w),
  !        0 = k3*v - k4*w                        = fw(u,v,w),
  !    where each of the rate coefficients are frozen at the fixed
  !    temperature T.
  !
  !    To solve this system, we call a simple damped fixed-point
  !    iteration: given an initial guess X0, compute iterates
  !        Xn = X{n-1} + lambda*f,
  !    where 0 < lambda <= 1 is the damping parameter.  We compute
  !    these iterates Xn until |f(Xn)| < epsilon.
  !
  ! Arguments:
  !    T - double (input), temperature
  !    u - double (in/out), concentration (in: guess, out: solution)
  !    v - double (in/out), concentration (in: guess, out: solution)
  !    w - double (in/out), concentration (in: guess, out: solution)
  !  lam - double (in), damping parameter (lambda)
  !  eps - double (in), nonlinear solver tolerance (epsilon)
  !  maxit - integer (in), maximum allowed iterations
  !  its - integer (out), # of iterations required for convergence
  !  res - double (out), final nonlinear residual (max norm)
  !-----------------------------------------------------------------
  !======= Inclusions ===========

  !======= Declarations =========
  implicit none
  integer, intent(in) :: maxit
  integer, intent(out) :: its
  double precision, intent(in) :: T, lam, eps
  double precision, intent(out) :: res
  double precision, intent(inout) :: u, v, w

  double precision :: k1, k2, k3, k4, f(3)

  !======= Internals ============

  ! compute chemical rate coefficients
  k1 = exp(-5.d0*T)
  k2 = atan(5.d0*(T-0.5d0))/3.d0 + 0.5d0
  k3 = 1.d0/cosh(5.d0*(T-0.5d0))
  k4 = tanh(5.d0*(T-0.5d0)**2)

  ! compute initial residual function
  f = chem_residual()
  res = maxval(abs(f))

  ! loop
  do its = 0,maxit

     if (res < eps)  exit

     ! fixed-point iteration solution update
     u = u + lam*f(1)
     v = v + lam*f(2)
     w = w + lam*f(3)

     ! compute residuals
     f = chem_residual()
     res = maxval(abs(f))

  enddo

contains

  function chem_residual()
    double precision :: chem_residual(3)
    chem_residual(1) = k2*v + k1*u*(u+v+w-1.d0)
    chem_residual(2) = k1*u*(1.d0-u-v-w) - (k2+k3)*v + k4*w
    chem_residual(3) = k3*v - k4*w
  end function chem_residual

end subroutine chem_solver
!=================================================================


! Program by: Jostein Brandshoi

PROGRAM exercise_2d
    ! This program solves the diffusion equation numerically for the oceanic boundary layer with the initial- and
    ! boundary conditions given in the exercise. After execution a file (with filename specified as a command line
    ! argument) will be outputed with the results for specific time-values. Thi program can be compiled and executed
    ! by itself just fine, but the script visualize_results.py automates the process and provides plot of the results.
    IMPLICIT NONE

    ! ------------------------------- VARIABLE DECLARATIONS -------------------------------
    integer :: j, n                                                     ! Counter variables used in loops below (j: space, n: time)
    integer, parameter :: j_max = 27, n_max = 1201                      ! Maximum number of gridpoints in space and time

    double precision, parameter :: D = 30.0                                         ! Hight of the oceanic boundary layer [m]
    double precision, parameter :: psi_0 = 10.0                                     ! Steady max temperature at top of ocean [deg C]
    double precision, parameter :: K = 0.45                                         ! K = (kappa * delta_t) / delta_z [dim-less]
    double precision, parameter :: kappa_O = 30.0 * 1E-4                            ! Diffusion coefficient for the ocean [m^2/s]
    double precision, parameter :: delta_z = D / (j_max - 1.0)                      ! Increment in space (j_max points implies (j_max - 1) steps) [m]
    double precision, parameter :: delta_t = (K * delta_z ** 2) / kappa_O           ! Increment in time [s]
    double precision, parameter :: gmma = 1.5, t_c = 6.0 * 24 * 3600                ! Gamma parameter [dim-less], Reference time of 6 days [s]

    double precision, dimension(1 : j_max) :: psi_n, psi_np1, psi_temp
    double precision :: t_n                                                         ! t-value in [0, H] to represent time. Used in boundary con. [m]

    character(len = 32) :: output_filename                              ! Variable to hold output filename specified by cmd-line arg
    ! -------------------------------------------------------------------------------------

    ! -------------------------- INITIAL AND BOUNDARY CONDITIONS --------------------------
    psi_n(:) = 0.0         ! Initially the water column n has 0 deg C for all the z-values
    ! -------------------------------------------------------------------------------------

    ! ------- GETTING FILENAME FROM CMD-LINE AND WRITE RESULTS TO .DAT-FILE. EACH LINE CORRESPONDS TO ONE N-VALUES -------
    CALL GET_COMMAND_ARGUMENT(1, output_filename)                  ! Get command line argument that specifies output file
    open(unit = 10, file = output_filename, form = "formatted")    ! Open file that will store results based on cmd-line arg
    ! -------------------------------------------------------------------------------------

    ! ------------------------ SOLVING THE EQUATION WITH FTCS-SCHEME ----------------------
    do n = 0, n_max - 2
        do j = 2, j_max - 1
            t_n = n * delta_t                                     ! Compute t-value at n'th time point
            psi_np1(1) = 0.0                                      ! The bottom (z = -D) is held at 0 deg C for all times
            psi_np1(j_max) = psi_0 * tanh((gmma * t_n) / t_c)     ! Compute psi at top (z = 0) for each t_n according to BC.
            psi_np1(j) = psi_n(j) + K * (psi_n(j + 1) - 2 * psi_n(j) + psi_n(j - 1))
        end do

        ! Write psi for the requested n-values (plus some more) to a .dat file where each line is on the form "n psi(1) psi(2) ..."
        if (n == 0 .or. n == 100 .or. n == 200 .or. n == 400 .or. n == 600 .or. n == 800 .or. n == 1000 .or. n == 1199) then
            write(unit = 10, fmt = "(28f20.14)") float(n), psi_n(:) / psi_0
        end if

        psi_n = psi_np1     ! Update psi_n to be the value of the newly computed timestep
    end do
    ! -------------------------------------------------------------------------------------

    close(unit = 10)! Close file after writing

END PROGRAM exercise_2d


module robertson_rate

  use stiff3_solver, only: wp => stiff3_wp

  implicit none

contains

  !
  ! Robertson rate equations
  !
  subroutine fun(n,y,f)
    integer, intent(in) :: n
    real(wp), intent(in) :: y(n)
    real(wp), intent(inout) :: f(n)
    f(1) = -4.e-2_wp*y(1)+1.e4_wp*y(2)*y(3)
    f(2) = -f(1)-3.e7_wp*y(2)**2
    f(3) = 3.e7_wp*y(2)**2
  end subroutine

  !
  ! Robertson rate equations - Jacobian
  !
  subroutine dfun(n,y,df)
    integer, intent(in) :: n
    real(wp), intent(in) :: y(n)
    real(wp), intent(inout) :: df(n,n)
    df(1,1) = -4.e-2_wp
    df(1,2) = 1.e4_wp*y(3)
    df(1,3) = 1.e4_wp*y(2)
    df(2,1) = 4.e-2_wp
    df(2,2) = -1.e4_wp*y(3)-6.e7_wp*y(2)
    df(2,3) = -1.e4_wp*y(2)
    df(3,1) = 0.0_wp
    df(3,2) = 6.e7_wp*y(2)
    df(3,3) = 0.0_wp
  end subroutine

end module

program main

  use stiff3_solver, only: wp => stiff3_wp, stiff3
  use robertson_rate, only: fun, dfun

  implicit none

  integer, parameter :: n = 3
  real(wp) :: y(n), w(n)
  real(wp) :: h0, eps, x0, x1

  integer, parameter :: nprint = 1

! initial value
  y = [1.0_wp, 0.0_wp, 0.0_wp]

! initial step size
  h0 = 0.0001_wp

! tolerance parameters
  eps = 1.e-5_wp
  w = 1
  w(2) = 1.e-4_wp

! time interval
  x0 = 0.0_wp
  x1 = 10.0_wp

  call output(x0,y,0,0.0_wp)
  call stiff3(n,fun,dfun,output,nprint,x0,x1,h0,eps,w,y)

contains

  subroutine output(x,y,iha,qa)
    real(wp), intent(in) :: x
    real(wp), intent(in) :: y(:)
    integer, intent(in) :: iha
    real(wp), intent(in) :: qa
    real(wp) :: y2
    y2 = 1.e4_wp*y(2)
    print '(4(E19.12,2X),I4,2X,E19.12)', x, y(1), y2, y(3), iha, qa
  end subroutine

end program


    module initialisation

    use custom_precision

    implicit none

    private

    interface initialise_to_random
    procedure  initialise_to_random_1D
    procedure  initialise_to_random_2D
    procedure  initialise_to_random_1D_dp
    procedure  initialise_to_random_2D_dp
    end interface

    interface initialise_tridiagonal
    procedure initialise_tridiagonal_sp
    procedure initialise_tridiagonal_dp
    end interface

    public initialise_tridiagonal
    public initialise_to_random

    contains

    !#############################################
    subroutine initialise_to_random_2D(mat, nrows, ncols, start, last)
    real, allocatable, intent(inout)    :: mat(:,:)
    integer, intent(in)                 :: nrows, ncols
    real, intent(in)                    :: start, last

    real                                :: r, temp
    integer                             :: irow, icol

    r = last - start

    do icol = 1, ncols
        do irow = 1, nrows
            call random_number(temp)
            mat(irow, icol) = start + temp * r
        end do
    end do
    end subroutine initialise_to_random_2D

    !#############################################
    subroutine initialise_to_random_1D(vec, ncols, start, last)
    real, allocatable, intent(inout)    :: vec(:)
    integer, intent(in)                 :: ncols
    real, intent(in)                    :: start, last

    real                                :: r, temp
    integer                             :: icol

    r = last - start

    do icol = 1, ncols
        call random_number(temp)
        vec(icol) = start + temp * r
    end do
    end subroutine initialise_to_random_1D

    !#############################################
    subroutine initialise_tridiagonal_sp(mat, n, upper, diag, lower)
    real, allocatable, intent(inout)    :: mat(:,:)
    integer, intent(in)                 :: n
    real, intent(in)                    :: upper, diag, lower

    integer                             :: irow, icol

    do icol = 1, n
        do irow = 1, n
            if (irow == icol) then
                mat(irow, icol) = diag
            else
                if (irow == icol + 1) then
                    mat(irow, icol) = lower
                else if (irow == icol - 1) then
                    mat(irow, icol) = upper
                else
                    mat(irow, icol) = 0.
                end if
            end if
        end do
    end do
    end subroutine initialise_tridiagonal_sp

    !#############################################
    subroutine initialise_to_random_2D_dp(mat, nrows, ncols, start, last)
    real(DP), allocatable, intent(inout)    :: mat(:,:)
    integer, intent(in)                     :: nrows, ncols
    real(DP), intent(in)                    :: start, last

    real(DP)                                :: r, temp
    integer                                 :: irow, icol

    r = last - start

    do icol = 1, ncols
        do irow = 1, nrows
            call random_number(temp)
            mat(irow, icol) = start + temp * r
        end do
    end do
    end subroutine initialise_to_random_2D_dp

    !#############################################
    subroutine initialise_to_random_1D_dp(vec, ncols, start, last)
    real(DP), allocatable, intent(inout)    :: vec(:)
    integer, intent(in)                     :: ncols
    real(DP), intent(in)                    :: start, last

    real(DP)                                :: r, temp
    integer                                 :: icol

    r = last - start

    do icol = 1, ncols
        call random_number(temp)
        vec(icol) = start + temp * r
    end do
    end subroutine initialise_to_random_1D_dp

    !#############################################
    subroutine initialise_tridiagonal_dp(mat, n, upper, diag, lower)
    real(DP), allocatable, intent(inout)    :: mat(:,:)
    integer, intent(in)                     :: n
    real(DP), intent(in)                    :: upper, diag, lower

    integer                             :: irow, icol

    do icol = 1, n
        do irow = 1, n
            if (irow == icol) then
                mat(irow, icol) = diag
            else
                if (irow == icol + 1) then
                    mat(irow, icol) = lower
                else if (irow == icol - 1) then
                    mat(irow, icol) = upper
                else
                    mat(irow, icol) = 0.
                end if
            end if
        end do
    end do
    end subroutine initialise_tridiagonal_dp

    end module initialisation


!
! lab1_2.f90
!
! Copyright 2016 Bruno S <bruno@oac.unc.edu.ar>
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
! MA 02110-1301, USA.
!
!
PROGRAM lab1_2

USE precision, pr => dp
IMPLICIT NONE
INTEGER :: i, j, k
REAL(pr) :: h, x, e, er, cal

open(unit=10, file='salida_ej2.dat', status='UNKNOWN', action='WRITE')
write(10, *) "# h Fp er"

x = 1._pr
e = exp(x)
h = 1._pr

do i=1, 15, 1
    h = h * 0.1_pr
    cal = fp(h, x)
    er = cal - e

    write(10, *) h, cal, abs(er)
end do

CONTAINS

FUNCTION f(x)
REAL (pr) :: f
REAL (pr), INTENT(IN) :: x

    f = exp(x)

END FUNCTION f

FUNCTION fp(h, x)
REAL (pr) :: fp
REAL (pr), INTENT(IN) :: h, x

    fp = f(x + h) - f(x - h)
    fp = fp/(2._pr*h)

END FUNCTION fp

END PROGRAM lab1_2


#include "../defines.inc"
module vector_utils
   use precision, only: dp, eps, pi
   implicit none

contains

   function distance(a, b)
      implicit none
      real(dp), dimension(3), intent(in) :: a, b
      real(dp) distance
      distance = sqrt((a(1) - b(1))**2 + (a(2) - b(2))**2 + (a(3) - b(3))**2)
   end function distance

   function angle(a, b, c)
      implicit none
      real(dp) angle
      real(dp), dimension(3), intent(in) :: a, b, c
      angle = acos(dot_product(a - b, c - b)/(norm2(a - b)*norm2(c - b)))

   end function angle

   function cross(a, b)
      implicit none
      real(dp), dimension(3) :: cross
      real(dp), dimension(3), intent(in) :: a, b

      cross(1) = a(2)*b(3) - a(3)*b(2)
      cross(2) = a(3)*b(1) - a(1)*b(3)
      cross(3) = a(1)*b(2) - a(2)*b(1)

   end function cross

   function angle_between(a, b)
      implicit none
      real(dp) angle_between
      real(dp), dimension(3), intent(in) :: a, b

      real(dp) amag, bmag
      amag = norm2(a)
      bmag = norm2(b)
      angle_between = 2.0*atan2(norm2(amag*b - bmag*a), norm2(amag*b + bmag*a))
      ! algorithm from https://www.jwwalker.com/pages/angle-between-vectors.html
   end function angle_between

   function rotateR(ROT, R)
      use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
      implicit none
      real(dp), intent(in) :: ROT(3, 4) ! Rotation matrix
      real(dp), intent(in) :: R(3)
      real(dp) rotateR(3)
      rotateR(1) = ROT(1, 4) + ROT(1, 1)*R(1) + ROT(1, 2)*R(2) + ROT(1, 3)*R(3)
      rotateR(2) = ROT(2, 4) + ROT(2, 1)*R(1) + ROT(2, 2)*R(2) + ROT(2, 3)*R(3)
      rotateR(3) = ROT(3, 4) + ROT(3, 1)*R(1) + ROT(3, 2)*R(2) + ROT(3, 3)*R(3)
      if (WLC_P__WARNING_LEVEL >= 1) then
         if (isnan(rotateR(1)) .or. isnan(rotateR(2)) .or. isnan(rotateR(3))) then
            write (ERROR_UNIT, *) "NAN detected in ROT"
            write (ERROR_UNIT, *) "R", R
            write (ERROR_UNIT, *) "ROT", ROT
         endif
      endif
   end function rotateR

   function rotateU(ROT, U)
      implicit none
      real(dp), intent(in) :: ROT(3, 4) ! Rotation matrix
      real(dp), intent(in) :: U(3)
      real(dp) rotateU(3)
      rotateU(1) = ROT(1, 1)*U(1) + ROT(1, 2)*U(2) + ROT(1, 3)*U(3)
      rotateU(2) = ROT(2, 1)*U(1) + ROT(2, 2)*U(2) + ROT(2, 3)*U(3)
      rotateU(3) = ROT(3, 1)*U(1) + ROT(3, 2)*U(2) + ROT(3, 3)*U(3)
   end function rotateU

   function angle_of_triangle(a, b, c)
      implicit none
      real(dp), intent(in) :: a, b, c
      real(dp) angle_of_triangle
      angle_of_triangle = acos((a**2 - b**2 - c**2)/(-2.0_dp*b*c))
   end function angle_of_triangle

   function round_into_pm1(x)
      implicit none
      real(dp), intent(in) :: x
      real(dp) round_into_pm1
      round_into_pm1 = min(x, 1.0_dp)
      round_into_pm1 = max(x, -1.0_dp)
   end function round_into_pm1

!! ---------------------------------------------------------------
!
!    Generates random unit vector
!
!------------------------------------------------------------
   subroutine randomUnitVec(U, rand_stat)
      use mersenne_twister

      implicit none
      type(random_stat), intent(inout) :: rand_stat  ! status of random number generator
      real(dp), intent(out) :: U(3)
      real(dp) z
      real(dp) theta
      real(dp) temp
      real(dp) urand(2)

      call random_number(urand, rand_stat)
      theta = urand(1)*2.0_dp*PI
      z = urand(2)*2.0_dp - 1.0_dp
      temp = sqrt(1.0_dp - z**2)
      U(1) = temp*cos(theta)
      U(2) = temp*sin(theta)
      U(3) = z

      ! Alturnative algorithem
      !call random_number(urand,rand_stat)
      !ALPHA = 2.0_dp*PI*urand(1)
      !BETA = acos(2.0_dp*urand(2)-1.0_dp)
      !U(1) = sin(BETA)*cos(ALPHA)
      !U(2) = sin(BETA)*sin(ALPHA)
      !U(3) = cos(BETA)

      ! Alturnative algorithem
      !real(dp) urand(3)
      !call random_gauss(urand, rand_stat)
      !U = urand
      !U = U/norm2(U)
   end subroutine

!--------------------------------------------------------------*
!
!           Calculates random perpendicular vectors
!
!    Quinn Made Changes to this file starting on 12/15/15
!    Quinn made this an independent file on 6/20/18
!
!---------------------------------------------------------------

   subroutine random_perp(u, p, t, rand_stat)
      ! The subroutine generates the second two vectors in a unit triad
      ! The output vectors, p and t, are perpendicular to eachother and u
      ! The triad is randomly left or right handed
      use mersenne_twister
      implicit none
      !real(dp), PARAMETER :: PI = 3.141592654 ! Value of pi
      type(random_stat) rand_stat  ! status of random number generator
      real(dp) urnd(1) ! single random number

      real(dp) v(2) ! random 2-vec
      real(dp), intent(in) :: u(3) ! input
      real(dp), intent(out) :: p(3) ! output: random perpendicular to u
      real(dp), intent(out) :: t(3) ! orthogonal to p and u
      real(dp) f

      if (abs(u(1)**2 + u(2)**2 + u(3)**2 - 1.0_dp) .gt. eps) then
         print *, u
         print *, "Error in random_perp, please give me a unit vector"
         stop 1
      endif

      call random_number(urnd, rand_stat)
      v(1) = cos(2.0_dp*PI*urnd(1))
      v(2) = sin(2.0_dp*PI*urnd(1))

      if (u(3) .gt. 0.0) then
         f = 1.0_dp/(1.0_dp + u(3))
         p(1) = (u(3) + f*u(2)**2)*v(1) - u(2)*u(1)*v(2)*f
         p(2) = (u(3) + f*u(1)**2)*v(2) - u(2)*u(1)*v(1)*f
         p(3) = -1.0_dp*(u(2)*v(2) + u(1)*v(1))
      else
         f = 1.0_dp/(1.0_dp - u(3))
         p(1) = (-u(3) + f*u(2)**2)*v(1) - u(2)*u(1)*v(2)*f
         p(2) = (-u(3) + f*u(1)**2)*v(2) - u(2)*u(1)*v(1)*f
         p(3) = (u(2)*v(2) + u(1)*v(1))

      endif

      t(1) = u(2)*p(3) - u(3)*p(2)
      t(2) = u(3)*p(1) - u(1)*p(3)
      t(3) = u(1)*p(2) - u(2)*p(1)

      ! random sign
      call random_number(urnd, rand_stat)
      if (urnd(1) .lt. 0.5_dp) then
         t(1) = -1.0_dp*t(1)
         t(2) = -1.0_dp*t(2)
         t(3) = -1.0_dp*t(3)
      endif

      ! Testing
      !if (abs(dot_product(p,u)) > 0.000001_dp) then
      !    print*, "Error in random_perp, 1"
      !    stop 1
      !endif
      !if (abs(p(1)**2 + p(2)**2 + p(3)**2-1) .gt. 0.0000001_dp) then
      !    print*, "Error in random_perp, 2"
      !    stop 1
      !endif
      !if (abs(t(1)**2 + t(2)**2 + t(3)**2 -1).gt.0.000001_dp) then
      !    print*, "Error in random_perp, 3"
      !    stop 1
      !endif
      !if (abs(dot_product(t,p)) > 0.0000001_dp) then
      !    print*, "Error in random_perp, 4"
      !    stop 1
      !endif
      !if (abs(dot_product(t,u)) > 0.0000001_dp) then
      !    print*, "Error in random_perp, 5"
      !    stop 1
      !endif
      ! END Testing

      return
   end subroutine

!--------------------------------------------------------------*
!
!    Calculates axis angle rotation matrix
!    Calculates the rotation in the right handed sense by angle alpha
!    in the TA direction.
!    The magnitude of TA is disreguarded.
!    The forth column is the offset
!
!    Quinn split out this file on 6/20/18
!
!---------------------------------------------------------------

   subroutine axisAngle(ROT, alpha, TAin, P1)
      use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
      implicit none
      real(dp), intent(in) :: TAin(3)    ! Axis of rotation  (Need not be unit vector!!)
      real(dp), intent(in) :: P1(3)    ! Point on rotation line
      real(dp), intent(in) :: ALPHA    ! Angle of move
      real(dp), intent(out) :: ROT(3, 4) ! Rotation matrix
      real(dp) MAG      ! Magnitude of vector
      real(dp) TA(3)    ! Normalized vector
      integer i

!print*, "PA", P1
      MAG = sqrt(TAin(1)**2 + TAin(2)**2 + TAin(3)**2)
      TA(1) = TAin(1)/MAG
      TA(2) = TAin(2)/MAG
      TA(3) = TAin(3)/MAG

      ROT(1, 1) = TA(1)**2 + (TA(2)**2 + TA(3)**2)*cos(ALPHA)
      ROT(1, 2) = TA(1)*TA(2)*(1.0_dp - cos(ALPHA)) - TA(3)*sin(ALPHA)
      ROT(1, 3) = TA(1)*TA(3)*(1.0_dp - cos(ALPHA)) + TA(2)*sin(ALPHA)
      ROT(1, 4) = (P1(1)*(1.0_dp - TA(1)**2) &
                   - TA(1)*(P1(2)*TA(2) + P1(3)*TA(3)))*(1.-cos(ALPHA)) + (P1(2)*TA(3) - P1(3)*TA(2))*sin(ALPHA)

      ROT(2, 1) = TA(1)*TA(2)*(1.0_dp - cos(ALPHA)) + TA(3)*sin(ALPHA)
      ROT(2, 2) = TA(2)**2 + (TA(1)**2 + TA(3)**2)*cos(ALPHA)
      ROT(2, 3) = TA(2)*TA(3)*(1.0_dp - cos(ALPHA)) - TA(1)*sin(ALPHA)
      ROT(2, 4) = (P1(2)*(1.0_dp - TA(2)**2) &
                   - TA(2)*(P1(1)*TA(1) + P1(3)*TA(3)))*(1.-cos(ALPHA)) + (P1(3)*TA(1) - P1(1)*TA(3))*sin(ALPHA)

      ROT(3, 1) = TA(1)*TA(3)*(1.-cos(ALPHA)) - TA(2)*sin(ALPHA)
      ROT(3, 2) = TA(2)*TA(3)*(1.-cos(ALPHA)) + TA(1)*sin(ALPHA)
      ROT(3, 3) = TA(3)**2 + (TA(1)**2 + TA(2)**2)*cos(ALPHA)
      ROT(3, 4) = (P1(3)*(1.0_dp - TA(3)**2) &
                   - TA(3)*(P1(1)*TA(1) + P1(2)*TA(2)))*(1.0_dp - cos(ALPHA)) + (P1(1)*TA(2) - P1(2)*TA(1))*sin(ALPHA)

      if (WLC_P__WARNING_LEVEL >= 1) then
         do i = 1, 3
            if (isnan(ROT(1, i)) .or. isnan(ROT(2, i)) .or. isnan(ROT(3, i))) then
               write (ERROR_UNIT, *) "NAN detected in axisAngle"
               write (ERROR_UNIT, *) "alpha", alpha
               write (ERROR_UNIT, *) "TAin", TAin
               write (ERROR_UNIT, *) "P1", P1
               write (ERROR_UNIT, *) "ROT", ROT
               stop
            endif
         enddo
      endif
   end subroutine

   subroutine rotateAIntoB(A, B, P1, ROT)
      use, intrinsic :: iso_fortran_env, only: ERROR_UNIT
      implicit none
      real(dp), intent(in) :: A(3)
      real(dp), intent(in) :: B(3)
      real(dp), intent(in) :: P1(3)    ! Point on rotation line
      real(dp), intent(out) :: ROT(3, 4) ! Rotation matrix
      real(dp) ALPHA    ! Angle of move
      real(dp) TA(3)    ! Normalized vector

      TA = cross(A, B)
      alpha = asin(norm2(TA)/(norm2(A)*norm2(B)))
      if (norm2(A) < 10**(-10) .or. norm2(B) < 10**(-10)) then
         ROT = 0.0_dp
         ROT(1, 1) = 1.0_dp
         ROT(2, 2) = 1.0_dp
         ROT(3, 3) = 1.0_dp
         write (ERROR_UNIT, *) "Tried to rotate", A, " into ", B
         return
      endif

      call axisAngle(ROT, alpha, TA, P1)
   end subroutine rotateAIntoB
end module


*-----------------------------------------------------------------------
* MR - multiple regression using the SLATEC library routine DHFTI
*
* Finds the nearest approximation to BETA in the system of linear equations:
*
*              X(j,i) . BETA(i) = Y(j)
* where
*                  1 ... j ... N
*                  1 ... i ... K
* and
*                  K .LE. N
*
* INPUT ARRAYS ARE DESTROYED!
*
*___Name_________Type_______________In/Out____Description________________________
*   X(N,K)       Double precision   In        Predictors
*   Y(N)         Double precision   Both      On input:   N Observations
*                                             On output:  K beta weights
*   N            Integer            In        Number of observations
*   K            Integer            In        Number of predictor variables
*   DWORK(3*K)   Double precision   Neither   Workspace
*   IWORK(K)     Integer            Neither   Workspace
*-----------------------------------------------------------------------
      SUBROUTINE MR (X, Y, N, K, DWORK, IWORK)
       IMPLICIT NONE
       INTEGER K, N, IWORK
       DOUBLE PRECISION X, Y, DWORK
       DIMENSION X(N,K), Y(N), DWORK(3*K), IWORK(K)

*         local variables
       INTEGER I, J
       DOUBLE PRECISION TAU, TOT

*        maximum of all column sums of magnitudes
       TAU = 0.
       DO J = 1, K
         TOT = 0.
         DO I = 1, N
           TOT = TOT + ABS(X(I,J))
         END DO
         IF (TOT > TAU) TAU = TOT
       END DO
       TAU = TAU * EPSILON(TAU)        ! tolerance argument

*            call function
       CALL DHFTI (X, N, N, K, Y, N, 1, TAU,
     $  J, DWORK(1), DWORK(K+1), DWORK(2*K+1), IWORK)
       IF (J < K) PRINT *, 'mr: solution is rank deficient!'
       RETURN
      END  ! of MR

*-----------------------------------------------------------------------
      PROGRAM t_mr        ! polynomial regression example
       IMPLICIT NONE
       INTEGER N, K
       PARAMETER (N=15, K=3)
       INTEGER IWORK(K), I, J
       DOUBLE PRECISION XIN(N), X(N,K), Y(N), DWORK(3*K)

       DATA XIN / 1.47, 1.50, 1.52, 1.55, 1.57, 1.60, 1.63, 1.65, 1.68,
     $            1.70, 1.73, 1.75, 1.78, 1.80, 1.83 /
       DATA Y / 52.21, 53.12, 54.48, 55.84, 57.20, 58.57, 59.93, 61.29,
     $          63.11, 64.47, 66.28, 68.10, 69.92, 72.19, 74.46 /

*              make coefficient matrix
       DO J = 1, K
         DO I = 1, N
           X(I,J) = XIN(I) **(J-1)
         END DO
       END DO

*               solve
       CALL MR (X, Y, N, K, DWORK, IWORK)

*               print result
  10   FORMAT ('beta: ', $)
  20   FORMAT (F12.4, $)
  30   FORMAT ()
       PRINT 10
       DO J = 1, K
         PRINT 20, Y(J)
       END DO
       PRINT 30
       STOP 'program complete'
      END


subroutine itemwise_calc(input, output)

  implicit none

  real*8, dimension(:), intent(in) :: input
  real*8, dimension(size(input)), intent(out) :: output
  integer :: n

  !$omp parallel do
  do n = 1, size(input)
    output(n) = (input(n) - 3) * (input(n) - 2) * (input(n) - 1) * input(n) * (input(n) + 1) * (input(n) + 2) * (input(n) + 3)
  end do
  !$omp end parallel do

  return

end subroutine


! triangle - ASS configuration
! Copyright 2021 by Eric Conrad.
! License - MIT License - see: https://opensource.org/licenses/MIT
!
!   input - the measure of an angle the length of a pair of sides
!       that don't contain the angle (NB: one of the two sides will
!       be opposite the given angle)
!   remarks - there may be 0, 1 or 2 solutions
!   output -
!       the sides and angles
!       the semiperimeter and the area
!       type of triangle
!
! Corrections:
!  14 Jan 2021 -
!		- added copyright and license statement
!		- corrected text of second error message under "Remaining error checks",
!		  changing "given angles" (plural) to "given angle" (singular).

! When I took geometry in high school, this was called the ASS
! configuration.  In today's more puritannical times, it's called
! the SSA configuration.

      program triangle
      print*,"ASS Configuration"

! Notes:
!   100 grad = 90 degrees = pi/2 (rad) = 1 rt angle = 1/4 rev
!   200 grad = 180 degrees = pi (rad) = 2 rt angles = 1/2 rev

      print*,"Angle measure units (1-radian, 2-degree, 3-grad, 4-rev):"
      read(*,*) imeas
      if(imeas .lt. 1 .or. imeas .gt. 4) then
          print*,"ERROR: unsupported angle measure"
          stop 1
      end if

      print*,"Enter the measure of the given angle (A):"
      read(*,*) alpha
      print*,"Enter the length of the side opposite A (a):"
      read(*,*) a
      print*,"Enter the length of a side adjacent to A (b):"
      read(*,*) b

! First error condition:
! the given sides must be positive in length
      if(a.le.0.0 .or. b.le.0.0) then
          print*,"ERROR: The given sides must be positive in length"
          stop 1
      end if

! Convert the angle measures
      pi = 4*atan(1.d0)
      if(imeas.eq.1) then       ! input in radians
          dalpha = 180 * alpha / pi
          galpha = 200 * alpha / pi
          ralpha = alpha / (2 * pi)
      else if(imeas.eq.2) then  ! input in degrees
          dalpha = alpha
          alpha = pi * dalpha / 180
          galpha = 200 * dalpha / 180
          ralpha = dalpha / 360
      else if(imeas.eq.3) then  ! input in grads
          galpha = alpha
          alpha = pi * galpha / 200
          dalpha = 180 * galpha / 200
          ralpha = dalpha / 400
      else                      ! input in revolutions
          ralpha = alpha
          alpha = 2 * pi * galpha
          dalpha = 360 * galpha
          galpha = 400 * ralpha
      end if

! Remaining error checks:
!   (1) the given angle should positive
      if(alpha.le.0) then
          print*, "ERROR: the given angle must be positive"
          stop 1
      end if
!   (2) the given angle must be less than a straight angle
      if(alpha.ge.pi) then
          print*, "ERROR: the given angle must be less" // &
                "than a straight angle"
          stop 1
      end if

! law of sines
! it's safe for finding sides (apart from numerical errors), but
! must be used carefully when used to find angles...
! there will be either no solutions or two solutions (the principal
! acute angle and its obtuse counterpart) or a double solution (a
! right angle)...

! Step 1) Find angle B using the law of sines
!     sin(B) / B = sin(A) / A

      sinB = b * sin(alpha) / a
      print*, "sin(B) =", sinB
      if(sinB .gt. 1) then
          print*, "There is no triangle satifying these constraints."
          stop 1
      end if

! we have reduced the confirguration to AAS (A, B, a), but there
! are two values of B to consider... and there are still some
! landmines...

! the principal solution
      print*, "Principal solution"
      beta = asin(sinB)
      print*, "a =", a, ", b =", b
      print*, "A =", alpha, ", B =", beta
      if((alpha + beta) .ge. pi) then
          print*, "The two known angles exceed a straight angle."
          print*, "No solution."
          stop 1
      end if

      dbeta = 180 * beta / pi
      gbeta = 200 * beta / pi
      rbeta = beta / (2 * pi)

! the principal solution B gives a real triangle...

      gamm = pi - alpha - beta          ! third angle
      dgamma = 180 * gamm / pi
      ggamma = 200 * gamm / pi
      rgamma = gamm / (2 * pi)

      c = sin(gamm) * a / sin(alpha)

! output solution of triangle
      print*, "------- PRINCIPAL SOLUTION --------------------------"
      print*, "a =", a, "  (given)"
      print*, "b =", b, "  (given)"
      print*, "c =", c
      print*, "A =", alpha, "degrees:", dalpha, "  (given)"
      print*, "B =", beta, "degrees:", dbeta, "  (principal)"
      print*, "C =", gamm, "degrees:", dgamma
      print*, "-----------------------------------------------------"
      print*, "Angles in grads:"
      print*, "     ", galpha, gbeta, ggamma
      print*, "     sum:", galpha + gbeta + ggamma, "  (exp: 200)"
      print*, "Angles in revolutions:"
      print*, "     ", ralpha, rbeta, rgamma
      print*, "     sum:", ralpha + rbeta + rgamma, "  (exp: 0.5)"
      print*, "-----------------------------------------------------"

! output semiperimeter and area
      s = (a + b + c) / 2
      print*, "semiperimeter:", s
      area = sqrt(s * (s-a) * (s-b) * (s-c))    ! Heron's formula
      print*, "area:", area

! angle sum
      sum1 = alpha + beta + gamm
      err1 = sum1 - pi
      sum2 = dalpha + dbeta + dgamma
      err2 = sum2 - 180.0
      print*, "angle sum (radians):", sum1, "   error:", err1
      print*, "angle sum (degrees):", sum2, "   error:", err2

! triangle inequality check:
!           a + b < c; b + c < a; c + a < c
! A sufficient and necessary condition is that no side may
! exceed the semiperimeter.
      if (max(a,b,c) .ge. s) then
          print*,"ERROR: (triangle inequality) max(a,b,c) < s"
      end if

! 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

! the secondary solution
      print*, "====================================================="
      print*, "Secondary solution"
      beta2 = pi - beta
      print*, "a =", a, ", b =", b
      print*, "A =", alpha, ", B =", beta2
      if(beta2 .eq. beta) then
          print*, "Angle B is a right angle."
          print*, "The solution is unique."
          stop 0
      end if
      beta = beta2
      if((alpha + beta) .ge. pi) then
          print*, "The two known angles exceed a straight angle."
          print*, "No secondary solution."
          stop 0
      end if

      dbeta = 180 * beta / pi
      gbeta = 200 * beta / pi
      rbeta = beta / (2 * pi)

! the secondary (obtuse) solution B gives a real triangle...

      gamm = pi - alpha - beta          ! third angle
      dgamma = 180 * gamm / pi
      ggamma = 200 * gamm / pi
      rgamma = gamm / (2 * pi)

      c = sin(gamm) * a / sin(alpha)

! output solution of triangle
      print*, "------- SECONDARY SOLUTION --------------------------"
      print*, "a =", a, "  (given)"
      print*, "b =", b, "  (given)"
      print*, "c =", c
      print*, "A =", alpha, "degrees:", dalpha, "  (given)"
      print*, "B =", beta, "degrees:", dbeta, "  (secondary)"
      print*, "C =", gamm, "degrees:", dgamma
      print*, "-----------------------------------------------------"
      print*, "Angles in grads:"
      print*, "     ", galpha, gbeta, ggamma
      print*, "     sum:", galpha + gbeta + ggamma, "  (exp: 200)"
      print*, "Angles in revolutions:"
      print*, "     ", ralpha, rbeta, rgamma
      print*, "     sum:", ralpha + rbeta + rgamma, "  (exp: 0.5)"
      print*, "-----------------------------------------------------"

! output semiperimeter and area
      s = (a + b + c) / 2
      print*, "semiperimeter:", s
      area = sqrt(s * (s-a) * (s-b) * (s-c))    ! Heron's formula
      print*, "area:", area

! angle sum
      sum1 = alpha + beta + gamm
      err1 = sum1 - pi
      sum2 = dalpha + dbeta + dgamma
      err2 = sum2 - 180.0
      print*, "angle sum (radians):", sum1, "   error:", err1
      print*, "angle sum (degrees):", sum2, "   error:", err2

! triangle inequality check:
!           a + b < c; b + c < a; c + a < c
! A sufficient and necessary condition is that no side may
! exceed the semiperimeter.
      if (max(a,b,c) .ge. s) then
          print*,"ERROR: (triangle inequality) max(a,b,c) < s"
      end if

! 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

      end program


module binomialtree
implicit none
private
public tree_stockprice, eurocall, europut, amcall, amput

contains

real function tree_stockprice(S0, u, d, i, j) result(price)
  real, intent(in) :: S0, u, d
  integer, intent(in) :: i, j
  ! using Python array indexing (start from 0)
  price = S0 * u**(i-j) * d**j
end function

real function eurocall(S0, X, rdt, p, u, d, nbsteps) result(price)
  real, intent(in) :: S0, X, rdt, p, u, d
  integer, intent(in) :: nbsteps
  real, dimension(nbsteps+1) :: pricearr
  integer :: i, j
  do j = 0, nbsteps
     pricearr(j+1) = max(tree_stockprice(S0, u, d, nbsteps, j)-X, 0.0)
  end do
  do i = nbsteps-1, 0, -1
     do j = 0, i
        pricearr(j+1) = exp(-rdt)*(p*pricearr(j+1)+(1-p)*pricearr(j+2))
     end do
  end do
  price = pricearr(1)
end function

real function europut(S0, X, rdt, p, u, d, nbsteps) result(price)
  real, intent(in) :: S0, X, rdt, p, u, d
  integer, intent(in) :: nbsteps
  real, dimension(nbsteps+1) :: pricearr
  integer :: i, j
  do j = 0, nbsteps
     pricearr(j+1) = max(X-tree_stockprice(S0, u, d, nbsteps, j), 0.0)
  end do
  do i = nbsteps-1, 0, -1
     do j = 0, i
        pricearr(j+1) = exp(-rdt)*(p*pricearr(j+1)+(1-p)*pricearr(j+2))
     end do
  end do
  price = pricearr(1)
end function

real function amcall(S0, X, rdt, p, u, d, nbsteps) result(price)
  real, intent(in) :: S0, X, rdt, p, u, d
  integer, intent(in) :: nbsteps
  real, dimension(nbsteps+1) :: pricearr
  real, dimension(nbsteps) :: temp_euroval
  real :: imvalue
  integer :: i, j
  do j = 0, nbsteps
     pricearr(j+1) = max(tree_stockprice(S0, u, d, nbsteps, j)-X, 0.0)
  end do
  do i = nbsteps-1, 0, -1
     do j = 0, i
        temp_euroval(j+1) = exp(-rdt)*(p*pricearr(j+1)+(1-p)*pricearr(j+2))
     end do
     do j = 0, i
        imvalue = tree_stockprice(S0, u, d, i, j)-X
        pricearr(j+1) = max(imvalue, temp_euroval(j+1))
     end do
  end do
  price = pricearr(1)
end function

real function amput(S0, X, rdt, p, u, d, nbsteps) result(price)
  real, intent(in) :: S0, X, rdt, p, u, d
  integer, intent(in) :: nbsteps
  real, dimension(nbsteps+1) :: pricearr
  real, dimension(nbsteps) :: temp_euroval
  real :: imvalue
  integer :: i, j
  do j = 0, nbsteps
     pricearr(j+1) = max(X-tree_stockprice(S0, u, d, nbsteps, j), 0.0)
  end do
  do i = nbsteps-1, 0, -1
     do j = 0, i
        temp_euroval(j+1) = exp(-rdt)*(p*pricearr(j+1)+(1-p)*pricearr(j+2))
     end do
     do j = 0, i
        imvalue = X-tree_stockprice(S0, u, d, i, j)
        pricearr(j+1) = max(imvalue, temp_euroval(j+1))
     end do
  end do
  price = pricearr(1)
end function

end module

! compiling
! > f2py -h binomialtree.pyf -m binomialtree binomialtree.f90
! > f2py -c binomialtree.pyf binomialtree.f90


program midpoint
    implicit none
    integer :: i, N
    real :: t, h, pi = 4. * atan(1.)
    real, dimension(2) :: x, k1

    h = 0.1
    N = 2. * pi / h

    ! Midpoint method
    x(1) = 1.
    x(2) = 0.
    write(*,*)0., x
    do i=1,N
        t = (i - 1) * h
        k1 = f(x, t)
        x = x + h * f(x + k1 * h / 2, t + h / 2)
        write(*,*)i * h, x
    end do

contains

    function f(x, t)
        implicit none
        real, intent(in) :: t
        real, dimension(2), intent(in) :: x
        real, dimension(2) :: f

        f(1) = x(2)
        f(2) = -x(1)
    end function
end program


      subroutine krnlcolumnannihilate( n, A, ldA, cvec, svec )

      implicit none

*
*     PURPOSE
*     =======
*
*     Reduces an upper Hessenberg n-by-n matrix A to upper triangular
*     form by constructing and applying a decreasing sequence of column
*     n - 1 column rotations.
*
*     More specifically, the following update of A is performed:
*
*       A := A * G(k) * G(k-1) * ... * G(2)
*
*     where G(k) for k = 2, 3, ..., n affects only columns k - 1 and k
*     in the following way. Let x denote column k - 1 and y denote
*     column k. Furthermore, define c = cvec(k) and s = svec(k). Then
*     the effect of A * G(k) is equivalent to the update
*
*       [ x y ] := [ x y ] * [ c -s ]
*                            [ s  c ].
*
*     The transformation G(k) is chosen such that it annihilates the
*     subdiagonal element A(k,k-1) using the diagonal element A(k,k) as
*     a pivot.
*
*
*     ARGUMENTS
*     =========
*
*     n             (input) INTEGER
*
*                   The number of rows and columns in A.
*
*     A             (input/output) DOUBLE PRECISION array
*                   dimension ldA-by-n
*
*                   The matrix A.
*
*     ldA           (input) INTEGER
*
*                   The column stride of A.
*
*     cvec          (output) DOUBLE PRECISION array
*                   dimension n
*
*                   cvec(k) is the c-parameter of G(k).
*
*     svec          (output) DOUBLE PRECISION array
*                   dimension m
*
*                   svec(k) is the s-parameter of G(k).
*

*
*     Scalar arguments.
*
      integer n, ldA

*
*     Array arguments.
*
      double precision A( ldA, * ), cvec( * ), svec( * )

*
*     Externals.
*
      external dlartg

*
*     Local scalars.
*
      integer i, j
      double precision c, s, x, y, tmp

      do j = n, 2, -1
         tmp = A( j, j )
         call dlartg( tmp, A( j, j - 1 ), c, s, A( j, j ) )
         cvec( j ) = c
         svec( j ) = s
         A( j, j - 1 ) = 0.0D+0
         do i = 1, j - 1
            x = A( i, j - 1 )
            y = A( i, j     )
            A( i, j - 1 ) = c * x - s * y
            A( i, j     ) = s * x + c * y
         end do
      end do

      end subroutine


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: max_int = 100

  ! Variables
  integer(4) :: i,sum_sq,sq_sum,diff

  ! Do work
  sum_sq = 0
  sq_sum = 0
  do i=1,max_int
     sum_sq = sum_sq + i**2
     sq_sum = sq_sum + i
  enddo

  sq_sum = sq_sum**2
  diff   = sq_sum - sum_sq

  ! Write out answer
  write(*,*) 'Difference between sum of squares and square of sums up to ',&
       max_int,': ',diff

end program main


subroutine gcd_iter(value, u, v)
  integer, intent(out) :: value
  integer, intent(inout) :: u, v
  integer :: t

  do while( v /= 0 )
     t = u
     u = v
     v = mod(t, v)
  enddo
  value = abs(u)
end subroutine gcd_iter


 ! It was proposed by Christian Goldbach that every odd composite number can be
 ! written as the sum of a prime and twice a square.
 !
 ! 9 = 7 + 2×1^2
 ! 15 = 7 + 2×2^2
 ! 21 = 3 + 2×3^2
 ! 25 = 7 + 2×3^2
 ! 27 = 19 + 2×2^2
 ! 33 = 31 + 2×1^2
 !
 ! It turns out that the conjecture was false.
 !
 ! What is the smallest odd composite that cannot be written as the sum of a
 ! prime and twice a square?
 !
 ! Answer: 5777
 !
 ! Project Euler: 46

program main

        use euler

implicit none

        integer (int32) :: i = 1;

24 &
        i = i + 2;

        if(isprime(i) .OR. satisfies_goldbach(i)) goto 24;

        print*, i

contains

        ! This function generates twice squares and subtracts this from the
        ! test number. If the number, once subtracted, is a prime, then this
        ! satisfies Goldbach's conjecture. Otherwise the function terminates
        ! when there exists no twice square that may be subtracted positively.

        pure logical function satisfies_goldbach(n)

                integer (int32), intent(in) :: n
                integer (int32) :: i, sqr;

                satisfies_goldbach = .FALSE.
                i = 1; sqr = 2;

                do while (sqr < n .AND. .NOT. satisfies_goldbach)

                        satisfies_goldbach = isprime(n - sqr);
                        i = i + 1
                        sqr = 2 * (i**2);

                end do

        end function satisfies_goldbach

end program main


*----------------------------------------------------------------------*
*     follows: exp and log of matrices
*----------------------------------------------------------------------*
      subroutine expgmat(ndim,expx,xmat,xscr1,xscr2,thrsh)
*----------------------------------------------------------------------*
*     calculate exp(X), returned on expx, of (ndim,ndim)-matrix X,
*     input on xmat, by Taylor expansion (threshold thrsh)
*     xscr is a scratch matrix of the same dimensions as xmat, expx
*
*     any quadratic matrix may be supplied
*
*     andreas, aug 2004
*
*----------------------------------------------------------------------*

      implicit none

      include 'stdunit.h'

      integer, parameter :: ntest = 00, maxn = 100

      integer, intent(in) ::
     &     ndim
      real(8), intent(in) ::
     &     thrsh
      real(8), intent(inout) ::
     &     expx(ndim,ndim), xmat(ndim,ndim),
     &     xscr1(ndim,ndim),  xscr2(ndim,ndim)

      logical ::
     &     conv
      integer ::
     &     n, ndim2, ii
      real(8) ::
     &     xnrm, fac

      real(8), external ::
     &     inprod

      expx(1:ndim,1:ndim) = xmat(1:ndim,1:ndim)
      xscr2(1:ndim,1:ndim) = xmat(1:ndim,1:ndim)

      do ii = 1, ndim
        expx(ii,ii) = expx(ii,ii) + 1d0
      end do

      ndim2 = ndim*ndim
      n = 1
      conv = .false.

      do while (.not.conv)
        n = n+1
        if (n.gt.maxn) exit

        fac = 1d0/dble(n)

        ! Xscr = 1/N Xscr * X
c        call matml7(xscr1,xscr2,xmat,
c     &              ndim,ndim,
c     &              ndim,ndim,
c     &              ndim,ndim,0d0,fac,0)
        call dgemm('n','n',ndim,ndim,ndim,
     &             fac,xscr2,ndim,
     &                 xmat,ndim,
     &             0d0,xscr1,ndim)

        xnrm = sqrt(inprod(xscr1,xscr1,ndim2))
        if (xnrm.lt.thrsh) conv = .true.

        if (ntest.ge.10)
     &       write(lulog,*) ' N = ',n,'  |1/N! X^N| = ',xnrm

        expx(1:ndim,1:ndim) = expx(1:ndim,1:ndim) + xscr1(1:ndim,1:ndim)

        xscr2(1:ndim,1:ndim) = xscr1(1:ndim,1:ndim)

      end do

      if (.not.conv) then
        write(lulog,*) ' Taylor expansion of exp(X) did not converge!'
        call quit(1,'expgmat','no convergence')
      end if

      return
      end


! Created by EverLookNeverSee@GitHub on 5/28/20
! For more information see FCS/img/Exercise_02.png

program main
    implicit none
    ! P = earth pressure on a retaining structure
    ! w --> wieght per unit volume of filled up earth
    ! h --> height of earth fill
    ! phi --> angle of repose of filled material
    ! declaring variables
    real :: w = 513.0, h = 3.0, phi = 30.0, P, radian_phi
    ! the argument of trigonometric functions must be in radians
    radian_phi = phi * 3.1415 / 180.0
    ! calculating P
    P = ((w * h ** 2.0) / 2.0) * ((1.0 - sin(radian_phi)) / (1.0 + sin(radian_phi)))
    ! formated print statement
    print "(a3,f10.6)", "P: ", P
end program main