!----------------------------------------------------------------------------- best with 100 columns

!> interface to sparse linear solvers and ILU preconditioners (ITSOL)
module modSparse
  use iso_c_binding
  private

  ! constants
  integer,parameter,public::CSR_CLEAN=1 !< remove CSR duplicated/zero entries
  integer,parameter,public::CSR_CLEAN_PSORT=2 !< remove CSR duplicated/zero entries, partial sort
  integer,parameter,public::CSR_CLEAN_SORT=3 !< remove CSR duplicated/zero entries, full sort

  integer(C_INT),parameter::UMFPACK_CONTROL=20 !< size of umfpack control array
  integer(C_INT),parameter::UMFPACK_INFO=90 !< size of umfpack info array
  integer(C_INT),parameter::UMFPACK_AT=1 !< umfpack uses CSC format, so need to transpose

  integer,parameter,public::APLDIA_IN_PLACE=0 !< add diagonal values in-place

  !> generic CSR linear equation object
  type,public::linEq
    integer::nEq !< number of equations
    integer,private::maxNNz !< maximum number of non-zeros
    integer,allocatable::iA(:) !< CSR index array (size nEq+1)
    integer,allocatable::jA(:) !< CSR index array (size nNz)
    double precision,allocatable::A(:) !< CSR value array
  contains
    procedure,public::initLinEq
    procedure,public::clear=>clearLinEq
    procedure,public::setCSR=>setCSRLinEq
    procedure,public::setCOO=>setCOOLinEq
    procedure,public::mulVec=>mulVecLinEq
    procedure,public::addDiag=>addDiagLinEq
    final::purgeLinEq
  end type

  !> CSR linear equation object solved by multi-front method of umfpack
  type,extends(linEq),public::multiFront
    type(C_PTR),private::symbolic=C_NULL_PTR !< symbolic object
    type(C_PTR),private::numeric=C_NULL_PTR !< numeric object
    integer(C_INT),private,allocatable::ciA(:),cjA(:) !< 0-based index
    real(C_DOUBLE),private::control(UMFPACK_CONTROL) !< options
    real(C_DOUBLE),private::info(UMFPACK_INFO) !< exiting info
  contains
    procedure,public::init=>initMultiFront
    procedure,public::clear=>clearMultiFront
    procedure,public::fact=>factMultiFront
    procedure,public::solve=>solveMultiFront
    final::purgeMultiFront
  end type

  !> CSR linear equation object (incompletely) solved by ILUT of SPARSKIT2/ITSOL
  type,extends(linEq),public::ILU
    integer,allocatable,private::ju(:),jlu(:),jw(:) !< auxiliary storage for ILUT
    double precision,allocatable,private::alu(:),w(:) !< auxiliary storage for ILUT
    integer,private::lFill !< maximum number of non-diagonal L or U elements in a row
    integer,private::iwk !< length of alu, jlu
  contains
    procedure,public::init=>initILU
    procedure,public::clear=>clearILU
    procedure,public::fact=>factILU
    procedure,public::solve=>solveILU
    final::purgeILU
  end type

  !> interface to umfpack C functions and SPARSKIT2
  interface

    !> symbolic factorization of CSC format
    subroutine umfpack_di_symbolic(n_row,n_col,Ap,Ai,Ax,Symbolic,Control,Info)&
    &  bind(c,name='umfpack_di_symbolic')
      use iso_c_binding
      integer(C_INT),value::n_row,n_col
      integer(C_INT),intent(in)::Ap(*),Ai(*)
      real(C_DOUBLE),intent(in)::Ax(*)
      type(C_PTR)::Symbolic
      real(C_DOUBLE),intent(in)::Control(*)
      real(C_DOUBLE)::Info(*)
    end subroutine

    !> numerical factorization of CSC format
    subroutine umfpack_di_numeric(Ap,Ai,Ax,Symbolic,Numeric,Control,Info)&
    &  bind(c,name='umfpack_di_numeric')
      use iso_c_binding
      integer(C_INT),intent(in)::Ap(*),Ai(*)
      real(C_DOUBLE),intent(in)::Ax(*)
      type(C_PTR),value::Symbolic
      type(C_PTR)::Numeric
      real(C_DOUBLE),intent(in)::Control(*)
      real(C_DOUBLE)::Info(*)
    end subroutine

    !> solve CSC format
    subroutine umfpack_di_solve(sys,Ap,Ai,Ax,X,B,Numeric,Control,Info)&
    &  bind(c,name='umfpack_di_solve')
      use iso_c_binding
      integer(C_INT),value::sys
      integer(C_INT),intent(in)::Ap(*),Ai(*)
      real(C_DOUBLE),intent(in)::Ax(*)
      real(C_DOUBLE)::X(*)
      real(C_DOUBLE),intent(in)::B(*)
      type(C_PTR),value::Numeric
      real(C_DOUBLE),intent(in)::Control(*)
      real(C_DOUBLE)::Info(*)
    end subroutine

    !> get default control array
    subroutine umfpack_di_defaults(Control) bind(c,name='umfpack_di_defaults')
      use iso_c_binding
      real(C_DOUBLE)::Control(*)
    end subroutine

    !> free symbolic factorization
    subroutine umfpack_di_free_symbolic(Symbolic) bind(c,name='umfpack_di_free_symbolic')
      use iso_c_binding
      type(C_PTR)::Symbolic
    end subroutine

    !> free numeric factorization
    subroutine umfpack_di_free_numeric(Numeric) bind(c,name='umfpack_di_free_numeric')
      use iso_c_binding
      type(C_PTR)::Numeric
    end subroutine

    !> convert COO format to CSR format
    subroutine coocsr(nrow,nnz,a,ir,jc,ao,jao,iao)
      integer,intent(in)::nrow,nnz
      double precision,intent(in)::a(*)
      integer,intent(in)::ir(*),jc(*)
      double precision,intent(inout)::ao(*)
      integer,intent(inout)::jao(*),iao(*)
    end subroutine

    !> CSR format cleanup and sort
    subroutine clncsr(job,value2,nrow,a,ja,ia,indu,iwk)
      integer,intent(in)::job,value2,nrow
      integer,intent(inout)::ia(nrow+1),ja(*)
      double precision,intent(inout)::a(*)
      integer,intent(inout)::indu(nrow),iwk(nrow+1)
    end subroutine

    !> CSR format matrix vector product y=Ax
    subroutine amux(n,x,y,a,ja,ia)
      integer,intent(in)::n
      double precision,intent(in)::x(*)
      double precision,intent(inout)::y(*)
      double precision,intent(in)::a(*)
      integer,intent(in)::ja(*),ia(*)
    end subroutine

    !> add diagonal values to CSR format matrix B=A+Diag
    subroutine apldia(nrow,job,a,ja,ia,diag,b,jb,ib,iw)
      integer,intent(in)::nrow,job
      double precision,intent(inout)::a(*),b(*)
      integer,intent(inout)::ja(*),jb(*),ia(nrow+1),ib(nrow+1),iw(*)
      double precision,intent(in)::diag(nrow)
    end subroutine

    !> ILUT factorization
    subroutine ilut(n,a,ja,ia,lfil,droptol,alu,jlu,ju,iwk,w,jw,ierr)
      integer,intent(in)::n
      double precision,intent(in)::a(*)
      integer,intent(in)::ja(*),ia(n+1)
      integer,intent(in)::lfil
      double precision,intent(in)::droptol
      double precision,intent(inout)::alu(*)
      integer,intent(inout)::jlu(*),ju(n)
      integer,intent(in)::iwk
      double precision,intent(inout)::w(n+1)
      integer,intent(inout)::jw(2*n)
      integer,intent(out)::ierr
    end subroutine

    !> LU forward and backward solve
    subroutine lusol(n,y,x,alu,jlu,ju)
       integer,intent(in)::n
       double precision,intent(in)::y(n)
       double precision,intent(inout)::x(n)
       double precision,intent(in)::alu(*)
       integer,intent(in)::jlu(*),ju(*)
    end subroutine

  end interface

contains

  !> generic constructor of linEq
  subroutine initLinEq(this,nEq,maxNNz)
    class(linEq),intent(inout)::this !< this linEq
    integer,intent(in)::nEq !< number of equations
    integer,intent(in)::maxNNZ !< maximum number of non-zeros

    this%nEq=nEq
    this%maxNNz=maxNNz
    allocate(this%iA(nEq+1))
    allocate(this%jA(maxNNz))
    allocate(this%A(maxNNz))
  end subroutine

  !> clear this generic linEq
  subroutine clearLinEq(this)
    class(linEq),intent(inout)::this !< this linEq

    if(allocated(this%iA)) deallocate(this%iA)
    if(allocated(this%jA)) deallocate(this%jA)
    if(allocated(this%A)) deallocate(this%A)
  end subroutine

  !> set matrix with CSR format for this generic linEq
  subroutine setCSRLinEq(this,iA,jA,A,job)
    class(linEq),intent(inout)::this !< this linEq
    integer,intent(in)::iA(*) !< CSR index array (size nEq+1)
    integer,intent(in)::jA(*) !< CSR index array (size nNz)
    double precision,intent(in)::A(*) !< CSR value array
    integer,intent(in),optional::job !< additional cleanups
    integer::nNz
    integer,allocatable::indu(:),iwk(:)

    this%iA(1:this%nEq+1)=iA(1:this%nEq+1)
    nNz=iA(this%nEq+1)-1
    this%jA(1:nNz)=jA(1:nNz)
    this%A(1:nNz)=A(1:nNz)
    if(present(job))then
      allocate(indu(this%nEq))
      allocate(iwk(this%nEq+1))
      call clncsr(job,1,this%nEq,this%A,this%jA,this%iA,indu,iwk)
      deallocate(indu,iwk)
    end if
  end subroutine

  !> set matrix with COO format for this generic linEq
  subroutine setCOOLinEq(this,iA,jA,A,nNz,job)
    class(linEq),intent(inout)::this !< this linEq
    integer,intent(in)::iA(*) !< COO row index array (size nNz)
    integer,intent(in)::jA(*) !< COO column index array (size nNz)
    double precision,intent(in)::A(*) !< COO value array
    integer,intent(in)::nNz !< number of non-zeros
    integer,intent(in),optional::job !< additional cleanups
    integer,allocatable::indu(:),iwk(:)

    call coocsr(this%nEq,nNz,A,iA,jA,this%A,this%jA,this%iA)
    if(present(job))then
      allocate(indu(this%nEq))
      allocate(iwk(this%nEq+1))
      call clncsr(job,1,this%nEq,this%A,this%jA,this%iA,indu,iwk)
      deallocate(indu,iwk)
    end if
  end subroutine

  !> multiply matrix by a vector y=this*x
  subroutine mulVecLinEq(this,x,y)
    class(linEq),intent(in)::this !< this linEq
    double precision,intent(in)::x(*) !< vector to multiply with
    double precision,intent(inout)::y(*) !< result vector

    call amux(this%nEq,x,y,this%A,this%jA,this%iA)
  end subroutine

  !> add diagonal d into matrix this=this+diag
  subroutine addDiagLinEq(this,diag)
    class(linEq),intent(inout)::this !< this linEq
    double precision,intent(in)::diag(*) !< the diagonal values
    integer,allocatable::iw(:)

    allocate(iw(this%nEq))
    call apldia(this%nEq,APLDIA_IN_PLACE,this%A,this%jA,this%iA,diag,this%A,this%jA,this%iA,iw)
    deallocate(iw)
  end subroutine

  !> generic destructor of linEq
  subroutine purgeLinEq(this)
    type(linEq),intent(inout)::this !< this linEq

    call this%clear()
  end subroutine

  !> constructor of multiFront
  subroutine initMultiFront(this,nEq,maxNNz)
    class(multiFront),intent(inout)::this !< this multiFront
    integer,intent(in)::nEq !< number of equations
    integer,intent(in)::maxNNZ !< maximum number of non-zeros

    call this%initLinEq(nEq,maxNNz)
    allocate(this%ciA(nEq+1))
    allocate(this%cjA(maxNNZ))
    call umfpack_di_defaults(this%control)
  end subroutine

  !> clear this multiFront
  subroutine clearMultiFront(this)
    use iso_c_binding
    class(multiFront),intent(inout)::this !< this multiFront

    call this%linEq%clear()
    call umfpack_di_free_symbolic(this%symbolic)
    call umfpack_di_free_numeric(this%numeric)
    if(allocated(this%ciA)) deallocate(this%ciA)
    if(allocated(this%cjA)) deallocate(this%cjA)
  end subroutine

  !> destructor of multiFront
  subroutine purgeMultiFront(this)
    type(multiFront),intent(inout)::this !< this multiFront

    call this%clear()
  end subroutine

  !> factorize this multiFront with umfpack
  subroutine factMultiFront(this)
    use iso_c_binding
    class(multiFront),intent(inout)::this !< this multiFront
    integer::nnz

    nnz=this%iA(this%nEq+1)-1
    this%ciA(:)=this%iA(:)-1
    this%cjA(1:nnz)=this%jA(1:nnz)-1
    call umfpack_di_symbolic(this%nEq,this%nEq,this%ciA,this%cjA,this%A,this%symbolic,&
    &                        this%control,this%info)
    call umfpack_di_numeric(this%ciA,this%cjA,this%A,this%symbolic,this%numeric,&
    &                       this%control,this%info)
  end subroutine

  !> solve this multiFront which is already factorized
  subroutine solveMultiFront(this,rhs,x)
    use iso_c_binding
    class(multiFront),intent(inout)::this !< this multiFront
    double precision,intent(in)::rhs(this%nEq) !< the right-hand-side
    double precision,intent(inout)::x(this%nEq) !< the solution

    call umfpack_di_solve(UMFPACK_AT,this%ciA,this%cjA,this%A,x,rhs,this%numeric,&
    &                     this%control,this%info)
  end subroutine

  !> constructor of ILU
  subroutine initILU(this,nEq,maxNNz,lFill)
    class(ILU),intent(inout)::this !< this ILU
    integer,intent(in)::nEq !< number of equations
    integer,intent(in)::maxNNZ !< maximum number of non-zeros
    integer,intent(in)::lFill !< maximum number of non-diagonal L or U elements in a row

    call this%initLinEq(nEq,maxNNz)
    this%lFill=min(lFill,this%nEq-1)
    this%iwk=this%nEq*min(2*lFill+1,this%nEq)
    allocate(this%alu(this%iwk))
    allocate(this%jlu(this%iwk))
    allocate(this%ju(this%nEq))
    allocate(this%jw(2*this%nEq))
    allocate(this%w(this%nEq+1))
  end subroutine

  !> clear this ILU
  subroutine clearILU(this)
    class(ILU),intent(inout)::this !< this ILU

    call this%linEq%clear()
    if(allocated(this%ju)) deallocate(this%ju)
    if(allocated(this%jlu)) deallocate(this%jlu)
    if(allocated(this%jw)) deallocate(this%jw)
    if(allocated(this%alu)) deallocate(this%alu)
    if(allocated(this%w)) deallocate(this%w)
  end subroutine

  !> destructor of ILU
  subroutine purgeILU(this)
    type(ILU),intent(inout)::this !< this ILU

    call this%clear()
  end subroutine

  !> ILUT factorize this ILU with drop tolerance eps
  subroutine factILU(this,eps)
    class(ILU),intent(inout)::this !< this ILU
    double precision,intent(in),optional::eps !< drop tolerance
    double precision::droptol
    integer::ierr

    if(present(eps))then
      droptol=eps
    else
      droptol=0d0
    end if
    call ilut(this%nEq,this%A,this%jA,this%iA,this%lFill,droptol,this%alu,this%jlu,this%ju,&
    &         this%iwk,this%w,this%jw,ierr)
  end subroutine

  !> solve this ILU which is already factorized
  subroutine solveILU(this,rhs,x)
    class(ILU),intent(inout)::this !< this ILU
    double precision,intent(in)::rhs(this%nEq) !< the right-hand-side
    double precision,intent(inout)::x(this%nEq) !< the solution

    call lusol(this%nEq,rhs,x,this%alu,this%jlu,this%ju)
  end subroutine

end module


program Primes
  use PrimeDecompose
  implicit none

  integer, dimension(100) :: outprimes
  integer i

  outprimes = 0

  call find_factors(12345649494449_huge, outprimes)

  do i = 1, 100
     if ( outprimes(i) == 0 ) exit
     print *, outprimes(i)
  end do

end program Primes


Module calclight
        implicit none
        ! f2py --verbose --fcompiler=intelem -c -m calclight calclight.f90
        contains

            subroutine qsw(radfl0,radmax,cawdir,clouds,rlat,time,daysinyear)
            ! This subroutine get max irradiance for day, latitude, clouds (HYCOM)
            ! -------------------------------------------------------------------------------------------
            ! USAGE: call qsw0(radfl0,radmax,cawdir,clouds, real(lat)*pi/180.0,time,daysinyear)
            !
            ! WHERE: pi      = 4.0*atan(1.0)
            !        clouds  = 0.0
            !        rlat    = lat*pi/180.0
            !        time    = 1.0:365
            !        daysinyear=365.0
            ! -------------------------------------------------------------------------------------------
            ! radfl0 (out) - 24 hrs mean solar irrradiance at the marine surface layer --- (unit: w/m^2)
            ! radmax (out) - daily maximum solar irrradiance at the marine surface layer --- (unit: w/m^2)
            ! cawdir (out) - not sure what this is
            ! clouds (in)     - cloud input (fraction of cloudy sky)
            ! rlat (in)       - latitude (radians)
            ! time (in)       - julian day
            ! daysinyear (in) - number of days in the year

                  real  cawdir,radfl0,radmax
                  real  clouds,rlat
                  real time
                  integer daysinyear

                  real pi2,deg,rad,eepsil
                  integer ifrac,npart
                  real fraci,absh2o,s0,day,dangle,decli,sundv
                  real cc,sin2,cos2,cosz,scosz,stot,bioday,biohr,hangle
                  real srad,sdir,sdif,altdeg,cfac,ssurf

!f2py intent(in,overwrite) clouds,lat,time,daysinyear
!f2py intent(in,out,overwrite) radfl0,radmax,cawdir

            ! --- -------------------------------------------------------------------
            ! --- compute 24 hrs mean solar irrradiance at the marine surface layer
            ! --- (unit: w/m^2)
            ! --- -------------------------------------------------------------------

            ! --- set various quantities

                  !print *,'calling qsw0'
                  pi2=8.*atan(1.)          !        2 times pi
                  deg=360./pi2             !        convert from radians to degrees
                  rad=pi2/360.             !        convert from degrees to radians
                  eepsil=1.e-9             !        small number

                  ifrac=24                 !        split each 12 hrs day into ifrac parts
                  fraci=1./real(ifrac)     !        1 over ifrac

                  absh2o=0.09              ! ---    absorption of water and ozone
                  s0=1365.                 ! w/m^2  solar constant

            ! --- -------------------------------------------------------------------
            ! --- compute 24 hrs mean solar radiation at the marine surface layer
            ! --- -------------------------------------------------------------------

            !KAL  ttime=time+dt/86400.
            !KAL? day=aint(time*365./360.)          !accumulated day number (jan1=0,364,..)
                  !day=aint(time/float(daysinyear))  !accumulated day number (jan1=0,364,..)
                  day=amod(time,float(daysinyear))    !0 < day < 364
                  day=floor(day)
                  dangle=pi2*day/float(daysinyear)   !day-number-angle, in radians
                  if (day<0. .or. day>daysinyear+1) then
                     print *,'qsw0: Error in day for day angle'
                     print *,'Day angle is ',day,daysinyear
                     stop
                  end if

            ! --- compute astronomic quantities --
                  decli=.006918+.070257*sin(dangle)   -.399912*cos(dangle) &
                              +.000907*sin(2.*dangle)-.006758*cos(2.*dangle) &
                              +.001480*sin(3.*dangle)-.002697*cos(3.*dangle)

                  sundv=1.00011+.001280*sin(dangle)   +.034221*cos(dangle) &
                              +.000077*sin(2.*dangle)+.000719*cos(2.*dangle)

            ! --- compute cloudiness fraction

            ! KAL cc=clouds(i,j,l0)*w0+clouds(i,j,l1)*w1
            ! KAL.  +clouds(i,j,l2)*w2+clouds(i,j,l3)*w3
                  cc = clouds

            ! --- compute astronomic quantities

                  sin2=sin(rlat)*sin(decli)
                  cos2=cos(rlat)*cos(decli)

            ! --- split each day into ifrac parts, and compute the solar radiance for
            ! --- each part. by assuming symmetry of the irradiance about noon, it
            ! --- is sufficient to compute the irradiance for the first 12 hrs of
            ! --- the (24 hrs) day (mean for the first 12 hrs equals then the mean
            ! --- for the last 12 hrs)

                  scosz=0.
                  stot=0.
                  radmax=0.0

                  do npart=1,ifrac
                     bioday=day+(npart-.5)*fraci*.5
                     biohr=bioday*86400.                !hour of day in seconds
                     biohr=amod(biohr+43200.,86400.)    !hour of day;  biohr=0  at noon
                     hangle=pi2*biohr/86400.            !hour angle, in radians
                     cosz=amax1(0.,sin2+cos2*cos(hangle)) !cosine of the zenith angle
                     scosz=scosz+cosz                     !  ..accumulated..

                     srad =s0*sundv*cosz                  !extraterrestrial radiation

                     !print *,i,j,npart,srad,cosz,eepsil
                     ! obs: .7^100 = 3x10^-16 , an already ridicolously low number ...
                     sdir=srad*0.7**(min(100.,1./(cosz+eepsil)))    !direct radiation component
            !         sdir=srad*0.7**(1./(cosz+eepsil))    !direct radiation component
            !         sdir=srad * exp(-0.356674943938732447/(cosz+eepsil))

                     sdif=((1.-absh2o)*srad-sdir)*.5      !diffusive radiation component

                     altdeg=amax1(0.,asin(min(1.0,sin2+cos2)))*deg !solar noon altitude in degrees

                     cfac=(1.-0.62*cc+0.0019*altdeg)      !cloudiness correction

                     ssurf=(sdir+sdif)*cfac
                     radmax=max(radmax,ssurf)
                     stot=stot+ssurf
                  enddo
                  scosz=scosz*fraci                    !24-hrs mean of  cosz
                  radfl0=stot*fraci               !24-hrs mean shortw rad in w/m^2

                  cawdir=1.-amax1(0.15,0.05/(scosz+0.15))
                 ! print *,time,day,dangle,decli,sundv !,radfl0(63,95)
                                                       !co-albedo over water for dir light
                  end subroutine qsw

            !     -------------------------------------------------
                  SUBROUTINE SURLIG(H,MAXLIG,D,B,HEIGHT,SLIG)
            !     -------------------------------------------------
            !	  Surface irradiance after Skartveit & Olseth 1988
                      implicit none
                  REAL     B,D,DELTA,HEIGHT,H,P,V,MAXLIG
                  REAL     SLIG,H12,TWLIGHT

!f2py intent(in,overwrite) H,MAXLIG,D,B
!f2py intent(in,out,overwrite) HEIGHT,SLIG

            !     B:Degrees north
            !     DELTA: sun declination
            !     D: day of the year
            !     H: hour of day
            !     HEIGHT: sin(sunheight)
            !     IRR. irradiance above sea surface uEm-2s-1
            !     P: Pi
            !     R: factor for distance variations between sun-earth
            !     SLIG:surface light
            !     V: sunheight in degrees
            !     TWLIGHT: light at 0-degree sun
            !	  MAXLIG: level of irradiance at midday

                  P = 3.1415927
                  TWLIGHT = 5.76

                    DELTA = .3979*SIND(.9856*(D-80)+		&
                        1.9171*(SIND(.9856*D)-.98112))
                            H12 = DELTA*SIND(B*1.)-					&
                          SQRT(1.-DELTA**2)*COSD(B*1.)*COSD(15.*12)

                    HEIGHT = DELTA*SIND(B*1.)-					&
                             SQRT(1.-DELTA**2)*COSD(B*1.)*COSD(15.*H)

                    V = ASIND(HEIGHT)

                      IF (V .GE. 0.) THEN
                        SLIG = MAXLIG*(HEIGHT/H12) + TWLIGHT
                      ELSE IF (V .GE. -6.) THEN
                        SLIG = ((TWLIGHT - .048)/6.)*(6.+V)+.048
                      ELSE IF (V .GE. -12.) THEN
                        SLIG = ((.048 - 1.15E-4)/6.)*(12.+V)+1.15E-4
                      ELSE IF (V .GE. -18) THEN
                        SLIG = (((1.15E-4)-1.15E-5)/6.)*(18.+V)+1.15E-5
                      ELSE
                        SLIG = 1.15E-5
                      ENDIF

                    !WRITE(*,800)D,H,HEIGHT/H12,HEIGHT

            800   FORMAT(I4,3X,F5.2,3X,2(F15.10,2X))

                  RETURN

                  end subroutine surlig

end module calcLight


! RUN: bbc %s -o "-" | FileCheck %s

! Test integer intrinsic operation lowering to fir.

! CHECK-LABEL:eq0_test
LOGICAL FUNCTION eq0_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi eq, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
eq0_test = x0 .EQ. x1
END FUNCTION

! CHECK-LABEL:ne1_test
LOGICAL FUNCTION ne1_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi ne, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
ne1_test = x0 .NE. x1
END FUNCTION

! CHECK-LABEL:lt2_test
LOGICAL FUNCTION lt2_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi slt, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
lt2_test = x0 .LT. x1
END FUNCTION

! CHECK-LABEL:le3_test
LOGICAL FUNCTION le3_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi sle, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
le3_test = x0 .LE. x1
END FUNCTION

! CHECK-LABEL:gt4_test
LOGICAL FUNCTION gt4_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi sgt, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
gt4_test = x0 .GT. x1
END FUNCTION

! CHECK-LABEL:ge5_test
LOGICAL FUNCTION ge5_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:[[reg3:%[0-9]+]] = arith.cmpi sge, [[reg1]], [[reg2]] : i32
! CHECK:fir.convert [[reg3]] {{.*}} -> !fir.logical<4>
ge5_test = x0 .GE. x1
END FUNCTION

! CHECK-LABEL:add6_test
INTEGER(4) FUNCTION add6_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:addi [[reg1]], [[reg2]] : i32
add6_test = x0 + x1
END FUNCTION

! CHECK-LABEL:sub7_test
INTEGER(4) FUNCTION sub7_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:subi [[reg1]], [[reg2]] : i32
sub7_test = x0 - x1
END FUNCTION

! CHECK-LABEL:mult8_test
INTEGER(4) FUNCTION mult8_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:muli [[reg1]], [[reg2]] : i32
mult8_test = x0 * x1
END FUNCTION

! CHECK-LABEL:div9_test
INTEGER(4) FUNCTION div9_test(x0, x1)
INTEGER(4) :: x0
INTEGER(4) :: x1
! CHECK-DAG:[[reg1:%[0-9]+]] = fir.load %arg0
! CHECK-DAG:[[reg2:%[0-9]+]] = fir.load %arg1
! CHECK:arith.divsi [[reg1]], [[reg2]] : i32
div9_test = x0 / x1
END FUNCTION


PROGRAM SAMPLES_MAIN
! Test code that runs the VTMOP driver on one of the test problems from
! VTMOP_FUNC_MOD in serial execution mode.
!
! The outputs are printed to the file samples_out.txt

! Import the library of VTMOP interfaces.
USE VTMOP_LIB
! Import the library of sample multiobjective functions.
USE VTMOP_FUNC_MOD
IMPLICIT NONE

! Output file.
CHARACTER(LEN=20), PARAMETER :: OUTFILE = "samples_out.txt"

! Adjust the problem dimensions below. D is the number of design variables,
! and P is the number of objectives. Any values P >= 2 and D >= P are allowed.
INTEGER, PARAMETER :: D=5, P=3

! Set the following to FALSE if changing the objective function is changed.
LOGICAL, PARAMETER :: CHECK_MAE = .TRUE.

! Pointer to the objective function, defined in VTMOP_FUNC_MOD.
! Uncomment one the following.
!PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => CONVEX ! Convex Pareto front.
!PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => DTLZ1 ! Planar Pareto front.
PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => DTLZ2 ! Sphere Pareto front.
!PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => DTLZ3 ! Sphere Pareto front.
!PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => DTLZ5 ! Low-dim Pareto curve.
!PROCEDURE(VTMOP_MOD_OBJ_INT), POINTER :: OBJ_F => DTLZ7 ! Discont. Par. front.

! Local variables used for defining the problem.
INTEGER :: I ! Loop index.
INTEGER :: IERR ! Error flag.
REAL(KIND=R8) :: MU ! Working precision.
REAL(KIND=R8) :: LB(D), UB(D) ! Lower/upper bound constraints.
REAL(KIND=R8) :: OBJ_BOUNDS(P,2) ! Lower/upper objective bounds.
REAL(KIND=R8), ALLOCATABLE :: DB_X(:,:), DB_F(:,:) ! Full database
REAL(KIND=R8), ALLOCATABLE :: PARETO_X(:,:), PARETO_F(:,:) ! Solution set.

! Get the unit roundoff.
MU = EPSILON(0.0_R8)

! Set the bounds constraints.
LB(:) = 0.0_R8
UB(:) = 1.0_R8

! Don't use any objective bounds.
OBJ_BOUNDS(:,1) = -HUGE(0.0_R8)
OBJ_BOUNDS(:,2) = HUGE(0.0_R8)

! Call VTMOP driver to solve the problem.

! Do 1000 function evaluations with checkpointing.
CALL VTMOP_SOLVE( D, P, LB, UB, OBJ_F, PARETO_X, PARETO_F, IERR,   &
                  ADAPTIVE_SEARCH=.TRUE., BB_BUDGET=1000,          &
                  MAXITERS=1000, SEARCH_BUDGET=D,                  &
                  INITIAL_SBUDGET=2*D, LOPT_BUDGET=2500,           &
                  DECAY=0.5_R8, DES_TOL=SQRT(MU), EPS=SQRT(MU),    &
                  EPSW=MU**0.25_R8, OBJ_TOL=SQRT(MU),              &
                  MIN_RADF=0.02_R8, TRUST_RADF=0.2_R8,             &
                  DES_PTS=DB_X, OBJ_PTS=DB_F, LOCAL_OPT=GPS,       &
                  OBJ_BOUNDS=OBJ_BOUNDS, FIT_SURROGATES=LSHEP_FIT, &
                  EVAL_SURROGATES=LSHEP_EVAL, PFLAG=0, ICHKPT=1    )
IF (IERR .GE. 10) THEN
   WRITE(*,11) "An error occurred. IERR=", IERR; STOP; END IF

! Do another 1000 iterations in recovery mode to test the checkpoint recovery.
CALL VTMOP_SOLVE( D, P, LB, UB, OBJ_F, PARETO_X, PARETO_F, IERR,   &
                  ADAPTIVE_SEARCH=.TRUE., BB_BUDGET=2000,          &
                  MAXITERS=2000, SEARCH_BUDGET=D,                  &
                  INITIAL_SBUDGET=2*D, LOPT_BUDGET=2500,           &
                  DECAY=0.5_R8, DES_TOL=SQRT(MU), EPS=SQRT(MU),    &
                  EPSW=MU**0.25_R8, OBJ_TOL=SQRT(MU),              &
                  MIN_RADF=0.02_R8, TRUST_RADF=0.2_R8,             &
                  DES_PTS=DB_X, OBJ_PTS=DB_F, LOCAL_OPT=GPS,       &
                  OBJ_BOUNDS=OBJ_BOUNDS, FIT_SURROGATES=LSHEP_FIT, &
                  EVAL_SURROGATES=LSHEP_EVAL, PFLAG=0, ICHKPT=-1   )
IF (IERR .GE. 10) THEN
   WRITE(*,11) "An error occurred. IERR=", IERR; STOP; END IF

! Check the solution.
CALL CHECK_SOLUTION()

! Write the outputs to OUTFILE.
OPEN(99, FILE=OUTFILE, STATUS="REPLACE")

! Print the summary statistics.
WRITE(99,*) "Summary:"
WRITE(99,12) "Number of nondominated/efficient points: ", SIZE(PARETO_X,2)
WRITE(99,12) "Total number of function evaluations: ", SIZE(DB_X,2)

! Print the nondominated objective set.
WRITE(99,*)
WRITE(99,*) "Nondominated point set:"
DO I = 1, SIZE(PARETO_F, 2)
   WRITE(99,10) PARETO_F(:,I)
END DO

! Print the efficient set.
WRITE(99,*)
WRITE(99,*) "Efficient point set:"
DO I = 1, SIZE(PARETO_X, 2)
   WRITE(99,10) PARETO_X(:,I)
END DO

! Print the full database of observed objective points.
WRITE(99,*)
WRITE(99,*) "Full database of objective values observed:"
DO I = 1, SIZE(DB_F,2)
   WRITE(99,10) DB_F(:,I)
END DO

! Print the full database of design points evaluated.
WRITE(99,*)
WRITE(99,*) "Full database of evaluated design points:"
DO I = 1, SIZE(DB_X,2)
   WRITE(99,10) DB_X(:,I)
END DO

! Close the output file.
CLOSE(99)

! Free the output arrays.
DEALLOCATE(DB_F, DB_X, PARETO_F, PARETO_X)

! Output formats.
10 FORMAT(1X,5ES15.7)
11 FORMAT(1X,A,I3)
12 FORMAT(1X,A,I5)
13 FORMAT(2X,A)

CONTAINS

SUBROUTINE CHECK_SOLUTION
! Auxiliary subroutine for checking residuals against a tolerance,
! in the special case of DTLZ2.

! Local variables.
INTEGER :: N
REAL(KIND=R8) :: MAE, TOLERANCE
! N is the number of points on the Pareto front approximation.
N = SIZE(PARETO_F,2)
! The tolerance is a small number proportional to (P * D).
TOLERANCE = MAX(0.01_R8, SQRT(MU)) * REAL(P*D, KIND=R8)
! Compute the mean absolute error (MAE).
MAE = 0.0_R8
DO I = 1, N
   MAE = MAE + ABS(NORM2(PARETO_F(:,I)) - 1.0_R8)
END DO
MAE = MAE / REAL(N, KIND=R8)
! Perform sanity checks for correctness.
IF (N < P + 1) THEN
   WRITE(*,*) "The number of solution points is unreasonably low."
   WRITE(*,*) "An installation error may have occurred."
ELSE IF (CHECK_MAE .AND. MAE > TOLERANCE) THEN
   WRITE(*,*) "The MAE did not meet the tolerance."
   WRITE(*,*) "An installation error may have occurred."
ELSE
   WRITE(*,*) "The serial installation appears to be correct."
   WRITE(*,*) "The full output is contained in the file ", OUTFILE
END IF
RETURN
END SUBROUTINE CHECK_SOLUTION

END PROGRAM SAMPLES_MAIN


  subroutine src1_bous(meqn,mbc,mx,xlower,dx,q,maux,aux,t,dt)

      use bous_module

      implicit none

      integer, intent(in) :: meqn,mbc,mx,maux
      real(kind=8), intent(inout) ::   q(meqn,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: xlower, dx, t, dt

      real(kind=8)  q0(meqn,1-mbc:mx+mbc)
      real(kind=8) psi(mx+2)

      real(kind=8)   rk_stage(1:mx,4)
      real(kind=8) :: delt
      integer ::  i,k,ii,nstep,rk_order
      real(kind=8) tol,x
      integer(kind=4) INFO

      INTEGER            LDB
      INTEGER            IPIV( mx+2 )
      DOUBLE PRECISION   D(mx+2), DL(mx+1), DU(mx+1), DU2(1:mx)

      logical verbose

      verbose=.False.

!      ----------------------------------------------------------------
!
!      Boussinesq type-------------------------------------------------

     !nstep=ceiling(dt/dx*2*sqrt(2.))  ! ???
     !write(6,*) '+++ nstep = ',nstep
     nstep = 1

     k = 1

     delt=dt/nstep

     LDB = mx+2
     D  =0.d0
     DU =0.d0
     DL =0.d0
     DU2=0.d0

     rk_order = 2

     do ii=1,nstep

          call set_diag(mx,meqn,mbc,dx,q,maux,aux, DL, D, DU)

          call DGTTRF( mx+2, DL, D, DU, DU2, IPIV, INFO )

          psi = 0.d0
          rk_stage = 0.d0
          q0  = q

          !-----------------------
          if (rk_order == 2) then
          ! RK2

          ! First Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,1) = psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,1)

          ! Second Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,2)=psi(2:mx+1)

          q(2,1:mx) = q(2,1:mx)- delt*rk_stage(1:mx,2)

          endif ! rk_order==2

          !-----------------------
          if (rk_order == 4) then
          ! RK4

          ! First Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,1) = psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,1)

          ! Second Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,2)=psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt/2.d0*rk_stage(1:mx,2)

          ! Third Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,3)=psi(2:mx+1)

          q0(2,1:mx)=q(2,1:mx)-delt*rk_stage(1:mx,3)

          ! Fourth Stage

          call set_psi(mx,meqn,mbc,dx,q0,maux,aux,psi)

          call DGTTRS( 'N', mx+2, 1, DL, D, DU, DU2 &
                      , IPIV, psi, LDB,INFO )

          rk_stage(1:mx,4)=psi(2:mx+1)

          q(2,1:mx) = q(2,1:mx)- delt/6.d0*(rk_stage(1:mx,1) &
               + 2.d0*rk_stage(1:mx,2) &
               + 2.d0*rk_stage(1:mx,3) + rk_stage(1:mx,4))

          endif ! rk_order==4

      enddo

 999  continue

  end subroutine src1_bous

! =========================================================
      subroutine set_diag(mx,meqn,mbc,dx,q,maux,aux, DL, D, DU)
! =========================================================
      use bous_module
      use geoclaw_module, only: sea_level

      implicit none

      integer(kind=4) mx,meqn,mbc,maux,mxy
      integer(kind=4) i,k
      real(kind=8) dx

      real(kind=8)   q(meqn,1-mbc:mx+mbc)
      real(kind=8) aux(maux,1-mbc:mx+mbc)

      DOUBLE PRECISION   D(mx+2), DL(mx+1), DU(mx+1)

      real(kind=8), dimension(1-mbc:mx+mbc) :: h0, hh, hhh

      h0 = sea_level - aux(1,:)

        do i=1-mbc,mx+mbc
           hh(i)=(max(0.,h0(i)))**2
           hhh(i)=(max(0.,h0(i)))**3
        enddo

        D = 1.d0
        DU= 0.d0
        DL= 0.d0

        do i=1,mx

            if ((minval(q(1,i-2:i+2)) < 0.1d0) &
                .or. (minval(h0(i-2:i+2)) < 0.1d0)) then

            !if ((q(1,i)<0.1d0) .or. (h0(i)<0.1d0) .or. &
            !    (minval(h0(i-2:i+2))<0.1d0) .or. &
            !    (maxval(q(1,i-2:i+2))<0.1d0) .or. &
            !    (minval(h0(i-1:i+1))<=0.1d0)) then

              ! do nothing

            else

              D(i+1) = 1.d0 + 2.d0*(B_param+.5d0)*hh(i)/dx**2 &
                    -2.d0/6.d0*hhh(i)/h0(i)/dx**2

              DU(i+1)=-(B_param+.5d0)*hh(i)/dx**2 &
                    +1.d0/6.d0*hhh(i)/h0(i+1)/dx**2

              DL(i)=-(B_param+.5d0)*hh(i)/dx**2 &
                    +1.d0/6.d0*hhh(i)/h0(i-1)/dx**2

            endif

        enddo

      return
      end subroutine set_diag

!======================================================================
      subroutine set_psi(mx,meqn,mbc,dx,q,maux,aux,psi)

      use geoclaw_module, only: g => grav, sea_level
      use bous_module

      implicit none

      integer, intent(in) :: mx,meqn,mbc,maux
      real(kind=8), intent(in) :: dx

      real(kind=8), intent(in) ::  q(meqn,1-mbc:mx+mbc)
      real(kind=8), intent(in) :: aux(maux,1-mbc:mx+mbc)
      real(kind=8), intent(out) :: psi(mx+2)

      real(kind=8)  tol
      real(kind=8)  depth, depth0, depth1
      real(kind=8), dimension(1-mbc:mx+mbc) :: h0, hh, hhh, eta, hu2
      real(kind=8), dimension(1-mbc:mx+mbc) :: hetax,detax,s1,s1_h
      integer :: i,j,k,kk,iL,iR

      ! phase out dispersive term between depth0 and depth1:
      depth0 = 180.d0  ! pure SWE in shallower water than this
      depth1 = 190.d0  ! full Bouss in deeper water than this

      h0 = sea_level - aux(1,:)

         do i=1-mbc,mx+mbc
           if (q(1,i).gt.1d-4) then
              hu2(i)= q(2,i)**2/q(1,i)
             else
              hu2(i)= 0.d0
             endif
           eta(i)= q(1,i) - h0(i)
           hh(i)=(max(0.d0,h0(i)))**2
           hhh(i)=(max(0.d0,h0(i)))**3
        enddo

     hetax = 0.d0
     detax = 0.d0

         do i= 1,mx
         if (minval(h0(i-1:i+1)) > 0.d0) then
            if (i==1) then
                hetax(i)= q(1,i)*(eta(i+1)-eta(i))/dx
                detax(i)= h0(i)*(eta(i+1)-eta(i))/dx
            elseif (i==mx) then
                hetax(i)= q(1,i)*(eta(i)-eta(i-1))/dx
                detax(i)= h0(i)*(eta(i)-eta(i-1))/dx
            else
                hetax(i)= q(1,i)*(eta(i+1)-eta(i-1))/dx/2.
                detax(i)= h0(i)*(eta(i+1)-eta(i-1))/dx/2.
            endif
         endif
        enddo

     s1=0.d0
     s1_h=0.d0

     do i=1,mx
          if (i==1) then
             s1(i)= (hu2(i+1)-hu2(i))/dx
          elseif (i==mx) then
             s1(i)= (hu2(i)-hu2(i-1))/dx
          else
             s1(i)= (hu2(i+1)-hu2(i-1))/2.d0/dx
          endif

          s1(i)= s1(i)+g*hetax(i)

           if (h0(i) > 0.1d0) then
              s1_h(i)=s1(i)/h0(i)
           else
              s1_h(i)=0.d0
           endif
     enddo

      tol = 1d-8

      psi=0.d0

        do i=1,mx

           k = i+1

           if ((h0(i) < depth0) .or. (q(1,i) < depth0)) then
              ! no dispersive term:
              psi(k) = 0.d0

           else

              if (i==1) then

                     psi(k)=(B_param+.5d0)*hh(i)* &
                      (s1(i+2)-2.d0*s1(i+1)+s1(i))/dx**2. &
                     -B_param*g*hh(i)* &
                      (detax(i+2)-2.d0*detax(i+1)+detax(i))/dx**2 &
                     -hhh(i)/6.d0*(s1_h(i+2)-2.d0*s1_h(i+1) &
                     +s1_h(i))/dx**2

              elseif (i==mx) then

                     psi(k)=(B_param+.5d0)*hh(i)* &
                      (s1(i)-2.d0*s1(i-1)+s1(i-2))/dx**2. &
                     -B_param*g*hh(i)* &
                      (detax(i)-2.d0*detax(i-1)+detax(i-2))/dx**2 &
                     -hhh(i)/6.d0*(s1_h(i)-2.d0*s1_h(i-1) &
                     +s1_h(i-2))/dx**2

              else

                  psi(k)=(B_param+.5d0)*hh(i)* &
                   (s1(i+1)-2.d0*s1(i)+s1(i-1))/dx**2. &
                  -B_param*g*hh(i)* &
                   (detax(i+1)-2.d0*detax(i)+detax(i-1))/dx**2 &
                  -hhh(i)/6.d0*(s1_h(i+1)-2.d0*s1_h(i) &
                  +s1_h(i-1))/dx**2

              endif
           endif

        if (h0(i) .lt. depth1) then
            ! reduce psi linearly between depth0 and depth1:
            psi(k) = psi(k) * (h0(i)-depth0)/(depth1-depth0)
            endif

        enddo

 994  continue

      return
      end subroutine set_psi


! This program is to build CMB fisher matrix using the outputs of CAMB

Program fisherCMB
implicit none

integer:: numfid !number of fiducial parameters
real:: percentage !variant of the fiducial parameters
double precision, dimension(2:3000,3,3):: R_fid=0, C_fid=0, R_fid_inv=0 !for l=2 to 3000, not neccessarily to 3000 (1,1) for TT (1,2) for TE, (2,2) for EE, (3,3) for BB
double precision:: detR
double precision, dimension(2:3000,3,3,2,30):: C_p, C_m !variant powerspectrum for plus and minus delta
character(len=80):: input_fid='cambout/camb_fid_lensedtotCls.dat'
character(len=80), dimension(2,30):: inputfiles !2 for p and m, 30 just to prepare up 30 params
character(len=80), dimension(80):: store !for storing the variant matrix
integer:: file_unit=9, storefile_unit=900 !unit of the file
integer:: l, m, n, l_BB_max=512 !multiple
double precision:: cltt, clee, clbb, clte !TT,EE,BB,TE
double precision:: clttp, cleep, clbbp, cltep !delta plus TT,EE,BB,TE
double precision:: clttm, cleem, clbbm, cltem !delta minus TT,EE,BB,TE
double precision:: dcltt, dclee, dclbb, dclte
double precision, dimension(30):: params=0
double precision, dimension(30,30):: fisher=0
double precision:: dfisher
double precision:: fsky
double precision:: r1,r2,r3,r12,cm1,cm2,cm3,cm12,cn1,cn2,cn3,cn12
double precision:: total_n_BB, N_TT, N_EE

!!!!!!!!!!!
!prepare for potential input files
INCLUDE 'trunk/storederivate'
!!!!!!!!!!!

write(*,*)'Enter the sky fraction (e.g. 0.65)'
read(*,*)fsky

!!!!!!!!!!read in fiducial parameters
open(unit=800,file='trunk/paramfid.dat',status='unknown')
read(800,*)numfid
read(800,*)percentage
do m=1,numfid
    read(800,*)params(m)
	end do
close(800)

!read in the fiducial power spectrum
open(unit=17,file=input_fid,status='unknown')
open(unit=207,file='total_uncertainty/total_BB_COrE.txt',status='unknown')
open(unit=208,file='total_uncertainty/N_TT_pre.txt',status='unknown')
open(unit=209,file='total_uncertainty/N_EE_pre.txt',status='unknown')

100 read(17,*,end=101)l, cltt, clee, clbb, clte
!!!!!!!!!!!!! Important! C_X in Camb is C_L*l*(l+1)/(2pi)
    C_fid(l,1,1)=cltt/l/(l+1)*2*3.14159265
	C_fid(l,1,2)=clte/l/(l+1)*2*3.14159265
	C_fid(l,2,1)=clte/l/(l+1)*2*3.14159265
	C_fid(l,2,2)=clee/l/(l+1)*2*3.14159265
	C_fid(l,3,3)=clbb/l/(l+1)*2*3.14159265
	read(208,*)N_TT
	read(209,*)N_EE
	R_fid(l,1,1)=C_fid(l,1,1)+N_TT
	R_fid(l,1,2)=C_fid(l,1,2)+N_EE
	R_fid(l,2,1)=C_fid(l,2,1)
	R_fid(l,2,2)=C_fid(l,2,2)
	! Using BB up to l_BB_maxx
	if (l<=l_BB_max) then
	   read(207,*)total_n_BB
	   R_fid(l,3,3)=C_fid(l,3,3)+total_n_BB
	else
	   R_fid(l,3,3)=1.0
	end if
	!take the inverse of R_fid
	detR=(R_fid(l,1,1)*R_fid(l,2,2)-R_fid(l,1,2)*R_fid(l,2,1))*R_fid(l,3,3)
	R_fid_inv(l,1,1)=R_fid(l,2,2)*R_fid(l,3,3)/detR
	R_fid_inv(l,2,2)=R_fid(l,1,1)*R_fid(l,3,3)/detR
	R_fid_inv(l,1,2)=-R_fid(l,2,1)*R_fid(l,3,3)/detR
	R_fid_inv(l,2,1)=R_fid_inv(l,1,2)
    R_fid_inv(l,3,3)=1/R_fid(l,3,3)
	!End taking the inverse of R_fid
	open(unit=storefile_unit,file='trunk/R_fid_inv.dat',status='unknown')
	write(storefile_unit,*)l, R_fid_inv(l,1,1),R_fid_inv(l,2,2),R_fid_inv(l,3,3),R_fid_inv(l,1,2)
    goto 100
101 continue
    close(207)
	close(208)
	close(209)
    close(17)
	close(storefile_unit)
    file_unit=file_unit+1
	storefile_unit=storefile_unit+1

!!!!!!!!!!!!!!!!read in variant inputs and calculate the fist derivative
!!!!!Read in
    do m=1,numfid
	    open(unit=file_unit,file=inputfiles(1,m),status='unknown')
	 	open(unit=file_unit+1,file=inputfiles(2,m),status='unknown')
		open(unit=storefile_unit,file=store(m),status='unknown')
	200 read(file_unit,*,end=201)l, clttp, cleep, clbbp, cltep
	    read(file_unit+1,*)l, clttm, cleem, clbbm, cltem
		!!!!!!!!!!!!! Important! C_X in Camb is C_L*l*(l+1)/(2pi)
		dcltt=(clttp-clttm)/(2*percentage*params(m))/l/(l+1)*2*3.14159265
		dclee=(cleep-cleem)/(2*percentage*params(m))/l/(l+1)*2*3.14159265
		dclbb=(clbbp-clbbm)/(2*percentage*params(m))/l/(l+1)*2*3.14159265
		dclte=(cltep-cltem)/(2*percentage*params(m))/l/(l+1)*2*3.14159265
		write(storefile_unit,*)dcltt, dclee, dclbb, dclte
	    goto 200
	201 continue
	    close(file_unit)
		close(file_unit+1)
		close(storefile_unit)
	    file_unit=file_unit+2
		storefile_unit=storefile_unit+1
	end do
!!!!!!!!!!!!!!!!End read in variant inputs and calculate the fist derivative

!!!!!!!!!!Calculate the fisher matrix
open(unit=600,file='trunk/R_fid_inv.dat')
!!! for diagonal elements
do m=1,numfid
open(unit=601,file=store(m),status='unknown')
rewind 600
301 read(600,*,end=300)l,r1,r2,r3,r12
    read(601,*)cm1,cm2,cm3,cm12
    dfisher=(r1*cm1+r12*cm12)**2
	dfisher=dfisher+2.0*(r1*cm12+r12*cm2)*(r12*cm1+r2*cm12)
	dfisher=dfisher+(r12*cm12+r2*cm2)**2
	if (l<=l_BB_max) then
	  dfisher=dfisher+r3*r3*cm3*cm3
	end if
	dfisher=(l+0.5)*dfisher
	fisher(m,m)=fisher(m,m)+dfisher
    go to 301
300 continue
    close(601)
	fisher(m,m)=fisher(m,m)*fsky
end do

!!!! for off diagonal elements
do m=1,numfid
    do n=m+1,numfid
	rewind 600
    open(unit=601,file=store(m),status='unknown')
    open(unit=602,file=store(n),status='unknown')
	401 read(600,*,end=400)l,r1,r2,r3,r12
	    read(601,*)cm1,cm2,cm3,cm12
	    read(602,*)cn1,cn2,cn3,cn12
		dfisher=(r1*cm1+r12*cm12)*(r1*cn1+r12*cn12)
		dfisher=dfisher+(r1*cm12+r12*cm2)*(r12*cn1+r2*cn12)
		dfisher=dfisher+(r1*cn12+r12*cn2)*(r12*cm1+r2*cm12)
		dfisher=dfisher+(r12*cm12+r2*cm2)*(r12*cn12+r2*cn2)
		if (l<=l_BB_max) then
		dfisher=dfisher+r3*r3*cm3*cn3
		end if
		dfisher=(l+0.5)*dfisher
		fisher(m,n)=fisher(m,n)+dfisher
	    goto 401
	400 continue
	close(601)
	close(602)
	fisher(m,n)=fsky*fisher(m,n)
	fisher(n,m)=fisher(m,n)
	end do
end do
!!!!End calculating fisher matrix

!!!!!!!output the fisher matrix in fisher.txt
open(unit=1000,file='fisher.txt')
do m=1,numfid
write(1000,66)fisher(m,1:numfid)
66 format(es13.6, es18.6, es18.6, es18.6, es18.6, es18.6, es18.6, es18.6)
end do
close(1000)

END program fisherCMB