SUBROUTINE gpscalc_alphaAD(K_NOBS,K_NLEV,P_A,P_REFRAC,P_REFRAC_HAT, &
                         & P_NR,P_NR_HAT,P_ALPHA_HAT)  
           

!**** *gpscalc_alphaAD* - 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 for each impact parameter

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

!     CALL gpscalc_alphaad(K_NOBS,K_NLEV,P_A,P_REFRAC,P_REFRAC_HAT, &
!                        & P_NR,P_NR_HAT,P_ALPHA_HAT)     

!     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_RERAC_HAT    =  Adjoint refractivity on the full model levels
!           P_NR           =  refractive index*radius on the full model levels
!           P_NR_HAT       =  Adjoint refractive index*radius on the full model levels
!           P_ALPHA_HAT    =  Adjoint bending angles


!     gpscalc_alphaad is called from gpsro_ad

!**   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      2010/03/26 : Limit the kval
!     -------------------------------------------------------------------------


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(INOUT) :: P_REFRAC_HAT(K_NLEV) 
REAL(KIND=JPRB)   ,INTENT(IN)    :: P_NR(K_NLEV) ! index * radius product
REAL(KIND=JPRB)   ,INTENT(INOUT) :: P_NR_HAT(K_NLEV) 
REAL(KIND=JPRB)   ,INTENT(INOUT) :: P_ALPHA_HAT(K_NOBS) ! bending angle 
! local variables

INTEGER(KIND=JPIM) :: i,I_N,ibot,jbot,I_KBOT  ! counters
REAL(KIND=JPRB) :: Z_KVAL(K_NLEV-1)           ! refractivity decay rates
REAL(KIND=JPRB) :: Z_KVAL_SAVE(K_NLEV-1)      ! refractivity decay rates 
REAL(KIND=JPRB) :: Z_KVAL_HAT(K_NLEV-1)       ! Adjoint "
REAL(KIND=JPRB) :: Z_ROOT_2PIA                ! sqrt(2*pi*a)
REAL(KIND=JPRB) :: Z_REF_LOW                  ! lower refractivity
REAL(KIND=JPRB) :: Z_REF_LOW_HAT              ! Adjoint "
REAL(KIND=JPRB) :: Z_NR_LOW                   ! lower nr product
REAL(KIND=JPRB) :: Z_NR_LOW_HAT               ! Adjoint "
REAL(KIND=JPRB) :: Z_TUP,Z_TLOW               ! limits used in erf
REAL(KIND=JPRB) :: Z_TUP_HAT,Z_TLOW_HAT       ! Adjoint "
REAL(KIND=JPRB) :: Z_DALPHA                   ! Change in bending angle
REAL(KIND=JPRB) :: Z_DALPHA_HAT               ! Adjoint "
REAL(KIND=JPRB) :: Z_DIFF_ERF                 ! difference in erf values
REAL(KIND=JPRB) :: Z_DIFF_ERF_HAT             ! Adjoint "
REAL(KIND=JPRB) :: ZERF_UP,ZERF_LOW,ZT          ! new variables to remove eff func.call
REAL(KIND=JPRB) :: ZERF_UP_HAT,ZERF_LOW_HAT,ZT_HAT                      

REAL(KIND=JPRB) :: ZHOOK_HANDLE 

! Initialise local adjoint variables

IF (LHOOK) CALL DR_HOOK('GPSCALC_ALPHAAD',0,ZHOOK_HANDLE)
Z_REF_LOW_HAT = 0.0_JPRB
Z_NR_LOW_HAT =0.0_JPRB
Z_KVAL_HAT(:) = 0.0_JPRB
Z_DIFF_ERF_HAT = 0.0_JPRB
Z_DALPHA_HAT = 0.0_JPRB
Z_TLOW_HAT = 0.0_JPRB
Z_TUP_HAT = 0.0_JPRB
ZERF_UP_HAT = 0.0_JPRB
ZERF_LOW_HAT = 0.0_JPRB
ZT_HAT = 0.0_JPRB 

! calculate the exponential decay rate between levels

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 (nr(kbot) < nr(kbot-1) .OR. refrac(kbot) > refrac(kbot-1) ) EXIT 
   
  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))) 

! store this value for "IF" statement in adjoint code 
   
  Z_KVAL_SAVE(i) = Z_KVAL(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)))  
   
ENDDO

! now calculate the bending angle values

DO I_N=K_NOBS,1,-1

  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  

  DO i = K_NLEV-1,ibot,-1
   
    IF ( i == ibot) THEN 
      
      Z_REF_LOW = P_REFRAC(i)*EXP(-Z_KVAL(i)*(P_A(I_N)-P_NR(i)))     
     
      Z_NR_LOW = P_A(I_N)
     
    ELSE 
      
      Z_REF_LOW = P_REFRAC(i) 
     
      Z_NR_LOW  = P_NR(i) 
     
    ENDIF

! limits used in the error function


    Z_TUP = SQRT(Z_KVAL(i)*(P_NR(i+1)-P_A(I_N)))
      
    Z_TLOW = 0.0_JPRB                         
      
    IF (i > ibot) THEN
      
      Z_TLOW = SQRT(Z_KVAL(i)*(P_NR(i)  -P_A(I_N)))
            
    ENDIF 
    
     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   

! adjoint bit
      
    P_ALPHA_HAT(I_N) = P_ALPHA_HAT(I_N)

    Z_DALPHA_HAT = Z_DALPHA_HAT + P_ALPHA_HAT(I_N)
      
    Z_REF_LOW_HAT = &
     & Z_REF_LOW_HAT + Z_DALPHA/MAX(1.0E-10_JPRB,Z_REF_LOW)*Z_DALPHA_HAT  
      
    Z_DIFF_ERF_HAT = &
     & Z_DIFF_ERF_HAT + Z_DALPHA/MAX(1.0E-10_JPRB,Z_DIFF_ERF)*Z_DALPHA_HAT  

    Z_NR_LOW_HAT = &
     & Z_NR_LOW_HAT + Z_DALPHA*Z_KVAL(i)*Z_DALPHA_HAT  
      
    Z_KVAL_HAT(i) = &
     & Z_KVAL_HAT(i) + Z_DALPHA*(Z_NR_LOW-P_A(I_N) + 0.5_JPRB/Z_KVAL(i))*Z_DALPHA_HAT  
            
    Z_DALPHA_HAT = 0.0_JPRB
  
! ajoint of diff_erf    
    
    ZERF_UP_HAT = ZERF_UP_HAT + Z_DIFF_ERF_HAT
    ZERF_LOW_HAT = ZERF_LOW_HAT - Z_DIFF_ERF_HAT 
    Z_DIFF_ERF_HAT = 0.0_JPRB
    
    
    IF (i == ibot) THEN
    
       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TUP)
       
       Z_TUP_HAT = Z_TUP_HAT + &
      &(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*  &
      &EXP(-(Z_TUP*Z_TUP))*2.0_JPRB*Z_TUP*ZERF_UP_HAT

       ZT_HAT = ZT_HAT - &
      &(0.3480242_JPRB-(0.1917596_JPRB-2.2435668_JPRB*zt)*zt)*   &
      &EXP(-(Z_TUP*Z_TUP))*ZERF_UP_HAT
       
       ZERF_UP_HAT = 0.0_JPRB

       Z_TUP_HAT = Z_TUP_HAT - zt/(1.0_JPRB+0.47047_JPRB*Z_TUP)*0.47047_JPRB*ZT_HAT
       ZT_HAT = 0.0_JPRB
       

       ZERF_LOW_HAT = 0.0_JPRB

 
    ELSEIF (i > ibot .AND. i < K_NLEV-1) THEN
 
! upper
 
       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TUP)
       
       Z_TUP_HAT = Z_TUP_HAT + &
      &(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*  &
      &EXP(-(Z_TUP*Z_TUP))*2.0_JPRB*Z_TUP*ZERF_UP_HAT

       ZT_HAT = ZT_HAT - &
      &(0.3480242_JPRB-(0.1917596_JPRB-2.2435668_JPRB*zt)*zt)*   &
      &EXP(-(Z_TUP*Z_TUP))*ZERF_UP_HAT
       
       ZERF_UP_HAT = 0.0_JPRB
 
       Z_TUP_HAT = Z_TUP_HAT - zt/(1.0_JPRB+0.47047_JPRB*Z_TUP)*0.47047_JPRB*ZT_HAT
       ZT_HAT = 0.0_JPRB
    
! lower

       zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TLOW) 
    
       Z_TLOW_HAT = Z_TLOW_HAT + &
      &(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*  &
      &EXP(-(Z_TLOW*Z_TLOW))*2.0_JPRB*Z_TLOW*ZERF_LOW_HAT
      
       ZT_HAT = ZT_HAT - &
      &(0.3480242_JPRB-(0.1917596_JPRB-2.2435668_JPRB*zt)*zt)* &
      &EXP(-(Z_TLOW*Z_TLOW))*ZERF_LOW_HAT
      
      ZERF_LOW_HAT = 0.0_JPRB
              
      Z_TLOW_HAT = Z_TLOW_HAT - zt/(1.0_JPRB+0.47047_JPRB*Z_TLOW)*0.47047_JPRB*ZT_HAT
      ZT_HAT = 0.0_JPRB
             
        
    ELSE

! includes extrapolation
         
      zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*Z_TLOW) 

       Z_TLOW_HAT = Z_TLOW_HAT + &
      &(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*  &
      &EXP(-(Z_TLOW*Z_TLOW))*2.0_JPRB*Z_TLOW*ZERF_LOW_HAT
      
       ZT_HAT = ZT_HAT - &
      &(0.3480242_JPRB-(0.1917596_JPRB-2.2435668_JPRB*zt)*zt)* &
      &EXP(-(Z_TLOW*Z_TLOW))*ZERF_LOW_HAT
      
      ZERF_LOW_HAT = 0.0_JPRB
              
      Z_TLOW_HAT = Z_TLOW_HAT - zt/(1.0_JPRB+0.47047_JPRB*Z_TLOW)*0.47047_JPRB*ZT_HAT
      ZT_HAT = 0.0_JPRB


      ZERF_UP_HAT = 0.0_JPRB 

    
    ENDIF     
     
   
    IF (i > ibot) THEN
          
      Z_KVAL_HAT(i) = &
       & Z_KVAL_HAT(i) + 0.5_JPRB*(P_NR(i)-P_A(I_N))/Z_TLOW*Z_TLOW_HAT  

      P_NR_HAT(i) = &
       & P_NR_HAT(i) + 0.5_JPRB*Z_KVAL(i)/Z_TLOW*Z_TLOW_HAT                 

      Z_TLOW_HAT = 0.0_JPRB 
                                    
    ENDIF 
   
    Z_TLOW_HAT = 0.0_JPRB
     
! limits used in the error function

             
    Z_KVAL_HAT(i) = &
    & Z_KVAL_HAT(i) + 0.5_JPRB*(P_NR(i+1)-P_A(I_N))/Z_TUP*Z_TUP_HAT  
      
    P_NR_HAT(i+1) = &
    & P_NR_HAT(i+1) + 0.5_JPRB*Z_KVAL(i)/Z_TUP*Z_TUP_HAT  

    Z_TUP_HAT = 0.0_JPRB
      

    IF ( i == ibot) THEN 
      
      P_REFRAC_HAT(i) = &
       & P_REFRAC_HAT(i) + Z_REF_LOW/P_REFRAC(i) * Z_REF_LOW_HAT  
     
      Z_KVAL_HAT(i) = &
       & Z_KVAL_HAT(i) - Z_REF_LOW*(P_A(I_N)-P_NR(i))*Z_REF_LOW_HAT  
     
      P_NR_HAT(i) = &
       & P_NR_HAT(i) + Z_REF_LOW*Z_KVAL(i)*Z_REF_LOW_HAT  
     
      Z_REF_LOW_HAT = 0.0_JPRB
     
      Z_NR_LOW_HAT = 0.0_JPRB

    ELSE 
      
      P_REFRAC_HAT(i) = P_REFRAC_HAT(i) + Z_REF_LOW_HAT
     
      Z_REF_LOW_HAT = 0.0_JPRB
     
      P_NR_HAT(i) = P_NR_HAT(i) + Z_NR_LOW_HAT
     
      Z_NR_LOW_HAT = 0.0_JPRB
     
    ENDIF

  ENDDO
   
  P_ALPHA_HAT(I_N) = 0.0_JPRB

ENDDO

! Adjoint of K values

DO i=K_NLEV-1,jbot,-1
  

! new maximum kval 
  
  IF (Z_KVAL_SAVE(i) > (0.157_JPRB/P_REFRAC(i))) THEN
       
! maximum size of kval
     
     P_REFRAC_HAT(i) = P_REFRAC_HAT(i) - 0.157_JPRB/P_REFRAC(i)**2*Z_KVAL_HAT(i)
     
     Z_KVAL_HAT(i) = 0.0_JPRB      
          
  ENDIF  
 
    
  IF (Z_KVAL_SAVE(i) > 1.0E-6_JPRB) THEN
   
    P_NR_HAT(i) = P_NR_HAT(i) + &
     & Z_KVAL(i)/MAX(1.0_JPRB,(P_NR(i+1)-P_NR(i)))*Z_KVAL_HAT(i)   

    P_NR_HAT(i+1) = P_NR_HAT(i+1) - &
     & Z_KVAL(i)/MAX(1.0_JPRB,(P_NR(i+1)-P_NR(i)))*Z_KVAL_HAT(i)   

    P_REFRAC_HAT(i) = P_REFRAC_HAT(i) + &
     & Z_KVAL_HAT(i)/(P_REFRAC(i)*MAX(1.0_JPRB,(P_NR(i+1)-P_NR(i))))     
   
    P_REFRAC_HAT(i+1) = P_REFRAC_HAT(i+1) - &
     & Z_KVAL_HAT(i)/(P_REFRAC(i+1)*MAX(1.0_JPRB,(P_NR(i+1)-P_NR(i))))  
   
  ENDIF 
   
  Z_KVAL_HAT(i) = 0.0_JPRB

ENDDO

P_ALPHA_HAT(:) = 0.0_JPRB
Z_KVAL_HAT(:)  = 0.0_JPRB

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

END SUBROUTINE gpscalc_alphaAD
