!**************************************************************
! calculate the bending angle "alpha" for impact parameters a

SUBROUTINE gpscalc_alphaRKm2(kobs,    & ! no.of observations
                           & klev,    & ! no. of vertical levels
                           & khoriz,  & ! no. of horizontal layers  ODD
                           & ksplit,  &  
                           & pdsep,   & ! the angular spacing 
                           & pa,      & ! impact parameter values
                           & prefrac, & ! refractivity
                           & pradius, & ! radius values
                           & pnr,     &
                           & proc,    &
                           & pz_2d,   &
                           & pa_path, &
                           & palpha)    ! partial path length along rays


!**** *gpscalc_alpharkm2* - part of the GPSRO observation operator.

!     S. Healy             ECMWF          2007/12/11
!     Based on a GRAS-SAF routine.   

!     PURPOSE
!     -------
!     It evaluates the bending angle integral for each impact parameter

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

!     CALL gpscalc_alpharkm2(....)    

!     WHERE kobs   =  number of observed bending angles 
!           klev   =  number of vertical levels
!           khoriz =  number of horizontal locations
!           ksplit = splitting of model levels
!           pdsep  =  angular spacing
!           pa     =  impact parameters
!           prefrac=  refractivity values
!           pradius=  radius values
!           pnr    =  nr product 
!           pa_path= impact parameter at end points of ray path
!           palpha  = bending angle values 

!     gpscalc_alphark is called from gpsro_op2d

!**   METHOD
!     ------
!     1) calculate the ray bending angle for each impact param - using Runge-Kutta 
!    

!**   EXTERNALS
!     ---------
!     1) fcserf calculates the Gaussian error function
!     2) gpspderivs evaluates the derivs for the Runge-Kutta

!**   MODIFICATIONS
!     -------------
!     Sean Healy      2005/08/01 : Original
!     -------------------------------------------------------------------------


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)  :: kobs                 ! size of ob. vector
INTEGER(KIND=JPIM), INTENT(IN)  :: klev                 ! no. of refractivity levels
INTEGER(KIND=JPIM), INTENT(IN)  :: khoriz               ! no. of horizontal locations
INTEGER(KIND=JPIM), INTENT(IN)  :: ksplit
REAL(KIND=JPRB),    INTENT(IN)  :: pdsep                ! angular spacing of grid
REAL(KIND=JPRB),    INTENT(IN)  :: pa(kobs)             ! impact parameter 
REAL(KIND=JPRB),    INTENT(IN)  :: prefrac(klev,khoriz) ! refractivity values on levels
REAL(KIND=JPRB),    INTENT(IN)  :: pradius(klev,khoriz) ! radius values
REAL(KIND=JPRB),    INTENT(IN)  :: pnr(klev,khoriz)
REAL(KIND=JPRB),    INTENT(IN)  :: proc                 ! radius of curvature
REAL(KIND=JPRB),    INTENT(IN)  :: pz_2d
REAL(KIND=JPRB),    INTENT(OUT) :: pa_path(kobs,2)        
REAL(KIND=JPRB),    INTENT(OUT) :: palpha(kobs)         ! path length
                       

! local variables

INTEGER(KIND=JPIM) :: i,j,in,ibot,jbot,ikbot,iside,ik,ikp1,in_2d,ikcen
REAL(KIND=JPRB), PARAMETER :: zhmax = 3.0E4_JPRB
REAL(KIND=JPRB), PARAMETER :: zhmin = 1.0E2_JPRB
REAL(KIND=JPRB) :: zrad,zdndr
REAL(KIND=JPRB) :: zhwt1,zhwt2
REAL(KIND=JPRB) :: zamult
REAL(KIND=JPRB) :: zh,zh2,zhuse,zh_up
REAL(KIND=JPRB) :: zy(4),zyt(4)
REAL(KIND=JPRB) :: zdydh(4),zdydht(4,4)
REAL(KIND=JPRB) :: ztheta_tan,ztheta_min,ztheta_max
REAL(KIND=JPRB) :: zdr_max,zdr_dtheta,zrtan,zdr
REAL(KIND=JPRB) :: zalpha_half(2)
REAL(KIND=JPRB) :: zkval(klev-1,khoriz)
REAL(KIND=JPRB) :: ztlow,ztup,zdalpha,zRoot_halfPI
REAL(KIND=JPRB) :: zerf_up,zerf_low,zt,zdiff_erf,znr_low,zref_low,zaval
LOGICAL :: llfirst_1d,lleaving,llone_d_calc
REAL(KIND=JPRB) :: ZHOOK_HANDLE

#include "gpspderivs.intfb.h"

IF (LHOOK) CALL DR_HOOK('GPSCALC_ALPHARKM2',0,ZHOOK_HANDLE)


! the central profile kcen


ikcen = khoriz/2 + 1
ztheta_tan = REAL(ikcen-1)*pdsep 
ztheta_min = -ztheta_tan
ztheta_max =  ztheta_tan


! set the kvals used in the 1d calculation


DO i = 1,klev-1

   DO j = 1, khoriz
   
      zkval(i,j) = LOG(prefrac(i,j)/prefrac(i+1,j))/MAX((pnr(i+1,j) - pnr(i,j)),1.0_JPRB)
      zkval(i,j) = MAX(1.0E-6_JPRB,zkval(i,j))
    
   ENDDO
   
ENDDO   


! set n_2d level. For levels below n_2d we do 2D ray bending calculation
! above n_2d we do the 1D calculation


in_2d = 0 

DO WHILE ((pnr(in_2d+1,ikcen)-proc < pz_2d) .AND. (in_2d < klev - 1)) 

    in_2d = in_2d + 1
    
ENDDO    

    
jbot = 1

DO

  IF (prefrac(jbot,ikcen) > 0.0_JPRB .AND. pnr(jbot,ikcen) > 0.0_JPRB) EXIT
  
  jbot = jbot + 1

ENDDO

ikbot = klev

DO i=klev,jbot+1,-1

   IF (pnr(ikbot,ikcen) < pnr(ikbot-1,ikcen)) EXIT 

   ikbot = ikbot - 1

ENDDO
 
jbot = MAX(jbot,ikbot)


! set the outputs to missing


palpha(:)=RMDI
pa_path(:,:)= RMDI





zRoot_halfPI = SQRT(0.5_JPRB*rpi)

OBLOOP: DO in=1,kobs
   
   IF (pa(in) < pnr(jbot,ikcen) .OR. pa(in) > pnr(klev,ikcen)) CYCLE  
   
      
   ibot = jbot

   DO 

      IF (pnr(ibot+1,ikcen) - pa(in) > 1.0_JPRB) EXIT 

      ibot=ibot+1

   ENDDO


! calculate the radius at tangent point   

   zrad = 0.5_JPRB*(pradius(ibot,ikcen)+pradius(ibot+1,ikcen))
   zdndr = 1.0E-6_JPRB*(prefrac(ibot+1,ikcen)-prefrac(ibot,ikcen))/ &
               &  (pradius(ibot+1,ikcen)-pradius(ibot,ikcen)) 
  
   IF ( zrad*zdndr > -1.0_JPRB) THEN
  
       zrtan = pradius(ibot,ikcen) + &
             & (pa(in)-pnr(ibot,ikcen))/(1.0_JPRB + zrad*zdndr)

   ELSE
   
       zrtan = zrad   ! probably in a super-refracting layer
       
   ENDIF   
   
! if zrtan is within a 1 m of upper level set to upper level
   
   IF ((zrtan - pradius(ibot+1,ikcen)) > -1.0_JPRB) THEN

       ibot = ibot + 1
          
       zrtan = pradius(ibot,ikcen)
       
   ENDIF     
   
                    

!  set bending angle value  

   zalpha_half(:) = 0.0_JPRB
   

   DO iside = 1,2 
      
      pa_path(in,iside) = pa(in)
      llfirst_1d = .TRUE.
      llone_d_calc = .FALSE.
      zamult = 1.0_JPRB
      IF (iside == 2) zamult  = -1.0_JPRB
      

! initialise vector


      zy(1) = 0.0_JPRB           ! height above tangent point           
      zy(2) = 0.0_JPRB           ! theta
      zy(3) = ASIN(1.0_JPRB)     ! thi
      zy(4) = 0.0_JPRB           ! bending angle 
        
      DO i = ibot,klev-1
        
         IF ( i < MIN(in_2d,klev-1)) THEN  
        
            IF (i == ibot) THEN
         
               ik = ikcen         
               zdr_max = (pradius(i+1,ik)- zrtan)/REAL(ksplit) 
               if (zdr_max <= 0.0_JPRB .or.pradius(ibot,ik) <= 0.0_JPRB ) then
               
               write (*,*) 'gps-NEG'
               write (*,*) 'gps-2d op',i,ibot,ksplit,zdr_max,pradius(ibot,ik),&
               &pradius(i+1,ik),zrtan,pa(in),pnr(ibot,ikcen),pnr(ibot+1,ikcen),zrad,zdndr
               
               endif
               
               zh = SQRT(2.0_JPRB*pradius(ibot,ik)*zdr_max)
            
            ELSE 
 
               ik = INT((zy(2) + ztheta_tan)/pdsep)+1
               ik = MIN(MAX(1,ik),khoriz)
               zdr_max = (pradius(i+1,ik)- pradius(i,ik))/REAL(ksplit)               
               zh_up = SQRT(2.0_JPRB*pradius(i,ik)*zdr_max)                                        
               zh = zdr_max/MAX(COS(zy(3)),1.0E-10_JPRB)        
               zh = MIN(zh_up,zh) 
        
            ENDIF


! estimate the step-length        

                 
! limit to horizontal distance between grid points


             zh = MAX(MIN(zh,zhmax),zhmin)          
         
            zh2 = 0.5_JPRB*zh


! now calculate the path with a RUNGE-KUTTA

            LLEAVING = .FALSE. 
         
            DO  j = 1,ksplit 
                                            
                  zyt(:) = zy(:)  
            
! first calculation of derivs

               CALL gpspderivs(klev,khoriz,i,pdsep,ztheta_min,ztheta_max,ztheta_tan,&
               zrtan,zamult,prefrac,pradius,zyt,zdydht(:,1)) 
         
               zyt(:) = zy(:) + zdydht(:,1)*zh2

! second call at new yt
            
               CALL gpspderivs(klev,khoriz,i,pdsep,ztheta_min,ztheta_max,ztheta_tan,&
               zrtan,zamult,prefrac,pradius,zyt,zdydht(:,2)) 
 
               zyt(:) = zy(:) + zdydht(:,2)*zh2
            
! third call at new yt
            
               CALL gpspderivs(klev,khoriz,i,pdsep,ztheta_min,ztheta_max,ztheta_tan,&
               zrtan,zamult,prefrac,pradius,zyt,zdydht(:,3)) 
 
               zyt(:) = zy(:) + zdydht(:,3)*zh

! fourth last call

               CALL gpspderivs(klev,khoriz,i,pdsep,ztheta_min,ztheta_max,ztheta_tan,&
               zrtan,zamult,prefrac,pradius,zyt,zdydht(:,4)) 
                                  
               zdydh(:) = (zdydht(:,1)+zdydht(:,4)+2.0_JPRB*(zdydht(:,2)+zdydht(:,3)))/6.0_JPRB
            
               zyt(:) = zy(:) + zdydh(:)*zh
            

! check the radius - have we exited the level
            
               ik = INT((zyt(2) + ztheta_tan)/pdsep)+1
               ik = MIN(MAX(1,ik),khoriz-1)
               ikp1 = ik+1
         
! horizontal weighting factor               
            
               IF ( zyt(2) < ztheta_max .AND. zyt(2) > ztheta_min) THEN
                           
                  zhwt1 = (REAL(ik)*pdsep - (zyt(2)+ztheta_tan))/pdsep    
                  zhwt2 = 1.0_JPRB - zhwt1
            
               ELSEIF (zyt(2) < ztheta_min) THEN            
            
                  zhwt1 = 1.0_JPRB
                  zhwt2 = 0.0_JPRB
               
               ELSEIF (zyt(2) > ztheta_max) THEN
            
                  zhwt1 = 0.0_JPRB
                  zhwt2 = 1.0_JPRB
               
               ENDIF    
                              
                    
! radius of pressure level             

                 zrad = zhwt1*pradius(i+1,ik)+zhwt2*pradius(i+1,ikp1)   

            
! if gone over the boundary scale h
            
               IF ( j == ksplit .OR. (zy(1)+zrtan - zrad) > 0.0_JPRB ) THEN
            
                  LLEAVING = .TRUE.
            
                  zdr_dtheta = 0.0_JPRB
            
                  IF (zyt(2) < ztheta_max .AND. zyt(2) > ztheta_min) &            
                 & zdr_dtheta = (pradius(i+1,ikp1)-pradius(i+1,ik))/pdsep
        
                  zhuse = zh - (zyt(1)+zrtan-zrad)/(zdydh(1) - zdr_dtheta*zdydh(2))

                  zhuse = MAX(MIN(zhuse,zhmax),zhmin)
                                             
               ELSE 
            
                  zhuse = zh  
                           
               ENDIF 
         
                       

! update the position vector

               zy(:) = zy(:) + zdydh(:)*zhuse             
            
               IF (LLEAVING) EXIT  

! try to maintain roughly the same radial increment by adjusting h

               IF (j < ksplit) THEN
         
               zdr = (zrad-zy(1)-zrtan)/REAL(ksplit-j)
         
               zh = MIN(zh,zdr/MAX(COS(zy(3)),1.0E-10_JPRB))
            
               zh = MAX(MIN(zh,zhmax),zhmin)
            
               zh2 = 0.5_JPRB*zh
                                
               ENDIF 

              ENDDO  ! complete path thru ith layer

      ELSE 


! DO 1D calculation


         IF (llfirst_1d) THEN
         
            ik = NINT((zy(2) + ztheta_tan)/pdsep)+1
            ik = MIN(MAX(1,ik),khoriz-1)
            pa_path(in,iside) = &
           &(1.0_JPRB+1.0E-6_JPRB*prefrac(i,ik))*((zy(1)+zrtan)*SIN(zy(3)))
             zaval = pa_path(in,iside)
            zalpha_half(iside) = zy(4)
            llfirst_1d = .FALSE.
            
          ENDIF     

! Continue with 1D bending angle calculation

         IF ( i == ibot) THEN 

! we are doing a 1d calc for entire ray path
      
            llone_d_calc = .TRUE. 
            zref_low = prefrac(ibot,ik)*EXP(-zkval(ibot,ik)*(pa(in)-pnr(ibot,ik)))
            zaval = pa(in)
            pa_path(in,iside) = pa(in)  
            znr_low = pa(in)
        
         ELSE 
      
            zref_low = prefrac(i,ik) 
            znr_low  = pnr(i,ik) 
         
         ENDIF

         ztlow = 0.0_JPRB
         IF (i > ibot) ztlow = SQRT(MAX(zkval(i,ik)*(pnr(i,ik) - zaval),1.0E-10_JPRB))

         ztup = SQRT(MAX(zkval(i,ik)*(pnr(i+1,ik)-zaval),1.0E-10_JPRB))


! calculate the error functions within this routine rather than an external function call.


         IF (i == ibot) THEN
                                   
            zerf_low = 0.0_JPRB         
                 
            zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*ztup)
            
            zerf_up= &
           &1.0_JPRB-(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(ztup*ztup))            
         
         ELSEIF (i > ibot .AND. i < klev-1) THEN
                    
! lower
            zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*ztlow) 
            
            zerf_low = -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(ztlow*ztlow)) 

! upper

            zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*ztup)
            
            zerf_up= -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(ztup*ztup))            
                        
         ELSE
         
            zerf_up = 0.0_JPRB 
         
            zt = 1.0_JPRB/(1.0_JPRB+0.47047_JPRB*ztlow) 
            
            zerf_low = -(0.3480242_JPRB-(0.0958798_JPRB-0.7478556_JPRB*zt)*zt)*zt*EXP(-(ztlow*ztlow)) 
            
         ENDIF     
          
          
         zdiff_erf = zerf_up - zerf_low 

! bending angle          
         
         if ((zaval < 0.0_JPRB) .or. (zkval(i,ik) < 0.0_JPRB) .or. (zkval(i,ik)*(znr_low-zaval)) > 100.0) then
         write (*,*) 'gps-1d bit',i,ibot,ik,iside,zalpha_half(iside),zaval, &
         &zref_low, zkval(i,ik),znr_low,zdiff_erf
         
         endif
         
         zdalpha    =  &
        & 1.0E-6_JPRB * zRoot_halfPI* SQRT(zaval*zkval(i,ik)) & 
        & * zref_low*EXP(zkval(i,ik)*(znr_low-zaval))*zdiff_erf 
 
         zalpha_half(iside) = zalpha_half(iside) + zdalpha 

          

      ENDIF       
          
      ENDDO  ! i the layers
      

! if we performed a 1d calculation don't evaluate iside = 2

     
      IF (llone_d_calc) THEN
      
         zalpha_half(2) = zalpha_half(1)
          
         EXIT  ! exiting the iside loop
     
     ENDIF      


   ENDDO ! iside


! the total bending angle adding both sides

       
   palpha(in) = zalpha_half(1) + zalpha_half(2) 
   
ENDDO OBLOOP

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

END SUBROUTINE gpscalc_alphaRKm2
