module formal_cep
use variables
use general
use short_ch
use maths
use atmosfer
use statis
implicit none
contains

! *********************************************************
! *********************************************************
! CEP METHOD SOLUTION ROUTINES
! *********************************************************
! *********************************************************

!---------------------------------------------------------
! This function calculates the beta function
!---------------------------------------------------------
	function beta2(tau_in)
   real(kind=8) :: beta2, tau_in, salida, tau, coef
   real(kind=8) :: d, b, q, dbdx
   integer :: k

! KROLIK & McKEE APPROXIMATION
   	coef = 1.d0/(6.d0*sqrt(3.d0))
   	tau = tau_in / dsqrt(PI)
   	if (tau < 1.d-4) then
			salida = 1.d0
		else
			if (tau >= 3.41d0) then
   			salida = 1.d0 / (dsqrt(PI)*tau) * ( dsqrt(log(tau)) + 0.25d0 / dsqrt(log(tau)) + 0.14d0)
   		else
				salida = 1.d0 - 0.415d0*tau + 0.355d0*tau*log(tau)
   			dbdx = 0.355 -0.415 + 0.355*log(tau)
   			k = 1
   			d = tau * coef
   			b = 2.d0 * d
   			q = 1.d0
          	do while (q > 1.d-3)
            	salida = salida - d * tau
            	dbdx = dbdx - b
             	k = k + 1
             	d = -d * tau * sqrt((k+1.d0)/(k+2.d0))*(k-1.d0)/(k*(k+2.d0))
             	b = (k+1.d0) * d
             	q = abs(b/dbdx)
            enddo
	   	endif
		endif

! Calculation of the beta function by integrating the E3 exponential integral function
!   	if (tau_in == 0.d0) then
!			beta2 = 1.d0
!			return
!   	endif

!		salida = 0.d0
!   	if (tau_in /= 0.d0) then
!   		do i = 1, n_quadr_beta
!   			salida = salida + w_e3(i)*(0.5d0-expint(3,tau_in*exp(-x_e3(i)**2)/sqrt(PI))) / tau_in
!   		enddo
!   	endif

   	beta2 = salida

   end function beta2

!-------------------------------------------------------------------
! Solves a system of nonlinear equations using the Newton method
!-------------------------------------------------------------------
	subroutine mnewt(ntrial,x,n,tolx,tolf,derivatives)
	integer :: n,ntrial
	real(kind=8) :: tolf,tolx,x(n)
	logical :: derivatives
	integer :: i,k
	real(kind=8) :: errf,errx,fjac(n,n),fvec(n),p(n), tol
	integer, allocatable :: indx(:)

		errf = 1.d10
		do k=1,ntrial
			call usrfun(x,n,fvec,fjac, derivatives)   !User subroutine supplies function values at x in fvec

			do i=1,n  !Check function convergence.
				errf=errf+dabs(fvec(i))
			enddo
			if (errf <= tolf) then
				return
			endif
			p = -fvec

			allocate(indx(n))
			tol = 1.d-10
			call ludcmp(fjac,indx,tol)
			call lubksb(fjac,indx,p)
			deallocate(indx)

			errx=0.d0  ! Check root convergence.
			x = x + p

			do i=1,n   !Update solution.
				errx=errx+dabs(p(i))
			enddo
			if(errx <= tolx) then
				print *, 'Iteration ',k, '   rel_error: ',errx
				write(12,*) k, errx
				return
			endif

			print *, 'Iteration ',k, '   rel_error: ',errx
			write(12,*) k, errx
		enddo

	end subroutine mnewt

!-----------------------------------------------------------------
! Calculate Jbar_total and Lstar_total for this model and atmosphere
!-----------------------------------------------------------------
	subroutine formal_solver_jacobi_cep(x)
	real(kind=8) :: x(:)
	integer :: up, low, it, ip, ipl, ipt, ip1
	real(kind=8) :: sig, glu, acon, chim, chip, tau0

		do it = 1, nr

! Calculate opacities and source functions
!			call opacity(it,npmip1,1,n_radios)
			up = itran(1,it)
			low = itran(2,it)
			sig = dtran(1,it) / dtran(4,it) !sig=(h*nu*Blu)/(4*pi*Dnudoppler)
			glu = dlevel(2,low) / dlevel(2,up)
			acon = 1.4743d-2 * (1.d-15 * dtran(2,it))**3  !acon = (2*h*nu**3)/c**2

! Line opacity, line source function and Planck function.

			tau0 = 0.d0
			chip = 0.d0
			chim = 0.d0
			ip1 = 1
			do ip = 1, n_radios
				ipl = nl * (ip-1)

				chil(ip) = sig * (x(low+ipl) - glu * x(up+ipl))
				Sl(ip) = acon * glu * x(up+ipl) / (x(low+ipl) - glu * x(up+ipl))

				dSldn(ip,up+ipl) = acon*glu / (x(low+ipl) - glu * x(up+ipl))**2 * x(low+ipl)
				dSldn(ip,low+ipl) = -acon*glu / (x(low+ipl) - glu * x(up+ipl))**2 * x(up+ipl)

				B(ip) = acon * glu * popl(up+ipl) / (popl(low+ipl) - glu * popl(up+ipl))

			enddo

			if (verbose_flag == 1) then
				if (mod(it,10) == 0) then
					write(*,*) '       Transition : ', it
				endif
         endif

! Calculate outer boundary condition for this transition
        	call calcula_fondo(it)

! Calculate inner boundary condition for this transition
        	call calcula_centro(it)

! Do the formal solution of the RTE
			call rtpp_cep(n_radios, it)

! Build up the Lstar_total and Jbar_total matrices. These are necessary for the construction
! of the rate matrix
			do ip = 1, n_radios
				ipt = nr*(ip-1)
				Lstar_total(it+ipt) = lstar(ip)
				Jbar_total(it+ipt) = Jbar(ip)
				dJbar_totaldn(it+ipt,:) = dJbardn(ip,:)
			enddo

		enddo

	end subroutine formal_solver_jacobi_cep

!---------------------------------------------------------
! This subroutine solves the radiative transfer equation using the
! coupled escape probability scheme developed by Moshe Elitzur
!---------------------------------------------------------
   subroutine rtpp_cep(np,it)
	integer :: np, it
   integer :: i, j
   real(kind=8) :: tau_local, escape, delta_tau(4), alpha_tau(4)

   Jbar = 0.d0
	Lstar = 0.d0
!	flux = 0.d0
	dJbardn = 0.d0

	do i = 1, np
		tau_local = dabs(tau(it,i) - tau(it,i-1))

		escape = beta2(tau_local)

		Jbar(i) = Sl(i) * (1.d0 - escape)
		dJbardn(i,:) = dSldn(i,:) * (1.d0 - escape)

		Lstar(i) = (1.d0 - escape)

! Boundary condition
! There is a problem because the CEP method is based on zones, rather than in grid points
		escape = beta2(tau(it,i))
		Jbar(i) = Jbar(i) + 0.5d0*(fuera(1)+dentro(1)) * tau(it,i) * escape / tau_local

		escape = beta2(tau(it,i-1))
		Jbar(i) = Jbar(i) - 0.5d0*(fuera(1)+dentro(1)) * tau(it,i-1) * escape / tau_local

		do j = 1, np
			if (j /= i) then
				alpha_tau = 0.d0

				delta_tau(1) = dabs(tau(it,i) - tau(it,j))
				escape = beta2(delta_tau(1))
				alpha_tau(1) = delta_tau(1) * escape

				delta_tau(2) = dabs(tau(it,i-1) - tau(it,j))
				escape = beta2(delta_tau(2))
				alpha_tau(2) = delta_tau(2) * escape

				delta_tau(3) = dabs(tau(it,i) - tau(it,j-1))
				escape = beta2(delta_tau(3))
				alpha_tau(3) = delta_tau(3) * escape

				delta_tau(4) = dabs(tau(it,i-1) - tau(it,j-1))
				escape = beta2(delta_tau(4))
				alpha_tau(4) = delta_tau(4) * escape

				Jbar(i) = Jbar(i) + 0.5d0 * Sl(j) / tau_local * &
					(alpha_tau(1) - alpha_tau(2) - alpha_tau(3) + alpha_tau(4))

				dJbardn(i,:) = dJbardn(i,:) + 0.5d0 * dSldn(j,:) / tau_local * &
					(alpha_tau(1) - alpha_tau(2) - alpha_tau(3) + alpha_tau(4))

			endif
		enddo

!		flux(np) = flux(np) + (1.d0-Jbar(i)/Sl(i)) * Sl(i) * tau_local
	enddo

   end subroutine rtpp_cep

!-------------------------------------------------------------------
! Returns the value of the equations of the nonlinear set to be solved
!-------------------------------------------------------------------
	subroutine funcv_analytic(x,n,fvec,fjac)
	integer :: n
	real(kind=8) :: x(n), fvec(n), fjac(n,n)
	integer :: ip
	integer :: low, up, ipl, ipt, i, j, il, it, il2
	real(kind=8) :: A(nl, nl), A2(nl,nl), B(nl), populat(nl), producto(nl), cul, acon, blu, glu, djbar, poptot
	real(kind=8), allocatable :: jac(:,:,:)

		allocate(jac(nl,nl,n))

		call calc_tau
		call formal_solver_jacobi_cep(x)

		do ip = 1, n_radios

! Offsets for storing
			ipl = nl*(ip-1)
			ipt = nr*(ip-1)

			A = 0.d0
			jac = 0.d0

! Upward collisional rates A(low,up)
			call collis(ip,A)

! Calculate the downward rates and interchange the positions
			do i = 1, nl
				do j = 1, i-1
					cul = A(i,j)
! Rate into de j-th level
					A(j,i) = cul
! Rate into de i-th level
					A(i,j) = popl(i+ipl) / popl(j+ipl) * cul
				enddo
			enddo

! Active radiative rates (preconditioning)
			do it = 1, nact

				up = itran(1,it)
				low = itran(2,it)
				acon = 1.4743d-2 * (1.d-15 * dtran(2,it))**3  !acon = (2*h*nu**3)/c**2
				blu = PI4H * dtran(1,it) / dtran(2,it)
				glu = dlevel(2,low) / dlevel(2,up)

				djbar = Jbar_total(it+ipt)

				A(low,up) = A(low,up) + glu * blu * (acon + djbar )
				A(up,low) = A(up,low) + blu * djbar

				jac(low,up,:) = jac(low,up,:) + glu * blu * dJbar_totaldn(it+ipt,:)
				jac(up,low,:) = jac(up,low,:) + blu * dJbar_totaldn(it+ipt,:)

			enddo

! Background radiative rates
			do it = nact + 1, nr

				up = itran(1,it)
				low = itran(2,it)
				acon = 1.4743d-2 * (1.d-15 * dtran(2,it))**3  !acon = (2*h*nu**3)/c**2
				blu = PI4H * dtran(1,it) / dtran(2,it)
				glu = dlevel(2,low) / dlevel(2,up)

				A(low,up) = A(low,up) + glu * blu * (acon + Jbar_total(it+ipt))
				A(up,low) = A(up,low) + blu * Jbar_total(it+ipt)

				jac(low,up,:) = jac(low,up,:) + glu * blu * dJbar_totaldn(it+ipt,:)
				jac(up,low,:) = jac(up,low,:) + blu * dJbar_totaldn(it+ipt,:)

			enddo

! The system is homogeneous with null determinant. We have to substitute one of the equations by a closure
! relation. The sum over one column gives the total output rate from level i
			do i = 1, nl

				do j = 1, i-1
					A(i,i) = A(i,i) - A(j,i)
					jac(i,i,:) = jac(i,i,:) - jac(j,i,:)
				enddo
				do j = i+1, nl
					A(i,i) = A(i,i) - A(j,i)
					jac(i,i,:) = jac(i,i,:) - jac(j,i,:)
				enddo

			enddo

			A2 = A

! Conservation equation
			B = 0.d0
			A(nl, 1:nl) = 1.d0
			jac(nl, 1:nl, :) = 0.d0

			poptot = datph(3,ip) * nh(ip)
			B(nl) = poptot

			do il = 1, nl
				populat(il) = x(il+ipl)
			enddo

! Return the rate equations
			producto = matmul(A,populat)-B

			do il = 1, nl
				fvec(il+ipl) = producto(il)
			enddo

! Analytical Jacobian. Since the equations are F_j = sum(A_jk * n_k, k) - b_j, the Jacobian J_ji is
! J_ji = dF_j/dn_i = sum(dA_jk/dn_i * n_k,k) + sum(A_jk * dn_k/dn_i,k) = sum(dA_jk/dn_i * n_k,k) + A_ji
			do il = 1, nl
				do il2 = 1, nl
					fjac(il+ipl,il2+ipl) = A(il,il2)
				enddo
				do il2 = 1, nl*n_radios
					fjac(il+ipl,il2) = fjac(il+ipl,il2) + sum(jac(il,:,il2)*populat)
				enddo
			enddo

		enddo

		deallocate(jac)

	end subroutine funcv_analytic

!-------------------------------------------------------------------
! Returns the value of the equations of the nonlinear set to be solved
!-------------------------------------------------------------------
	subroutine funcv(x,n,fvec)
	integer :: n
	real(kind=8) :: x(n), fvec(n)
	integer :: ip
	integer :: low, up, ipl, ipt, i, j, il, it
	real(kind=8) :: A(nl, nl), B(nl), populat(nl), producto(nl), cul, acon, blu, glu, djbar, poptot

		call formal_solver_jacobi_cep(x)

		do ip = 1, n_radios

! Offsets for storing
			ipl = nl*(ip-1)
			ipt = nr*(ip-1)

			A = 0.d0

! Upward collisional rates A(low,up)
			call collis(ip,A)

! Calculate the downward rates and interchange the positions
			do i = 1, nl
				do j = 1, i-1
					cul = A(i,j)
! Rate into de j-th level
					A(j,i) = cul
! Rate into de i-th level
					A(i,j) = popl(i+ipl) / popl(j+ipl) * cul
				enddo
			enddo

! Active radiative rates (preconditioning)
			do it = 1, nact

				up = itran(1,it)
				low = itran(2,it)
				acon = 1.4743d-2 * (1.d-15 * dtran(2,it))**3  !acon = (2*h*nu**3)/c**2
				blu = PI4H * dtran(1,it) / dtran(2,it)
				glu = dlevel(2,low) / dlevel(2,up)

				djbar = Jbar_total(it+ipt)

				A(low,up) = A(low,up) + glu * blu * (acon + djbar )
				A(up,low) = A(up,low) + blu * djbar

			enddo

! Background radiative rates
			do it = nact + 1, nr

				up = itran(1,it)
				low = itran(2,it)
				acon = 1.4743d-2 * (1.d-15 * dtran(2,it))**3  !acon = (2*h*nu**3)/c**2
				blu = PI4H * dtran(1,it) / dtran(2,it)
				glu = dlevel(2,low) / dlevel(2,up)

				A(low,up) = A(low,up) + glu * blu * (acon + Jbar_total(it+ipt))
				A(up,low) = A(up,low) + blu * Jbar_total(it+ipt)

			enddo

! The system is homogeneous with null determinant. We have to substitute one of the equations by a closure
! relation. The sum over one column gives the total output rate from level i
			do i = 1, nl

				do j = 1, i-1
					A(i,i) = A(i,i) - A(j,i)
				enddo
				do j = i+1, nl
					A(i,i) = A(i,i) - A(j,i)
				enddo

			enddo

! Conservation equation
			B = 0.d0
			A(nl, 1:nl) = 1.d0

			poptot = datph(3,ip) * nh(ip)
			B(nl) = poptot

			do il = 1, nl
				populat(il) = pop(il+ipl)
			enddo

! Return the rate equations
			producto = matmul(A,populat)-B

			do il = 1, nl
				fvec(il+ipl) = producto(il)
			enddo
		enddo

	end subroutine funcv

!-------------------------------------------------------------------
! Calculates the Jacobian using forward-differences
!-------------------------------------------------------------------
	subroutine fdjac(n,x,fvec,df)
	integer :: n
	real(kind=8) :: df(n,n),fvec(n),x(n),EPS
	PARAMETER (EPS=1.d-4)
	integer :: i,j
	real(kind=8) :: h,temp,f(n)

		do j=1,n
			temp=x(j)
			h=EPS*dabs(temp)
			if(h.eq.0.d0)h=EPS
			x(j)=temp+h
			h=x(j)-temp
			call funcv(x,n,f)
			x(j)=temp
			do i=1,n
				df(i,j)=(f(i)-fvec(i))/h
			enddo
		enddo

	end subroutine fdjac

!-------------------------------------------------------------------
! Returns the equations and the Jacobian of the nonlinear set to be solved at point x
!-------------------------------------------------------------------
	subroutine usrfun(x,n,fvec,fjac, derivatives)
	integer :: n
	logical :: derivatives
	real(kind=8) :: x(n), fvec(n), fjac(n,n)

		fjac = 0.d0

! Analytical derivatives
		if (derivatives) then
			call funcv_analytic(x,n,fvec,fjac)
		else
! Numerical derivatives
			call funcv(x,n,fvec)
			call fdjac(n,x,fvec,fjac)
		endif

	end subroutine usrfun

end module formal_cep


!##############################################################################
! PROGRAM portfoliochoice
!
! ## Optimal portfolio choice, tangent portfolio, optimal risk exposure
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program portfoliochoice

    use toolbox

    implicit none
    integer, parameter :: TT = 5        ! number of time periods
    integer, parameter :: NN = 3        ! number of stocks
    real*8, parameter :: gamma = 10d0   ! risk aversion
    real*8, parameter :: r_f = 0.05     ! the risk free rate

    real*8 :: omega_mv(NN), omega_tan(NN), omega(NN), omega_f
    real*8 :: mu(NN), sig(NN,NN), siginv(NN,NN), ID(NN)
    real*8 :: mu_mv, sig_mv, mu_tan, sig_tan, mu_p, sig_p

    integer :: ii
    real*8 :: a, b, c, x1(0:100), y1(0:100)

    ! get returns and their statistical properties
    call returns

    ! invert variance-covariance matrix
    siginv = lu_invert(sig)

    ! derive parameters
    a = dot_product(matmul(ID, siginv), ID)
    b = dot_product(matmul(ID, siginv), mu)
    c = dot_product(matmul(mu, siginv), mu)

    ! calculate minimum variance portfolio
    omega_mv = matmul(siginv,ID)/dot_product(matmul(ID,siginv),ID)

    ! check riskless interest rate
    if(dot_product(mu, omega_mv) < r_f)then
        write(*,'(a)') 'Riskless interest rate is too high!'
        stop
    endif

    ! compute tangent portfolio
    omega_tan = matmul(siginv, mu - r_f)

    ! get investors choice
    omega = omega_tan/gamma
    omega_f = 1d0 - sum(omega)

    ! normalize tangent portfolio shares to 1
    omega_tan = omega_tan/sum(omega_tan)

    ! compute returns and variances
    mu_mv   = dot_product(mu, omega_mv)
    sig_mv  = dot_product(omega_mv, matmul(sig, omega_mv))
    mu_tan  = dot_product(mu, omega_tan)
    sig_tan = dot_product(omega_tan, matmul(sig, omega_tan))
    mu_p    = R_f*omega_f + dot_product(mu, omega)
    sig_p   = dot_product(omega, matmul(sig, omega))

    ! print results
    write(*,'(a,3f8.3)')'Expected return risky asset',(mu(ii), ii = 1, 3)
    write(*,*)
    write(*,'(a,3f8.3)')'Variance-covariance matrix ',(sig(1,ii), ii = 1, 3)
    write(*,'(a,3f8.3)')'                           ',(sig(2,ii), ii = 1, 3)
    write(*,'(a,3f8.3)')'                           ',(sig(3,ii), ii = 1, 3)
    write(*,*)
    write(*,'(a)') 'Portfolio shares:   Riskless   Stock 1   Stock 2   Stock 3      mu_p     sig_p'
    write(*,'(a,10x,5f10.4)')'MV Portfolio      ', omega_mv(1), omega_mv(2), omega_mv(3), mu_mv, sig_mv
    write(*,'(a,10x,5f10.4)')'Tangent Portfolio ', omega_tan(1), omega_tan(2), omega_tan(3), mu_tan, sig_tan
    write(*,'(a,6f10.4)')'Optimal Portfolio ', omega_f, omega(1), omega(2), omega(3), mu_p, sig_p

    ! create plot data for efficient portfolios
    do ii = 0, 100
        x1(ii) = 1d0/1000d0*dble(ii+20)
    enddo
    y1 = (a*x1**2 - 2*b*x1+c)/(a*c - b**2)

    call plot(y1, x1)
    call plot((/1d0/a/), (/b/a/), marker=7, markersize=1.5d0, noline=.true., legend='MV Portfolio')
    call plot((/sig(1, 1)/), (/mu(1)/), marker=7, markersize=1.5d0, noline=.true., legend='Stock 1')
    call execplot(xlabel='Portfolio Variance', ylabel='Portfolio Mean Return')

contains

    ! get returns and statictical properties
    subroutine returns

        implicit none
        integer :: ii, ij
        real*8 :: odat(0:TT,NN), r(TT,NN)

        ! set vector of ones
        ID(:) = 1.0d0

        ! initialize price data
        odat(0,:) = (/ 1.00d0, 2.00d0, 3.00d0 /)
        odat(1,:) = (/ 1.02d0, 2.65d0, 2.80d0 /)
        odat(2,:) = (/ 1.17d0, 2.40d0, 4.50d0 /)
        odat(3,:) = (/ 1.08d0, 2.70d0, 4.20d0 /)
        odat(4,:) = (/ 1.16d0, 2.85d0, 3.20d0 /)
        odat(5,:) = (/ 1.26d0, 2.75d0, 4.20d0 /)

        ! compute return per period
        do ii = 1, NN
            do ij = 1, TT
                r(ij, ii) = odat(ij, ii)/odat(ij-1, ii)-1d0
            enddo
        enddo

        ! compute expected value
        do ii = 1, NN
            mu(ii) = sum(r(:, ii))/dble(TT)
        enddo

        ! compute covariance matrix
        do ii = 1, NN
            do ij = 1, NN
                sig(ii, ij) = dot_product(r(:, ii)-mu(ii), r(:, ij)-mu(ij))
            enddo
        enddo
        sig = sig/dble(TT)

    end subroutine

end program


!***********************************************************************
!                                                                      *
      SUBROUTINE TFPOT
!                                                                      *
!   Calculation of the universal Thomas-Fermi potential.               *
!                                                                      *
!   Call(s) to: [LIB92]: DRAW.                                         *
!                                                                      *
!                                         Last revision: 09 Dec 1992   *
!                                                                      *
!***********************************************************************
!
!...Translated by Pacific-Sierra Research 77to90  4.3E  11:06:21   1/ 2/07
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEBUG_C
      USE DEF_C, ONLY: Z, NELEC
      USE GRID_C
      USE NPOT_C, ONLY: ZZ
      USE ORB_C
      USE POTE_C, ONLY: YP
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE draw_I
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: I, NB3, NROWS, II, II1, II2, II3
      REAL(DOUBLE) :: THIRD, WA, WB, WC, WD, WE, WF
!-----------------------------------------------
!
!
      THIRD = 1.0D00/3.0D00
!
      WA = Z - DBLE(NELEC - 1)
      WB = MAX(Z - WA,0.0D00)
      WB = WB**THIRD/0.8853D00
      DO I = 1, N
!
!   Rational function approximation to the universal Thomas-Fermi
!   function
!
         WC = SQRT(WB*R(I))
         WD = WC*(0.60112D0*WC + 1.81061D0) + 1.0D00
         WE = WC*(WC*(WC*(WC*(0.04793D0*WC + 0.21465D0) + 0.77112D0) + &
            1.39515D0) + 1.81061D0) + 1.0D00
         WF = WD/WE
         YP(I) = (ZZ(I)-WA)*WF*WF + WA
      END DO
!
!   Debug printout
!
      IF (LDBPR(26)) THEN
         WRITE (99, 300)
         NB3 = N/3
         IF (3*NB3 == N) THEN
            NROWS = NB3
         ELSE
            NROWS = NB3 + 1
         ENDIF
         DO II = 1, NROWS
            II1 = II
            II2 = II1 + NROWS
            II3 = II2 + NROWS
            IF (II3 <= N) THEN
               WRITE (99, 301) R(II1), YP(II1), R(II2), YP(II2), R(II3), YP(II3&
                  )
            ELSE IF (II2 <= N) THEN
               WRITE (99, 301) R(II1), YP(II1), R(II2), YP(II2)
            ELSE
               WRITE (99, 301) R(II1), YP(II1)
            ENDIF
         END DO
         CALL DRAW (YP, 1.0D00, YP, 1.0D00, N)
      ENDIF
!
      RETURN
!
  300 FORMAT(/,/,/,' Thomas-Fermi potential'/,/,3(&
         ' --------- r --------- ------ -r*V(r) ------'))
  301 FORMAT(1P,6(1X,1D21.14))
      RETURN
!
      END SUBROUTINE TFPOT


c this code calculate the spectrum of a standard thin disk
c the code is based on the formula in the book "accretion
c power in astrophysics" by Frank et al. 1992
c in unit of cm.g.sec

! This is a modification of Feng's code ssd.f. Since the effect of the
! illumination of the thin disk by radiation from the ADAF seems
! to be negligible, I removed the reprocessing effect.

     	IMPLICIT REAL*8(A-H,O-Z)
        dimension y(4),dy(4),w(16),nu(200),fnu(200)
	common dotm,h,k,mass,rs,solarmass,rin
        double precision mass,nu,k,h,nnu

	call cpu_time(start_time)

! Output file
	open(20,file='ssd_alone.dat')

	h=6.626d-27
	c=2.9979d+10
	k=1.3807d-16
	pi=3.1416d0
	pc=3.086d+18
	solarmass=1.989d+33
	g=6.672d-8

	read(*,*) mass
	mass=mass*1.d6*solarmass

	rs=2.*g*mass/c/c
	dotme=1.39d18*mass/solarmass

c note in the above defination, the factor of 0.1 is included
c the unit is g/s

c ***********************************
c I still did not figure this out. By comparing the output of
c this code with the SSD models in Lasota+96, Quataert+99, Nemmen+06,
c for the same mdot the SSD SEDs there are 10x weaker compared to the
c output of this code. By hand I introduced below a factor 0.1 for
c the correction of mdot. (9/01/2008)
c **********************************
c UPDATE Mar 8th 2012
c Still wondering about the 0.1 factor below
c **********************************
      read(*,*) dotm
      dotm=0.1d0*dotm*dotme
c      dotm=dotm*dotme
c	  dotm=6.4d-4*dotme !--------------3-----------------!

      read(*,*) rin
      rin=rin*rs

      read(*,*) theta
	  theta=theta/57.2958 !--------------6-----------------!
c*********************************
	do 10 i=1,50

c *** Changed the initial frequency from 12. to 11
	nu(i)=10.d0**(11.+0.1d0*i)

	if(nu(i).lt.1.d16) rout=8.d+4*rs
	if(nu(i).gt.1.d16) rout=1.d+4*rs

	nnu=nu(i)
	s=0.d0
	call simpsn(rin,rout,1.d-3,8000,n,s,nnu)
	write(*,*) i,nu(i),n,s,exp(700.d0)

	fnu(i)=4.*pi*h*cos(theta)*nu(i)**3.d0/c/c*s
c *** Changed the output below to nu*Lnu instead of nu*Fnu
c	write(20,*) log10(nu(i)),log10(nu(i)*fnu(i)/distance**2.)
	write(20,*) log10(nu(i)),log10(nu(i)*fnu(i)*4.*pi)

10	continue

	call cpu_time(finish_time)
	print*,'cpu times=',finish_time-start_time,' seconds'

	end
c=====================================================================c
	function f(x,nu)
	implicit real*8(a-h,o-z)
	common dotm,h,k,mass,rs,solarmass,rin
	double precision mass,nu,k,msun,g,pi,sigma

	  msun=1.989d33
      g=6.67d-8
      pi=3.1416d0
! Stefan-Boltzmann constant
      sigma=5.67d-5

! Dissipation rate
	  fvis=3./8./pi/sigma*g*mass/x**3.d0*dotm*(1.-(3.*rs/x)**0.5d0)

! Temperature
	  tem=fvis**0.25d0

c for the above formula, see the first page of Chapter 8 in <<accretion>> book

	if (h*nu/(k*tem).gt.700.) then
 	  f=0.d0
	else
      f=x/(dexp(h*nu/(k*tem))-1.d0)
	endif

	return
	end

c=============================================================c
	subroutine simpsn(a,b,eps,k,n,s,nu)
        implicit real*8(a-h,o-z)
	double precision nu
        n=1
        c=abs(a)+abs(b)
        h=0.5*(b-a)
        t1=h*(f(a,nu)+f(b,nu))
1       x=a-h
        t2=0.5*t1
        do 2 i=1,n
        x=x+2.*h
2       t2=t2+h*f(x,nu)
        s=0.33333333333d0*(4.*t2-t1)
        n=n+n
        if(abs(s-s0).le.(1.+abs(s))*eps) return
3       s0=s
        t1=t2
        h=h*0.5
        if(c+h.ne.c) goto 1
        n=-n
        return
        end


      SUBROUTINE sla_PREBN (BEP0, BEP1, RMATP)
*+
*     - - - - - -
*      P R E B N
*     - - - - - -
*
*  Generate the matrix of precession between two epochs,
*  using the old, pre-IAU1976, Bessel-Newcomb model, using
*  Kinoshita's formulation (double precision)
*
*  Given:
*     BEP0    dp         beginning Besselian epoch
*     BEP1    dp         ending Besselian epoch
*
*  Returned:
*     RMATP  dp(3,3)    precession matrix
*
*  The matrix is in the sense   V(BEP1)  =  RMATP * V(BEP0)
*
*  Reference:
*     Kinoshita, H. (1975) 'Formulas for precession', SAO Special
*     Report No. 364, Smithsonian Institution Astrophysical
*     Observatory, Cambridge, Massachusetts.
*
*  Called:  sla_DEULER
*
*  P.T.Wallace   Starlink   23 August 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  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
*
*-

      IMPLICIT NONE

      DOUBLE PRECISION BEP0,BEP1,RMATP(3,3)

*  Arc seconds to radians
      DOUBLE PRECISION AS2R
      PARAMETER (AS2R=0.484813681109535994D-5)

      DOUBLE PRECISION BIGT,T,TAS2R,W,ZETA,Z,THETA

*  Interval between basic epoch B1850.0 and beginning epoch in TC
      BIGT = (BEP0-1850D0)/100D0

*  Interval over which precession required, in tropical centuries
      T = (BEP1-BEP0)/100D0

*  Euler angles
      TAS2R = T*AS2R
      W = 2303.5548D0+(1.39720D0+0.000059D0*BIGT)*BIGT

      ZETA = (W+(0.30242D0-0.000269D0*BIGT+0.017996D0*T)*T)*TAS2R
      Z = (W+(1.09478D0+0.000387D0*BIGT+0.018324D0*T)*T)*TAS2R
      THETA = (2005.1125D0+(-0.85294D0-0.000365D0*BIGT)*BIGT+
     :        (-0.42647D0-0.000365D0*BIGT-0.041802D0*T)*T)*TAS2R

*  Rotation matrix
      CALL sla_DEULER('ZYZ',-ZETA,THETA,-Z,RMATP)

      END


\ CLASSIC LUNAR LANDER
\ MICHEL JEAN, MAY 2020
\ INSPIRED BY : RAFAEL DELIANO 2017, AHL DAVID 1978, BILL COTTER 1977

: introduction

cr ." THIS IS A COMPUTER SIMULATION OF AN APOLLO LUNAR" cr
." LANDING CAPSULE" cr
." THE ON-BOARD COMPUTER HAS FAILED (IT WAS MADE BY" cr
." XEROX) SO YOU HAVE TO LAND THE CAPSULE MANUALLY." cr
." SET BURNS RATE OF RETRO ROCKETS TO ANY VALUE BETWEEN" cr
." 0 (FREE FALL) AND 200 (MAXIMUM BURN) POUNDS PER SECOND." cr
." SET NEW BURN RATE EVERY 10 SECONDES" cr
." CAPSULE WEIGHT 32500 LBS; FUEL WEIGHT 16500 LBS." cr
." GOOD LUCK" cr
;

fvariable mt    \ masse of carburant
fvariable x     \ distance of the surface of the moon
fvariable v     \ velocity m/s
fvariable t     \ time

fvariable s     \ burn rate kg/s
variable allu   \ burn rate lbs/s

fvariable mtn   \ new carburant mass
fvariable mtavr \ average carburant mass
fvariable mavr  \ average mass
fvariable vavr  \ average velocity
fvariable gxs   \ compensation of the gravity
fvariable gx    \ gravity at x
fvariable vn    \ new velocity

7257.6e fconstant mc \ mass of the LEM
10.0e fconstant dt \ burn time in sec
3050.0e fconstant lsp \ impulsion of the carburant Newton*sec/kg

: initialisation
        7484.4e mt f! \ masse carburant
        193121.3e x f! \ distance en m
        1609.34e v f! \ vitesse m/s
        0.0e allu f!
        0.0e t f!
;

: gravity       \ gravity force in function distance
        7.349e22 x f@ 1.7349e6 f+
        fdup f* f/ 6.674e-11 f* gx f!
;

: mass          \ mass of the LEM
        t f@ dt f+ t f!
        mt f@ s f@ dt f* f- mtn f!
        mt f@ mtn f@ f+ 2e f/ mtavr f!
        mtavr f@ mc f+ mavr f!
;

: allumage      \ verify and transform burn lbs/sec to kg/sec
        allu @ 200 > if cr ." MAXIMUM BURN IS 200 " 200 allu ! then
        allu @ 0 d>f 0.4536e f* s f!
;

: speed         \ speed of descent
        gx f@ mavr f@  f* lsp s f@ f* f- mavr f@ f/ gxs f!
        v f@ gxs f@ dt f* f+ vn f!
        v f@ vn f@ f+ 2e f/ vavr f!
;

: position      \ new position
         x f@ vavr f@ dt f* f- 0.5e gxs f@ f* dt fdup f* f* f- x f!
;

: calcul        \ main calcul routine
        allumage
        mass
        gravity
        speed
        position
        mtn f@ 0e f< if 0e mtn f! then \ mass carburant can't be negative
        mtn f@ mt f!
        vn f@ v f!
        0 allu ! \ cut gas!
;

: affichage
        cr
        t f@ f>d drop . ." SEC  |  "
        x f@ 3.28084e f* f>d drop dup 5280 / .  ." MI "
        5280 mod . ." FT  |  "
        v f@ 2.237e f* f>d drop . ." MPH  | "
        mt f@ 2.20462e f* f>d drop . ." LB_FUEL  "
;

: input-gas
        cr ." BURN RATE (0 to 200) : "
	PAD DUP 3 ACCEPT EVALUATE allu !
;

: landing
        cr ." ON THE MOON AT "  t f@ f>d drop . ." SECONDES "
        cr ." IMPACT VELOCITY "  v f@ 2.237e f* f>d drop . ." MPH "
        cr ." FULL LEFT "  mt f@ 2.20462e f* f>d drop . ." LBS  " cr
        v f@ 0.54e f< if ." PERFECT LANDING NEIL" cr else
        v f@ 4.5e f< if ." ROUGH LANDING" cr else
        v f@ 25e f< if ." THE LEM IS BROKEN. A RESCUE MISSION" cr
        ." HAVE TO RECOVER YOU" cr else
        ." YOU HAVE CREATED A NEW CRATER ON THE MOON" cr
        then then then
        ." FOR RETRY, TYPE 'GO' "

;

: go
        initialisation
        BEGIN
       affichage
        mt f@ 1e f< not if
        input-gas
        then
        calcul
        x f@ 0.5e f< UNTIL
        landing
;

introduction
go


C$Procedure      XPOSBL ( Transpose a matrix by blocks    )

      SUBROUTINE XPOSBL ( BMAT, NROW, NCOL, BSIZE, BTMAT )

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

      INTEGER               NROW
      INTEGER               NCOL
      INTEGER               BSIZE
      DOUBLE PRECISION      BMAT  ( NROW, NCOL )
      DOUBLE PRECISION      BTMAT ( NROW, NCOL )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     BMAT       I   a matrix composed of square block submatrices
C     NROW       I   the number of rows in the matrix BMAT
C     NCOL       I   the number of columns in the matrix BMAT
C     BSIZE      I   the size of the square blocks in BMAT
C     BTMAT      O   the result of transposing the blocks of BMAT
C
C$ Detailed_Input
C
C     BMAT       is a block structured matrix.  In other words
C                it looks like:
C
C
C                   -                                -
C                  |      :      :       :     :      |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   11 :   12 :    13 : ... :   1C |
C                  |......:......:.......:     :......|
C                  |      :      :       :     :      |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   21 :   22 :    23 : ... :   2C |
C                  |......:......:.......:     :......|
C                  |      .                           |
C                  |      .                           |
C                  |      .                           |
C                  |......................     .......|
C                  |      :      :       :     :      |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   R1 :   R2 :    R3 : ... :   RC |
C                  |......:......:.......:     :......|
C                   -                                -
C
C                where each B   is a square matrix of BSIZE rows and
C                            ij
C                and columns.
C
C     NROW       is the number of rows in the input matrix.
C
C     NCOL       is the number of columns in the input matrix.
C
C     BSIZE      is the number of rows and columns in each block
C                of the input matrix.
C
C$ Detailed_Output
C
C     BTMAT     is the matrix obtained from BMAT when each of its
C               blocks is transposed.  Given the description of
C               BMAT above, BTMAT looks like:
C
C
C                   -                                -
C                  |   t  :   t  :    t  :     :   t  |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   11 :   12 :    13 : ... :   1C |
C                  |......:......:.......:     :......|
C                  |      :      :       :     :      |
C                  |   t  :   t  :    t  :     :   t  |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   21 :   22 :    23 : ... :   2C |
C                  |......:......:.......:     :......|
C                  |      .                           |
C                  |      .                           |
C                  |      .                           |
C                  |......................     .......|
C                  |      :      :       :     :      |
C                  |   t  :   t  :    t  :     :   t  |
C                  |  B   :  B   :   B   :     :  B   |
C                  |   R1 :   R2 :    R3 : ... :   RC |
C                  |......:......:.......:     :......|
C                   -                                -
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     1) If the number of rows input is not positive, your program
C        will probably experience a run-time error.  However, in the
C        event that your system does not catch this error, this routine
C        will diagnose it and signal the error 'SPICE(BADROWCOUNT)'.
C
C     1) If the number of columns input is not positive, your program
C        will probably experience a run-time error.  However, in the
C        event that your system does not catch this error, this routine
C        will diagnose it and signal the error 'SPICE(BADCOLUMNCOUNT)'.
C
C     3) If the block size input is not positive, the error
C        'SPICE(BADBLOCKSIZE)' is signalled.
C
C     4) If BMAT cannot be partitioned into an integer number of
C        blocks, the error 'SPICE(BLOCKSNOTEVEN)' is signalled.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine transposes the blocks of a block structured
C     matrix.  This operation is valuable, as it is a means
C     for computing the inverse of a state transformation matrix
C     (see the example below).
C
C$ Examples
C
C     The following code fragment illustrates how you would convert
C     a state relative to earth-fixed coordinates to J2000 coordinates.
C
C     C
C     C     We want to state earthfixed coordinates (399) to J2000
C     C     coordinates
C     C
C           BODY = 399
C           REF  = 'J2000'
C
C     C
C     C     Get the 6 by 6 state transformation matrix from J2000
C     C     coordinates to earthfixed coordinates.
C     C
C           CALL TISBOD ( REF, BODY, ET, TISPM )
C
C     C
C     C     The inverse of TISPM can be obtained by transposing the
C     C     3 by 3 blocks of the 6 by 6 matrix TISPM.
C     C
C           CALL XPOSBL ( TISPM, 6, 6, 3, TSPMI )
C
C
C     C
C     C     Now transform the earthfixed state (ESTATE) to the
C     C     inertial state (ISTATE).
C     C
C           CALL MXVG   ( TSPMI, ESTATE, 6, 6, ISTATE )
C
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     W.L. Taber     (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 22-APR-2010 (NJB)
C
C        Header correction: assertions that the output
C        can overwrite the input have been removed.
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 5-NOV-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     transpose a matrix by blocks
C
C-&

C
C     Local variables
C
      DOUBLE PRECISION      TEMP

      INTEGER               I
      INTEGER               J
      INTEGER               CB
      INTEGER               RB

C
C     Ok. Here's what's going to happen.
C
C     The matrix has the form:
C
C       -                                -
C      |      :      :       :     :      |
C      |  B   :  B   :   B   :     :  B   |
C      |   11 :   12 :    13 : ... :   1C |
C      |......:......:.......:     :......|
C      |      :      :       :     :      |
C      |  B   :  B   :   B   :     :  B   |
C      |   21 :   22 :    23 : ... :   2C |
C      |......:......:.......:     :......|
C      |      .                           |
C      |      .                           |
C      |      .                           |
C      |......................     .......|
C      |      :      :       :     :      |
C      |  B   :  B   :   B   :     :  B   |
C      |   R1 :   R2 :    R3 : ... :   RC |
C      |......:......:.......:     :......|
C
C      Where each block B   is a square matrix.
C                        ij
C
C      All we really need to do is figure out how to transpose any
C      of the blocks.  Once that is done we can just cycle over
C      all of the blocks in the matrix.
C
C      So what does the ij block look like? Well, this is it.
C
C
C             a              a               ...    a
C              RB+1 CB+1      RB+1 CB+2              RB+1 CB+BSIZE
C
C             a              a               ...    a
C              RB+2 CB+1      RB+2 CB+2              RB+2 CB+BSIZE
C
C             a              a               ...    a
C              RB+3 CB+1      RB+3 CB+2              RB+3 CB+BSIZE
C
C                                 .
C                                 .
C                                 .
C
C              a              a                 ... a
C               RB+BSIZE CB+1  RB+BSIZE CB+2         RB+BSIZE CB+BSIZE
C
C
C     where RB = (i-1)*BSIZE, and CB = (j-1)*BSIZE.  But inspection of
C     this block shows that to transpose it we simply need to swap
C     the entries
C
C                a           and  a
C                 RB+m CB+n        RB+n CB+m
C
C     where m and n range over all integers from 1 to BSIZE.
C

C
C     Let's first check to make sure that the requested operation
C     makes sense.  Are all of the integers positive?
C
      IF (  BSIZE .LT. 1 ) THEN
         CALL CHKIN  ( 'XPOSBL'                                       )
         CALL SETMSG ( 'The block size is not positive. '             //
     .                 'The block size is #.'                         )
         CALL ERRINT ( '#', BSIZE                                     )
         CALL SIGERR ( 'SPICE(BADBLOCKSIZE)'                          )
         CALL CHKOUT ( 'XPOSBL'                                       )
         RETURN
      END IF

      IF (  NROW .LT. 1 ) THEN
         CALL CHKIN  ( 'XPOSBL'                                       )
         CALL SETMSG ( 'The number of rows in the matrix is not '     //
     .                 'positive. The number of rows is #.'           )
         CALL ERRINT ( '#', NROW                                      )
         CALL SIGERR ( 'SPICE(BADROWCOUNT)'                           )
         CALL CHKOUT ( 'XPOSBL'                                       )
         RETURN
      END IF

      IF (  NCOL .LT. 1 ) THEN
         CALL CHKIN  ( 'XPOSBL'                                       )
         CALL SETMSG ( 'The number of columns in the matrix is not '  //
     .                 'positive. The number of columns is #.'        )
         CALL ERRINT ( '#', NCOL                                      )
         CALL SIGERR ( 'SPICE(BADCOLUMNCOUNT)'                        )
         CALL CHKOUT ( 'XPOSBL'                                       )
         RETURN
      END IF

C
C     Is there a whole number of blocks in the matrix.
C
      IF (      ( MOD( NCOL, BSIZE ) .NE. 0 )
     .     .OR. ( MOD( NROW, BSIZE ) .NE. 0 ) ) THEN

         CALL CHKIN  ( 'XPOSBL'                                       )
         CALL SETMSG ( 'The block size does not evenly divide both '  //
     .                 'the number of rows and the number of '        //
     .                 'columns. The '                                //
     .                 'block size is #; the number of rows is #; '   //
     .                 'the number of columns is #. '                 )

         CALL ERRINT ( '#', BSIZE                                     )
         CALL ERRINT ( '#', NROW                                      )
         CALL ERRINT ( '#', NCOL                                      )
         CALL SIGERR ( 'SPICE(BLOCKSNOTEVEN)'                         )
         CALL CHKOUT ( 'XPOSBL'                                       )
         RETURN
      END IF

C
C     If we get to this point we are ready to do the transposes.
C     Cycle over all of the blocks in the matrix.
C
      DO CB = 0, NCOL-1, BSIZE
         DO RB = 0, NROW-1, BSIZE

C
C           OK. Transpose block ( RB, CB ).
C
            DO I = 1, BSIZE
               DO J = 1, I

                  IF ( I .EQ. J ) THEN
                     BTMAT ( RB+I, CB+J ) = BMAT ( RB+I, CB+J )
                  ELSE
                     TEMP                 = BMAT ( RB+I, CB+J )
                     BTMAT ( RB+I, CB+J ) = BMAT ( RB+J, CB+I )
                     BTMAT ( RB+J, CB+I ) = TEMP
                  END IF

               END DO
            END DO

         END DO
      END DO

      RETURN
      END


SUBROUTINE cgsolve(q,its)

!-------------------------------------------------------------
!
!  Perform a simple conjugate gradient solution
!
!-------------------------------------------------------------

USE invar
USE solvar
IMPLICIT NONE
INTEGER :: it
INTEGER, INTENT(OUT) :: its
REAL*8 :: alf, bet, dfmx, tmp, bnorm
REAL*8, DIMENSION(neq), INTENT(IN) :: q
REAL*8, DIMENSION(neq) :: res, sd, tmp1, phio, ones

! Initialize my guess
!phi = 0.0
!res = q

phi = phiold
res = q - MATMUL(jmat,phi)
sd = res
tmp = DOT_PRODUCT(res,res)
ones = 1.0

!bnorm = SQRT(tmp)
!! Want to use just the residual when the bnorm is larger than one, means more iterations
!IF (bnorm > 1.0) THEN
!   bnorm = 1.0
!ELSE
!   ! Want to use faster multiplications at each iteration, so take inverse and store
!   bnorm = 1.0/bnorm
!END IF

DO it = 1, itmx
   ! Copy old phi vector
   phio = phi

   ! The CG steps...should be optimized later or use outside solver
   tmp1 = MATMUL(jmat,sd)
   alf = tmp/(DOT_PRODUCT(sd,tmp1))
   phi = phi + alf*sd
!   dfmx = SQRT(tmp)*bnorm
   IF (MINVAL(ABS(phio)) >= tolr) THEN
      dfmx = MAXVAL(ABS(phi/phio - ones))
   ELSE
      dfmx = MAXVAL(ABS(phi - phio))
   END IF

   ! Cycle if not converged, less than itmx, and it not equal to the number of
   ! equations -- CG has zero residual when iterations = number of equations
   IF (dfmx > cgr .AND. it < itmx .AND. it /= neq) THEN
      res = res - alf*tmp1
      bet = 1.0/tmp
      tmp = DOT_PRODUCT(res,res)
      bet = tmp*bet
      sd  = res + bet*sd
      CYCLE
   ELSE IF (dfmx < cgr .OR. it == neq) THEN
!      cnvf = 1
      its = it
      EXIT
   ELSE IF (it == itmx) THEN
!      cnvf = 0
      its = it
      EXIT
   END IF
END DO

RETURN
END SUBROUTINE cgsolve


*     MB04DY EXAMPLE PROGRAM TEXT.
*     Copyright (c) 2002-2020 NICONET e.V.
*
*     .. Parameters ..
      INTEGER          NIN, NOUT
      PARAMETER        ( NIN = 5, NOUT = 6 )
      INTEGER          NMAX
      PARAMETER        ( NMAX = 20 )
      INTEGER          LDA, LDQG
      PARAMETER        ( LDA = NMAX, LDQG = NMAX )
      INTEGER          LDWORK
      PARAMETER        ( LDWORK = NMAX )
*     .. Local Scalars ..
      INTEGER          I, INFO, J, N
      CHARACTER*1      JOBSCL
*     .. Local Arrays ..
      DOUBLE PRECISION A(LDA,NMAX), D(NMAX), DWORK(LDWORK),
     $                 QG(LDQG,NMAX+1)
*     .. External Functions ..
      LOGICAL          LSAME
      EXTERNAL         LSAME
*     .. External Subroutines ..
      EXTERNAL         MB04DY
*     .. Executable Statements ..
*
      WRITE ( NOUT, FMT = 99999 )
*     Skip the heading in the data file and read the data.
      READ ( NIN, FMT = '()' )
      READ ( NIN, FMT = * ) N, JOBSCL
      IF ( N.LT.0 .OR. N.GT.NMAX ) THEN
         WRITE ( NOUT, FMT = 99998 ) N
      ELSE
         READ ( NIN, FMT = * ) ( ( A(I,J),    J = 1,N ), I = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(J,I+1), I = J,N ), J = 1,N )
         READ ( NIN, FMT = * ) ( ( QG(I,J),   I = J,N ), J = 1,N )
*        Scale the Hamiltonian matrix.
         CALL MB04DY( JOBSCL, N, A, LDA, QG, LDQG, D, DWORK, INFO )
         IF ( INFO.NE.0 ) THEN
            WRITE ( NOUT, FMT = 99997 ) INFO
         ELSE
*           Show the scaled Hamiltonian matrix.
            WRITE ( NOUT, FMT = 99996 )
            DO 10 I = 1, N
              WRITE ( NOUT, FMT = 99993 )  ( A(I,J),    J = 1,N ),
     $           ( QG(J,I+1), J = 1,I-1 ), ( QG(I,J+1), J = I,N )
10          CONTINUE
            DO 20 I = 1, N
               WRITE ( NOUT, FMT = 99993 ) (  QG(I,J), J = 1,I-1 ),
     $               ( QG(J,I), J = I,N ), ( -A(J,I),  J = 1,N )
20          CONTINUE
*           Show the scaling factors.
            IF ( LSAME( JOBSCL, 'S' ) ) THEN
               WRITE ( NOUT, FMT = 99995 )
               WRITE ( NOUT, FMT = 99993 ) ( D(I), I = 1,N )
            ELSE IF ( LSAME( JOBSCL, '1' ) .OR. LSAME( JOBSCL, 'O' ) )
     $            THEN
               WRITE ( NOUT, FMT = 99994 )
               WRITE ( NOUT, FMT = 99993 ) D(1)
            END IF
         ENDIF
      END IF
      STOP
*
99999 FORMAT (' MB04DY EXAMPLE PROGRAM RESULTS',/1X)
99998 FORMAT (/' N is out of range.',/' N = ',I5)
99997 FORMAT (' INFO on exit from MB04DY = ',I2)
99996 FORMAT (/' The scaled Hamiltonian is ')
99995 format (/' The scaling factors are ')
99994 format (/' The scaling factor tau is ')
99993 FORMAT (1X,8(F10.4))
      END


MODULE FontesSubrotinas

   CONTAINS

      SUBROUTINE ComplementosU_SW(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         u_extrapolado  = extrapola_u_S(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_S(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + cc_u_w(t,j) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u_extrapolado )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - cc_u_w(t ,j) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + cc_v_s(t , i) + cc_v_s(t, i+1))/4.0d0)*(u (pu+Nx) - u_extrapolado )/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - cc_u_w(t0,j) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + cc_v_s(t0, i) + cc_v_s(t0,i+1))/4.0d0)*(u0(pu+Nx) - u_extrapolado0)/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_w(t+1,j)/(dx**2) + (16.0d0/5.0)*(cc_u_s(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_SW

      SUBROUTINE ComplementosU_S(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         u_extrapolado  = extrapola_u_S(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_S(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u_extrapolado )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - u (pu-1) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + cc_v_s(t,  i) + cc_v_s(t,  i+1))/4.0d0)*(u (pu+Nx) - u_extrapolado )/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - u0(pu-1) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + cc_v_s(t0, i) + cc_v_s(t0, i+1))/4.0d0)*(u0(pu+Nx) - u_extrapolado0)/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*(cc_u_s(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_S

      SUBROUTINE ComplementosU_SE(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Usando interpolacao cubica
         u_extrapolado  = extrapola_u_S(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_S(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( cc_u_e(t,j) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u_extrapolado )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(cc_u_e(t, j) - u (pu-1) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + cc_v_s(t, i) + cc_v_s(t, i+1))/4.0d0)*(u (pu+Nx) - u_extrapolado )/(2.0d0*dy)
         Aij0 = u0(pu)*(cc_u_e(t0,j) - u0(pu-1) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + cc_v_s(t0,i) + cc_v_s(t0,i+1))/4.0d0)*(u0(pu+Nx) - u_extrapolado0)/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_e(t+1,j)/(dx**2) + (16.0d0/5.0)*(cc_u_s(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_SE

      SUBROUTINE ComplementosU_W(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + cc_u_w(t,j) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - cc_u_w(t,  j) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u (pu+Nx) - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - cc_u_w(t0, j) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u0(pu+Nx) - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_w(t+1,j)/(dx**2) )

      END SUBROUTINE ComplementosU_W

      SUBROUTINE ComplementosU_C(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - u (pu-1) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u (pu+Nx) - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - u0(pu-1) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u0(pu+Nx) - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         Cij = 0.0d0

      END SUBROUTINE ComplementosU_C

      SUBROUTINE ComplementosU_E(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Difusao
         Dij = ( cc_u_e(t, j) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u(pu+Nx) - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(cc_u_e(t,  j) - u (pu-1) )/(2.0d0*dx) + ((v (pv) + v (pv+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u (pu+Nx) - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(cc_u_e(t0, j) - u0(pu-1) )/(2.0d0*dx) + ((v0(pv) + v0(pv+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u0(pu+Nx) - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_e(t+1,j)/(dx**2) )

      END SUBROUTINE ComplementosU_E

      SUBROUTINE ComplementosU_NW(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Usando interpolacao cubica
         u_extrapolado  = extrapola_u_N(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_N(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + cc_u_w(t, j) )/(dx**2) + ( u_extrapolado - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - cc_u_w(t,  j) )/(2.0d0*dx) + ((cc_v_n(t, i) + cc_v_n(t ,i+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u_extrapolado  - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - cc_u_w(t0, j) )/(2.0d0*dx) + ((cc_v_n(t0,i) + cc_v_n(t0,i+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u_extrapolado0 - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_w(t+1,j)/(dx**2) + (16.0d0/5.0)*(cc_u_n(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_NW

      SUBROUTINE ComplementosU_N(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Usando interpolacao cubica
         u_extrapolado  = extrapola_u_N(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_N(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( u(pu+1) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u_extrapolado - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(u (pu+1) - u (pu-1) )/(2.0d0*dx) + ((cc_v_n(t, i) + cc_v_n(t, i+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u_extrapolado  - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(u0(pu+1) - u0(pu-1) )/(2.0d0*dx) + ((cc_v_n(t0,i) + cc_v_n(t0,i+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u_extrapolado0 - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*(cc_u_n(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_N

      SUBROUTINE ComplementosU_NE(t, t0, pu, Nx, dx, dy, dt, Re, u, u0, v, v0, Dij, Aij, Aij0, Cij, pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pu, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dij, Aij, Aij0, Cij

         INTEGER :: pv, i, j
         DOUBLE PRECISION :: u_extrapolado, u_extrapolado0

         j = (pu-1)/Nx + 1
         i = pu - (j-1)*Nx
         pv = pu + j - 1
         pp = pv

         ! Usando interpolacao cubica
         u_extrapolado  = extrapola_u_N(t,  pu, i, Nx, u)
         u_extrapolado0 = extrapola_u_N(t0, pu, i, Nx, u0)

         ! Difusao
         Dij = ( cc_u_e(t,j) - 2.0d0*u(pu) + u(pu-1) )/(dx**2) + ( u_extrapolado - 2.0d0*u(pu) + u(pu-Nx) )/(dy**2)

         ! Adveccao: Aij = u*du/dx + v*du/dy
         Aij  = u (pu)*(cc_u_e(t, j) - u (pu-1) )/(2.0d0*dx) + ((cc_v_n(t, i) + cc_v_n(t, i+1) + v (pv-(Nx+1)) + v (pv+1-(Nx+1)))/4.0d0)*(u_extrapolado  - u (pu-Nx))/(2.0d0*dy)
         Aij0 = u0(pu)*(cc_u_e(t0,j) - u0(pu-1) )/(2.0d0*dx) + ((cc_v_n(t0,i) + cc_v_n(t0,i+1) + v0(pv-(Nx+1)) + v0(pv+1-(Nx+1)))/4.0d0)*(u_extrapolado0 - u0(pu-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de U"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao U entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_u)?
         Cij = (dt/(2.0d0*Re))*( cc_u_e(t+1,j)/(dx**2) + (16.0d0/5.0)*(cc_u_n(t+1,i)/(dy**2)) )

      END SUBROUTINE ComplementosU_NE

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

      SUBROUTINE ComplementosV_SW(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Usando interpolacao cubica
         v_extrapolado  = extrapola_v_W(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_W(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v_extrapolado )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + cc_v_s(t,i) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + cc_u_w(t, j) + u (pu+(Nx-1)) + cc_u_w(t, j+1))/4.0d0)*(v (pv+1) - v_extrapolado )/(2.0d0*dx) + v (pv)*(v (pv+Nx) - cc_v_s(t ,i))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + cc_u_w(t0,j) + u0(pu+(Nx-1)) + cc_u_w(t0,j+1))/4.0d0)*(v0(pv+1) - v_extrapolado0)/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - cc_v_s(t0,i))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_w(t+1,j)/(dx**2) + cc_v_s(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_SW

      SUBROUTINE ComplementosV_S(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + cc_v_s(t,i) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + u (pu-1) + u (pu+(Nx-1)) + u (pu+(Nx-1)-1))/4.0d0)*(v (pv+1) - v (pv-1) )/(2.0d0*dx) + v (pv)*(v (pv+Nx) - cc_v_s(t ,i))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + u0(pu-1) + u0(pu+(Nx-1)) + u0(pu+(Nx-1)-1))/4.0d0)*(v0(pv+1) - v0(pv-1) )/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - cc_v_s(t0,i))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( cc_v_s(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_S

      SUBROUTINE ComplementosV_SE(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         v_extrapolado  = extrapola_v_E(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_E(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v_extrapolado - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + cc_v_s(t,i) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (cc_u_e(t, j) + u (pu-1) + cc_u_e(t, j+1) + u (pu+(Nx-1)-1))/4.0d0)*(v_extrapolado  - v (pv-1))/(2.0d0*dx) + v (pv)*(v (pv+Nx) - cc_v_s(t ,i))/(2.0d0*dy)
         Avij0 = ( (cc_u_e(t0,j) + u0(pu-1) + cc_u_e(t0,j+1) + u0(pu+(Nx-1)-1))/4.0d0)*(v_extrapolado0 - v0(pv-1))/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - cc_v_s(t0,i))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_e(t+1,j)/(dx**2) + cc_v_s(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_SE

      SUBROUTINE ComplementosV_W(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Usando interpolacao cubica
         v_extrapolado  = extrapola_v_W(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_W(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v_extrapolado )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + cc_u_w(t, j) + u (pu+(Nx-1)) + cc_u_w(t, j+1))/4.0d0)*(v (pv+1) - v_extrapolado )/(2.0d0*dx) + v (pv)*(v (pv+Nx) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + cc_u_w(t0,j) + u0(pu+(Nx-1)) + cc_u_w(t0,j+1))/4.0d0)*(v0(pv+1) - v_extrapolado0)/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_w(t+1,j)/(dx**2) )

      END SUBROUTINE ComplementosV_W

      SUBROUTINE ComplementosV_C(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + u (pu-1) + u (pu+(Nx-1)) + u (pu+(Nx-1)-1))/4.0d0)*(v (pv+1) - v (pv-1) )/(2.0d0*dx) + v (pv)*(v (pv+Nx) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + u0(pu-1) + u0(pu+(Nx-1)) + u0(pu+(Nx-1)-1))/4.0d0)*(v0(pv+1) - v0(pv-1) )/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = 0.0d0

      END SUBROUTINE ComplementosV_C

      SUBROUTINE ComplementosV_E(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Usando interpolacao cubica
         v_extrapolado  = extrapola_v_E(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_E(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v_extrapolado - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( v(pv+Nx) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (cc_u_e(t , j) + u (pu-1) + cc_u_e(t, j+1) + u (pu+(Nx-1)-1))/4.0d0)*(v_extrapolado  - v (pv-1) )/(2.0d0*dx) + v (pv)*(v (pv+Nx) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (cc_u_e(t0, j) + u0(pu-1) + cc_u_e(t0,j+1) + u0(pu+(Nx-1)-1))/4.0d0)*(v_extrapolado0 - v0(pv-1) )/(2.0d0*dx) + v0(pv)*(v0(pv+Nx) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_e(t+1,j)/(dx**2) )

      END SUBROUTINE ComplementosV_E

      SUBROUTINE ComplementosV_NW(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Usando interpolacao cubica
         v_extrapolado  = extrapola_v_W(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_W(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v_extrapolado )/(dx**2) + ( cc_v_n(t,i) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + cc_u_w(t, j) + u (pu+(Nx-1)) + cc_u_w(t, j+1))/4.0d0)*(v (pv+1) - v_extrapolado )/(2.0d0*dx) + v (pv)*(cc_v_n(t ,i) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + cc_u_w(t0,j) + u0(pu+(Nx-1)) + cc_u_w(t0,j+1))/4.0d0)*(v0(pv+1) - v_extrapolado0)/(2.0d0*dx) + v0(pv)*(cc_v_n(t0,i) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_w(t+1,j)/(dx**2) + cc_v_n(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_NW

      SUBROUTINE ComplementosV_N(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Difusao
         Dvij = ( v(pv+1) - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( cc_v_n(t,i) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (u (pu) + u (pu-1) + u (pu+(Nx-1)) + u (pu+(Nx-1)-1))/4.0d0)*(v (pv+1) - v (pv-1) )/(2.0d0*dx) + v (pv)*(cc_v_n(t ,i) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (u0(pu) + u0(pu-1) + u0(pu+(Nx-1)) + u0(pu+(Nx-1)-1))/4.0d0)*(v0(pv+1) - v0(pv-1) )/(2.0d0*dx) + v0(pv)*(cc_v_n(t0,i) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( cc_v_n(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_N

      SUBROUTINE ComplementosV_NE(t, t0, pv, Nx, dx, dy, dt, Re, u, u0, v, v0, Dvij, Avij, Avij0, Cij,  pp )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, t0, pv, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt, Re
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: u, u0, v, v0

         INTEGER,          INTENT(INOUT) :: pp
         DOUBLE PRECISION, INTENT(INOUT) :: Dvij, Avij, Avij0, Cij

         INTEGER :: pu, i, j
         DOUBLE PRECISION :: v_extrapolado, v_extrapolado0

         j = (pv-1)/Nx + 1
         i = pv - (j-1)*Nx
         pu = pv - j + 1
         pp = pv

         ! Usando interpolacao cubica
         v_extrapolado  = extrapola_v_E(t,  pv, j, Nx, v)
         v_extrapolado0 = extrapola_v_E(t0, pv, j, Nx, v0)

         ! Difusao
         Dvij = ( v_extrapolado - 2.0d0*v(pv) + v(pv-1) )/(dx**2) + ( cc_v_n(t,i) - 2.0d0*v(pv) + v(pv-Nx) )/(dy**2)

         ! Adveccao: Avij = u*dv/dx + v*dv/dy
         Avij  = ( (cc_u_e(t, j) + u (pu-1) + cc_u_e(t, j+1) + u (pu+(Nx-1)-1))/4.0d0)*(v_extrapolado  - v (pv-1))/(2.0d0*dx) + v (pv)*(cc_v_n(t ,i) - v (pv-Nx))/(2.0d0*dy)
         Avij0 = ( (cc_u_e(t0,j) + u0(pu-1) + cc_u_e(t0,j+1) + u0(pu+(Nx-1)-1))/4.0d0)*(v_extrapolado0 - v0(pv-1))/(2.0d0*dx) + v0(pv)*(cc_v_n(t0,i) - v0(pv-Nx))/(2.0d0*dy)

         ! Termo oriundo do "lado esquerdo da equacao de V"
         ! OBS: Como o complemento Cij veio do lado esquerdo da equacao V entao ele representa a solucao no passo de tempo + 1
         ! OBS: como o complemento Cij depende da extrapolacao utilizada mover para as funcoes de extrapolacao (extrapola_v)?
         Cij = (dt/(2.0d0*Re))*( (16.0d0/5.0)*cc_v_e(t+1,j)/(dx**2) + cc_v_n(t+1, i)/(dy**2) )

      END SUBROUTINE ComplementosV_NE

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

     DOUBLE PRECISION FUNCTION StencilP_SW(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_SW = -(1.0d0/dt)*((ut(pu) - cc_u_w(t+1, j))/dx + (vt(pv) - cc_v_s(t+1, i))/dy)

      END FUNCTION StencilP_SW

      DOUBLE PRECISION FUNCTION StencilP_S(t, p, Nx, dx, dy, dt, ut, vt )

         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_S = -(1.0d0/dt)*((ut(pu) - ut(pu-1))/dx + (vt(pv) - cc_v_s(t+1, i))/dy)

      END FUNCTION StencilP_S

      DOUBLE PRECISION FUNCTION StencilP_SE(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_SE = -(1.0d0/dt)*((cc_u_e(t+1, j) - ut(pu-1))/dx + (vt(pv) - cc_v_s(t+1, i))/dy)

      END FUNCTION StencilP_SE

      DOUBLE PRECISION FUNCTION StencilP_W(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_W = -(1.0d0/dt)*((ut(pu) - cc_u_w(t+1, j))/dx + (vt(pv) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_W

      DOUBLE PRECISION FUNCTION StencilP_C(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_C = -(1.0d0/dt)*((ut(pu) - ut(pu-1))/dx + (vt(pv) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_C

      DOUBLE PRECISION FUNCTION StencilP_E(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_E = -(1.0d0/dt)*((cc_u_e(t+1,j) - ut(pu-1))/dx + (vt(pv) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_E

      DOUBLE PRECISION FUNCTION StencilP_NW(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_NW = -(1.0d0/dt)*((ut(pu) - cc_u_w(t+1, j))/dx + (cc_v_n(t+1, i) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_NW

      DOUBLE PRECISION FUNCTION StencilP_N(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_N = -(1.0d0/dt)*((ut(pu) - ut(pu-1))/dx + (cc_v_n(t+1, i) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_N

      DOUBLE PRECISION FUNCTION StencilP_NE(t, p, Nx, dx, dy, dt, ut, vt )
         USE FuncoesAlias

         IMPLICIT NONE

         INTEGER, INTENT(IN) :: t, p, Nx
         DOUBLE PRECISION, INTENT(IN) :: dx, dy, dt
         DOUBLE PRECISION, DIMENSION(:), INTENT(IN) :: ut, vt

         INTEGER :: pv, pu, i, j

         j = (p-1)/Nx + 1
         i = p - (j-1)*Nx
         pu = p - j + 1
         pv = p

         StencilP_NE = -(1.0d0/dt)*((cc_u_e(t+1, j) - ut(pu-1))/dx + (cc_v_n(t+1, i) - vt(pv-Nx))/dy)

      END FUNCTION StencilP_NE

END MODULE FontesSubrotinas


      program vgrd2ncom
      implicit none
c
c --- convert a HYCOM sigma-Z grid to NCOM
c
      integer          k,kdm,nsigma
      real             al,als,dp00,dp00f,z(0:999)
      double precision zz,dz
c
      integer       lp
      common/linepr/lp
c
      lp = 6
c
c --- 'kdm   ' = number of layers
c --- 'nsigma' = number of sigma  levels (kdm-nsigma z-levels)
c
      call blkini(kdm,   'kdm   ')
      call blkini(nsigma,'nsigma')
c
c --- 'dp00  ' = z-level spacing minimum thickness (m)
c --- 'dp00f ' = z-level spacing stretching factor
c
      call blkinr(dp00,  'dp00  ','(a6," =",f10.4," m")')
      call blkinr(dp00f, 'dp00f ','(a6," =",f10.4,"  ")')
c
      z(0) = 0.0
      zz   = 0.0d0
      dz   = dp00
      do k= 1,kdm
        zz = zz + dz
        z(k) = -zz
        dz = dz * dp00f
        write(6,'(a,i3,f10.3,f10.5)')
     &    'k,zz,dz = ',k,zz,dz
      enddo
      open(unit=21,file='ovgrd_1.D',form='unformatted')
      al  = kdm+1
      als = nsigma+1
      write(21) al,als,z(0:kdm)
      end


      SUBROUTINE machar(ibeta,it,irnd,ngrd,machep,negep,iexp,minexp,
     *maxexp,eps,epsneg,xmin,xmax)
      INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
      REAL eps,epsneg,xmax,xmin
      INTEGER i,itemp,iz,j,k,mx,nxres
      REAL a,b,beta,betah,betain,one,t,temp,temp1,tempa,two,y,z,zero,
     *CONV
      CONV(i)=float(i)
      one=CONV(1)
      two=one+one
      zero=one-one
      a=one
1     continue
        a=a+a
        temp=a+one
        temp1=temp-a
      if (temp1-one.eq.zero) goto 1
      b=one
2     continue
        b=b+b
        temp=a+b
        itemp=int(temp-a)
      if (itemp.eq.0) goto 2
      ibeta=itemp
      beta=CONV(ibeta)
      it=0
      b=one
3     continue
        it=it+1
        b=b*beta
        temp=b+one
        temp1=temp-b
      if (temp1-one.eq.zero) goto 3
      irnd=0
      betah=beta/two
      temp=a+betah
      if (temp-a.ne.zero) irnd=1
      tempa=a+beta
      temp=tempa+betah
      if ((irnd.eq.0).and.(temp-tempa.ne.zero)) irnd=2
      negep=it+3
      betain=one/beta
      a=one
      do 11 i=1, negep
        a=a*betain
11    continue
      b=a
4     continue
        temp=one-a
        if (temp-one.ne.zero) goto 5
        a=a*beta
        negep=negep-1
      goto 4
5     negep=-negep
      epsneg=a
      machep=-it-3
      a=b
6     continue
        temp=one+a
        if (temp-one.ne.zero) goto 7
        a=a*beta
        machep=machep+1
      goto 6
7     eps=a
      ngrd=0
      temp=one+eps
      if ((irnd.eq.0).and.(temp*one-one.ne.zero)) ngrd=1
      i=0
      k=1
      z=betain
      t=one+eps
      nxres=0
8     continue
        y=z
        z=y*y
        a=z*one
        temp=z*t
        if ((a+a.eq.zero).or.(abs(z).ge.y)) goto 9
        temp1=temp*betain
        if (temp1*beta.eq.z) goto 9
        i=i+1
        k=k+k
      goto 8
9     if (ibeta.ne.10) then
        iexp=i+1
        mx=k+k
      else
        iexp=2
        iz=ibeta
10      if (k.ge.iz) then
          iz=iz*ibeta
          iexp=iexp+1
        goto 10
        endif
        mx=iz+iz-1
      endif
20    xmin=y
      y=y*betain
      a=y*one
      temp=y*t
      if (((a+a).ne.zero).and.(abs(y).lt.xmin)) then
        k=k+1
        temp1=temp*betain
        if ((temp1*beta.ne.y).or.(temp.eq.y)) then
          goto 20
        else
          nxres=3
          xmin=y
        endif
      endif
      minexp=-k
      if ((mx.le.k+k-3).and.(ibeta.ne.10)) then
        mx=mx+mx
        iexp=iexp+1
      endif
      maxexp=mx+minexp
      irnd=irnd+nxres
      if (irnd.ge.2) maxexp=maxexp-2
      i=maxexp+minexp
      if ((ibeta.eq.2).and.(i.eq.0)) maxexp=maxexp-1
      if (i.gt.20) maxexp=maxexp-1
      if (a.ne.y) maxexp=maxexp-2
      xmax=one-epsneg
      if (xmax*one.ne.xmax) xmax=one-beta*epsneg
      xmax=xmax/(beta*beta*beta*xmin)
      i=maxexp+minexp+3
      do 12 j=1,i
         if (ibeta.eq.2) xmax=xmax+xmax
         if (ibeta.ne.2) xmax=xmax*beta
12    continue
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/machar.for


!===============================
! ray_write_cell
!===============================
subroutine ray_analytic_rho(ilevel)
  use amr_commons
  use poisson_commons
  use ray_commons
  use pm_commons
  implicit none

  ! For testing porpoises
  ! Arguments:
  !            iray: to identify grid
  !            ind:  to identify cell
  !            istep: number of step

  real (dp), dimension(1:100, 1:8) :: ray_fields

  integer :: ngrid
  integer :: ilevel, ind, igrid, icell, iskip, igrid_mg
  integer :: ix, iy, iz
  real(dp), dimension(1:3) :: xc
  real(dp), dimension(1:3) :: x_cell
  real(dp) :: dx
  real(dp), dimension(1:100) :: mean_fields

  integer :: i, j

  logical :: found_boundary
  integer :: found

  real(dp) :: r2
  real(dp) :: b2, c2  ! Semiaxis of the thing

  if(myid==1) write(*,*) "Entering ray_analytic_rho..."

  ngrid=active(ilevel)%ngrid
  dx  = 0.5d0**ilevel

  b2 = 1.0  !0.6**2
  c2 = 1.0  !0.7**2

  ! Loop over cells
  do ind=1,twotondim
     iskip = ncoarse+(ind-1)*ngridmax

     ! Loop over active grids
     do igrid_mg=1,ngrid
        igrid = active(ilevel)%igrid(igrid_mg)
        icell = iskip + igrid

        iz=(ind-1)/4
        iy=(ind-1-4*iz)/2
        ix=(ind-1-2*iy-4*iz)
        xc(1)=(dble(ix)-0.5D0)*dx
        xc(2)=(dble(iy)-0.5D0)*dx
        xc(3)=(dble(iz)-0.5D0)*dx

        x_cell(1) = xg(igrid,1) + xc(1)
        x_cell(2) = xg(igrid,2) + xc(2)
        x_cell(3) = xg(igrid,3) + xc(3)

        r2 = (x_cell(1)-0.5D0)**2 + (x_cell(2)-0.5D0)**2/b2 + (x_cell(3)-0.5D0)**2/c2

        ! This is in the code presentation paper:
        rho(icell) = 10000.0D0 * exp(-r2/((1.5D0/ray_Lbox)**2));
        rho(icell) = 10000.0D0 * exp(-r2/((0.7D0/ray_Lbox)**2));
        !rho(icell) = 10000.0D0 * exp(-r2/((0.1D0/ray_Lbox)**2));
        !rho(icell) = 0.0001*x_cell(1)
        ! This is for ISW:

        !rho(icell) = 10000.0D0 * (x_cell(3)-0.5D0)**3*(x_cell(1)-0.5D0)**2
        !rho(icell) = 10000.0D0 * (x_cell(3)-0.5D0)**2*(x_cell(1)-0.5D0)**2

        phi(icell) = -rho(icell)

        !phi(icell) = 100.0D0*x_cell(2)**3+10000.0D0

     end do
  end do

  ! Communicate
  call make_virtual_fine_dp(rho(1),ilevel)
  call make_virtual_fine_dp(phi(1),ilevel)

end subroutine ray_analytic_rho


      SUBROUTINE DSINTI (N,WSAVE)
      IMPLICIT NONE
      INTEGER :: N, K, NP1, NS2
      DOUBLE PRECISION :: WSAVE(1), DT, PI
      DATA PI /3.14159265358979323846D0/
      IF (N .LE. 1) RETURN
      NS2 = N/2
      NP1 = N+1
      DT = PI/FLOAT(NP1)
      DO 101 K=1,NS2
         WSAVE(K) = 2.0D0*SIN(K*DT)
  101 CONTINUE
      CALL DFFTI (NP1,WSAVE(NS2+1))
      RETURN
      END


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      SUBROUTINE LINE3 (COORD, NUMNP, DIST, T, NDIM, P1, P2, TOLER,
     *   NODEL, BOUND, SORTYP, MAP, SORUP, INUM, OPT, SELECT)
      DIMENSION COORD (NUMNP,*), DIST(*), T(*), P1(*), P2(*),
     *   TOLER(2), MAP(*)
      CHARACTER*(*) NODEL, BOUND, SORTYP, OPT
      LOGICAL SORUP, SELECT(*), ISABRT
      include 'nu_io.blk'

      CALL LOCOUT ('LINE', NDIM, NODEL, TOLER, SORTYP, P1, P2, BOUND)

      IF (BOUND(:3) .EQ. 'BOU') THEN
         BMULT = 1.0
      ELSE
         BMULT = 0.0
      END IF

      TEMP = TOLER(1)
      TOLER(1) = MAX(0.0, TEMP - TOLER(2))
      TOLER(2) = MAX(0.0, TEMP + TOLER(2))

      A  = P2(1) - P1(1)
      B  = P2(2) - P1(2)
      C  = P2(3) - P1(3)
      X1 = P1(1)
      Y1 = P1(2)
      Z1 = P1(3)
      DLINE = A**2 + B**2 + C**2
      IF (DLINE .EQ. 0.0) THEN
         CALL PRTERR ('CMDERR', 'Zero length line input')
         RETURN
      END IF

      DO 10 I=1, NUMNP
         IF (SELECT(I)) THEN
            X0 = COORD(I,1)
            Y0 = COORD(I,2)
            Z0 = COORD(I,3)
            T(I) = -1. * (A * (X1 - X0) + B * (Y1 - Y0) + C * (Z1 - Z0))
     *              / (A**2 + B**2 + C**2)

            X = X1 + A * T(I)
            Y = Y1 + B * T(I)
            Z = Z1 + C * T(I)

            DIST(I) = (X - X0)**2 + (Y - Y0)**2 + (Z - Z0)**2
         END IF
   10 CONTINUE
      INUM = 0
      DISMIN = 1.0E38
      DO 20 I=1, NUMNP
         IF (SELECT(I)) THEN
            DISMIN = MIN(DIST(I), ABS(DISMIN-TEMP))
            IF (DIST(I) .GE. TOLER(1)**2 .AND. DIST(I) .LE. TOLER(2)**2
     *         .AND. BMULT * T(I) .GE. 0.0 .AND. BMULT * T(I) .LE. 1.0)
     *         THEN
               INUM = INUM + 1
               MAP(INUM) = I
            END IF
         END IF
   20 CONTINUE

      IF      (SORTYP .EQ. 'X') THEN
         CALL INDEXX (COORD(1,1), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Y') THEN
         CALL INDEXX (COORD(1,2), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'Z') THEN
         CALL INDEXX (COORD(1,3), MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'T' .OR. SORTYP .EQ. 'PARAMETR') THEN
         CALL INDEXX (T,          MAP, INUM, .FALSE.)
      ELSE IF (SORTYP .EQ. 'DISTANCE') THEN
         CALL INDEXX (DIST,       MAP, INUM, .FALSE.)
      END IF

      IF (SORUP) THEN
         IBEG = 1
         IEND = INUM
         IINC = 1
      ELSE
         IBEG = INUM
         IEND = 1
         IINC = -1
      END IF

      IF (OPT .EQ. '*' .OR. INDEX(OPT, 'P') .GT. 0) THEN
         DO 30 IO=IOMIN, IOMAX
            WRITE (IO, 40) NODEL
   30    CONTINUE
   40    FORMAT (/,T50,'DISTANCE',/2X,A8,T16,'X',T26,'Y',T36,'Z',
     *      T45,'NORMAL',T55,'PARAMETRIC',/)
         DO 60 IN = IBEG, IEND, IINC
            IF (ISABRT()) RETURN
            I = MAP(IN)
            DO 50 IO=IOMIN, IOMAX
               WRITE (IO, 90) I, (COORD(I,J),J=1,3), SQRT(DIST(I)),
     *            T(I)
   50       CONTINUE
   60    CONTINUE

         IF (INUM .EQ. 0) THEN
            DO 70 IO=IOMIN, IOMAX
               WRITE (IO, 80) SQRT(DISMIN)
   70       CONTINUE
         END IF
      END IF
   80 FORMAT (/' None found within range, minimum distance = ',
     *   1PE12.3,/)
   90 FORMAT (I10, 3(F10.4), 2(1PE12.3))
      RETURN
      END


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2020 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 norshell6(xi,et,xl,xnor)
!
!     calculates the normal on a triangular shell element in a point
!     with local coordinates xi and et. The coordinates of the nodes
!     belonging to the element are stored in xl
!
      implicit none
!
      integer i,j,k
!
      real*8 shp(4,6),xs(3,2),xl(3,6),xnor(3)
!
      real*8 xi,et
!
!     shape functions and their glocal derivatives for an element
!     described with two local parameters and three global ones.
!
!     local derivatives of the shape functions: xi-derivative
!
      shp(1,1)=4.d0*(xi+et)-3.d0
      shp(1,2)=4.d0*xi-1.d0
      shp(1,3)=0.d0
      shp(1,4)=4.d0*(1.d0-2.d0*xi-et)
      shp(1,5)=4.d0*et
      shp(1,6)=-4.d0*et
!
!     local derivatives of the shape functions: eta-derivative
!
      shp(2,1)=4.d0*(xi+et)-3.d0
      shp(2,2)=0.d0
      shp(2,3)=4.d0*et-1.d0
      shp(2,4)=-4.d0*xi
      shp(2,5)=4.d0*xi
      shp(2,6)=4.d0*(1.d0-xi-2.d0*et)
!
!     computation of the local derivative of the global coordinates
!     (xs)
!
      do i=1,3
        do j=1,2
          xs(i,j)=0.d0
          do k=1,6
            xs(i,j)=xs(i,j)+xl(i,k)*shp(j,k)
          enddo
        enddo
      enddo
!
!     computation of the jacobian determinant
!
      xnor(1)=xs(2,1)*xs(3,2)-xs(3,1)*xs(2,2)
      xnor(2)=xs(1,2)*xs(3,1)-xs(3,2)*xs(1,1)
      xnor(3)=xs(1,1)*xs(2,2)-xs(2,1)*xs(1,2)
!
      return
      end