SUBROUTINE gpscalc_alpha(K_NOBS,K_NLEV,P_A,P_REFRAC,P_NR,P_Z,P_ALPHA,P_N, &
                       & P_DNDZ,P_D2NDZ2,K_LEVM,LD_QC1,LD_QC2)
           
!**** *gpscalc_alpha* - part of the GPSRO observation operator.

!     S. Healy             ECMWF          2004/10/26
!     Based on a EUMETSAT GRAS-SAF routine that was Dr'd automatically by the CY27 merge.  

!     PURPOSE
!     -------
!     It evaluates the bending angle integral
!     as well as the refractivity and refractivity vertical gradient
!     and the second order derivative d2N/dz2
!     given an impact parameter.

!**   INTERFACE
!     ---------

!     CALL gpscalc_alpha(K_NOBS,K_NLEV,P_A,P_REFRAC,P_NR,P_Z,P_ALPHA,P_N, &
!                        P_DNDZ,P_D2NDZ2,K_LEVM,LD_QC1,LD_QC2

!     WHERE K_NOBS   =  number of observed bending angles 
!           K_NLEV   =  number of full model levels
!           P_A      =  impact parameter values
!           P_RERAC  =  refractivity on the full model levels
!           P_NR     =  refractive index*radius on the full model levels
!           P_Z      =  geometric heights of the full model levels
!           P_ALPHA  =  bending angles at impact parameter P_A
!           P_N      =  refractivity at impact parameter P_A
!           P_DNDZ   =  refrac. vertical gradient at impact parameter P_A
!           P_D2NDZ2 =  2nd derivative of refractivity w.r.t hgt in the layer
!           K_LEVM   =  number of the model layer where lies the obs
!           LD_QC1   =  flag which indicates whether the 1st order derivative
!                       of refrac. w.r.t. height stays within allowed bounds
!           LD_QC2   =  flag which indicates whether the 2nd order derivative
!                       of refrac. w.r.t. height stays within allowed bounds


!     gpscalc_alpha is called from gpsro_op

!**   METHOD
!    
!     1) calculate the exponential decay of refractivity with nr between model levels
!     2) evaluates the bending angle integral for each impact parameter

!**   EXTERNALS
!     ---------
!     1) fcserf calculates the Gaussian error function

!**   MODIFICATIONS
!     -------------
!     Sean Healy      2004/10/26 : Original
!     Sean Healy      2007/11/12 : Removal of error function calls. 
!     Paul Poli       2006/09/12 : Added output of P_N, P_DNDZ, K_LEVM
!     Paul Poli       2006/11/09 : Added output of P_D2NDZ2,LD_QC1,LD_QC2
!     Sean Healy      2010/03/26 : Introduced maximum refractivity gradient 
!     -------------------------------------------------------------------------

USE PARKIND1  ,ONLY : JPIM     ,JPRB
USE YOMHOOK   ,ONLY : LHOOK,   DR_HOOK

USE YOMANCS  , ONLY : RMDI 
USE YOMCST   , ONLY : RPI

IMPLICIT NONE

! subroutine args. 

INTEGER(KIND=JPIM),INTENT(IN)    :: K_NOBS! size of ob. vector 
INTEGER(KIND=JPIM),INTENT(IN)    :: K_NLEV! no. of refractivity levels 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_A(K_NOBS) ! impact parameter
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_REFRAC(K_NLEV) ! refractivity values on levels
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_NR(K_NLEV) ! index * radius product
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_Z(K_NLEV)  ! geometric height
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_ALPHA(K_NOBS) ! bending angle 
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_N(K_NOBS) ! refractivity
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_DNDZ(K_NOBS) ! refrac. vertical gradient
REAL(KIND=JPRB)   ,INTENT(OUT)   :: P_D2NDZ2(K_NOBS) ! 2nd order derivative
INTEGER(KIND=JPIM),INTENT(OUT)   :: K_LEVM(K_NOBS) ! model layer number
LOGICAL           ,INTENT(OUT)   :: LD_QC1(K_NOBS), LD_QC2(K_NOBS)

! local variables

INTEGER(KIND=JPIM) :: i,I_N,ibot,jbot,I_KBOT                ! counters
REAL(KIND=JPRB) :: Z_KVAL(K_NLEV-1)                         ! decay rates
REAL(KIND=JPRB) :: Z_LVAL(K_NLEV)                           ! dn/dz value
REAL(KIND=JPRB) :: Z_MVAL(K_NLEV-1)                         ! d2n/dz2 value
REAL(KIND=JPRB) :: Z_ROOT_2PIA                              ! sqrt(2*pi*a)
REAL(KIND=JPRB) :: Z_REF_LOW                                ! lower refractivity value
REAL(KIND=JPRB) :: Z_INDREF_LOW                             ! lower refractive index value
REAL(KIND=JPRB) :: Z_NR_LOW                                 ! lower nr value
REAL(KIND=JPRB) :: Z_TUP,Z_TLOW                             ! limits used in erf
REAL(KIND=JPRB) :: Z_DIFF_ERF                               ! difference in erf values
REAL(KIND=JPRB) :: Z_DALPHA                                 ! change in bending angle
REAL(KIND=JPRB) :: ZERF_UP,ZERF_LOW,ZT                      ! new variables to remove eff func.call
REAL(KIND=JPRB) :: ZHOOK_HANDLE

IF (LHOOK) CALL DR_HOOK('GPSCALC_ALPHA',0,ZHOOK_HANDLE)
jbot = 1

DO

  IF (P_REFRAC(jbot) > 0.0_JPRB .AND. P_NR(jbot) > 0.0_JPRB) EXIT
  
  jbot = jbot + 1

ENDDO

! cannot integrate through super refracting layer

I_KBOT = K_NLEV

DO i=K_NLEV,jbot+1,-1

  IF ((P_NR(I_KBOT) - P_NR(I_KBOT-1)) < 10.0_JPRB) EXIT 

  I_KBOT = I_KBOT - 1

ENDDO

jbot = MAX(jbot,I_KBOT)

! calculate the exponential decay rate between levels

DO i=jbot,K_NLEV-1

  Z_KVAL(i) = LOG(P_REFRAC(i)/P_REFRAC(i+1)) / &
   & MAX(1.0_JPRB,(P_NR(i+1)-P_NR(i)))  
  Z_KVAL(i) = MAX(1.0E-6_JPRB,Z_KVAL(i))
  
! introduce maximum refractivity gradient SBH
  
  Z_KVAL(i) = MIN(Z_KVAL(i), (0.157_JPRB/P_REFRAC(i)))  
 
  Z_LVAL(i) = (P_REFRAC(i+1)-P_REFRAC(i)) / &
   & MAX(1.0_JPRB,(P_Z(i+1)-P_Z(i)))
   
ENDDO

Z_LVAL(K_NLEV)=Z_LVAL(K_NLEV-1)

! calculate the second order derivative

DO i=jbot,K_NLEV-1

  Z_MVAL(i) = (Z_LVAL(i+1)-Z_LVAL(i)) / &
   & MAX(1.0_JPRB,(P_Z(i+1)-P_Z(i)))

ENDDO

! now calculate the bending angle, refractivity and refractivity vertical
! gradient values

P_ALPHA(:) = RMDI
P_N(:)     = RMDI
P_DNDZ(:)  = RMDI
P_D2NDZ2(:)= RMDI
K_LEVM(:)  = 0
LD_QC1(:)  = .TRUE.
LD_QC2(:)  = .TRUE.

DO I_N=1,K_NOBS

  IF (P_A(I_N) < P_NR(jbot) .OR. P_A(I_N) > P_NR(K_NLEV) .OR. P_A(I_N) == RMDI) CYCLE  

  Z_ROOT_2PIA = SQRT(2.0_JPRB*RPI*P_A(I_N))

  ibot = jbot

  DO 

    IF ((P_NR(ibot+1) - P_A(I_N)) > 1.0_JPRB .OR. ibot == K_NLEV-1) EXIT 

    ibot=ibot+1

  ENDDO
 
!  set bending angle value  

  P_ALPHA(I_N) = 0.0_JPRB
      
  DO i = ibot, K_NLEV-1
   
    IF ( i == ibot) THEN 
      
      Z_REF_LOW = P_REFRAC(ibot)*EXP(-Z_KVAL(ibot)*(P_A(I_N)-P_NR(ibot)))
      Z_NR_LOW = P_A(I_N)
      Z_INDREF_LOW = 1.0_JPRB+1.0E-6_JPRB*Z_REF_LOW
      P_DNDZ(I_N) = 1.0_JPRB / ( (P_NR(ibot+1)-P_NR(ibot))/ &
          & (LOG(P_REFRAC(ibot+1)/P_REFRAC(ibot))*Z_REF_LOW* &
          &  Z_INDREF_LOW) - &
          & 1.0E-6_JPRB*P_A(I_N)/Z_INDREF_LOW/Z_INDREF_LOW )
      P_D2NDZ2(I_N) = Z_MVAL(ibot)
      P_N(I_N)    = Z_REF_LOW
      K_LEVM(I_N) = ibot

      LD_QC1(I_N) = LD_QC1(I_N).AND. &
                 & (Z_LVAL(ibot)<-0.001E-3).AND. &
                 & (Z_LVAL(ibot)/=RMDI).AND. &
                 & (Z_LVAL(i)/=0.)
      
    ELSE 
      
      Z_REF_LOW = P_REFRAC(i) 
      Z_NR_LOW  = P_NR(i) 
     
    ENDIF


    LD_QC1(I_N) = LD_QC1(I_N).AND.(Z_LVAL(i)>-50.E-3)
    LD_QC2(I_N) = LD_QC2(I_N).AND.(Z_MVAL(i)>=-100.E-6).AND. &
              &  (Z_MVAL(i)<=100.E-6)
         
    Z_TUP = SQRT(Z_KVAL(i)*(P_NR(i+1)-P_A(I_N)))
          
    Z_TLOW = 0.0_JPRB                         

    IF (i > ibot) Z_TLOW = SQRT(Z_KVAL(i)*(P_NR(i)  -P_A(I_N)))
    
! re-written to remove error function calls. 
    
    IF (i == ibot) THEN
 
       ZERF_LOW = 0.0_JPRB 
 
       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TUP)
    
       ZERF_UP= 1.0_JPRB-(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(Z_TUP*Z_TUP))
    

 
    ELSEIF (i > ibot .AND. i < K_NLEV-1) THEN
    
    
! lower

       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TLOW) 
    
       ZERF_LOW = -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(Z_TLOW*Z_TLOW)) 

! upper

       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TUP)
    
       ZERF_UP  = -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(Z_TUP*Z_TUP))    
        
    ELSE

! includes extrapolation
 
       ZERF_UP = 0.0_JPRB 

       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TLOW) 
    
       ZERF_LOW = -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(Z_TLOW*Z_TLOW)) 
    
    ENDIF     
    
    
    Z_DIFF_ERF = ZERF_UP - ZERF_LOW
    
    Z_DALPHA    =  &
     & + 1.0E-6_JPRB * Z_ROOT_2PIA * SQRT(Z_KVAL(i))  &
     & * Z_REF_LOW*EXP(Z_KVAL(i)*(Z_NR_LOW-P_A(I_N)))*Z_DIFF_ERF   
      
    P_ALPHA(I_N) = P_ALPHA(I_N) + Z_DALPHA
      
  ENDDO
  
ENDDO

IF (LHOOK) CALL DR_HOOK('GPSCALC_ALPHA',1,ZHOOK_HANDLE)

END SUBROUTINE GPSCALC_ALPHA
