!----------------------Subroutine--------------------------------------!
!
      SUBROUTINE PERM_I( PERMRFX,PORDX )
!
!-------------------------Disclaimer-----------------------------------!
!
!     This material was prepared as an account of work sponsored by
!     an agency of the United States Government. Neither the
!     United States Government nor the United States Department of
!     Energy, nor Battelle, nor any of their employees, makes any
!     warranty, express or implied, or assumes any legal liability or
!     responsibility for the accuracy, completeness, or usefulness
!     of any information, apparatus, product, software or process
!     disclosed, or represents that its use would not infringe
!     privately owned rights.
!
!----------------------Acknowledgement---------------------------------!
!
!     This software and its documentation were produced with Government
!     support under Contract Number DE-AC06-76RLO-1830 awarded by the
!     United Department of Energy. The Government retains a paid-up
!     non-exclusive, irrevocable worldwide license to reproduce,
!     prepare derivative works, perform publicly and display publicly
!     by or for the Government, including the right to distribute to
!     other Government contractors.
!
!---------------------Copyright Notices--------------------------------!
!
!            Copyright Battelle Memorial Institute, 1996
!                    All Rights Reserved.
!
!----------------------Description-------------------------------------!
!
!     Kozeny-Carmen  Porosity-Permeability Relationship
!
!     Original:
!     Carman PC. 1937. Fluid flow through granular beds. Transactions of
!     the Institution of Chemical Engineers, 15:150-156.
!     Reprinted:
!     Carman PC. 1997. Fluid flow through granular beds. Chemical
!     Engineering Research & Design, 75:S32-S48.
!
!
!----------------------Authors-----------------------------------------!
!
!     Written by DH Bacon, PNNL, 11 Nov 2010.
!

!----------------------Fortran 90 Modules------------------------------!
!
      USE GLB_PAR
      USE SOLTN
!

!----------------------Implicit Double Precision-----------------------!
!
      IMPLICIT REAL*8 (A-H,O-Z)
      IMPLICIT INTEGER (I-N)
!
!----------------------Parameter Statements----------------------------!
!

!
!----------------------Common Blocks-----------------------------------!
!

!
!----------------------Executable Lines--------------------------------!
!
      ISUB_LOG = ISUB_LOG+1
      SUB_LOG(ISUB_LOG) = '/PERM_I'
      IF( INDEX(SVN_ID(331)(1:1),'$').EQ.0 ) SVN_ID(331) =
     & '$Id: perm_i.F 1080 2017-03-14 16:22:02Z d3c002 $'
!
!---  Permeability reduction factor  ---
!
      PERMRFX = PORDX*PORDX*PORDX/((1.D+0 - PORDX)*(1.D+0 - PORDX))
!
!---  Reset subroutine string sequence  ---
!
      ISUB_LOG = ISUB_LOG-1
!
!---  End of PERM_I group  ---
!
      RETURN
      END


module ThermalModelM
  use UtilitiesM

  use SparseKit

  use MeshM
  use ModelM

  use HeatFluxM

  implicit none

  private
  public :: ThermalModelDT, thermalModel

  type, extends(modelDT) :: ThermalModelDT
     type(Sparse)                           :: lhs
     type(Sparse)                           :: mass
     real(rkind), dimension(:), allocatable :: rhs
     real(rkind), dimension(:), allocatable :: dof
     type(HeatFluxDT)                       :: heatFlux
   contains
     procedure, public :: init
     procedure, public :: freeSystem
     procedure, public :: setTransientValues
  end type ThermalModelDT

  interface thermalModel
     procedure :: constructor
  end interface thermalModel

contains

  type(ThermalModelDT) function constructor(nDof, nnz, id, nNode, nElement, nCondition)
    implicit none
    integer(ikind), intent(in) :: nDof
    integer(ikind), intent(in) :: nnz
    integer(ikind), intent(in) :: id
    integer(ikind), intent(in) :: nNode
    integer(ikind), intent(in) :: nElement
    integer(ikind), intent(in) :: nCondition
    call constructor%init(nDof, nnz, id, nNode, nElement, nCondition)
  end function constructor

  subroutine init(this, nDof, nnz, id, nNode, nElement, nCondition)
    implicit none
    class(ThermalModelDT), intent(inout) :: this
    integer(ikind)       , intent(in)    :: nDof
    integer(ikind)       , intent(in)    :: nnz
    integer(ikind)       , intent(in)    :: id
    integer(ikind)       , intent(in)    :: nNode
    integer(ikind)       , intent(in)    :: nElement
    integer(ikind)       , intent(in)    :: nCondition
    this%lhs  = sparse(nnz, nDof)
    this%mass = sparse(nnz, nDof)
    allocate(this%rhs(nDof))
    allocate(this%dof(nDof))
    call this%initModel(1) !una sola malla en el modelo
    this%mesh(1) = mesh(id, nNode, nElement, nCondition)
  end subroutine init

  subroutine freeSystem(this)
    implicit none
    class(ThermalModelDT), intent(inout) :: this
    call this%lhs%free()
    if(allocated(this%rhs)) deallocate(this%rhs)
  end subroutine freeSystem

  subroutine setTransientValues(this, printStep, t0, errorTol)
    implicit none
    class(ThermalModelDT), intent(inout) :: this
    integer(ikind)       , intent(in)    :: printStep
    real(rkind)          , intent(in)    :: t0
    real(rkind)          , intent(in)    :: errorTol
    call this%processInfo%setPrintStep(printStep)
    call this%processInfo%setT0(t0)
    call this%processInfo%setErrorTol(errorTol)
  end subroutine setTransientValues

end module ThermalModelM


!-----------------------------------------------------------
! Subroutine to write snapshots of the disc
! as a function of radius
!
!-----------------------------------------------------------

subroutine write_dump

  use gravdata
  use magdata
  use unitdata

  implicit none

  real ::  alpha_visc,sig_max,mdisk, tot_lumin
  real :: mdot_grav, mdot_mag, grav_max,mag_max, mmag,mgrav
  integer :: i,ifirst

  write (*,103) 'Output at time t = ',t/yr
102 format (9E15.5)
103 format (A,E15.5)
104 format (4E15.5)
107 format(7E15.5)
110 format(10E15.5)
111 format (11E15.5)

  ! Calculate parameters

  call calc_layers
  call luminosity(tot_lumin,spectrum,Tc,tau)

  ! write out disc profiles
  IF(counter<=9) THEN
           WRITE(fileno,'(I1)') counter
        ELSE IF(counter>9.and.counter<=99) THEN
           WRITE(fileno,'(I2)') counter
        ELSE IF(counter>99.and.counter<=999) THEN
           WRITE(fileno,'(I3)') counter
        ELSE IF(counter>999.and.counter<=9999) THEN
           WRITE(fileno,'(I4)') counter
        ELSE IF(counter>9999.and.counter<=99999) THEN
           WRITE(fileno,'(I5)') counter
        ENDIF
        fileno = TRIM(fileno)

  OPEN(iprof, file=TRIM(prefix)//'profile.'//fileno, status='unknown')
  write(iprof,*) nrgrid
  do i = isr, ier

     write (iprof,110) rz(i)/AU,sigma(i), cs(i), kappa(i), gamma(i),mu(i),Tc(i), &
	tau(i),nu_tc(i), alpha_g(i)
  enddo

  close(iprof)

  OPEN(iprof,file=TRIM(prefix)//'layer.'//fileno,status='unknown')
  WRITE(iprof,*) nrgrid
  do i=isr,ier
     write(iprof,111) rz(i)/AU, sigma(i), sigma_m(i), sigma_tot(i), cs_m(i),kappa_m(i),gamma_m(i), &
	mu_m(i),tau_m(i),nu_m(i),alpha_m
  enddo
close(iprof)

  OPEN(ispec, file=TRIM(prefix)//'spectrum.'//fileno, status='unknown')
  write(ispec,*) 1000
  do i = 1, 1000
     write(ispec,*) spectrum(1,i), spectrum(2,i)
  enddo

  close(ispec)

  ! Compute disk mass and maximum surface density
  ! Also compute radially averaged accretion rates

  mdisk = 0.0d0
  mgrav= 0.0d0
  mmag = 0.0d0

  grav_max = 0.0d0
  mag_max = 0.0d0
  sig_max = 0.0d0

  do i = isr, ier
     mmag = mmag + 2.0d0*pi*rz(i)*(rf(i+1)-rf(i))*sigma_m(i)
     mgrav = mgrav + 2.0d0*pi*rz(i)*(rf(i+1)-rf(i))*sigma(i)
     mdisk = mdisk+2.0d0*pi*rz(i)*(rf(i+1)-rf(i))*sigma_tot(i)

     grav_max = max(grav_max,sigma(i))
     mag_max = max(mag_max,sigma_m(i))
     sig_max = max(sig_max,sigma_tot(i))

     mdot_grav = mdot_grav + 3.0*pi*nu_tc(i)*sigma(i)/REAL(nrgrid)
     mdot_mag = mdot_mag + 3.0*pi*nu_m(i)*sigma_m(i)/REAL(nrgrid)

  enddo

  mdisk = mdisk/solarmass
  mgrav = mgrav/solarmass
  mmag = mmag/solarmass

  mdot_grav = mdot_grav*yr/solarmass
  mdot_mag = mdot_mag*yr/solarmass

  ! Write out snapshot data (disk mass, sigma, total luminosity)
  write(itime,110) t/yr, mgrav,mmag,mdisk, grav_max,mag_max, sig_max,tot_lumin, mdot_grav,mdot_mag

   open(87,file=TRIM(prefix)//'mri.'//fileno,status='unknown')
  do i=isr,ier
  write(87,*) rz(i)/AU, fullmri(i)
  enddo
  close(87)

  return

end  subroutine write_dump


module glbl_prmtrs
  implicit none
  public

double precision, parameter :: smalldble=1.d-10, bigdble=1.d99
integer         , parameter :: intbigdble=100000000
double precision, parameter :: one=1.d0, dpi=dacos(-1.d0), zero=0.d0, half=0.5d0, two=2.d0
character(len=*), parameter :: undefined = 'undefined'

! CGS
double precision, parameter :: kboltz = 1.3806488D-16
double precision, parameter :: stefan = 5.670373d-5
double precision, parameter :: mnucl = 1.6733D-24
double precision, parameter :: msun = 1.989D+33
double precision, parameter :: rsolar = 7.0D+10
double precision, parameter :: secinday= 8.64d4
double precision, parameter :: secinyear= 3.1557600d7
double precision, parameter :: ggrav  = 6.67384D-8
double precision, parameter :: clight = 2.99792458d10
double precision, parameter :: Lsun = 3.846d23
double precision, parameter :: AU = 1.49597871d13
double precision, parameter :: Jsun = 1.1d47 ! ang. mom. for 25d
double precision, parameter :: sigmaE = 6.652458734d-25 ! = sigma_thomson_scattering_on_free_electrons
double precision, parameter :: kpE = 3.98d-1 ! 3.1d-2! = sigma_thomson / mass_proton.
! For kpE, we used the formula (65) of KUDRITZKI+89 w/ I_HE=2 & N_He/N_H = 0.2

INTEGER, PARAMETER :: nshpe=4, nw=4
INTEGER, PARAMETER :: fll_=1, eta_=fll_+1, q_=eta_+1, bet_=q_+1

! integer, parameter :: nshpe=2
! integer, parameter :: q_=1, fll_=q_+1

! INTEGER, PARAMETER :: neqpar=20
! INTEGER, PARAMETER :: aleph_=1, GM1mod_=aleph_+1, GM2_=GM1mod_+1, Om_=GM2_+1, a_=Om_+1, Rstr_=a_+1, Racc_=Rstr_+1, &
!                       CM_=Racc_+1, gm_=CM_+1, &
!                       GM1_=gm_+1, beta_=GM1_+1, vinf_=beta_+1, &
!                       ratioRadiiIni_=vinf_+1, g0lines_=ratioRadiiIni_+1, &
!                       MdotHL_ = g0lines_+1, rout_=MdotHL_+1, egg_=rout_+1, velIni_=egg_+1, roche2_=velIni_+1, NStoL1_=roche2_+1

INTEGER, PARAMETER :: neqpar=5
INTEGER, PARAMETER :: egg_=1, NStoL1_=egg_+1, CM_=NStoL1_+1, potatL1_=CM_+1, Racc_=potatL1_+1

! usr-defined
! Specify the number of lines in the files where the accelerations are stores
double precision, dimension(69) :: rad_andreas, dist_andreas
COMMON rad_andreas, dist_andreas

! GM1_
! R_ --> Rstr_
! L_ <-- Luminosity
! kbT_ <-- Temperature
! Edd_ <-- Gamma_Eddington
! Mdot_ <-- Mdot_0
! rho0_
! cs0_
! al_
! gmRad_

integer, parameter :: NrWind=200000 ! # of radial steps in the subroutine mass_wind
double precision, dimension(2,NrWind) :: glines1D
double precision, dimension(2,NrWind) :: glines
COMMON glines1D, glines
double precision :: th_min, ph_max, ph_min, courantpar
COMMON th_min, ph_max, ph_min, courantpar
double precision :: rmin
COMMON rmin
double precision :: chrono_0, chrono_1, chrono_2, chrono_3, chrono_4, chrono_5
COMMON chrono_0, chrono_1, chrono_2, chrono_3, chrono_4, chrono_5
character(len=8), parameter :: chrono_0_mess='chrono_0', chrono_1_mess='chrono_1', &
chrono_2_mess='chrono_2', chrono_3_mess='chrono_3', chrono_4_mess='chrono_4', chrono_5_mess='chrono_5'

!V!DOUBLE PRECISION :: normt
DOUBLE PRECISION,DIMENSION(nshpe) :: shpe
DOUBLE PRECISION,DIMENSION(neqpar) :: eqpar
!V!DOUBLE PRECISION,DIMENSION(nw+1) :: normvar
COMMON   eqpar,shpe!,normvar,normt,shpe
INTEGER :: i0max, j0max, kmax, Nth_rmp, Nph_rmp
COMMON   i0max, j0max, kmax, Nth_rmp, Nph_rmp
character(len=500) :: folder
COMMON folder
character(len=400) :: mess
COMMON mess
character(len=400) :: log_file, scale_file, par_file, &
big_picture, surf_pts, arrival_map, out_file, err_file, hist_file, &
mass_wind_1D
character(len=400) :: theta_logangle, param_file, info_file, draw_all_in_plane, &
draw_good_in_plane, adim_file, dim_file, parameter_file, file_radiative, file_pressure, Rout, Lorb
character(len=4)   :: law
COMMON law
COMMON log_file, scale_file, par_file, &
big_picture, surf_pts, arrival_map, out_file, err_file, hist_file, &
mass_wind_1D, adim_file, dim_file, file_radiative, file_pressure, Rout, Lorb
COMMON theta_logangle, param_file, info_file, draw_all_in_plane, draw_good_in_plane, parameter_file
logical :: want_it_all, wind_boosted50, fast_wind
COMMON want_it_all, wind_boosted50, fast_wind

end module glbl_prmtrs


!     ------------------------------------------------------------------
Subroutine DecisionBifurcation(AE, BE, MaxLRows, XLL, NDim, iDofT, NodELT, Sol0, Sol1, CommonPar, Param, JParam, DelT, DTm, Time)
!     ------------------------------------------------------------------
	use funcAux
	use finiteStrainLib !! New Way
	use ptsGaussLib
	use DETERMINANT , only : lengthParam
	use multiscaleLib, only : getMinDetQ

	implicit none

	!   ===== SUBROUTINE ARGUMENTS  =======
	integer :: MaxLRows,Ndim,iDofT,NodELT! all integers
	Real*8 :: DelT, DTm,Time ! all reals
	Real*8 :: AE(MaxLRows,MaxLRows), BE(MaxLRows), XLL(*), Sol0(*), Sol1(*), Param(*), JParam(*), CommonPar(*)

	!   =====   END ARGUMENTS  =======

	Integer :: nG , ApRow, i, j ! counters
	integer, parameter :: NdimE = 2 ! this code only makes sense in 2D
	Real*8 :: GradU(NdimE,NdimE)
	Real*8 , allocatable ::  SolU(:) , Xel(:) !! all have dimension NodG*NdimE
	integer :: iShiftDeltaU , iShiftFlag, Nelem , PosDetQ, PosBifDomain, iShiftC
	integer :: pOrder , NGP, NodG, iFEMtype , iSimplex, iBubble , nStepTheta
	real*8 :: normal(NdimE), beta(NdimE), alpha, theta, bifFac
	real*8 , save :: minDetQ = 0.0d0 ,thetaCrit = 0.0d0, betaCrit = 0.0d0
	type(ptGaussClass) :: PtG
	integer , save :: iElem = 0

	iShiftDeltaU = nint(CommonPar(1))
	iShiftC = nint(CommonPar(2))
	iFEMtype = nint(CommonPar(3))
	NElem = nint(commonPar(4))
	PosBifDomain = nint(CommonPar(5)) ! in the Param
	PosDetQ = nint(CommonPar(6)) ! in the last node

	call setFEMtype(iFEMtype,NodG,pOrder,NGP,iSimplex,iBubble)

	call getSliceAllocate(SolU,Sol1,1,NodG,iShiftDeltaU + 1 ,iShiftDeltaU + NdimE, iDofT)
	call getSliceAllocate(Xel,XLL,1,NodG,1 ,NdimE, Ndim)

	NGP = 1
	nG = 1

	call PtG%init(Xel,NodG,NdimE,NGP,pOrder,iBubble, iSimplex)

	call PtG%calcGradU(GradU,SolU,nG)

	bifFac = 0.0d0
	iElem = mod(iElem + 1,Nelem)

	if(iElem == 0) then
		nStepTheta = 100
		call getMinDetQ(minDetQ,thetaCrit,betaCrit,Sol1,NdimE,idofT,NodElt,iShiftC,nStepTheta)
	end if

	if(minDetQ < 0.0d0) then
		alpha = 0.0d0*PI
		theta = datan(0.3d0/1.0d0)
		normal(1) = -dsin(theta)
		normal(2) = dcos(theta)
		beta(1) = dcos(theta + alpha)
		beta(2) = dsin(theta + alpha)

		do i = 1, NdimE
		do j = 1, NdimE
			BifFac = BifFac + GradU(i,j)*beta(i)*normal(j)
		end do
		end do

	end if

	Param(LengthParam + PosBifDomain ) = BifFac

	ApRow  = NodG*iDofT + PosDetQ
	AE(ApRow,ApRow) = 1.0d0
	BE(ApRow) = minDetQ

	deallocate(SolU,Xel)

end subroutine

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Subroutine DecisionBifurcationS(Coupling,CommonPar,iDofT,Ndim,MaxLRows,iAdd)
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
	use funcAux
	use ptsGaussLib
    IMPLICIT NONE
    Integer :: MaxLRows,Ndim,iDofT, iAdd
    Integer   Coupling(MaxLRows,MaxLRows)
    Real*8 CommonPar(*)

    Integer :: ApRow, iShiftFlag, iFemType, NodG, PosDetQ
	integer, parameter :: NdimE = 2

	iFEMtype = nint(CommonPar(3))
	PosDetQ = nint(CommonPar(6)) ! in the last node

	call setNodG(iFemType, NodG)

	ApRow  = NodG*iDofT + PosDetQ

	Coupling(ApRow,ApRow) =  1

end Subroutine


      subroutine extln(x,y,z,g)
      common/gfeps/ eps,lengte
      dimension x(2),y(2),z(2)
C
C ====================================================================
C    extend the line with end points "x(1),y(1),z(1)" and "x(2),y(2),
C    z(2)" at both ends a distance "g" on the picture plane.
C ====================================================================
C
C.....the end point "1" - with greater "y" value.
      am=y(1)-y(2)
      if(abs(am).le.eps) goto 1
      an=(z(1)-z(2))/am
      am=(x(1)-x(2))/am
      a=g/sqrt(1.+am*am)
      v=a*am
      u=a*an
C++   print 100,an,am,a,v,u
C##100   format(' s/p extln: an,am,a,v,u=',5f10.3)
C
C.....the end point "0".
      y(1)=y(1)+a
      x(1)=x(1)+v
      z(1)=z(1)+u
C.....point "3".
      y(2)=y(2)-a
      x(2)=x(2)-v
      z(2)=z(2)-u
      return
C..... case, when "y(1)=y(2)".
1     continue
      u=x(1)
      v=x(2)
      am=x(1)-x(2)
      if(am.ge.0.) goto 2
      x(1)=x(1)-g
      x(2)=x(2)+g
C----- y(1) and y(2) are without any change |
      goto 3
2     continue
      x(1)=x(1)+g
      x(2)=x(2)-g
C----- y(1) and y(2) are without any change |
3     continue
      if(abs(am).le.eps) return
      an=(z(1)-z(2))/am
      z(1)=z(1)+an*(x(1)-u)
      z(2)=z(2)+an*(x(2)-v)
C++   print 101,u,v,am
C##101   format(' unusual s/p *extln*: u,v,am=',3f10.3)
      return
      end


!--------------------------------------------------------------------------------------
!
!Copyright (C) 2014 TopCoder Inc., All Rights Reserved.
!
!--------------------------------------------------------------------------------------

!--------------------------------------------------------------------------------------
!
!   Copyright 2014 Ecole Centrale de Nantes, 1 rue de la No�, 44300 Nantes, France
!
!   Licensed under the Apache License, Version 2.0 (the "License");
!   you may not use this file except in compliance with the License.
!   You may obtain a copy of the License at
!
!       http://www.apache.org/licenses/LICENSE-2.0
!
!   Unless required by applicable law or agreed to in writing, software
!   distributed under the License is distributed on an "AS IS" BASIS,
!   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!   See the License for the specific language governing permissions and
!   limitations under the License.
!
!   Contributors list:
!   - G. Delhommeau
!   - P. Guevel
!   - J.C. Daubisse
!   - J. Singh
!
!--------------------------------------------------------------------------------------

!   This module computes the potential for problem already solved.
!
! Changes in version 1.2 (Implementation of Higher Order Panel Methods)
!       Added COMMON_TYPE module as dependency

!   @author yedtoss
!   @version 1.2
MODULE POTENTIAL_DOMAIN

    USE COMMON_TYPE
    IMPLICIT NONE

CONTAINS

    SUBROUTINE COMPUTE_POTENTIAL_DOMAIN(PHI,XC,YC,ZC,AM0,AMH,NEXP, SolverVar)
        !
        USE MIDENTIFICATION
        USE COM_VAR
        USE ELEMENTARY_FNS
        USE COMPUTE_GREEN_FREESURFACE
        !

        !
        INTEGER::J,NEXP
        REAL::XC,YC,ZC,AM0,AMH
        REAL:: S1B,S2B,S1S,S2S,C,D,POT1,POT2
        REAL:: W,PI,DPI
        COMPLEX :: PHI

        TYPE(TempVar), TARGET :: SolverVar
        REAL, POINTER :: T
        COMPLEX, DIMENSION(:), POINTER :: ZPB,ZPS
        COMPLEX, DIMENSION(:), POINTER :: ZIGB,ZIGS
        COMPLEX, DIMENSION(:, :), POINTER :: ZIJ
        REAL, POINTER :: FSP,FSM,VSXP,VSYP,VSZP,VSXM,VSYM,VSZM
        REAL, POINTER :: SP1,SM1,SP2,SM2
        REAL, POINTER :: VSXP1,VSXP2,VSYP1,VSYP2,VSZP1,VSZP2
        REAL, POINTER :: VSXM1,VSXM2,VSYM1,VSYM2,VSZM1,VSZM2
        INTEGER, POINTER:: NQ
        REAL, POINTER:: CQ(:),QQ(:),AMBDA(:),AR(:)
        T => SolverVar%T
        ZPB => SolverVar%ZPB
        ZPS => SolverVar%ZPS
        ZIGB => SolverVar%ZIGB
        ZIGS => SolverVar%ZIGS
        ZIJ => SolverVar%ZIJ
        FSP => SolverVar%FSP
        FSM => SolverVar%FSM
        VSXP => SolverVar%VSXP
        VSYP => SolverVar%VSYP
        VSZP => SolverVar%VSZP
        VSXM => SolverVar%VSXM
        VSYM => SolverVar%VSYM
        VSZM => SolverVar%VSZM
        SP1 => SolverVar%SP1
        SM1 => SolverVar%SM1
        SP2 => SolverVar%SP2
        SM2 => SolverVar%SM2
        VSXP1 => SolverVar%VSXP1
        VSXP2 => SolverVar%VSXP2
        VSYP1 => SolverVar%VSYP1
        VSYP2 => SolverVar%VSYP2
        VSZP1 => SolverVar%VSZP1
        VSZP2 => SolverVar%VSZP2
        VSXM1 => SolverVar%VSXM1
        VSXM2 => SolverVar%VSXM2
        VSYM1 => SolverVar%VSYM1
        VSYM2 => SolverVar%VSYM2
        VSZM1 => SolverVar%VSZM1
        VSZM2 => SolverVar%VSZM2
        NQ => SolverVar%NQ
        CQ => SolverVar%CQ
        QQ => SolverVar%QQ
        AMBDA => SolverVar%AMBDA
        AR => SolverVar%AR
        !
        PI=4.*ATAN(1.)
        DPI=2.*PI
        W=DPI/T
        POT1=0.0
        POT2=0.0

        DO J=1,IMX
            SP1=0.
            SP2=0.
            SM1=0.
            SM2=0.
            IF((Depth .EQ. 0.) .OR. (AMH .GE. 20))  THEN
                CALL VVV(1, 1,J,XC,YC,ZC, SolverVar) ! finite part
                CALL VNV(1, J,XC,YC,ZC, SolverVar)  !infinite part
            ELSE
                CALL VVV(1, 2,J,XC,YC,ZC, SolverVar)
                CALL VNVF(1, AM0,AMH,NEXP,J,XC,YC,ZC, SolverVar)
            ENDIF
            S1B=REAL(ZIGB(J))
            S1S=REAL(ZIGS(J))
            S2B=AIMAG(ZIGB(J))
            S2S=AIMAG(ZIGS(J))
            IF(NSYMY.EQ.0)THEN
                C=S1B*SP1
                D=S2B*SP2
                POT1=POT1+C-D
                C=S1B*SP2
                D=S2B*SP1
                POT2=POT2+C+D
            ELSE
                C=S1B*(SP1+SM1)+S1S*(SP1-SM1)
                D=S2B*(SP2+SM2)+S2S*(SP2-SM2)
                POT1=POT1+(C-D)*0.5
                C=S1B*(SP2+SM2)+S1S*(SP2-SM2)
                D=S2B*(SP1+SM1)+S2S*(SP1-SM1)
                POT2=POT2+(C+D)*0.5
            ENDIF
        END DO

        PHI=CMPLX(POT1,POT2)
        RETURN
    !      PRE1=-POT2*W/G
    !      PRE2=POT1*W/G
    !      POMOD=SQRT(PRE1**2+PRE2**2)
    !
    END SUBROUTINE

END MODULE POTENTIAL_DOMAIN


subroutine calcfull (j, nlon, nlat, nmon, ismf,           &
                     jsmf, iyr1rd, mon1rd, iyr1, mon1,    &
                     iyrn, monn, iyrnrd, monnrd, maxiter, &
                     tmin, tmax, dt, conv, bbmin,         &
                     obsclim, arr, centmon, a, c,         &
                     correl, oldttcalc)
   use prec
   use solver, only: solvmid

   implicit none

   integer, intent(in) :: j
   integer, intent(in) :: nlon
   integer, intent(in) :: nlat
   integer, intent(in) :: nmon
   integer, intent(in) :: monn
   integer, intent(in) :: iyrn
   integer, intent(in) :: maxiter
   integer, intent(in) :: iyr1
   integer, intent(in) :: mon1
   integer, intent(in) :: iyr1rd
   integer, intent(in) :: mon1rd
   integer, intent(in) :: iyrnrd
   integer, intent(in) :: monnrd

   real(r8), intent(in) :: tmin
   real(r8), intent(in) :: tmax
   real(r8), intent(in) :: dt
   real(r8), intent(in) :: conv
   real(r8), intent(in) :: bbmin

   real(r8), intent(inout) :: obsclim(nlon,nlat,12)
   real(r8), intent(inout) :: arr(nlon,nmon)
   real(r8), intent(in) :: centmon(nlon,nlat,12)
   real(r8), intent(in) :: a(nmon)
   real(r8), intent(in) :: c(nmon)
   real(r8), intent(in) :: correl(12)

   logical, intent(in) :: oldttcalc     ! for bfb agreement with original code

   integer :: ismf, jsmf
   integer :: i
   integer :: n, m, mm
   integer :: nprior, nafter

   real(r8) :: vecin(nmon)
   real(r8) :: vecout(nmon)
   real(r8) :: cc
   real(r8) :: tt

   write(6,*) 'Calculating mid-month values for latitude ', j

   do i=1,nlon

! Fill in some months prior to the 1st observed month and
! after the last observed month

      nprior = 12*(iyr1rd-iyr1) + mon1rd - mon1
      if (nprior > 0) then
         do m=1,nprior
            if ((nprior+1-m) > 12) then
               cc = 0.0
            else
               cc = correl(nprior+1-m)
            end if
            mm = mod((mon1-2+m), 12) + 1
            tt = arr(i,nprior+1)*cc
            if (obsclim(i,j,mm)+tt > tmax) tt = tmax-obsclim(i,j,mm)
!
!JR Bugfix from K. Taylor: do not zero tt.  Keep to allow bfb vs. original code
!
            if (oldttcalc) then
               if (obsclim(i,j,mm) >= tmax) tt = 0.0
            end if
            if (obsclim(i,j,mm)+tt  < tmin) tt = tmin-obsclim(i,j,mm)
            if (oldttcalc) then
               if (obsclim(i,j,mm) <= tmin) tt = 0.0
            end if
            arr(i,m) = tt
         end do
      end if

      nafter = 12*(iyrn-iyrnrd) + monn - monnrd

      if (nafter > 0) then
         do m=1,nafter
            if (m > 12) then
               cc = 0.0
            else
               cc = correl(m)
            end if
            mm = mod((monnrd-1+m), 12) + 1
            tt = arr(i,nmon-nafter)*cc
            if ((obsclim(i,j,mm)+tt) > tmax) tt = tmax-obsclim(i,j,mm)
!
!JR Bugfix from K. Taylor: do not zero tt.  Keep to allow bfb vs. original code
!
            if (oldttcalc) then
               if (obsclim(i,j,mm)  >= tmax) tt = 0.0
            end if
            if ((obsclim(i,j,mm)+tt) < tmin) tt = tmin-obsclim(i,j,mm)
            if (oldttcalc) then
               if (obsclim(i,j,mm)  <= tmin) tt = 0.0
            end if
            arr(i,nmon-nafter+m) = tt
         end do
      end if

! Copy data into vecin, vecout

      do n=1,nmon
         mm = mod((mon1+n-2), 12) + 1
         vecin(n) = arr(i,n) + obsclim(i,j,mm)
         vecout(n) = vecin(n)
      end do

      call solvmid (i, j, nmon, conv, dt, &
                    tmin, tmax, bbmin, maxiter, a, &
                    c, vecin, vecout, ismf, jsmf)

      do n=1,nmon
         mm = mod((mon1+n-2), 12) + 1
         arr(i,n) = vecout(n) - centmon(i,j,mm)
      end do
   end do

   return
end subroutine calcfull


      SUBROUTINE DL7SRT(N1, N, L, A, IRC)
C
C  ***  COMPUTE ROWS N1 THROUGH N OF THE CHOLESKY FACTOR  L  OF
C  ***  A = L*(L**T),  WHERE  L  AND THE LOWER TRIANGLE OF  A  ARE BOTH
C  ***  STORED COMPACTLY BY ROWS (AND MAY OCCUPY THE SAME STORAGE).
C  ***  IRC = 0 MEANS ALL WENT WELL.  IRC = J MEANS THE LEADING
C  ***  PRINCIPAL  J X J  SUBMATRIX OF  A  IS NOT POSITIVE DEFINITE --
C  ***  AND  L(J*(J+1)/2)  CONTAINS THE (NONPOS.) REDUCED J-TH DIAGONAL.
C
C  ***  PARAMETERS  ***
C
      INTEGER N1, N, IRC
      DOUBLE PRECISION L(1), A(1)
C     DIMENSION L(N*(N+1)/2), A(N*(N+1)/2)
C
C  ***  LOCAL VARIABLES  ***
C
      INTEGER I, IJ, IK, IM1, I0, J, JK, JM1, J0, K
      DOUBLE PRECISION T, TD, ZERO
C
      PARAMETER (ZERO=0.D+0)
C
C  ***  BODY  ***
C
      I0 = N1 * (N1 - 1) / 2
      DO 50 I = N1, N
         TD = ZERO
         IF (I .EQ. 1) GO TO 40
         J0 = 0
         IM1 = I - 1
         DO 30 J = 1, IM1
              T = ZERO
              IF (J .EQ. 1) GO TO 20
              JM1 = J - 1
              DO 10 K = 1, JM1
                   IK = I0 + K
                   JK = J0 + K
                   T = T + L(IK)*L(JK)
 10                CONTINUE
 20           IJ = I0 + J
              J0 = J0 + J
              T = (A(IJ) - T) / L(J0)
              L(IJ) = T
              TD = TD + T*T
 30           CONTINUE
 40      I0 = I0 + I
         T = A(I0) - TD
         IF (T .LE. ZERO) GO TO 60
         L(I0) =  SQRT(T)
 50      CONTINUE
C
      IRC = 0
      GO TO 999
C
 60   L(I0) = T
      IRC = I
C
 999  RETURN
C
C  ***  LAST LINE OF DL7SRT  ***
      END


        module timemod

        real, allocatable :: volinv(:), sxj(:), syj(:), sxi(:), syi(:)
        real, allocatable :: acoustic(:), viscous(:)

        end module timemod
!=============================================================================!
        subroutine dtcfl(vl, dtl)
!
!  Compute the CFL and time step
!
!  Note: this isn't correct for three-dimensional flow
!
!  WARNING:  I think that the CFL is defined incorrectly!!!!!!!
!
!  Revised:  6-11-96
!=============================================================================!
        use global
        use timemod
        use material
        use local
        implicit none

        real :: vl(ny*nx,ndof), dtl(ny*nx)

        real :: cfl, dtlmax

        real    :: cflv, cfla, cflc
        integer :: iv, jv, ia, ja, ic, jc, nloc(1)
!=============================================================================!

!.... first time setup

        if (istep.eq.1 .or. linear.eq.1) then
          allocate( volinv(ny*nx), sxj(ny*nx), syj(ny*nx), sxi(ny*nx), &
                    acoustic(ny*nx), viscous(ny*nx), syi(ny*nx) )

!.... temporarily one/detJ

          volinv = one / (m1 * n2 - m2 * n1)

          sxj =  n2 * dxi * volinv
          syj = -m2 * dxi * volinv

          sxi = -n1 * deta * volinv
          syi =  m1 * deta * volinv

          volinv = one / ( dxi * deta * volinv )

          acoustic = sqrt( sxi**2 + two * sxi * syi + syi**2 + &
                           sxj**2 + two * sxj * syj + syj**2 ) / Ma

          viscous = two * ( sxi**2 + two * sxi * syi + syi**2 + &
                    two * (sxi * sxj + sxi * syj + syi * sxj + syi * syj) + &
                    sxj**2 + two * sxj * syj + syj**2 ) * volinv
        end if

!.... initialize

        rho = vl(:,1)
        u1  = vl(:,2)
        u2  = vl(:,3)
        u3  = vl(:,4)
        t   = vl(:,5)
        rhoinv = one / rho

!.... get the material properties

        call getmat(t(:),                               &
                    mu(:),   lm(:),    con(:),          &
                    dmu(:),  d2mu(:),  dlm(:),          &
                    d2lm(:), dcon(:),  d2con(:)         )

        mu = max( mu / Re, (lm + mu) / Re, con / ( Re * Pr ) ) * rhoinv

!.... put sqrt(t) into t for use as temporary speed of sound

        t = sqrt(t)

!.... Total CFL

!       dtl = (abs( u1 * sxi + u2 * syi ) + &
!              abs( u1 * sxj + u2 * syj ) + &
!              t * acoustic + &
!              mu * viscous ) * volinv

!       cflv = maxval( dtl )
!       nloc = maxloc( dtl )
!       iv = (nloc(1)-1) / ny + 1
!       jv = nloc(1) - (iv-1)*ny

!.... convective CFL

!       dtl = (abs( u1 * sxi + u2 * syi ) + &
!              abs( u1 * sxj + u2 * syj ) ) * volinv

!       cflc = maxval( dtl )
!       nloc = maxloc( dtl )
!       ic = (nloc(1)-1) / ny + 1
!       jc = nloc(1) - (ic-1)*ny

!.... acoustic CFL

        dtl = (abs( u1 * sxi + u2 * syi ) + &
               abs( u1 * sxj + u2 * syj ) + &
               t * acoustic ) * volinv

        cfla = maxval( dtl )
        nloc = maxloc( dtl )
        ia = (nloc(1)-1) / ny + 1
        ja = nloc(1) - (ia-1)*ny

        cfl = cfla              ! use the acoustic CFL for scaling

        if (cfl*dtmax .le. cflmax) then
          delt = dtmax
          dtl  = dtmax
        else
          delt = cflmax / cfl
          if (loctime.eq.0) then
            dtl = delt
          else
            dtl = cflmax / dtl
          end if
        end if

!.... WARNING:  When this is on, things can be crazy!
!.... enforce x symmetry (don't need this when there is no symmetry)

!       if (loctime.eq.1) then
!         do i = 1, nx/2
!           dtl(:,i) = dtl(:,nx-i+1)
!         end do
!       end if

        if (istep.eq.1 .or. linear.eq.1) then
!         write(*,"(/,'Maximum Total CFL/dt      = ',1pe13.6, &
!               & ' at (',i3,',',i3,')')") cflv, iv, jv
          write(*,"  ('Maximum Acoustic CFL/dt   = ',1pe13.6, &
                & ' at (',i3,',',i3,')')") cfla, ia, ja
!         write(*,"  ('Maximum Convective CFL/dt = ',1pe13.6, &
!               & ' at (',i3,',',i3,')')") cflc, ic, jc
          write(*,"(/,'Delt = ',1pe13.6,'  CFLa = ',1pe13.6)") &
                delt, cfl*delt
!         write(*,  "('CFLa = ',1pe13.6,'  CFLc = ',1pe13.6,/)") &
!               cfla*delt, cflc*delt
        end if

!.... output the maximum dt

!       if (loctime.eq.1) then
!         dtlmax = maxval( dtl )
!         nloc = maxloc( dtl )
!         ia = (nloc(1)-1) / ny + 1
!         ja = nloc(1) - (ia-1)*ny
!         write(80,"(i5,1x,2(1pe13.6,1x,i5,1x,i5,1x))") istep, delt, &
!                 iv, jv, dtlmax, ia, ja
!       end if

!.... the linear solver doesn't need this stuff anymore

        if (linear.eq.1) then
          deallocate( volinv, sxj, syj, sxi, syi, acoustic, viscous)
        end if

        return
        end