! Implicit FVM solver for parabolic 2D heat transfer equation
! By Arthur Rostami

program CFD_SECOND_PROJECT_IMPLICIT
    implicit none

!______________________variables________________________

integer:: i,j,K1,K2,He,ymid,L,h_fluid,xmid,rhoC,step,m1,m2,n1,n2,ii,jj
real:: e1,dx,dt,t_st,t_fin,m,n,ap0,alpha,beta,a,b,c,r
real,allocatable:: T_half(:,:),T_new(:,:),T_old(:,:),T3(:,:),T1(:,:),T2(:,:),K(:,:),er(:,:),x(:),y(:),H(:,:),G(:,:)

!___________________Define Parameters____________________

print*, 'Please Enter delta x:'
read*, dx
print*, 'Please Enter delta t:'
read*, dt

L=2                   ! LENGTH OF PLATE
He=1                  ! HEIGHT OF PLATE
m=(2.0/dx)+2          ! number of grid points in x direction (two half steps)
m1=(0.8/dx)+2
m2=(1.6/dx)+1
n=(1.0/dx)+2          ! number of grid points in y direction (two half steps)
n1=(0.4/dx)+2
n2=(1.0/dx)+2
h_fluid=5
rhoC=2000             ! density * c
K1=10                 ! first material
ap0=rhoC*dx*dx/dt

!_________________________mid line positions______________________________

ymid=(0.5/dx)+2
xmid=(1/dx)+2

!_____________________________Mesh generation_____________________________

allocate(T_old(m,n),x(m),y(n),er(m,n),T_new(m,n),T1(m,n),T2(m,n),K(m,n),T_half(m,n),H(m,n),G(m,n),T3(m,n))
x(1)=0
y(1)=0
x(m)=2
y(n)=1
do i=2,m-1
    x(i)=(i-1)*dx-dx/2
end do
do j=2,n-1
    y(j)=(j-1)*dx-dx/2
end do

!_____________________________Initial Condition____________________________

do i=1,m
    do j=1,n
        T_old(i,j)=50
        T_new(i,j)=50
        T_half(i,j)=50
        er(i,j)=0
        K(i,j)=K1
        H(i,j)=0
        G(i,j)=0
    end do
end do

!__________Boundary condition T old______________

do j=2,n
   T_old(m,j)=(h_fluid*100+(2*K1*T_old(m-1,j))/dx)/(2*K1/dx+5)       !BC Q"=H(100-T) & k=10
end do
do i=2,m-1
   T_old(i,n)=T_old(i,n-1)                                           !BC Q"=0
end do
do i=2,m-1
   T_old(i,1)=50*dx/(2*K1)+T_old(i,2)                                !BC Q"=50
end do
do j=1,n
   T_old(1,j)=100*y(j)                                               !BC T=100y
end do

    !________________________________________________________________________
    !_____________________________Implicit Solver____________________________
    !________________________________________________________________________

step=1     !step is time step counter
call cpu_time(t_st)
do while (step<100000)

!__________________________x-sweep________________________________

    T_half(:,:)=T_old(:,:)

    do i=m1,m2
        do j=n1,n2
            K(i,j)=3*((T_old(i,j)/5)+2)
        end do
    end do

!____________________________TDMA_________________________________

    do j=2,n-1
        do i=2,m-1
            if(i==2)then
                a=0
                b=ap0+K(3,j)+K(1,j)+3*dx*dx
                c=-1*K(3,j)
                r=50*dx*dx+K(2,j-1)*T_old(2,j-1)+K(2,j+1)*T_old(2,j+1)+(ap0-K(2,j-1)-K(2,j+1))*T_old(2,j)+K(i-1,j)*100*y(j)
                H(2,j)=c/b
                G(2,j)=r/b
            else if(i==m-1)then
                a=-1*K(m-2,j)
                b=ap0+K(m,j)+K(m-2,j)+3*dx*dx-K(m,j)*((2*K1/dx)/(2*K1/dx+h_fluid))
                c=0
                alpha=K(m,j)*h_fluid*100/(2*K1/dx+h_fluid)
                r=50*dx*dx+K(m-1,j-1)*T_old(m-1,j-1)+K(m-1,j+1)*T_old(m-1,j+1)+(ap0-K(m-1,j-1)-K(m-1,j+1))*T_old(m-1,j)+alpha
                H(m-1,j)=0
                G(m-1,j)=(r-a*G(m-2,j))/(b-a*H(m-2,j))
            else
                a=-1*K(i-1,j)
                b=ap0+K(i+1,j)+K(i-1,j)+3*dx*dx
                c=-1*K(i+1,j)
                r=50*dx*dx+K(i,j-1)*T_old(i,j-1)+K(i,j+1)*T_old(i,j+1)+(ap0-K(i,j-1)-K(i,j+1))*T_old(i,j)
                H(i,j)=c/(b-a*H(i-1,j))
                G(i,j)=(r-a*G(i-1,j))/(b-a*H(i-1,j))
            end if
    end do
    do ii=m-1,2,-1
        T_half(ii,j)=G(ii,j)-H(ii,j)*T_half(ii+1,j)
    end do
    end do

!_____________Boundary condition update: T half______________

    do j=2,n-1
        T_half(m,j)=(h_fluid*100+2*K1/dx*T_half(m-1,j))/(2*K1/dx+h_fluid)       !BC Q"=H(100-T) & k=10
    end do
    do i=2,m
        T_half(i,1)=50*dx/(2*K1)+T_half(i,2)                                    !BC Q"=50
    end do
    do i=2,m
        T_half(i,n)=T_half(i,n-1)                                               !BC Q"=0
    end do

!__________________________y-sweep________________________________

    T_new(:,:)=T_half(:,:)

    do i=m1,m2
        do j=n1,n2
            K(i,j)=3*((T_half(i,j)/5)+2)
        end do
    end do

!____________________________TDMA_________________________________

do i=2,m-1
    do j=2,n-1
      if(j==2)then
        a=0
        b=ap0+K(i,1)+K(i,3)+3*dx*dx-K(i,1)
        c=-1*K(i,3)
        beta=K(i,j-1)*(50*dx/(2*K1))
        r=50*dx*dx+K(i-1,2)*T_half(i-1,2)+K(i+1,2)*T_half(i+1,2)+(ap0-K(i-1,2)-K(i+1,2))*T_half(i,2)+beta
        H(i,2)=c/b
        G(i,2)=r/b
      else if(j==n-1)then
        a=-1*K(i,n-2)
        b=ap0+K(i,n-2)+3*dx*dx
        c=0
        r=50*dx*dx+K(i-1,n-1)*T_half(i-1,n-1)+K(i+1,n-1)*T_half(i+1,n-1)+(ap0-K(i-1,n-1)-K(i+1,n-1))*T_half(i,n-1)
        H(i,n-1)=0
        G(i,n-1)=(r-a*G(i,n-2))/(b-a*H(i,n-2))
      else
        a=-1*K(i,j-1)
        b=ap0+K(i,j-1)+K(i,j+1)+3*dx*dx
        c=-1*K(i,j+1)
        r=50*dx*dx+K(i+1,j)*T_half(i+1,j)+K(i-1,j)*T_half(i-1,j)+(ap0-K(i+1,j)-K(i-1,j))*T_half(i,j)
        H(i,j)=c/(b-a*H(i,j-1))
        G(i,j)=(r-a*G(i,j-1))/(b-a*H(i,j-1))
        end if
    end do
    do jj=n-1,2,-1
        T_new(i,jj)=G(i,jj)-H(i,jj)*T_new(i,jj+1)
    end do
end do

!_____________Boundary condition update: T half______________

    do j=2,n-1
        T_new(m,j)=(h_fluid*100+2*K1/dx*T_new(m-1,j))/(2*K1/dx+h_fluid)           !BC Q"=H(100-T) & k=10
    end do
    do i=2,m
        T_new(i,1)=50*dx/(2*K1)+T_new(i,2)                                        !BC Q"=50
    end do
    do i=2,m
        T_new(i,n)=T_new(i,n-1)                                                   !BC Q"=0
    end do
!______________________Saving Temp at chosen times ________________________

    if(step==2000) T1(:,:)=T_new(:,:)     !saving temperature at t=2000dt
    if(step==10000) T2(:,:)=T_new(:,:)    !saving temperature at t=10000dt
    if(step==20000) T3(:,:)=T_new(:,:)    !saving temperature at t=20000dt

!________________error calculation_____________________

    er(:,:)=ABS(T_new(:,:)-T_old(:,:))
    e1=maxval(er)
    T_old(:,:)=T_new(:,:)
    if(e1<0.00001) exit
    step=step+1
end do
call cpu_time(t_fin)

!_____________________________Reporting solution information_____________________________

    print*, 'Number of iterations to reach steady state:    ',step
    print*, 'Maximum difference between the last two time steps:',e1, 'Celsius'
    print*, 'Solution will be Steady at:                        ',step*dt,'seconds'
    print*, 'Calculation time is:                               ',t_fin-t_st, 'seconds'

!_____________________________Saving the results_____________________________

    open(10,file='Temp contour at SS.plt')
    write(10,*)'VARIABLES = "X", "Y", "T"'
    write(10,*)'ZONE I=',m,'J=',n
    do j=1,n
        do i=1,m
            write(10,*) x(i),y(j),T_old(i,j)
        end do
    end do

    open(20,file='Temp contour at 2000.plt')
    write(20,*)'VARIABLES = "X", "Y", "T"'
    write(20,*)'ZONE I=',m,'J=',n
    do j=1,n
        do i=1,m
            write(20,*) x(i),y(j),T1(i,j)
        end do
    end do

    open(30,file='Temp contour at 10000.plt')
    write(30,*)'VARIABLES = "X", "Y", "T"'
    write(30,*)'ZONE I=',m,'J=',n
    do j=1,n
        do i=1,m
            write(30,*) x(i),y(j),T2(i,j)
        end do
    end do

    open(40,file='Temp contour at 30000.plt')
    write(40,*)'VARIABLES = "X", "Y", "T"'
    write(40,*)'ZONE I=',m,'J=',n
    do j=1,n
        do i=1,m
            write(40,*) x(i),y(j),T3(i,j)
        end do
    end do

    open(60,file='x-Midline temp at 2000.dat')
    write(60,*)"VARIABLES=X,TEMPERATURE"
    write(60,*)'ZONE I=',m,'J=',n
    do i=1,m
        write(60,*) (i-1)*dx,T1(i,ymid)
    end do

    open(70,file='y-Midline temp at 2000.dat')
    write(70,*)"VARIABLES=Y,TEMPERATURE"
    do j=1,n
        write(70,*) (j-1)*dx,T1(xmid,j)
    end do

    open(61,file='x-Midline temp at 10000.dat')
    write(61,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(61,*) (i-1)*dx,T2(i,ymid)
    end do

    open(71,file='y-Midline temp at 10000.dat')
    write(71,*)"VARIABLES=Y,TEMPERATURE"
    do j=1,n
        write(71,*) (j-1)*dx,T2(xmid,j)
    end do

    open(62,file='x-Midline temp at SS.dat')
    write(62,*)"VARIABLES=X,TEMPERATURE"
    do i=1,m
        write(62,*) (i-1)*dx,T_old(i,ymid)
    end do

    open(72,file='y-Midline temp at SS.dat')
    write(72,*)"VARIABLES=Y,TEMPERATURE"
    do j=1,n
        write(72,*) (j-1)*dx,T_old(xmid,j)
    end do

end program CFD_SECOND_PROJECT_IMPLICIT


! Compute the matrix elements of a boson Hamiltonian

program hamilt

  use, intrinsic :: iso_fortran_env
  use mod_elem
  implicit none

  integer(kind=int32) :: n1, n2, m1, m2, ios, err
  integer(kind=int64) :: n, nn, i, j, k, reclen
  !real(kind=REAL128) :: a, b, d
  !real(kind=REAL128), dimension(:, :), allocatable :: h
  real(kind=real64) :: a, b, d
  real(kind=real64), dimension(:, :), allocatable :: h
  integer(kind=int32), dimension(:, :), allocatable :: index

  ! Read Hamiltonian parameters
  open(unit=10, file='hamilt.inp', iostat=ios)
  if ( ios /= 0 ) stop "hamilt.inp: Error opening file "
  read(10, *) n, a, b, d
  close(unit=10, iostat=ios)
  if ( ios /= 0 ) stop "Error closing file unit 10"

  nn = n * (n + 1) / 2
  ! Allocate arrays
  allocate(h(nn, nn), stat=err)
  if (err /= 0) print *, "h: Allocation request denied"
  allocate(index(2, nn), stat=err)
  if (err /= 0) print *, "h: Allocation request denied"

  inquire(iolength=reclen) h(:, 1)
  !write(*, fmt=*) reclen
  open(unit=20, file='hamilt.bin', iostat=ios, form='unformatted', &
       access='direct', recl=reclen)
  if ( ios /= 0 ) stop "hamilt.bin: Error opening file "

  ! Compute index
  k = 0
  do i = 0, n - 1
    do j = 0, n - i - 1
      k = k + 1
      index(1, k) = i
      index(2, k) = j
      !write(*,"(3i3x)") i, j, k
    enddo
  end do
  !write(*,*) "------"
  !write(*, "(2i3x)") (index(1,i), index(2, i), i=1, nn)
  !write(*,*) "------"

  do i = 1, nn
    do j = 1, nn
      m1 = index(1, i)
      m2 = index(2, i)
      n1 = index(1, j)
      n2 = index(2, j)

      h(i, j) = a * (elem(m1, n1, 1, 1) * elem(m2, n2, 0, 0) +               &
                     elem(m1, n1, 0, 0) * elem(m2, n2, 1, 1))                &
   + 0.25 * b * (3 * elem(m1, n1, 1, 0) * elem(m2, n2, 2, 0)                 &
               + 3 * elem(m1, n1, 0, 1) * elem(m2, n2, 0, 2)                 &
                   - elem(m1, n1, 3, 0) * elem(m2, n2, 0, 0)                 &
                   - elem(m1, n1, 0, 3) * elem(m2, n2, 0, 0))                &
       + 0.75 * b * (elem(m1, n1, 0, 1) * elem(m2, n2, 2, 0)                 &
                   + elem(m1, n1, 1, 0) * elem(m2, n2, 0, 2)                 &
                   - elem(m1, n1, 1, 2) * elem(m2, n2, 0, 0)                 &
                   - elem(m1, n1, 2, 1) * elem(m2, n2, 0, 0)                 &
               + 2 * elem(m1, n1, 0, 1) * elem(m2, n2, 1, 1)                 &
               + 2 * elem(m1, n1, 1, 0) * elem(m2, n2, 1, 1))                &
      + 0.375 * d * (elem(m1, n1, 2, 2) * elem(m2, n2, 0, 0)                 &
                   + elem(m1, n1, 0, 0) * elem(m2, n2, 2, 2))                &
      + 0.125 * d * (elem(m1, n1, 2, 0) * elem(m2, n2, 0, 2)                 &
                   + elem(m1, n1, 0, 2) * elem(m2, n2, 2, 0))                &
      + 0.500 * d *  elem(m1, n1, 1, 1) * elem(m2, n2, 1, 1)                 &
      + 0.250 * d * (elem(m1, n1, 1, 3) * elem(m2, n2, 0, 0)                 &
                   + elem(m1, n1, 3, 1) * elem(m2, n2, 0, 0)                 &
                   + elem(m1, n1, 0, 0) * elem(m2, n2, 1, 3)                 &
                   + elem(m1, n1, 0, 0) * elem(m2, n2, 3, 1)                 &
                   + elem(m1, n1, 0, 2) * elem(m2, n2, 1, 1)                 &
                   + elem(m1, n1, 2, 0) * elem(m2, n2, 1, 1)                 &
                   + elem(m1, n1, 1, 1) * elem(m2, n2, 0, 2)                 &
                   + elem(m1, n1, 1, 1) * elem(m2, n2, 2, 0))                &
     + 0.0625 * d * (elem(m1, n1, 4, 0) * elem(m2, n2, 0, 0)                 &
                   + elem(m1, n1, 0, 4) * elem(m2, n2, 0, 0)                 &
                   + elem(m1, n1, 0, 0) * elem(m2, n2, 4, 0)                 &
                   + elem(m1, n1, 0, 0) * elem(m2, n2, 0, 4)                 &
               + 2 * elem(m1, n1, 2, 0) * elem(m2, n2, 2, 0)                 &
               + 2 * elem(m1, n1, 0, 2) * elem(m2, n2, 0, 2))
    enddo
  enddo

  do i = 1, nn
  !  write(*, '(1000(F35.32))') (h(i,j), j=1,nn)
     write(20, rec=i) (h(i,j), j=1,nn)
  enddo

  deallocate(h)
  deallocate(index)
  close(unit= 20, iostat=ios)
  if ( ios /= 0 ) stop "Error closing file unit 20"

end program hamilt


! =====================================================
subroutine rp1(maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,fwave,s,amdq,apdq)
! =====================================================

!     # Adjoint Riemann solver for the acoustics equations in 1d, with
!     #  variable coefficients (heterogeneous media)

!     # auxl(1,i) should contain the impedance Z in cell i
!     # auxl(2,i) should contain the sound speed c in cell i

    implicit double precision (a-h,o-z)

    dimension auxl(maux, 1-mbc:maxm+mbc)
    dimension auxr(maux, 1-mbc:maxm+mbc)
    dimension fwave(meqn, mwaves, 1-mbc:maxm+mbc)
    dimension    s(mwaves, 1-mbc:maxm+mbc)
    dimension   ql(meqn, 1-mbc:maxm+mbc)
    dimension   qr(meqn, 1-mbc:maxm+mbc)
    dimension apdq(meqn, 1-mbc:maxm+mbc)
    dimension amdq(meqn, 1-mbc:maxm+mbc)

!     local arrays
!     ------------
    dimension delta(2)

!   # split the jump in f(q) at each interface into f-waves

!   # find a1 and a2, the coefficients of the 2 eigenvectors:
    do 20 i = 2-mbc, mx+mbc
!       # material properties
        zi = auxl(1,i)
        zim = auxr(1,i-1)
        ci = auxl(2,i)
        cim = auxr(2,i-1)
        rhoi = zi/ci
        rhoim = zim/cim
        bulki = rhoi*ci**2
        bulkim = rhoim*cim**2

!       # f-wave splitting
        delta(1) = -(ql(2,i)/rhoi - qr(2,i-1)/rhoim)
        delta(2) = -(bulki*ql(1,i) - bulkim*qr(1,i-1))

        beta1 = (delta(2) + zi*delta(1)) / (zim + zi)
        beta2 = (-delta(2) + zim*delta(1)) / (zim + zi)

!       # Compute the waves.  Eigenvectors switched for adjoint:

        fwave(1,1,i) = beta1
        fwave(2,1,i) = beta1*zim
        s(1,i) = -cim

        fwave(1,2,i) = beta2
        fwave(2,2,i) = -beta2*zi
        s(2,i) = ci

    20 END DO

!     # compute the leftgoing and rightgoing fluctuations:
!     # Note s(1,i) < 0   and   s(2,i) > 0.

!   # f-wave spitting, so do not multiply by wave speeds:
    do 220 m=1,meqn
        do 220 i = 2-mbc, mx+mbc
            amdq(m,i) = fwave(m,1,i)
            apdq(m,i) = fwave(m,2,i)
    220 END DO

    return
    end subroutine rp1


c        PROGRAM MCLPMN
C
C       ============================================================
C       Purpose: This program computes the associated Legendre
C                functions Pmn(z) and their derivatives Pmn'(z) for
C                a complex argument using subroutine CLPMN
C       Input :  x --- Real part of z
C                y --- Imaginary part of z
C                m --- Order of Pmn(z),  m = 0,1,2,...,n
C                n --- Degree of Pmn(z), n = 0,1,2,...,N
C       Output:  CPM(m,n) --- Pmn(z)
C                CPD(m,n) --- Pmn'(z)
C       Examples:
C                n = 5, x = 0.5, y = 0.2
C
C       m     Re[Pmn(z)]    Im[Pmn(z)]    Re[Pmn'(z)]   Im[Pmn'(z)]
C      -------------------------------------------------------------
C       0    .252594D+00  -.530293D+00   -.347606D+01  -.194250D+01
C       1    .333071D+01   .135206D+01    .117643D+02  -.144329D+02
C       2   -.102769D+02   .125759D+02    .765713D+02   .598500D+02
C       3   -.572879D+02  -.522744D+02   -.343414D+03   .147389D+03
C       4    .335711D+03  -.389151D+02   -.226328D+03  -.737100D+03
C       5   -.461125D+03   .329122D+03    .187180D+04   .160494D+02
C
C                n = 5, x = 2.5, y = 1.0
C
C       m     Re[Pmn(z)]    Im[Pmn(z)]    Re[Pmn'(z)]   Im[Pmn'(z)]
C      -------------------------------------------------------------
C       0   -.429395D+03   .900336D+03   -.350391D+02   .193594D+04
C       1   -.216303D+04   .446358D+04   -.208935D+03   .964685D+04
C       2   -.883477D+04   .174005D+05   -.123703D+04   .381938D+05
C       3   -.273211D+05   .499684D+05   -.568080D+04   .112614D+06
C       4   -.565523D+05   .938503D+05   -.167147D+05   .219713D+06
C       5   -.584268D+05   .863328D+05   -.233002D+05   .212595D+06
C       ============================================================
C
c        IMPLICIT DOUBLE PRECISION (X,Y)
c        IMPLICIT COMPLEX*16 (C,Z)
c        DIMENSION CPM(0:40,0:40),CPD(0:40,0:40)
c        WRITE(*,*)'  Please enter m, n, x and y '
c        READ(*,*) M,N,X,Y
c        WRITE(*,30) M,N,X,Y
c        CALL CLPMN(40,M,N,X,Y,CPM,CPD)
c        WRITE(*,*)'   m   n    Re[Pmn(z)]    Im[Pmn(z)]    ',
c     &            'Re[Pmn''(z)]   Im[Pmn''(z)]'
c        WRITE(*,*)' -----------------------------------',
c     &            '-------------------------------'
c        DO 10 J=0,N
c10         WRITE(*,20)M,J,CPM(M,J),CPD(M,J)
c20      FORMAT(1X,2I4,1X,2D14.6,1X,2D14.6)
c30      FORMAT(1X,'m =',I2,', ','n =',I2,', ','x =',F5.1,
c     &         ', ','y =',F5.1)
c        END

        SUBROUTINE CLPMN(MM,M,N,X,Y,CPM,CPD)
C
C       =========================================================
C       Purpose: Compute the associated Legendre functions Pmn(z)
C                and their derivatives Pmn'(z) for a complex
C                argument
C       Input :  x  --- Real part of z
C                y  --- Imaginary part of z
C                m  --- Order of Pmn(z),  m = 0,1,2,...,n
C                n  --- Degree of Pmn(z), n = 0,1,2,...,N
C                mm --- Physical dimension of CPM and CPD
C       Output:  CPM(m,n) --- Pmn(z)
C                CPD(m,n) --- Pmn'(z)
C       =========================================================
C
        IMPLICIT DOUBLE PRECISION (X,Y)
        IMPLICIT COMPLEX*16 (C,Z)
        DIMENSION CPM(0:MM,0:N),CPD(0:MM,0:N)
        Z=CMPLX(X,Y)
        DO 10 I=0,N
        DO 10 J=0,M
           CPM(J,I)=(0.0D0,0.0D0)
10         CPD(J,I)=(0.0D0,0.0D0)
        CPM(0,0)=(1.0D0,0.0D0)
        IF (DABS(X).EQ.1.0D0.AND.Y.EQ.0.0D0) THEN
           DO 15 I=1,N
              CPM(0,I)=X**I
15            CPD(0,I)=0.5D0*I*(I+1)*X**(I+1)
           DO 20 J=1,N
           DO 20 I=1,M
              IF (I.EQ.1) THEN
                 CPD(I,J)=(1.0D+300,0.0D0)
              ELSE IF (I.EQ.2) THEN
                 CPD(I,J)=-0.25D0*(J+2)*(J+1)*J*(J-1)*X**(J+1)
              ENDIF
20         CONTINUE
           RETURN
        ENDIF
        LS=1
        IF (CDABS(Z).GT.1.0D0) LS=-1
        ZQ=CDSQRT(LS*(1.0D0-Z*Z))
        ZS=LS*(1.0D0-Z*Z)
        DO 25 I=1,M
25         CPM(I,I)=-LS*(2.0D0*I-1.0D0)*ZQ*CPM(I-1,I-1)
        DO 30 I=0,M
30         CPM(I,I+1)=(2.0D0*I+1.0D0)*Z*CPM(I,I)
        DO 35 I=0,M
        DO 35 J=I+2,N
           CPM(I,J)=((2.0D0*J-1.0D0)*Z*CPM(I,J-1)-(I+J-
     &              1.0D0)*CPM(I,J-2))/(J-I)
35      CONTINUE
        CPD(0,0)=(0.0D0,0.0D0)
        DO 40 J=1,N
40         CPD(0,J)=LS*J*(CPM(0,J-1)-Z*CPM(0,J))/ZS
        DO 45 I=1,M
        DO 45 J=I,N
           CPD(I,J)=LS*I*Z*CPM(I,J)/ZS+(J+I)*(J-I+1.0D0)
     &              /ZQ*CPM(I-1,J)
45      CONTINUE
        RETURN
        END


MODULE quadsets_mod

PRIVATE
PUBLIC :: quadsets

CONTAINS

  !> \author msleigh
  !!
  !! PURPOSE: Defines quadrature sets for Sn approximations
  !!
  !! STRUCTURE
  !! 1. Initialise variables
  !! 2. Define quadrature set

  SUBROUTINE quadsets( &
    & errstat)

  USE getkinds_mod
  USE setdata_mod

  IMPLICIT NONE

  ! Arguments
  INTEGER(KIND=ik), INTENT(OUT) :: errstat !<

  !----------------------------------------------------------------------------
  ! 1. Initialise variables
  !----------------------------------------------------------------------------

  errstat = 0_ik

  !----------------------------------------------------------------------------
  ! 2. Define quadrature set
  !----------------------------------------------------------------------------

  SELECT CASE (numdirs)
    CASE(1)              ! S2
      mu(1)  = 1.0_rk
      wgt(1) = 1.0_rk
    CASE(2)              ! S4
      mu(1)  = 0.3500212_rk
      mu(2)  = 0.8688903_rk
      wgt(1) = 0.6666666_rk
      wgt(2) = 0.3333333_rk
    CASE(3)              ! S6
      mu(1)  = 0.2666355_rk
      mu(2)  = 0.6815076_rk
      mu(3)  = 0.9261808_rk
      wgt(1) = 0.5094597_rk
      wgt(2) = 0.3144142_rk
      wgt(3) = 0.1761263_rk
    CASE(4)              ! S8
      mu(1)  = 0.2182179_rk
      mu(2)  = 0.5773503_rk
      mu(3)  = 0.7867958_rk
      mu(4)  = 0.9511897_rk
      wgt(1) = 0.4234568_rk
      wgt(2) = 0.2740740_rk
      wgt(3) = 0.1814814_rk
      wgt(4) = 0.1209877_rk
    CASE(6)              ! S12
      mu (1) = 0.1672126_rk
      mu (2) = 0.4595476_rk
      mu (3) = 0.6280191_rk
      mu (4) = 0.7600210_rk
      mu (5) = 0.8722706_rk
      mu (6) = 0.9716377_rk
      wgt(1) = 0.3279628_rk
      wgt(2) = 0.2381773_rk
      wgt(3) = 0.1263780_rk
      wgt(4) = 0.1249573_rk
      wgt(5) = 0.1117622_rk
      wgt(6) = 0.0707626_rk
    CASE(8)              ! S16
      mu(1)  = 0.1389568_rk
      mu(2)  = 0.3922893_rk
      mu(3)  = 0.5370966_rk
      mu(4)  = 0.6504264_rk
      mu(5)  = 0.7467506_rk
      mu(6)  = 0.8319966_rk
      mu(7)  = 0.9092855_rk
      mu(8)  = 0.9805009_rk
      wgt(1) = 0.2743402_rk
      wgt(2) = 0.2181700_rk
      wgt(3) = 0.0884188_rk
      wgt(4) = 0.1287509_rk
      wgt(5) = 0.0801592_rk
      wgt(6) = 0.0785138_rk
      wgt(7) = 0.0826592_rk
      wgt(8) = 0.0489872_rk
  END SELECT

  wgt = wgt/(2.0_rk*SUM(wgt))

  RETURN
  END SUBROUTINE quadsets

END MODULE quadsets_mod


C     FIBONACCI SEQUENCE - FORTRAN IV
      NN=46
      DO 1 I=0,NN
    1 WRITE(*,300) I,IFIBO(I)
  300 FORMAT(1X,I2,1X,I10)
      END
C
      FUNCTION IFIBO(N)
      IF(N) 9,1,2
    1 IFN=0
      GOTO 9
    2 IF(N-1) 9,3,4
    3 IFN=1
      GOTO 9
    4 IFNM1=0
      IFN=1
      DO 5 I=2,N
      IFNM2=IFNM1
      IFNM1=IFN
    5 IFN=IFNM1+IFNM2
    9 IFIBO=IFN
      END


module samples
   use constants
   use intervals
   implicit none
   private

   public :: sample

contains

   subroutine sample(x, what, how)
      real(dp), intent(out), target :: x(:)
      character(*), intent(in) :: what, how

      select case (what)
         case ('wave')
            select case (how)
               case ('harmonic')
                  call interval(x, 0.0_dp, 2.0_dp * pi, 1)
                  x = sin(x)

               case ('power')
                  call interval(x, 0.0_dp, 2.0_dp * pi, 1)
                  x = sin(x) ** 3

               case ('major')
                  call interval(x, 0.0_dp, 2.0_dp * pi, 1)
                  x = sin(x) ** 5

               case ('constant')
                  call interval(x, 0.0_dp, 2.0_dp * pi, 1)
                  x = sign(1.0_dp, sin(x))

               case ('linear')
                  call interval(x, 0.0_dp, 2.0_dp * pi, 1)
                  x = 2.0_dp / pi * asin(sin(x))

               case ('quadratic')
                  call interval(x, -2.0_dp, 2.0_dp, 1)
                  x = sign(2.0_dp * abs(x) - x ** 2, x)

               case ('circular')
                  call interval(x, -2.0_dp, 2.0_dp, 1)
                  x = sign(sqrt(2.0_dp * abs(x) - x ** 2), x)

               case ('cubic')
                  call interval(x, -1.0_dp, 1.0_dp, 1)
                  x = 1.5_dp * sqrt(3.0_dp) * (x ** 3 - x)

               case ('random')
                  call random_number(x)
                  x = 2.0_dp * x - 1.0_dp

               case default
                  write (stderr, "('Error: unknown sample ''', A, '''.')") how
                  write (stderr, "('See ''man mel'' for list of samples.')")
                  stop
            end select

         case ('fade')
            select case (how)
               case ('harmonic')
                  call interval(x, 0.0_dp, 0.5_dp * pi, 0)
                  x = sin(x)

               case ('smooth')
                  call interval(x, 0.0_dp, 0.5_dp * pi, 0)
                  x = sin(x) ** 2

               case ('power')
                  call interval(x, 0.0_dp, 0.5_dp * pi, 0)
                  x = sin(x) ** 3

               case ('major')
                  call interval(x, 0.0_dp, 0.5_dp * pi, 0)
                  x = sin(x) ** 5

               case ('linear')
                  call interval(x, 0.0_dp, 1.0_dp, 0)

               case ('quadratic')
                  call interval(x, -1.0_dp, 0.0_dp, 0)
                  x = 1.0_dp - x ** 2

               case ('circular')
                  call interval(x, -1.0_dp, 0.0_dp, 0)
                  x = sqrt(1.0_dp - x ** 2)

               case ('cubic')
                  call interval(x, 0.0_dp, 1.0_dp, 0)
                  x = 3.0_dp * x ** 2 - 2.0_dp * x ** 2

               case default
                  write (stderr, "('Error: unknown sample ''', A, '''.')") how
                  write (stderr, "('See ''man mel'' for list of samples.')")
                  stop
            end select
      end select
   end subroutine sample
end module samples


subroutine rpn3(ixyz,maxm,meqn,mwaves,maux,mbc,mx,ql,qr,auxl,auxr,wave,s,amdq,apdq)
! Riemann-solver for the advection equation
!    q_t  +  u*q_x + v*q_y + w*q_z = 0
! where u and v are a given velocity field.
!
! waves: 1
! equations: 1
! aux fields: 3
!
! Conserved quantities:
!       1 q
!
! Auxiliary variables
!       1 x_velocity
!       2 y_velocity
!       3 z_velocity
!
! The velocities are specified at the left/bottom/back cell face centers.
!
! Solve Riemann problems along one slice of data.
! This data is along a slice in the x-direction if ixyz=1
!                               the y-direction if ixyz=2.
!                               the z-direction if ixyz=3.
!
! On input, ql contains the state vector at the left edge of each cell
!           qr contains the state vector at the right edge of each cell
!
! On output, wave contains the waves, s the speeds,
! and amdq, apdq the left-going and right-going flux differences,
! respectively.  Note that in this advective form, the sum of
! amdq and apdq is not equal to a difference of fluxes except in the
! case of constant velocities.
!
! Note that the i'th Riemann problem has left state qr(i-1,:)
!                                    and right state ql(i,:)
! From the basic clawpack routines, this routine is called with ql = qr

    implicit none

    integer, intent(in) :: ixyz, maxm, meqn, mwaves, mbc, mx, maux

    double precision, intent(in) :: ql, qr, auxl, auxr
    double precision, intent(out) :: wave, s, amdq, apdq

    dimension wave(meqn,mwaves,1-mbc:maxm+mbc)
    dimension    s(mwaves,1-mbc:maxm+mbc)
    dimension   ql(meqn,1-mbc:maxm+mbc)
    dimension   qr(meqn,1-mbc:maxm+mbc)
    dimension amdq(meqn,1-mbc:maxm+mbc)
    dimension apdq(meqn,1-mbc:maxm+mbc)
    dimension auxl(maux,1-mbc:maxm+mbc)
    dimension auxr(maux,1-mbc:maxm+mbc)

    integer :: i

    ! Set wave, speed, and flux differences:
    do i = 2-mbc, mx+mbc
        wave(1,1,i) = ql(1,i) - qr(1,i-1)
        s(1,i) = auxl(ixyz,i)
        ! The flux difference df = s*wave all goes in the downwind direction:
        amdq(1,i) = dmin1(auxl(ixyz,i), 0.d0) * wave(1,1,i)
        apdq(1,i) = dmax1(auxl(ixyz,i), 0.d0) * wave(1,1,i)
    end do

    return
end subroutine rpn3


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine plane4(co,node,nodep,a,b,c,d)
!
!     given are 5 nodes: node and nodep(1) up to nodep(4)
!
!     first, the node among the nodep's with the largest
!     distance from node is eliminated. The remaining nodes
!     are stored into noden(1) up to noden(3).
!
!     Then, the equation of the plane through the
!     nodes noden(1),noden(2) and noden(3) in the form
!     a*x+b*y+c*z+d=0 such that the triangle through the
!     nodes noden(1),noden(2),nopen(3) is numbered clockwise
!     when looking in the direction of vector (a,b,c)
!
      implicit none
!
      integer nodep(4),i,j,noden(3),node,kflag,idist(4),n
!
      real*8 co(3,*),a,b,c,d,dd,p12(3),p23(3),p31(3),dist(4)
!
      kflag=2
      n=4
!
!     determining the distance of the nodep's to node
!
      do i=1,4
         dist(i)=((co(1,nodep(i))-co(1,node))**2+
     &            (co(2,nodep(i))-co(2,node))**2+
     &            (co(3,nodep(i))-co(3,node))**2)
         idist(i)=nodep(i)
c         write(*,*) nodep(i),dist(i)
      enddo
!
!     sorting the distances
!
      call dsort(dist,idist,n,kflag)
!
!     storing the 3 closest nodes in noden
!
      j=0
      do i=1,4
         if(nodep(i).eq.idist(4)) cycle
         j=j+1
         noden(j)=nodep(i)
      enddo
c      write(*,*) 'noden ',(noden(i),i=1,3)
!
!     sides of the triangle
!
      do i=1,3
         p12(i)=co(i,noden(2))-co(i,noden(1))
         p23(i)=co(i,noden(3))-co(i,noden(2))
         p31(i)=co(i,noden(1))-co(i,noden(3))
      enddo
!
!     normalized vector normal to the triangle: xn = p12 x p23
!
      a=p12(2)*p23(3)-p12(3)*p23(2)
      b=p12(3)*p23(1)-p12(1)*p23(3)
      c=p12(1)*p23(2)-p12(2)*p23(1)
      dd=dsqrt(a*a+b*b+c*c)
      a=a/dd
      b=b/dd
      c=c/dd
!
!     determining the inhomogeneous term
!
      d=-a*co(1,noden(1))-b*co(2,noden(1))-c*co(3,noden(1))
!
      return
      end


C++*******************************************************************
C
C  Program DEVAUC :  to fit De Vaucouleurs' law
C  to surface photometry of elliptical galaxies
C
C  XC(1)= effective surface brightness B0
C  XC(2)= effective radius RE
C
C  B(R)=B0*10.0**{-3.33*[(R/RE)**.25-1]}
C or  -2.5LOG10(I-SKY)+CTMAG = Ie + 8.325 ( (RAD/RE)**1/4 -1 )
C
C JLP
C Version 22-05-91
C--*******************************************************************
	PROGRAM DEVAUC
	PARAMETER (IDIM=1000)
	IMPLICIT REAL*8 (A-H,O-Z)
	REAL*8 ZMAG(IDIM),ZRAD(IDIM),XC(2)
	REAL*8 W(12000),RAD(IDIM),BRIGHT(IDIM),WORK(IDIM)
	REAL*4 XPLOT(IDIM),YPLOT1(IDIM),YPLOT2(IDIM),YPLOT3(IDIM)
	REAL*8 RMS,ZBI,CTMAG,RMIN,RMAX,SKY
	REAL*8 FSUMSQ
	INTEGER IW(100),NP1,IOP,NPTS,NPTS1
	INTEGER IMIN,IMAX,M,LIW,LW,N,IFAIL
	CHARACTER ANS*1,CHAR1*30,CHAR2*30,TITLE*40
	CHARACTER PLOTDEV*32,BUFFER*80,IN_FILE*40,IN_COMMENTS*80
	COMMON ZMAG,ZRAD
10	FORMAT(A)

C------------------------------------------------------------------
C Read the data:
	IOP=0
	CALL DREADFILE(RAD,BRIGHT,NP1,RAD,WORK,IWORK,IDIM,
     1                 IN_FILE,IN_COMMENTS,IOP)

C Entering the parameters :
	PRINT *,'Constant for the magnitudes?'
	READ(5,*) CTMAG
	PRINT *,'Give minimum and maximum radii for the fit'
	READ(5,*) RMIN,RMAX
	PRINT *,'Sky level you want to subtract to the input values?'
	READ(5,*) SKY
	PRINT *,'Give initial values for Be (mag) and r_equiv '
	READ(5,*) XC(1),XC(2)

C----------------------------------------------------------------------
C NPTS1 : max index value such as BRIGHT(I) .gt. SKY
C 512 : label for the main loop
C
512	NPTS1=NP1
	DO I=1,NP1
	  ZBI=BRIGHT(I)-SKY
	    IF(ZBI.LE.0.)THEN
	      PRINT *,' Profile troncated at R=',RAD(I-1)
	      NPTS1=I-1
	      GO TO 120
	    ELSE
              YPLOT1(I)=-2.5D0*DLOG10(ZBI)+CTMAG
	      IF(I.LE.5)PRINT *,'Rad, Mag',RAD(I),YPLOT1(I)
	    ENDIF
        END DO

120	CONTINUE

C---------------------------------------------------------------------
C Searching for the limiting indices : IMIN, IMAX

	CALL INDEX_MAX8(RAD,NPTS1,RMIN,IMIN)
	IMIN=IMIN+1
	CALL INDEX_MAX8(RAD,NPTS1,RMAX,IMAX)
	NPTS=IMAX-IMIN+1
	PRINT *,'IMIN, IMAX ',IMIN,IMAX

C Filling the arrays for the fit
	DO I=IMIN,IMAX
	  II=I-IMIN+1
	  ZMAG(II)=YPLOT1(I)
	  ZRAD(II)=RAD(I)
	END DO
C------------------------------------------------------------------
C Fitting stage :
C
	M=NPTS
	LIW=100
	LW=12000
	N=2
	IFAIL=1
	PRINT *,' FITTING WITH',M,' POINTS'
	CALL E04HFF(M,N,XC,FSUMSQ,IW,LIW,W,LW,IFAIL)
	 IF (IFAIL.NE.0) THEN
           PRINT *,' FAILURE IN E04HFF :  IFAIL = ',IFAIL
 	 END IF
	RMS=DSQRT(FSUMSQ/(M-N))
	WRITE(6,1000) RMS
1000	FORMAT(' SCATTER ABOUT FIT = ',F8.4,' MAGNITUDES  (RMS)')
	WRITE(6,1010) XC(1),XC(2)
1010	FORMAT(' EFFECTIVE SURFACE BRIGHTNESS : ',F8.3,' MAG/SQ ARCSEC',
     1	/,' EFFECTIVE RADIUS : ',F8.3)

C--------------------------------------------------------------
C Displaying the curves
C
	PRINT *,'Do you want to display the fit? (y)'
	READ(5,10) ANS

	IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
	   DO I=1,NPTS1
	     XPLOT(I)=RAD(I)**0.25
             YPLOT2(I)=XC(1)+8.325D0*((RAD(I)/XC(2))**0.25-1.0D0)
	   END DO
	  CHAR1='r 1/4   (arcsec.)'
	  CHAR2='magni./sq.arcsec.'
	  PRINT *,' Title ?'
	  READ(5,10) TITLE
	  PRINT *,' Output graphic device: '
	  READ(5,10) PLOTDEV
	  CALL DISPLAY2(XPLOT,YPLOT1,1,NPTS1,XPLOT,YPLOT2,1,NPTS1,
     1	CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',IN_FILE,IN_COMMENTS)

C Saving the data:
          OPEN(9,NAME='devauc_data.dat',STATUS='UNKNOWN')
	   DO I=1,NPTS1
            WRITE(9,18) XPLOT(I),YPLOT1(I),YPLOT2(I)
18          FORMAT(3(G12.5,1X))
           END DO
          CLOSE(9)
          WRITE(6,*) ' => Data saved in file devauc_data.dat'
	ELSE
	  GOTO 99
	ENDIF
C---------------------------------------------------------------------
C Residuals

	PRINT *,'Do you want to display the residuals? (Y)'
	READ(5,10) ANS

	IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
	   DO I=1,NPTS1
	     YPLOT2(I)=YPLOT1(I)-YPLOT2(I)
	     YPLOT3(I)=0.
	   END DO
	  CHAR1=' r 1/4  (arcsec.)'
	  CHAR2='Profile-Model (mag.)'
	  PRINT *,'Title?'
	  READ(5,10) TITLE
	  PRINT *,'Output graphic device: '
	  READ(5,10) PLOTDEV
	  CALL DISPLAY2(XPLOT,YPLOT2,1,NPTS1,XPLOT,YPLOT3,1,NPTS1,
     1	CHAR1,CHAR2,TITLE,PLOTDEV,'L','L2',IN_FILE,IN_COMMENTS)

	ENDIF

C---------------------------------------------------------------
99	PRINT *,'DO YOU WANT ANOTHER TRY ? (Y)'
	READ(5,10) ANS
	IF(ANS.NE.'N'.AND.ANS.NE.'n')THEN
	  PRINT *,' GIVE MINIMUM AND MAXIMUM RADII FOR FIT'
	  READ(5,*) RMIN,RMAX
	  PRINT *,' GIVE INITIAL VALUES FOR B0 (MAG) AND Requi '
	  READ(5,*) XC(1),XC(2)
	  PRINT *,' CONSTANT YOU WANT TO SUBTRACT TO THE INPUT VALUES ?'
	  READ(5,*) SKY
	  GO TO 512
	ENDIF

      STOP
      END
C_____________________________________________________________________
      SUBROUTINE LSFUN2(M,N,XC,FVECC,FJACC,LJC)
C******************************************************************
C                                                                 *
C  WORKS OUT RESIDUALS AND JACOBIAN MATRIX FOR DE VAUCOULEURS     *
C  LAW FIT                                                        *
C                                                                 *
C******************************************************************
	PARAMETER (IDIM=1000)
	IMPLICIT REAL*8(A-H,O-Z)
	REAL*8 FVECC(M),FJACC(LJC,N),XC(N)
	REAL*8 ZMAG(IDIM),ZRAD(IDIM)
	COMMON ZMAG,ZRAD
	ZM0=XC(1)
	A=XC(2)
	DO I=1,M
        FVECC(I)=ZMAG(I)-ZM0-8.325D0*((ZRAD(I)/A)**0.25-1.0D0)
        FJACC(I,1)=-1.0D0
        FJACC(I,2)=2.08125D0*(ZRAD(I)**0.25)/A**1.25
	END DO
	RETURN
	END
C------------------------------------------------------------------
	SUBROUTINE LSHES2(M,N,FVECC,XC,B,LB)
C*****************************************************************
C                                                                *
C  WORKS OUT HESSIAN MATRIX FOR DE VAUCOULEURS LAW FIT           *
C                                                                *
C*****************************************************************
	PARAMETER (IDIM=1000)
      IMPLICIT REAL*8(A-H,O-Z)
      REAL*8 B(LB),FVECC(M),XC(N)
      REAL*8 ZMAG(IDIM),ZRAD(IDIM)
      COMMON ZMAG,ZRAD
      ZM0=XC(1)
      A=XC(2)
      B(1)=0.0D0
      B(2)=0.0D0
      SUM22=0.0D0
      DO I=1,M
        SUM22=SUM22-FVECC(I)*2.6015625D0*ZRAD(I)**0.25/A**2.25
      END DO
      B(3)=SUM22
      RETURN
      END
C---------------------------------------------------------------


      SUBROUTINE PMAT(V,W)
C
      PARAMETER(NFAC=49)
      COMMON/OACOF/AA(NFAC,NFAC)
      DIMENSION V(1),W(1),C(NFAC)
C
      DO 10,I=1,NFAC
      DO 20,J=1,NFAC
   20 C(J)=AA(I,J)
C
      W(I)=SDOT(NFAC,C,1,V,1)
   10 CONTINUE
C
C
      RETURN
      END

       FUNCTION SDOT(N,X,INCX,Y,INCY)
       REAL*4 X(1),Y(1),SDOT
       SDOT=0.0
       IX=1
       IY=1
       DO 10 I=1,N
          SDOT=SDOT+X(IX)*Y(IY)
          IX=IX+INCX
          IY=IY+INCY
  10   CONTINUE
       RETURN
       END

       SUBROUTINE GRAD1(B,X)
C
       PARAMETER(NFAC=49,IRMAX=50)
       COMMON/OASET/PIO2
       COMMON/OACOF/AA(NFAC,NFAC)
       DIMENSION A(IRMAX,IRMAX),B(NFAC),X(NFAC)
       DIMENSION ALFA(IRMAX),R(NFAC,IRMAX),S(NFAC,IRMAX)
       DIMENSION Y(NFAC),Z(NFAC),RS(IRMAX),D(IRMAX)

C     ...
       DO II=1,IPQ
          DO  I=1,NFAC
             Y(I)=S(I,II)
          ENDDO
          DO JJ=II ,IPQ
             DO  I=1,NFAC
                Z(I)=S(I,JJ)
             ENDDO
             A(II,JJ)=SDOT(NFAC,Y,1,Z,1)
             A(JJ,II)=A(II,JJ)
          ENDDO
          DO  I=1,NFAC
             Z(I)=R(I,IPP0)
          ENDDO
          RS(II)=SDOT(NFAC,Y,1,Z,1)
       ENDDO
C     ...
       END


      program non_linear11

C     Check the linearization of integer products

C     Both subexpressions are affine and equal

      i1 = (n+1)*(n+1)+1
      read *, i1

C     Both expressions are equal, i2 >=0

      i2 = (n*m)*(n*m)
      read *, i2

C     For intervals, there 9 different sign cases

C     ++++

      if(x.gt.0) then
         l1 = 1
         l2 = 2
      else
         l1 = 10
         l2 = 20
      endif

      k1 = l1*l2
      read *, k1

C     ++-+

      if(x.gt.0) then
         l1 = 1
         l2 = -2
      else
         l1 = 10
         l2 = 20
      endif

      k2 = l1*l2
      read *, k2

C     -+++

      if(x.gt.0) then
         l1 = -1
         l2 = 2
      else
         l1 = 10
         l2 = 20
      endif

      k3 = l1*l2
      read *, k3

C     ++--

      if(x.gt.0) then
         l1 = 1
         l2 = -20
      else
         l1 = 10
         l2 = 2
      endif

      k4 = l1*l2
      read *, k4

C     --++

      if(x.gt.0) then
         l1 = -10
         l2 = 2
      else
         l1 = -1
         l2 = 20
      endif

      k5 = l1*l2
      read *, k5

C     -+--

      if(x.gt.0) then
         l1 = -1
         l2 = -20
      else
         l1 = 10
         l2 = -2
      endif

      k6 = l1*l2
      read *, k6

C     ---+

      if(x.gt.0) then
         l1 = -10
         l2 = -2
      else
         l1 = -1
         l2 = 20
      endif

      k7 = l1*l2
      read *, k7

C     ----

      if(x.gt.0) then
         l1 = -10
         l2 = -20
      else
         l1 = -1
         l2 = -2
      endif

      k8 = l1*l2
      read *, k8

C     -+-+ (this case further splits down according to magnitudes)

      if(x.gt.0) then
         l1 = -1
         l2 = -2
      else
         l1 = 10
         l2 = 20
      endif

      k9 = l1*l2
      read *, k9

C     -+-+ Same as above, but with overflows

      if(x.gt.0) then
         l1 = -1 000 000
         l2 = -2 000 000
      else
         l1 = 10 000 000
         l2 = 20 000 000
      endif

      k10 = l1*l2
      read *, k10

      end


      MODULE m_fitchk
      CONTAINS
      SUBROUTINE fitchk(f1,f2,av,rms,dmx)
!     ************************************************
!     compare functions f1 and f2
!     ************************************************
      IMPLICIT NONE
      REAL,INTENT(OUT):: av,dmx,rms
      REAL,INTENT(IN):: f1(:),f2(:)
!     .. Local Scalars ..
      REAL d
      INTEGER i

      av = 0.
      rms = 0.
      dmx = 0.
      DO  i = 1,SIZE(f1)
         av = av + f1(i)
         d = (f1(i)-f2(i))**2
         dmx = MAX(d,dmx)
         rms = rms + d
      ENDDO
      av = av/size(f1)
      IF (abs(av).LT.1.e-30) THEN
         rms = 0.
         dmx = 0.
         RETURN
      END IF
      rms = sqrt(rms/size(f1))/av*100.
      dmx = sqrt(dmx)/av*100.
      END SUBROUTINE
      END


module hmm
implicit none
public

contains

! Computes the (unscaled) forward variables of the HMM defined by
!
!     alpha_0[i] = init[i] * mko[obs[0], i]
!     alpha_t+1[i] = sum_j mkh[ij] * alpha_t[j] * mko[obs[t+1], i]
!
! where alpha is rescaled after each step alpha_t = alpha_t * c_t
! with the scaling variable
!
!     c_t = 1 / (sum_i alpha_t[i])
!
! :returns: (len(obs), len(mkh)) array, (len(obs)) array;
!     forward and scaling variables
subroutine get_forward(n_hid, n_obs, steps, mkh, mko, init, obs, forward, &
         scaling)
   implicit none
   integer, intent(in) :: n_hid
   integer, intent(in) :: n_obs
   integer, intent(in) :: steps
   real*8, intent(in)  :: mkh(n_hid, n_hid)
   real*8, intent(in)  :: mko(n_obs, n_hid)
   real*8, intent(in)  :: init(n_hid)
   integer, intent(in) :: obs(steps)
   real*8, intent(out) :: forward(steps, n_hid)
   real*8, intent(out) :: scaling(steps)

   integer :: t
   forward(1, :) = init * mko(obs(1), :)
   scaling(1) = to_scale(forward(1, :))

   do t = 1, steps - 1
      forward(t+1, :) = matmul(mkh, forward(t, :)) * mko(obs(t+1), :)
      scaling(t+1) = to_scale(forward(t+1, :))
   end do

contains

   function to_scale(forward_t) result(scaling_t)
      implicit none
      real*8, intent(inout) :: forward_t(:)
      real*8                :: scaling_t

      scaling_t = 1. / sum(forward_t)
      forward_t = forward_t * scaling_t
   end function to_scale

end subroutine get_forward

! Computes the (unscaled) backward variables of the HMM defined by
!
!    beta_T-1[i] = 1
!    beta_t[i] = sum_j mko[obs[t+1], j] beta_t+1[j] mkh[ji]
!
! where T = len(obs)
!
! :returns: (len(obs), len(mkh)) array; backward variables
subroutine get_backward(n_hid, n_obs, steps, mkh, mko, obs, scaling, backward)
   implicit none
   integer, intent(in) :: n_hid
   integer, intent(in) :: n_obs
   integer, intent(in) :: steps
   real*8, intent(in)  :: mkh(n_hid, n_hid)
   real*8, intent(in)  :: mko(n_obs, n_hid)
   integer, intent(in) :: obs(steps)
   real*8, intent(in)  :: scaling(steps)
   real*8, intent(out) :: backward(steps, n_hid)

   integer :: t
   backward(steps, :) = scaling(steps)

   do t = steps - 1, 1, -1
      backward(t, :) = matmul(mko(obs(t+1), :) * backward(t+1, :), mkh) * scaling(t)
   end do

end subroutine get_backward

subroutine iterate(n_hid, n_obs, steps, mkh, mko, init, obs, &
         mkh_n, mko_n, init_n)
   implicit none
   integer, intent(in) :: n_hid
   integer, intent(in) :: n_obs
   integer, intent(in) :: steps
   real*8, intent(in)  :: mkh(n_hid, n_hid)
   real*8, intent(in)  :: mko(n_obs, n_hid)
   real*8, intent(in)  :: init(n_hid)
   integer, intent(in) :: obs(steps)
   real*8, intent(out) :: mkh_n(n_hid, n_hid)
   real*8, intent(out) :: mko_n(n_obs, n_hid)
   real*8, intent(out) :: init_n(n_hid)

   real*8 forward(steps, n_hid), backward(steps, n_obs), &
         scaling(steps), gamma(steps, n_hid), gamma_sum(n_hid), &
         xi_t(n_hid, n_hid)
   integer t, i, j

   call get_forward(n_hid, n_obs, steps, mkh, mko, init, obs, forward, &
         scaling)
   call get_backward(n_hid, n_obs, steps, mkh, mko, obs, scaling, backward)

   do t = 1, steps
      gamma(t, :) = forward(t, :) * backward(t, :)
      gamma(t, :) = gamma(t, :) / sum(gamma(t, :))
   end do
   gamma_sum = sum(gamma(1:steps - 1, :), 1)

   mkh_n = 0.
   do t = 1, steps - 1
      do i = 1, n_hid
         do j = 1, n_hid
            xi_t(j, i) = forward(t, i) * mkh(j, i) * mko(obs(t+1), j) &
                  * backward(t+1, j)
         end do
      end do
      mkh_n = mkh_n + (xi_t / sum(xi_t))
   end do
   do i = 1, n_hid
      mkh_n(:, i) = gamma_sum(i)
   end do

   gamma_sum = gamma_sum + gamma(steps, :)
   mko_n = 0.
   do t = 1, steps
      mko_n(obs(t), :) = mko_n(obs(t), :) + gamma(t, :)
   end do
   do j = 1, n_hid
      mko_n(:, j) = mko_n(:, j) / gamma_sum(j)
   end do

   init_n = gamma(1, :)
end subroutine iterate
! gamma = forward * backward
! gamma /= np.sum(gamma, axis=-1)[:, None]
! xi = forward[:-1, None, :] * mkh[None, :, :] \
!    * mko[obs[1:], :, None] * backward[1:, :, None]
! xi /= np.sum(xi, axis=(1, 2))[:, None, None]

! init_n = gamma[0]
! mkh_n = np.sum(xi, axis=0) / np.sum(gamma[:-1], axis=0, keepdims=True)
! mko_n = np.empty((len(mko), len(mkh)))
! gamma_sum = np.sum(gamma, axis=0)
! for k in range(len(mko)):
!    mko_n[k, :] = np.sum(gamma[obs == k], axis=0) / gamma_sum

! return mkh_n, mko_n, init_n
end module hmm


       subroutine stencilf(A, B, N, iters)
       integer N, iters
       double precision A(N,N,N), B(N,N,N)
       integer i,j,k,z
       double precision c
       c = 1 / 7.

       do z=1,iters

         do k=2,N-1
           do j=2,N-1
             do i=2,N-1
               A(i,j,k) = c * (B(i,j,k) + B(i+1,j,k) + B(i-1,j,k)
     .            + B(i,j+1,k) + B(i,j-1,k) + B(i,j,k+1) + B(i,j,k-1))
             enddo
           enddo
         enddo

         do k=2,N-1
           do j=2,N-1
             do i=2,N-1
               B(i,j,k) = c * (A(i,j,k) + A(i+1,j,k) + A(i-1,j,k)
     .            + A(i,j+1,k) + A(i,j-1,k) + A(i,j,k+1) + A(i,j,k-1))
             enddo
           enddo
         enddo

       enddo

       return
       end


subroutine PLegendreA(p, lmax, z, csphase, exitstatus)
!------------------------------------------------------------------------------
!
!   This function evalutates all of the unnormalized associated legendre
!   polynomials up to degree lmax.
!
!   Calling Parameters
!
!       IN
!           lmax        Maximum spherical harmonic degree to compute.
!           z           [-1, 1], cos(colatitude) or sin(latitude).
!
!       OPTIONAL (IN)
!           csphase     1: Do not include the phase factor of (-1)^m
!                       -1: Apply the phase factor of (-1)^m.
!
!       OUT
!           p           A vector of all associated Legendgre polynomials
!                       evaluated at z up to lmax. The length must by greater
!                       or equal to (lmax+1)*(lmax+2)/2.
!
!       OPTIONAL (OUT)
!           exitstatus  If present, instead of executing a STOP when an error
!                       is encountered, the variable exitstatus will be
!                       returned describing the error.
!                       0 = No errors;
!                       1 = Improper dimensions of input array;
!                       2 = Improper bounds for input variable;
!                       3 = Error allocating memory;
!                       4 = File IO error.
!
!   Notes:
!
!   1.  The integral of plm**2 over (-1,1) is 2 * (l+m)! / (2l+1) / (l-m)!.
!   2.  The index of the array p corresponds to l*(l+1)/2 + m + 1.
!   3.  The default is to exlude the Condon-Shortley phase of (-1)^m.
!
!   Copyright (c) 2005-2019, SHTOOLS
!   All rights reserved.
!
!------------------------------------------------------------------------------
    use SHTOOLS, only: CSPHASE_DEFAULT
    use ftypes

    implicit none

    integer, intent(in) :: lmax
    real(dp), intent(out) :: p(:)
    real(dp), intent(in) :: z
    integer, intent(in), optional :: csphase
    integer, intent(out), optional :: exitstatus
    real(dp) :: pm2, pm1, pmm, sinsq, sinsqr, fact, plm
    integer :: k, kstart, m, l
    integer(int1) :: phase

    if (present(exitstatus)) exitstatus = 0

    if (size(p) < (lmax+1)*(lmax+2)/2) then
        print*, "Error --- PLegendreA"
        print*, "P must be dimensioned as (LMAX+1)*(LMAX+2)/2 " // &
                "where LMAX is ", lmax
        print*, "Input array is dimensioned ", size(p)
        if (present(exitstatus)) then
            exitstatus = 1
            return
        else
            stop
        end if

    else if (lmax < 0) then
        print*, "Error --- PLegendreA"
        print*, "LMAX must be greater than or equal to 0."
        print*, "Input value is ", lmax
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    else if(abs(z) > 1.0_dp) then
        print*, "Error --- PLegendreA"
        print*, "ABS(Z) must be less than or equal to 1."
        print*, "Input value is ", z
        if (present(exitstatus)) then
            exitstatus = 2
            return
        else
            stop
        end if

    end if

    if (present(csphase)) then
        if (csphase == -1) then
            phase = -1

        else if (csphase == 1) then
                phase = 1

        else
            print*, "Error --- PLegendreA"
            print*, "CSPHASE must be 1 (exclude) or -1 (include)."
            print*, "Input value is ", csphase
            if (present(exitstatus)) then
                exitstatus = 2
                return
            else
                stop
            end if

        end if

    else
            phase = CSPHASE_DEFAULT

    end if

    !--------------------------------------------------------------------------
    !
    !   Calculate P(l,0)
    !
    !--------------------------------------------------------------------------
    sinsq = (1.0_dp - z) * (1.0_dp + z)
    sinsqr = sqrt(sinsq)

    pm2 = 1.0_dp
    p(1) = 1.0_dp

    if (lmax == 0) return

    pm1 = z
    p(2) = pm1

    k = 2

    do l = 2, lmax, 1
        k = k + l
        plm = ( z * (2*l - 1) * pm1 - (l - 1) * pm2 ) / dble(l)
        p(k) = plm
        pm2 = pm1
        pm1 = plm

    end do

    !--------------------------------------------------------------------------
    !
    !   Calculate P(m,m), P(m+1,m), and P(l,m)
    !
    !--------------------------------------------------------------------------
    pmm = 1.0_dp
    fact = -1.0_dp
    kstart = 1

    do m = 1, lmax - 1, 1

        ! Calculate P(m,m)
        kstart = kstart + m + 1
        fact = fact + 2.0_dp
        pmm = phase * pmm * sinsqr * fact
        p(kstart) = pmm
        pm2 = pmm

        ! Calculate P(m+1,m)
        k = kstart + m + 1
        pm1 = z * pmm * (2 * m + 1)
        p(k) = pm1

        ! Calculate P(l,m)
        do l = m + 2, lmax, 1
            k = k + l
            plm = ( z * (2*l-1) * pm1 - (l+m-1) * pm2 ) / dble(l-m)
            p(k) = plm
            pm2 = pm1
            pm1 = plm

        end do

    end do

    ! P(lmax, lmax)
    kstart = kstart + m + 1
    fact = fact + 2.0_dp
    pmm = phase * pmm * sinsqr * fact
    p(kstart) = pmm

end subroutine PLegendreA


      SUBROUTINE slH2E ( AZ, EL, PHI, HA, DEC )
*+
*     - - - - -
*      D E 2 H
*     - - - - -
*
*  Horizon to equatorial coordinates:  Az,El to HA,Dec
*
*  (single precision)
*
*  Given:
*     AZ      r     azimuth
*     EL      r     elevation
*     PHI     r     observatory latitude
*
*  Returned:
*     HA      r     hour angle
*     DEC     r     declination
*
*  Notes:
*
*  1)  All the arguments are angles in radians.
*
*  2)  The sign convention for azimuth is north zero, east +pi/2.
*
*  3)  HA is returned in the range +/-pi.  Declination is returned
*      in the range +/-pi/2.
*
*  4)  The latitude is (in principle) geodetic.  In critical
*      applications, corrections for polar motion should be applied.
*
*  5)  In some applications it will be important to specify the
*      correct type of elevation in order to produce the required
*      type of HA,Dec.  In particular, it may be important to
*      distinguish between the elevation as affected by refraction,
*      which will yield the "observed" HA,Dec, and the elevation
*      in vacuo, which will yield the "topocentric" HA,Dec.  If the
*      effects of diurnal aberration can be neglected, the
*      topocentric HA,Dec may be used as an approximation to the
*      "apparent" HA,Dec.
*
*  6)  No range checking of arguments is done.
*
*  7)  In applications which involve many such calculations, rather
*      than calling the present routine it will be more efficient to
*      use inline code, having previously computed fixed terms such
*      as sine and cosine of latitude.
*
*  Last revision:   11 September 2005
*
*  Copyright P.T.Wallace.  All rights reserved.
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      REAL AZ, EL, PHI, HA, DEC

      DOUBLE PRECISION SA, CA, SE, CE, SP, CP, X, Y, Z, R

*  Useful trig functions.
      SA = SIN(AZ)
      CA = COS(AZ)
      SE = SIN(EL)
      CE = COS(EL)
      SP = SIN(PHI)
      CP = COS(PHI)

*  HA,Dec as x,y,z.
      X = -CA*CE*SP+SE*CP
      Y = -SA*CE
      Z = CA*CE*CP+SE*SP

*  To HA,Dec.
      R = SQRT(X*X+Y*Y)
      IF (R.EQ.0.0) THEN
         HA = 0.0
      ELSE
         HA = REAL(ATAN2(Y,X))
      END IF
      DEC = REAL(ATAN2(Z,R))

      END


!//=========================================================================
!// Oslo CTM3
!//=========================================================================
!// Based on UCI CTM core p-7.1 (1/2013).
!//
!// Ole Amund Sovde, March 2015
!//=========================================================================
!// Constant parameters for CTM run.
!//=========================================================================
module CMN_PARAMETERS
  !//-----------------------------------------------------------------------
  !// MODULE: CMN_PARAMETERS
  !// DESCRIPTION: Constant parameters for CTM run.
  !//-----------------------------------------------------------------------
  use cmn_precision, only: r8
  !//-----------------------------------------------------------------------
  implicit none
  !//-----------------------------------------------------------------------
  public
  !//-----------------------------------------------------------------------

  !// Physical constants
  !//-----------------------------------------------------------------------
  !// Earth radius [m]
  real(r8), parameter :: A0        = 6371000._r8
  !// Gravitational constant [m/s^2]
  real(r8), parameter :: G0        = 9.80665_r8
  !// pi & 2pi
  real(r8), parameter :: CPI       = 3.141592653589793_r8
  real(r8), parameter :: C2PI      = 2._r8*CPI
  !// Conversions to / from radians
  real(r8), parameter :: CPI180    = CPI/180._r8
  real(r8), parameter :: ZPI180    = 1._r8/CPI180
  !// Von Karman constant
  real(r8), parameter :: VONKARMAN = 0.4_r8
  !// Similarity profiles (from Kansas experiment)
  real(r8), parameter :: CSIM_BETA      = 4.7_r8
  real(r8), parameter :: CSIM_GAMMA     = 15._r8

  !// Chemistry constants
  !//-----------------------------------------------------------------------
  !// Conversion atm to Pa [Pa/atm]
  real(r8), parameter :: atm2Pa = 101325._r8
  real(r8), parameter :: Pa2atm = 1._r8 / atm2Pa
  !// Numbers of kcal in a J
  real(r8), parameter :: J2kcal = 4186.8_r8

  !// Molecular mass for air [g/mol]
  real(r8), parameter :: M_AIR  = 28.97_r8

  !// Universal gas constant [J/(K*mol)] = [m3*Pa/(K*mol)]
  real(r8), parameter :: R_UNIV = 8.31446_r8
  !// Gas constant in "chemical units" [m3*atm/(K*mol)] (~8.205d-5)
  real(r8), parameter :: R_ATM  = R_UNIV * Pa2atm
  !// Specific gas constant for air [J/(K*kg)] (~287.d0)
  real(r8), parameter :: R_AIR  = R_UNIV / M_AIR * 1.e3_r8
  !// Specific gas constant for water vapor [J/(K*kg)] (~461.d0)
  real(r8), parameter :: R_H2O  = R_UNIV / 18.01528_r8 * 1.e3_r8

  !// Avogadro's number [molecules/mol]
  real(r8), parameter :: AVOGNR = 6.022149e23_r8
  !// Boltzmann's const [J/(K*molecules)]
  real(r8), parameter :: BOLTZMANN = 1.38063e-23_r8
  !// Boltzmann's const [mb*cm3/(K*molecules)]
  real(r8), parameter :: KBOLTZ = 1.e4_r8 * BOLTZMANN

  !// Specific heat of dry air at constant pressure [J/(K*kg)
  real(r8), parameter :: cp_air = 1004._r8
  !// Latent heat of vaporization at 0C [J/kg] (Stull, 1988)
  real(r8), parameter :: Lv_0C = 2.501e6_r8
  !// Gradient of Lv between 0C and 100C [(J/kg)/K] (Stull, 1988)
  real(r8), parameter :: dLv_dT = -0.00237e6_r8
  !// Temperature [K] at 0C
  real(r8), parameter :: TK_0C = 273.15_r8
  !// Saturation vapor pressure of H2O [Pa]
  real(r8), parameter :: es_0C = 611.2_r8

  !// Temporal constants
  real(r8), parameter :: secDay  = 86400._r8
  real(r8), parameter :: secYear = 31536000._r8

  !// Limits on temperature for temperature dependent rates
  integer, parameter :: MINTEMP    = 150
  integer, parameter :: MAXTEMP    = 350
  integer, parameter :: TEMPRANGE  = MAXTEMP - MINTEMP

  !// Logical operator for including more extensive debugging
  logical, parameter :: LDEBUG=.true.

  !//-----------------------------------------------------------------------
end module CMN_PARAMETERS
!//=========================================================================