c $Revision: 23 $, $Date: 2011-03-31 07:41:37 -0600 (Thu, 31 Mar 2011) $
c $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/quickbeam/predict_psd07.f $
      program predict_psd07

c 14 Feb 2007

c This procedure uses the second moment and in-cloud temperature
c to predict the ice particle size distribution.
c The moment relations use the 2nd moment as a reference moment.

c For more details please read 'Snow size distribution parameterization for midlatitude and tropical ice clouds' by Field et al JAS2007

c !!!!!!!!!!!variables!!!!!!!!!!!!!!!!!!!!
c Input
c tc in C
c iwc in g m^-3
c x,y prefactor and exponent in mass-size relation m=xD^y
c for the UM    x=0.069, y=2.0    (SI units)
c regime: 'T' for tropical, 'M' for midlatitude

c Output
c D particle size in microns
c dN_dD particle size distribution: dN/dD m^-4
c L23 ratio of M3/M2 - mean mass weighted size if y=2

       real D(500),dN_dD(500),phi(500)
       real x,y,tc,iwc,iwcsi,My,m2,n,m3,xx
       character regime

c!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
c    read in input file
       open(unit=2,file="input.txt")
       read(2,*) iwc,tc,x,y,regime
       close(2)

c incloud temperature check

      if (tc.gt.0) then
         print*,'in-cloud temperature too warm (>0C)'
         goto 1000
      endif
      if (tc.lt.-70) then
         print*,'Warning: in-cloud temp colder than in original data'
      endif

c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

c Calculate 2nd moment
      iwcsi=iwc/1e3  !kg m^-3

      My=iwcsi/x  !yth moment

c use moment relations to get 2nd moment required for predicting psd

      m2=My
c default for UM y=2

c if y ne 2 then need to find second moment before proceeding
      if(y.ne.2.0) then
         m2=-9999
         call predict_mom07(m2,tc,y,My)
      endif
c !!M2 range check (1e-5 3e-2 m^-1)!!!!!!!!!!!!!!!!!!!!!

      if (m2.lt.0.0) then
         print*,'Negative M2'
         goto 1000
      endif
      if (m2.lt.1e-5.or.m2.gt.0.1) then
        print*,'Warning: M2 outside of range in original data'
      endif
c !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

c Use 2nd and 3rd moment to predict psd;;;;;;;;;;;;;;;;;;;;

       n=3
       call predict_mom07(m2,tc,n,m3)

c !!!define universal psd!!!!
      do 10 i=1,500
        xx=i/40. !dimensionless size
        if (regime.eq.'T') then
               phi(i)=152.0*exp(-12.4*xx)+3.28*xx**(-0.78)*exp(-1.94*xx)
        endif

        if (regime.eq.'M') then
               phi(i)=141.0*exp(-16.8*xx)+102.0*xx**(2.07)*exp(-4.82*xx)
        endif

        D(i)=1e6*xx*(m3/m2)
        dN_dD(i)=phi(i)*m2**4/m3**3
 10   continue

c !write output file

      open(unit=2,file="output.txt")
      write(2,*) 'Input values'
      write(2,*) 'IWC [g/m3]=',iwc
      write(2,*) 'T [C] =',tc
      write(2,*) 'x , y [SI]=', x, y
      write(2,*),'Regime =',regime
      write(2,*) ' '
      write(2,*) 'Output values'
      write(2,*) 'L32 [microns]=',1e6*m3/m2
      write(2,*) 'D (microns) dN/dD (m^-4)'
      do 20 i=1,500
        write(2,*),D(i),dN_dD(i)
 20   continue
      close(2)

 1000   continue

        stop
        end

        subroutine predict_mom07(m2,tc,n,m)

c subroutine to predict nth moment m given m2, tc, n
c if m2=-9999 then the routine will predict m2 given m,n,tc

        real a1,a2,a3,b1,b2,b3,c1,c2,c3
        real m2,tc,n,m,a_,b_,c_,A,B,C

       a1=      13.6078
       a2=     -7.76062
       a3=     0.478694
       b1=   -0.0360722
       b2=    0.0150830
       b3=   0.00149453
       c1=     0.806856
       c2=   0.00581022
       c3=    0.0456723

       a_=a1+a2*n+a3*n**2.0
       b_=b1+b2*n+b3*n**2.0
       c_=c1+c2*n+c3*n**2.0

       A=exp(a_)
       B=b_
       C=c_

c predict m from m2 and tc
        if(m2.ne.-9999) then
           m=A*exp(B*tc)*m2**C
        endif
c get m2 if mass-dimension relationship not proportional to D**2
        if(m2.eq.-9999) then
           m2=(m/(A*exp(B*tc)))**(1.0/C)
        endif

       return
       end


subroutine update_sponge_params(time) bind(C)

  use sponge_module
  use probdata_module, only: r_old_s
  use amrex_error_module, only: amrex_error

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: time

  logical          :: converged
  real(rt)         :: r, dr, r_guess, tol = 1.e-6_rt
  integer          :: n, max_iter = 25
  real(rt)         :: f, dfdr

  ! Find the analytic solution of the radius of the collapsing
  ! object via Newton-Raphson iteration.

  converged = .false.
  r_guess = 0.95*r_old_s

  do n = 1, max_iter
     dr = -f(r_guess,time) / dfdr(r_guess,time)

     ! We have lots of sqrt(1 - r/r_0), so r(t) has to be less than r_0.
     if (r_guess + dr > 6.5e8_rt) then
        r_guess = 0.5e0_rt*(r_guess + 6.5e8_rt)
     else
        r_guess = r_guess + dr
     endif

     if (abs(dr/r_guess) < tol) then
        converged = .true.
        r = r_guess
        r_old_s = r_guess
        exit
     endif

  enddo

  if (.not. converged) then
     call amrex_error("Newton iterations failed to converge in update_sponge_params.")
  endif

  sponge_lower_radius = r + 2.5e7_rt
  sponge_upper_radius = r + 5.0e7_rt
  sponge_timescale    = 1.0e-3_rt

end subroutine update_sponge_params

! The analytic solution from Colgate and White, Eq. 5 (with everything moved
! onto the LHS).  We use 1.e-20_rt to prevent against zeros in some places.

double precision function f(r,t)

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: r, t

  f = sqrt(8.e0_rt*3.14159265358979323846e0_rt*6.67428e-8_rt*1.e9_rt/3.e0_rt)*t - &
      sqrt(1.e0_rt - r/6.5e8_rt)*sqrt(r/6.5e8_rt) - asin(sqrt(1.0 - r/6.5e8_rt + 1.e-20_rt))

end function f

! The derivative (wrt x) of the analytic function f, defined above.
! We use 1.e-20_rt to prevent against zeros in some places.

double precision function dfdr(r,t)

  use amrex_fort_module, only : rt => amrex_real
  implicit none

  real(rt)        , intent(in) :: r, t

  dfdr = (0.5e0_rt/6.5e8_rt)*(-sqrt(1.e0_rt - r/6.5e8_rt + 1.e-20_rt)/sqrt(r/6.5e8_rt) + &
         sqrt(r/6.5e8_rt)/sqrt(1 - r/6.5e8_rt + 1.e-20_rt) + &
         1.e0_rt/(sqrt(r/6.5e8_rt)*sqrt(1.e0_rt - r/6.5e8_rt + 1.e-20_rt)))

end function dfdr


program kidou_q3_5
  !ホーマン軌道を使って太陽から離れていく場合に必要な加速量の合計が最大となるa2を求める。
  implicit none
  integer:: i
  real(8):: a1,a2,e,dv,x,dv_max,a2_max

  a1=1d0 !太陽から地球までの距離（天文単位）
  x=1d0 !μの値 （なんでもいい:a2の最大値を求めるだけなので、計算しやすいように規格化）
  dv_max=0d0 !今回はdvの最大値が0以上になることがわかってるので、適当に0にした
  a2_max=0d0

  do i=1,100000
     a2=i*0.001d0
     dv=sqrt((2d0*a2*x)/(1d0+a2))-sqrt(x)+sqrt(x/a2)-sqrt(2*x/(a2*(1d0+a2)))
     if (dv>dv_max) then
        dv_max=dv
        a2_max=a2
     end if
  end do

  write(*,*) a2_max

end program kidou_q3_5


!
!	Find dimension of the non-negative definite matrix mat.
!	tolsing is the singularity tolerance.

integer function dimfind(mat,tolsing)
implicit none
real(kind=8),intent(in)::mat(:,:),tolsing
interface
!	This function computes the modified Cholesky decomposition
!	of the n by n nonnegative definite symmecholc macholx sym.
!	tolsing is the singularity tolerance.
	function chol(sym,tolsing)
		implicit none
		real(kind=8),intent(in)::sym(:,:),tolsing
	 	real(kind=8)::chol(size(sym,1),size(sym,1))
	end function chol
end interface
!	row counts rows.
integer::row
!	Modified Cholesky decomposition is in matchol.
real(kind=8)::matchol(size(mat,1),size(mat,2))
matchol=chol(mat,tolsing)
dimfind=count((/(matchol(row,row)>0.0_8,row=1,size(mat,1))/))
return
end function dimfind


c=======================================================================
c
c     subroutine EM
c
c     EM Algorithm (Cluster Analysis)
c
c-----------------------------------------------------------------------
      SUBROUTINE em ( itermax, n, d, k, x, iwork, dwork,
     &                pk, nk, muk, covk, label, proba, f, like, info )
c-----------------------------------------------------------------------
c
c     INPUT
c       itermax  : number of iterations max.                     integer
c       n        : number of points (n>1)                        integer
c       d        : dimension (d>0)                               integer
c       k        : number of class (k>0)                         integer
c       x        : data (n*d)                                     double
c
c     WORKSPACE
c       iwork    : d                                             integer
c       dwork    : d*(3*d + 9)                                    double
c
c     INPUT/OUTPUT
c       pk       : proportion of each group (k)                   double
c       nk       : number of each group (k)                      integer
c       muk      : mean of each group (d*k)                       double
c       covk     : cov. matrix of each group (d)*(d*k)            double
c       label    : partition labels (n*k)                        integer
c       proba    : conditionale probability (n*k)                 double
c       f        : probability (n*k)                              double
c       like     : likelihood value                               double
c       info     : diagnostic argument                           integer
c
c-----------------------------------------------------------------------
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER itermax, n, d, k, nk(*), label(n,*), info
      DOUBLE PRECISION x(n,*), pk(*), proba(n,*), muk(d,*), covk(d,*),
     &                 f(n,*), like
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER l, iter, piw, pdw
c
c     external subroutines
      EXTERNAL estep, mstep
c
c-----------------------------------------------------------------------
c
c     initializations
      info = 0
c
c     pointers for integer work space  : iwork
c     ----------------------------------------
      piw = 1
c     piw : pointer for ESTEP, so ( d ) more
c
c     Total size of dwork array = ( d )
c
c     pointers for double precision work space  : dwork
c     -------------------------------------------------
      pdw = 1
c     pdw : pointer for ESTEP, so ( d*(3*d + 9) ) more
c
c     Total size of dwork array = d*(3*d + 9)
c
c------------------------------------------------------------------------
c
c     loop EM
      DO iter = 1, itermax
c
c       E step (expectation)
        CALL estep ( n, d, k, x, pk, muk, covk,
     &               iwork(piw), dwork(pdw), label, proba, f, like,info)
        IF (info .LT. 0) RETURN
c
c       M step (maximization)
        CALL mstep ( n, d, k, x, label, proba,
     &               pk, nk, muk, covk, info )
        IF (info .LT. 0) RETURN
        DO l = 1,k
            IF (nk(l) .EQ. 0) THEN
                like = -1.E+15
                RETURN
            ENDIF
        ENDDO
      ENDDO
c
      RETURN
      END