      SUBROUTINE MFFTC9(C,FAC)
*
*   PURPOSE:
*       ELEMENTARY COOLEY-TUKEY RADIX 5 STEP APPLIED TO A VECTOR-OF
*       2-VECTORS-OF-COMPLEX C[IMS,NM [IVS,NV [IES,NE]]].
*       SEE REF.[1] FOR NOTATIONS.
*       THIS ROUTINE CAN BE USED ONLY BY ROUTINE MFFTIS, WHICH CONTROLS
*       ITS OPERATION THROUGH THE MFFTPA COMMON
*
*   DUMMY ARGUMENTS :
*
*   C   ARRAY BEING FOURIER  TRANSFORMED
*   FAC PHASE FACTORS, PREPARED BY MFFTP; NOT MODIFIED IN OUTPUT
*
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      COMMON /MFFTPA/  IMS,IVS,IES,NM,NV,NE,MX,LX,MLIM,MSTEP,LLIM,LSTEP,
     $ NUSTEP,IVLIM,ILIM,MD2LIM,LD2LIM
      INTEGER NUSTEP
      DOUBLE COMPLEX C(0:NUSTEP-1,0:4),FAC(0:*)
      DOUBLE COMPLEX T1,T2,T3,T4,T5
      REAL*8 SIN72,RAD5D4,S36D72
      PARAMETER (
     $ SIN72 =  9.51056516295153572116439333E-1,
     $ RAD5D4 =  5.59016994374947424102293417E-1,
     $ S36D72 =  6.18033988749894848204586834E-1 )

      IF(LX.NE.1)THEN
          DO 200 MU=0,MLIM,MSTEP
            DO 150 IV=MU,MU+IVLIM,IVS
              ILAMF=0
              ILAMF2=NUSTEP
              ILAMF3=2*NUSTEP
              ILAMF4=3*NUSTEP
              DO 100 ILAM=IV,IV+ILIM
                T1=C(ILAM,1)*FAC(ILAMF)+C(ILAM,4)*FAC(ILAMF4)
                T2=C(ILAM,2)*FAC(ILAMF2)+C(ILAM,3)*FAC(ILAMF3)
                T3=(C(ILAM,1)*FAC(ILAMF)-C(ILAM,4)*FAC(ILAMF4))*SIN72
                T4=(C(ILAM,2)*FAC(ILAMF2)-C(ILAM,3)*FAC(ILAMF3))*SIN72
                T5=T1+T2
                T1=RAD5D4*(T1-T2)
                T2=C(ILAM,0)-0.25*T5
                C(ILAM,0)=C(ILAM,0)+T5
                T5=T2+T1
                T2=T2-T1
                T1=T3+S36D72*T4
                T3=S36D72*T3-T4
                C(ILAM,1)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
                C(ILAM,4)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
                C(ILAM,2)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
                C(ILAM,3)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
                ILAMF=ILAMF+1
                ILAMF2=ILAMF2+1
                ILAMF3=ILAMF3+1
                ILAMF4=ILAMF4+1
100           CONTINUE
150         CONTINUE
200       CONTINUE
      ELSE
          DO 400 MU=0,MLIM,MSTEP
            DO 350 IV=MU,MU+IVLIM,IVS
              DO 300 ILAM=IV,IV+ILIM
                T1=C(ILAM,1)+C(ILAM,4)
                T2=C(ILAM,2)+C(ILAM,3)
                T3=(C(ILAM,1)-C(ILAM,4))*SIN72
                T4=(C(ILAM,2)-C(ILAM,3))*SIN72
                T5=T1+T2
                T1=RAD5D4*(T1-T2)
                T2=C(ILAM,0)-0.25*T5
                C(ILAM,0)=C(ILAM,0)+T5
                T5=T2+T1
                T2=T2-T1
                T1=T3+S36D72*T4
                T3=S36D72*T3-T4
                C(ILAM,1)=T5+DCMPLX(-DIMAG(T1),DREAL(T1))
                C(ILAM,4)=T5-DCMPLX(-DIMAG(T1),DREAL(T1))
                C(ILAM,2)=T2+DCMPLX(-DIMAG(T3),DREAL(T3))
                C(ILAM,3)=T2-DCMPLX(-DIMAG(T3),DREAL(T3))
300           CONTINUE
350         CONTINUE
400       CONTINUE
      ENDIF
      END


!!>
!! mo_surface_les
!!
!! Surface calculations for les physics using Businger Dyer relationship
!!
!! @author Anurag Dipankar, MPI-M
!!
!! @par Revision History
!! Initial release by Anurag Dipankar, MPI-M (2013-03-07)
!!
!! @par Copyright and License
!!
!! This code is subject to the DWD and MPI-M-Software-License-Agreement in
!! its most recent form.
!! Please see the file LICENSE in the root of the source tree for this code.
!! Where software is supplied by third parties, it is indicated in the
!! headers of the routines.
!!

!----------------------------
#include "omp_definitions.inc"
!----------------------------

MODULE mo_surface_les

  USE mo_kind,                ONLY: wp
  USE mo_exception,           ONLY: message, message_text
  USE mo_nonhydro_types,      ONLY: t_nh_diag, t_nh_metrics
  USE mo_model_domain,        ONLY: t_patch
  USE mo_intp_data_strc,      ONLY: t_int_state
  USE mo_parallel_config,     ONLY: nproma
  USE mo_run_config,          ONLY: msg_level
  USE mo_loopindices,         ONLY: get_indices_c
  USE mo_impl_constants    ,  ONLY: min_rlcell_int
  USE mo_sync,                ONLY: SYNC_C, sync_patch_array, global_sum_array
  USE mo_physical_constants,  ONLY: cpd, p0ref, grav, alv, rd, rgrav, rd_o_cpd, vtmpc1
  USE mo_nwp_lnd_types,       ONLY: t_lnd_prog, t_lnd_diag
  USE mo_satad,               ONLY: spec_humi, sat_pres_water
  USE mo_nwp_phy_types,       ONLY: t_nwp_phy_diag
  USE mo_les_config,          ONLY: les_config
  USE mo_math_constants,      ONLY: pi_2, ln2
  USE mo_impl_constants_grf,  ONLY: grf_bdywidth_c
  USE mo_data_turbdiff,       ONLY: akt, alpha0
  USE mo_turbdiff_config,     ONLY: turbdiff_config
  USE mo_nh_testcases_nml,    ONLY: th_cbl, psfc_cbl

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: surface_conditions

  !Parameters for surface layer parameterizations: From Zeng_etal 1997 J. Clim
  REAL(wp), PARAMETER :: bsm = 5.0_wp  !Businger Stable Momentum
  REAL(wp), PARAMETER :: bum = 16._wp  !Businger Untable Momentum
  REAL(wp), PARAMETER :: bsh = 5.0_wp  !Businger Stable Heat
  REAL(wp), PARAMETER :: buh = 16._wp  !Businger Untable Heat

  !Parameters for surface parameterizations from COSMO docs
  REAL(wp), PARAMETER :: beta_10 = 0.042_wp
  REAL(wp), PARAMETER :: h_10    = 10._wp
  REAL(wp), PARAMETER :: zh_max  = 0.1_wp

  !Parameters for RICO case
  REAL(wp), PARAMETER :: c_m = 0.001229_wp
  REAL(wp), PARAMETER :: c_h = 0.001094_wp
  REAL(wp), PARAMETER :: c_q = 0.001133_wp
  REAL(wp), PARAMETER :: th0_rico = 298.5_wp
  REAL(wp), PARAMETER :: psfc = 101540._wp

  CHARACTER(len=12)  :: str_module = 'surface_les'  ! Output of module for 1 line debug
  INTEGER            :: idt_src    = 4           ! Determines level of detail for 1 line debug

  CONTAINS

  !>
  !! surface_conditions
  !!------------------------------------------------------------------------
  !! Calculate surface temperature and moisture given the fluxes using Businger
  !! Dyer relationships .OR. vice versa. All calculations are done at cell center
  !!
  !!------------------------------------------------------------------------
  !! @par Revision History
  !! Initial release by Anurag Dipankar, MPI-M (2013-02-06)
  SUBROUTINE  surface_conditions(p_nh_metrics, p_patch, p_nh_diag, p_int, &
                                 p_prog_lnd_now, p_prog_lnd_new, p_diag_lnd, &
                                 prm_diag, theta, qv)

    TYPE(t_nh_metrics),INTENT(in),TARGET :: p_nh_metrics !< single nh metric state
    TYPE(t_patch),     INTENT(in),TARGET :: p_patch    !< single patch
    TYPE(t_nh_diag),   INTENT(in)        :: p_nh_diag  !< single nh diagnostic state
    TYPE(t_int_state), INTENT(in),TARGET :: p_int      !< single interpolation state
    TYPE(t_lnd_prog),  INTENT(in)        :: p_prog_lnd_now!<land prog state
    TYPE(t_lnd_prog),  INTENT(inout)     :: p_prog_lnd_new!<land prog state
    TYPE(t_lnd_diag),  INTENT(inout)     :: p_diag_lnd    !<land diag state
    TYPE(t_nwp_phy_diag),   INTENT(inout):: prm_diag      !< atm phys vars
    REAL(wp),          INTENT(in)        :: theta(:,:,:)  !pot temp
    REAL(wp),          INTENT(in)        :: qv(:,:,:)     !spec humidity

    REAL(wp) :: rhos, obukhov_length, z_mc, ustar, mwind
    REAL(wp) :: zrough, exner, var(nproma,p_patch%nblks_c), theta_nlev, qv_nlev
    REAL(wp) :: theta_sfc, shfl, lhfl, umfl, vmfl, bflx1, bflx2, theta_sfc1, diff
    REAL(wp) :: RIB, zh, tcn_mom, tcn_heat, t_sfc, ex_sfc, inv_bus_mom
    REAL(wp) :: ustar_mean
    REAL(wp) :: pres_sfc(nproma,p_patch%nblks_c)
    INTEGER :: i_startblk, i_endblk, i_startidx, i_endidx, i_nchdom
    INTEGER :: rl_start, rl_end
    INTEGER :: jk, jb, jc, isidx, isblk, rl
    INTEGER :: nlev, jg, itr, jkp1
    REAL(wp) :: ustar_v(nproma,p_patch%nblks_c)         ! SBr, CHa

    CHARACTER(len=*), PARAMETER :: routine = 'mo_surface_les:surface_conditions'

    IF (msg_level >= 15) &
         CALL message(TRIM(routine), '')

    jg = p_patch%id

    IF(les_config(jg)%psfc < 0._wp)THEN
      !use pressure from dynamics
      pres_sfc = p_nh_diag%pres_sfc
    ELSE
      !use imposed pressure
      pres_sfc = les_config(jg)%psfc
    END IF

    ! number of vertical levels
    nlev = p_patch%nlev
    jk   = nlev
    jkp1 = jk+1

    i_nchdom   = MAX(1,p_patch%n_childdom)

    !loop indices: exclude halo
    rl_start   = grf_bdywidth_c+1
    rl_end     = min_rlcell_int
    i_startblk = p_patch%cells%start_blk(rl_start,1)
    i_endblk   = p_patch%cells%end_blk(rl_end,i_nchdom)

    SELECT CASE(les_config(jg)%isrfc_type)

    !Default case with TERRA
    !Most of what follows has been taken from mo_nwp_turbtrans_interface
    !for COSMO turbulence

    CASE(1)

     !For now the LES scheme uses the surface fluxes from land directly. Exchange coefficients
     !are calculated by calling turbtrans using GME approach. See comment on mo_interface_les
     !where it is called. Status as on 11.09.2013 (AD)

     !change sign of surface fluxes
     prm_diag%shfl_s  = - prm_diag%shfl_s
     prm_diag%lhfl_s  = - prm_diag%lhfl_s
     prm_diag%umfl_s  = - prm_diag%umfl_s
     prm_diag%vmfl_s  = - prm_diag%vmfl_s

     ! SBr, CHa
     ustar_v(:,:) = SQRT((prm_diag%umfl_s**2 + prm_diag%vmfl_s**2))
     p_nh_metrics%obukhov_length(:,:) = -theta(:,nlev,:)*ustar_v(:,:)**3/(akt*grav*prm_diag%shfl_s(:,:))

    !Prescribed latent/sensible heat fluxes: get ustar and surface temperature / moisture
    !Ideally, one should do an iteration to get ustar corresponding to given fluxes

    !Fixed surface pressure to be comparable to incompressible LES models. Pseudo density
    !(constant in time) that is used here is fixed to the initial value so that the flux
    !is fixed in density units.
    CASE(2)

!$OMP PARALLEL
!$OMP DO PRIVATE(jc,jb,i_startidx,i_endidx,exner,zrough,mwind,z_mc,RIB,rhos, &
!$OMP            ustar,obukhov_length,theta_sfc),ICON_OMP_RUNTIME_SCHEDULE
      DO jb = i_startblk,i_endblk
         CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
                            i_startidx, i_endidx, rl_start, rl_end)
         DO jc = i_startidx, i_endidx

            !Surface exner
            exner = EXP( rd_o_cpd*LOG(pres_sfc(jc,jb)/p0ref) )

            !Roughness length
            zrough = prm_diag%gz0(jc,jb) * rgrav

            !Get reference surface pot. temperature
            !First time step t_g takes value assigned in nwp_phy_init
            theta_sfc = p_prog_lnd_now%t_g(jc,jb) / exner

            !Mean wind at nlev
            mwind  = MAX( les_config(jg)%min_sfc_wind,SQRT(p_nh_diag%u(jc,jk,jb)**2+p_nh_diag%v(jc,jk,jb)**2) )

            !Z height
            z_mc   = p_nh_metrics%z_mc(jc,jk,jb) - p_nh_metrics%z_ifc(jc,jkp1,jb)

            !Now diagnose friction velocity (ustar)
            IF(les_config(jg)%ufric<0._wp)THEN
              !Bulk Richardson no at first model level
              RIB = grav * (theta(jc,jk,jb)-theta_sfc)*(z_mc-zrough)/(theta_sfc*mwind**2)
              !first guess
              ustar = SQRT( diag_ustar_sq(z_mc,zrough,RIB,mwind) )
              DO itr = 1 , 5
                !"-" sign in the begining because ustar*thstar = -shflx
                obukhov_length = - theta_sfc*ustar**3/(akt*grav*les_config(jg)%shflx)
                ustar = mwind / businger_mom(zrough,z_mc,obukhov_length)
              END DO

            ELSE
              ustar = les_config(jg)%ufric
              obukhov_length = -theta_sfc*ustar**3/(akt*grav*les_config(jg)%shflx)
            END IF

            !New temperature
            theta_sfc   = theta(jc,jk,jb) + les_config(jg)%shflx / ustar * &
                          businger_heat(zrough,z_mc,obukhov_length)

            p_prog_lnd_new%t_g(jc,jb) = theta_sfc * exner

            !Get surface qv
            p_diag_lnd%qv_s(jc,jb) = qv(jc,jk,jb) + les_config(jg)%lhflx / ustar * &
                                     businger_heat(zrough,z_mc,obukhov_length)

            !rho at surface: no qc at suface
            rhos   =  pres_sfc(jc,jb)/( rd * &
                     p_prog_lnd_new%t_g(jc,jb)*(1._wp+vtmpc1*p_diag_lnd%qv_s(jc,jb)) )

            !Get surface fluxes
            prm_diag%shfl_s(jc,jb)  = les_config(jg)%shflx * rhos * cpd
            prm_diag%lhfl_s(jc,jb)  = les_config(jg)%lhflx * rhos * alv
            prm_diag%umfl_s(jc,jb)  = ustar**2 * rhos * p_nh_diag%u(jc,jk,jb) / mwind
            prm_diag%vmfl_s(jc,jb)  = ustar**2 * rhos * p_nh_diag%v(jc,jk,jb) / mwind

         END DO
      END DO
!$OMP END DO
!$OMP END PARALLEL

    !Prescribed buoyancy flux and transfer coefficient at surface to get a uniform SST (Stevens 2007 JAS)
    !It uses fixed transfer coefficient and assumes that q_s is saturated
    !Fixed surface pressure to be comparable to incompressible LES models. Pseudo density
    !(constant in time) that is used here is fixed to the initial value so that the flux
    !is fixed in density units.
    CASE(3)

      !Get mean theta and qv at first model level and surface pressure

      var(:,:) = theta(:,jk,:)
      WHERE(.NOT.p_patch%cells%decomp_info%owner_mask(:,:)) var(:,:) = 0._wp
      theta_nlev =  global_sum_array(var)/REAL(p_patch%n_patch_cells_g,wp)

      var(:,:) = qv(:,jk,:)
      WHERE(.NOT.p_patch%cells%decomp_info%owner_mask(:,:)) var(:,:) = 0._wp
      qv_nlev =  global_sum_array(var)/REAL(p_patch%n_patch_cells_g,wp)

      !Iterate to get surface temperature given buoyancy flux:following UCLA-LES

      !Note that t_g(:,:) is uniform so the first index is used below
      rl    = grf_bdywidth_c+1
      isblk = p_patch%cells%start_blk(rl,1)
      isidx = p_patch%cells%start_idx(rl,1)

      ex_sfc  = 1._wp !EXP( rd_o_cpd*LOG(pres_sfc(isidx,isblk)/p0ref) )
      t_sfc     = p_prog_lnd_now%t_g(isidx,isblk)
      theta_sfc = t_sfc / ex_sfc

      diff = 1._wp
      itr = 0
      DO WHILE (diff > 1.e-6_wp .AND. itr < 10)
         bflx1 = les_config(jg)%tran_coeff*( (theta_sfc-theta_nlev)+vtmpc1* &
                 theta_nlev*(spec_humi(sat_pres_water(t_sfc),pres_sfc(isidx,isblk))- &
                 qv_nlev) )*grav/theta_nlev

         theta_sfc1 = theta_sfc + 0.1_wp
         t_sfc      = theta_sfc1 * ex_sfc

         bflx2 = les_config(jg)%tran_coeff*( (theta_sfc1-theta_nlev)+vtmpc1* &
                 theta_nlev*(spec_humi(sat_pres_water(t_sfc),pres_sfc(isidx,isblk))- &
                 qv_nlev) )*grav/theta_nlev

         theta_sfc = theta_sfc1 + 0.1_wp*(les_config(jg)%bflux-bflx1)/(bflx2-bflx1)
         t_sfc     = theta_sfc * ex_sfc

         diff = ABS(1._wp - theta_sfc/theta_sfc1)
         itr = itr + 1
      END DO

      !WRITE(message_text,'(i4,f14.6,f14.7)')itr,diff,bflx2
      !CALL message('FINAL ITR, RESID, AND BFLX:',message_text )

!$OMP PARALLEL
!$OMP DO PRIVATE(jc,jb,i_startidx,i_endidx,zrough,z_mc,mwind,RIB,ustar, &
!$OMP            obukhov_length,rhos),ICON_OMP_RUNTIME_SCHEDULE
      DO jb = i_startblk,i_endblk
         CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
                            i_startidx, i_endidx, rl_start, rl_end)
         DO jc = i_startidx, i_endidx

            !Mean wind at nlev
            mwind  = MAX( les_config(jg)%min_sfc_wind, SQRT(p_nh_diag%u(jc,jk,jb)**2+p_nh_diag%v(jc,jk,jb)**2) )

            z_mc   = p_nh_metrics%z_mc(jc,jk,jb) - p_nh_metrics%z_ifc(jc,jkp1,jb)

            !Now diagnose friction velocity (ustar)
            IF(les_config(jg)%ufric<0._wp)THEN
              !Roughness length
              zrough = prm_diag%gz0(jc,jb) * rgrav

              !Bulk Richardson no at first model level
              RIB = grav * (theta(jc,jk,jb)-theta_sfc) * (z_mc-zrough)/(theta_sfc*mwind**2)
              ustar = SQRT( diag_ustar_sq(z_mc,zrough,RIB,mwind) )
              DO itr = 1 , 5
                obukhov_length = - theta_sfc*ustar**3/(akt*grav* les_config(jg)%tran_coeff*&
                                   (theta_sfc-theta(jc,jk,jb)))
                ustar = mwind / businger_mom(zrough,z_mc,obukhov_length)
              END DO

            ELSE
              ustar = les_config(jg)%ufric
            END IF

            !Surface temperature
            p_prog_lnd_new%t_g(jc,jb) = t_sfc

            !Get surface qv
            p_diag_lnd%qv_s(jc,jb) = spec_humi(sat_pres_water(p_prog_lnd_new%t_g(jc,jb)),pres_sfc(jc,jb))

            !rho at surface: no qc at suface
            rhos   =  pres_sfc(jc,jb)/( rd * &
                     p_prog_lnd_new%t_g(jc,jb)*(1._wp+vtmpc1*p_diag_lnd%qv_s(jc,jb)) )

            prm_diag%shfl_s(jc,jb) = rhos*cpd*les_config(jg)%tran_coeff* &
                                     (theta_sfc-theta(jc,jk,jb))
            prm_diag%lhfl_s(jc,jb) = rhos*alv*les_config(jg)%tran_coeff* &
                                     (p_diag_lnd%qv_s(jc,jb)-qv(jc,jk,jb))
            prm_diag%umfl_s(jc,jb)  = ustar**2 * rhos * p_nh_diag%u(jc,jk,jb) / mwind
            prm_diag%vmfl_s(jc,jb)  = ustar**2 * rhos * p_nh_diag%v(jc,jk,jb) / mwind

         END DO
      END DO
!$OMP END DO
!$OMP END PARALLEL

   !Rico case
    CASE(4)

      !RICO case - bulk aerodynamic formulation with fixed exchange coef.
      DO jb = i_startblk,i_endblk
        CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
                            i_startidx, i_endidx, rl_start, rl_end)
        DO jc = i_startidx, i_endidx

            !Get surface qv and temperature
            p_diag_lnd%qv_s(jc,jb) = spec_humi(sat_pres_water(les_config(jg)%sst),psfc)
            p_prog_lnd_new%t_g(jc,jb) = les_config(jg)%sst

            !Mean wind at nlev
            mwind  = SQRT(p_nh_diag%u(jc,jk,jb)**2+p_nh_diag%v(jc,jk,jb)**2)

            shfl  =   c_h * mwind * (th0_rico-theta(jc,jk,jb))
            lhfl  =   c_q * mwind * (p_diag_lnd%qv_s(jc,jb)-qv(jc,jk,jb))
            umfl  =   c_m * mwind * p_nh_diag%u(jc,jk,jb)
            vmfl  =   c_m * mwind * p_nh_diag%v(jc,jk,jb)

            !Surface density
            rhos   =  psfc/( rd * &
                      p_prog_lnd_new%t_g(jc,jb)*(1._wp+vtmpc1*p_diag_lnd%qv_s(jc,jb)) )

            !Get surface fluxes
            prm_diag%shfl_s(jc,jb)  = shfl * rhos * cpd
            prm_diag%lhfl_s(jc,jb)  = lhfl * rhos * alv
            prm_diag%umfl_s(jc,jb)  = umfl * rhos
            prm_diag%vmfl_s(jc,jb)  = vmfl * rhos

        END DO
      END DO

    !Fix SST case
    CASE(5)

!   Get roughness length * grav
    IF(turbdiff_config(jg)%lconst_z0 .AND. turbdiff_config(jg)%const_z0 <= 0._wp)THEN
      DO jb = i_startblk,i_endblk
        CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
                           i_startidx, i_endidx, rl_start, rl_end)
        DO jc = i_startidx, i_endidx
           mwind = MAX( les_config(jg)%min_sfc_wind, SQRT(p_nh_diag%u(jc,jk,jb)**2+p_nh_diag%v(jc,jk,jb)**2) )
           var(jc,jb) = SQRT( MAX(0._wp,prm_diag%tcm(jc,jb)) ) * mwind
        END DO
      END DO

      WHERE(.NOT.p_patch%cells%decomp_info%owner_mask(:,:)) var(:,:) = 0._wp
      ustar_mean =  global_sum_array(var)/REAL(p_patch%n_patch_cells_g,wp)

      prm_diag%gz0(:,:) = MAX(0.001_wp,0.016_wp*ustar_mean**2)
    END IF

!$OMP PARALLEL
!$OMP DO PRIVATE(jc,jb,i_startidx,i_endidx,zrough,theta_sfc,mwind,z_mc, &
!$OMP            RIB,tcn_mom,tcn_heat,rhos,itr,shfl,lhfl,bflx1,ustar,   &
!$OMP            obukhov_length,inv_bus_mom),ICON_OMP_RUNTIME_SCHEDULE
      DO jb = i_startblk,i_endblk
         CALL get_indices_c(p_patch, jb, i_startblk, i_endblk, &
                            i_startidx, i_endidx, rl_start, rl_end)
         DO jc = i_startidx, i_endidx

           !Roughness length
           zrough = prm_diag%gz0(jc,jb) * rgrav

           !Get surface pot. temperature and humidity
           p_prog_lnd_new%t_g(jc,jb) = les_config(jg)%sst
           theta_sfc = p_prog_lnd_new%t_g(jc,jb) / EXP( rd_o_cpd*LOG(pres_sfc(jc,jb)/p0ref) )

           p_diag_lnd%qv_s(jc,jb) = spec_humi(sat_pres_water(les_config(jg)%sst),pres_sfc(jc,jb))

           !rho at surface: no qc at suface
           rhos   =  pres_sfc(jc,jb)/( rd * &
                     p_prog_lnd_new%t_g(jc,jb)*(1._wp+vtmpc1*p_diag_lnd%qv_s(jc,jb)) )

           mwind = MAX( les_config(jg)%min_sfc_wind, SQRT(p_nh_diag%u(jc,jk,jb)**2+p_nh_diag%v(jc,jk,jb)**2) )

           !Z height to be used as a reference height in surface layer
           z_mc   = p_nh_metrics%z_mc(jc,jk,jb) - p_nh_metrics%z_ifc(jc,jkp1,jb)

           !First guess for tch and tcm using bulk approach
           RIB = grav * (theta(jc,jk,jb)-theta_sfc) * (z_mc-zrough) / (theta_sfc * mwind**2)

           tcn_mom             = (akt/LOG(z_mc/zrough))**2
           prm_diag%tcm(jc,jb) = tcn_mom * stability_function_mom(RIB,z_mc/zrough,tcn_mom)

           tcn_heat            = akt**2/(LOG(z_mc/zrough)*LOG(z_mc/zrough))
           prm_diag%tch(jc,jb) = tcn_heat * stability_function_heat(RIB,z_mc/zrough,tcn_heat)

           !now iterate
           DO itr = 1 , 5
              shfl = prm_diag%tch(jc,jb)*mwind*(theta_sfc-theta(jc,jk,jb))
              lhfl = prm_diag%tch(jc,jb)*mwind*(p_diag_lnd%qv_s(jc,jb)-qv(jc,jk,jb))
              bflx1= shfl + vtmpc1 * theta_sfc * lhfl
              ustar= SQRT(prm_diag%tcm(jc,jb))*mwind

              obukhov_length = -ustar**3 * theta_sfc * rgrav / (akt * bflx1)

              inv_bus_mom = 1._wp / businger_mom(zrough,z_mc,obukhov_length)
              prm_diag%tch(jc,jb) = inv_bus_mom / businger_heat(zrough,z_mc,obukhov_length)

              prm_diag%tcm(jc,jb) = inv_bus_mom * inv_bus_mom
           END DO

           !Get surface fluxes
           prm_diag%shfl_s(jc,jb) = rhos*cpd*prm_diag%tch(jc,jb)*mwind*(theta_sfc-theta(jc,jk,jb))
           prm_diag%lhfl_s(jc,jb) = rhos*alv*prm_diag%tch(jc,jb)*mwind*(p_diag_lnd%qv_s(jc,jb)-qv(jc,jk,jb))
           prm_diag%umfl_s(jc,jb) = rhos*prm_diag%tcm(jc,jb)*mwind*p_nh_diag%u(jc,jk,jb)
           prm_diag%vmfl_s(jc,jb) = rhos*prm_diag%tcm(jc,jb)*mwind*p_nh_diag%v(jc,jk,jb)

         END DO
      END DO
!$OMP END DO NOWAIT
!$OMP END PARALLEL

    !No fluxes
    CASE(0)

      prm_diag%shfl_s  = 0._wp
      prm_diag%lhfl_s  = 0._wp
      prm_diag%umfl_s  = 0._wp
      prm_diag%vmfl_s  = 0._wp

  END SELECT

  !Sync is required for mom fluxes
  CALL sync_patch_array(SYNC_C, p_patch, prm_diag%umfl_s)
  CALL sync_patch_array(SYNC_C, p_patch, prm_diag%vmfl_s)

  END SUBROUTINE surface_conditions

  !>
  !! factor_heat
  !!------------------------------------------------------------------------
  !! Businger Dyer similarity profile:
  !! Louis (1979) A Parametirc model of vertical eddy fluxes in the atmosphere
  !! and R. B. Stull's book
  !!------------------------------------------------------------------------
  !! @par Revision History
  !! Initial release by Anurag Dipankar, MPI-M (2013-02-06)
  FUNCTION businger_heat(z0, z1, L) RESULT(factor)
     REAL(wp), INTENT(IN) :: z0, z1, L
     REAL(wp) :: factor, zeta, lamda, psi
     REAL(wp) :: zeta0, lamda0, psi0

     IF(L > 0._wp)THEN !Stable
       zeta   = z1/L
       zeta0  = z0/L
       IF(zeta > 1._wp)THEN !Zeng etal 1997 J. Clim
         psi    = -bsh*LOG(zeta) - zeta + 1
         psi0   = -bsh*LOG(zeta0) - zeta0 + 1
         factor = (LOG(L/z0) + bsh - psi + psi0  ) / akt
       ELSE
         psi    = -bsh*zeta
         psi0   = -bsh*zeta0
         factor = (LOG(z1/z0) - psi + psi0) / akt
       END IF
     ELSEIF(L < 0._wp)THEN !unstable
       zeta   = z1/L
       zeta0  = z0/L
       lamda  = SQRT(1._wp - buh*zeta)
       lamda0 = SQRT(1._wp - buh*zeta0)
       psi    = 2._wp * ( LOG(1._wp+lamda) - ln2 )
       psi0   = 2._wp * ( LOG(1._wp+lamda0) - ln2 )
       factor = (LOG(z1/z0) - psi + psi0) / akt
     ELSE !Neutral
       factor = LOG(z1/z0) / akt
     END IF

  END FUNCTION businger_heat
  !-----------------------------------------------------------------------------
  !-----------------------------------------------------------------------------
  FUNCTION phi_heat(z1, L) RESULT(factor)
     REAL(wp), INTENT(IN) :: z1, L
     REAL(wp) :: factor, zeta, lamda

     IF(L > 0._wp)THEN !Stable
       zeta   = z1/L
       IF(zeta > 1._wp)THEN
         factor = bsh + zeta
       ELSE
         lamda = bsh*zeta
         factor = 1._wp + lamda
       END IF
     ELSEIF(L < 0._wp)THEN !unstable
       zeta   = z1/L
       lamda  = SQRT(1._wp - buh*zeta)
       factor = 1._wp / lamda
     ELSE !neutral
       factor = 1._wp
     END IF

  END FUNCTION phi_heat

  !>
  !! factor_mom
  !!------------------------------------------------------------------------
  !! Businger Dyer similarity profile:
  !! Louis (1979) A Parametirc model of vertical eddy fluxes in the atmosphere
  !! and R. B. Stull's book
  !!------------------------------------------------------------------------
  FUNCTION businger_mom(z0, z1, L) RESULT(factor)
     REAL(wp), INTENT(IN) :: z0, z1, L
     REAL(wp) :: factor, zeta, psi, lamda
     REAL(wp) :: zeta0, psi0, lamda0

     IF(L > 0._wp)THEN !Stable
       zeta  = z1/L
       zeta0 = z0/L
       IF(zeta > 1._wp)THEN !Zeng etal 1997 J. Clim
         psi    = -bsm*LOG(zeta) - zeta + 1
         psi0   = -bsm*LOG(zeta0) - zeta0 + 1
         factor = (LOG(L/z0) + bsh - psi + psi0  ) / akt
       ELSE
         psi  = -bsm*zeta
         psi0 = -bsm*zeta0
         factor = ( LOG(z1/z0) - psi + psi0 ) / akt
       END IF
     ELSEIF(L < 0._wp)THEN !unstable
       zeta   = z1/L
       zeta0  = z0/L
       lamda  = SQRT(SQRT(1._wp - bum*zeta))
       lamda0 = SQRT(SQRT(1._wp - bum*zeta0))

       psi    = 2._wp * LOG(1._wp+lamda) + LOG(1._wp+lamda*lamda) - &
                2._wp * ATAN(lamda) + pi_2 - 3._wp*ln2

       psi0   = 2._wp * LOG(1._wp+lamda0) + LOG(1._wp+lamda0*lamda0) - &
                2._wp * ATAN(lamda0) + pi_2 - 3._wp*ln2

       factor = ( LOG(z1/z0) - psi + psi0 ) / akt
     ELSE !neutral
       factor = LOG(z1/z0) / akt
     END IF

  END FUNCTION businger_mom
  !-----------------------------------------------------------------------------
  !-----------------------------------------------------------------------------
  FUNCTION phi_mom(z1, L) RESULT(factor)
     REAL(wp), INTENT(IN) :: z1, L
     REAL(wp) :: factor, zeta, lamda

     IF(L > 0._wp)THEN !Stable
       zeta   = z1/L
       IF(zeta > 1._wp)THEN
         factor = bsm + zeta
       ELSE
         factor = 1._wp + bsm * zeta
       END IF
     ELSEIF(L < 0._wp)THEN !unstable
       zeta   = z1/L
       lamda  = SQRT(SQRT(1._wp - bum*zeta))
       factor = 1._wp / lamda
     ELSE !neutral
       factor  = 1._wp
     END IF

  END FUNCTION phi_mom

  !>
  !! diagnose ustar
  !!------------------------------------------------------------------------
  FUNCTION diag_ustar_sq(h, z0, RIB, wind) RESULT(ustar_sq)
     REAL(wp), INTENT(IN) :: h, z0, RIB, wind

     REAL(wp) :: ustar_sq, tcn_mom

     tcn_mom  = (akt/LOG(h/z0))**2
     ustar_sq = tcn_mom*wind**2*stability_function_mom(RIB,h/z0,tcn_mom)

  END FUNCTION diag_ustar_sq

  !>
  !! diagnose wstar
  !!------------------------------------------------------------------------
  FUNCTION diag_wstar_sq(h, z0, RIB, wind) RESULT(wstar_sq)
     REAL(wp), INTENT(IN) :: h, z0, RIB, wind

     REAL(wp) :: wstar_sq, tcn_heat, zh

     zh = MIN(z0, zh_max)

     IF(RIB < 0._wp)THEN
       tcn_heat = akt**2/(LOG(h/z0)*LOG(h/zh))
       wstar_sq = ( tcn_heat * wind**3 * ABS(RIB) * &
                    stability_function_heat(RIB,h/zh,tcn_heat) )**(2._wp/3._wp)
     ELSE
       wstar_sq = 0._wp
     END IF

  END FUNCTION diag_wstar_sq

  !>
  !! init_zrough
  !!------------------------------------------------------------------------
  FUNCTION init_gz(h, wind) RESULT(gz)
     REAL(wp), INTENT(IN) :: h, wind

     REAL(wp) :: z01, z02, gz

     z01 = alpha0 * wind**2 / ( (1._wp/beta_10) + LOG(h/h_10)/akt )**2
     !z02 = ( alpha0 * wind**2 * ABS(RIB) )**1.5_wp / (5 * SQRT(grav*h))

     !gz = MAX(z01, z02)
     gz = z01

  END FUNCTION init_gz

  !>
  !! stability_function_mom
  !! Taken from COSMO docs and Holstag & Boville 1992
  !!------------------------------------------------------------------------
  FUNCTION stability_function_mom(RIB, hz0, tc) RESULT(stab_fun)
     REAL(wp), INTENT(IN) :: RIB, hz0, tc

     REAL(wp) :: stab_fun, hz0_fac

     IF(RIB.GE.0._wp)THEN
       !Cosmo
       !stab_fun = 1._wp / ( 1._wp + 10._wp*RIB/SQRT(1._wp+5*RIB) )

       !H&B
       stab_fun = 1._wp / ( 1._wp + 10._wp*RIB*(1._wp+8._wp*RIB) )
     ELSE
       hz0_fac = ( hz0**(1._wp/3._wp) - 1._wp )**1.5_wp
       !for water surface (z0/h)**(1/3)<<1 giving hz0_fac=SQRT(h/z0)
       !Generally it is explicitly written for water surface but i don't
       !see any reason to do that.
       stab_fun = 1._wp + 10._wp*ABS(RIB)/(1._wp + 75._wp*tc*hz0_fac*SQRT(ABS(RIB)))
     END IF

  END FUNCTION stability_function_mom
  !>
  !! stability_function_heat
  !!------------------------------------------------------------------------
  FUNCTION stability_function_heat(RIB, hzh, tc) RESULT(stab_fun)
     REAL(wp), INTENT(IN) :: RIB, hzh, tc

     REAL(wp) :: stab_fun, hzh_fac

     IF(RIB.GE.0._wp)THEN
       !Cosmo
       !stab_fun = 1._wp / ( 1._wp + 15._wp*RIB*SQRT(1._wp+5*RIB) )

       !H&B
       stab_fun = 1._wp / ( 1._wp + 10._wp*RIB*(1._wp+8._wp*RIB) )
     ELSE
       hzh_fac = ( hzh**(1._wp/3._wp) - 1._wp )**1.5_wp
       !for water surface (zh/h)**(1/3)<<1 giving hzh_fac=SQRT(h/zh)
       !Generally it is explicitly written for water surface but i don't
       !see any reason to do that.
       stab_fun = 1._wp + 15._wp*ABS(RIB)/(1._wp + 75._wp*tc*hzh_fac*SQRT(ABS(RIB)))
     END IF
  END FUNCTION stability_function_heat

!-------------------------------------------------------------------------------

END MODULE mo_surface_les


#ifdef DBLE_MATH
#include "dble_math.h"
#endif
#include "real.h"
module mod_fxy_Coriolis_disp
#ifdef MPI
use mpi
#endif
use mod_grid
! === Dispersive ===============================================================
use mod_params, only : max_step, min_depth
#ifdef CONV_CHECK
use mod_params, only : conv_val
#endif
! ==============================================================================
#ifdef MPI
use mod_mpi
#endif
use mod_nest
use mod_params, only : VEL
implicit none

contains

#ifndef MPI
#ifndef CONV_CHECK
! === Coriolis force is supported on linear calc. ==============================
!  subroutine fxy_rwg_disp(wfld,dfld,dt,th0,dth,nlon,nlat,gflag,fg,cg)
   subroutine fxy_rwg_Coriolis_disp(wfld,dfld,cflag,dt,th0,dth,nlon,nlat,gflag,fg,cg)
! ==============================================================================
#else
! === Coriolis force is supported on linear calc. ==============================
!  subroutine fxy_rwg_disp(wfld,dfld,dt,th0,dth,nlon,nlat,gflag,fg,cg,conv_step)
   subroutine fxy_rwg_Coriolis_disp(wfld,dfld,cflag,dt,th0,dth,nlon,nlat,gflag,fg,cg,conv_step)
! ==============================================================================
#endif
#else
#ifndef CONV_CHECK
! === Coriolis force is supported on linear calc. ==============================
!  subroutine fxy_rwg_disp(wfld,dfld,dt,th0,dth,joff,nlon,nlat,gflag,bflag,fg,cg)
   subroutine fxy_rwg_Coriolis_disp(wfld,dfld,cflag,dt,th0,dth,joff,nlon,nlat,gflag,bflag,fg,cg)
! ==============================================================================
#else
! === Coriolis force is supported on linear calc. ==============================
!  subroutine fxy_rwg_disp(wfld,dfld,dt,th0,dth,joff,nlon,nlat,gflag,bflag,fg,cg,conv_step)
   subroutine fxy_rwg_Coriolis_disp(wfld,dfld,cflag,dt,th0,dth,joff,nlon,nlat,gflag,bflag,fg,cg,conv_step)
! ==============================================================================
#endif
#endif
      type(wave_arrays), target, intent(inout) :: wfld
      type(depth_arrays), target, intent(in) :: dfld
      real(kind=REAL_BYTE), intent(in) :: dt, th0, dth
      integer(kind=4), intent(in) :: nlon, nlat
#ifdef MPI
      integer(kind=4), intent(in) :: joff
#endif
#ifdef CONV_CHECK
      integer(kind=4), intent(out) :: conv_step
#endif
! === Coriolis force is supported on linear calc. ==============================
      integer(kind=4), intent(in) :: cflag
! ==============================================================================

      real(kind=REAL_BYTE), pointer, dimension(:,:) :: fx, fy, hz, dz, p
      integer(kind=4) :: i, j
      real(kind=REAL_BYTE) :: rote, g, gts, theta, sint, cfc
      real(kind=REAL_BYTE), parameter :: zap = 0.0d0
! === Coriolis force is supported on linear calc. ==============================
      real(kind=REAL_BYTE), parameter :: quart = 0.25d0
      real(kind=REAL_BYTE), parameter :: cfreq = 7.27220522d-05 ! angular freq of earth's rotation (rad/s)
      real(kind=REAL_BYTE) :: crls, fxbar, fybar
! ==============================================================================
      real(kind=REAL_BYTE), pointer, dimension(:,:) :: dx, dy
! === Dispersive ===============================================================
      type(data_grids), target, intent(inout) :: fg, cg
#ifdef MPI
      integer(kind=4), intent(in) :: bflag
      integer(kind=4) :: ist_, jst_
#endif
      integer(kind=4), intent(in) :: gflag
      integer(kind=4) :: ist, ind, jst, jnd
      real(kind=REAL_BYTE), pointer, dimension(:,:) :: fx_old, fy_old
      real(kind=REAL_BYTE), pointer, dimension(:,:) :: yu, yv ! RHS
      real(kind=REAL_BYTE), pointer, dimension(:,:) :: cu, cv ! Coefficient
      integer(kind=4) :: conv                                 ! Convergence loop
#ifdef CONV_CHECK
      real(kind=REAL_BYTE) :: diff, diffx, diffy, diffxy
#ifdef MPI
      integer(kind=4) :: ierr
#endif
      real(kind=REAL_BYTE) :: tmpx, tmpy
      real(kind=REAL_BYTE), pointer, dimension(:,:) :: tdx, tdy
#endif
! ==============================================================================
      real(kind=REAL_BYTE) :: c0, c1, c2, c3, c4
#ifdef __FUJITSU
      real(kind=REAL_BYTE), allocatable, dimension(:) :: ta0, ta1
#endif
#ifdef LESS_CC
      integer(kind=4), parameter :: check = 10
#endif

      fx => wfld%fx
      fy => wfld%fy
      hz => wfld%hz
! === Dispersive ===============================================================
      yu => wfld%yu
      yv => wfld%yv
      cu => wfld%cu
      cv => wfld%cv
      cu = 0.0d0
      cv = 0.0d0
      fx_old => wfld%fx_old
      fy_old => wfld%fy_old
! ==============================================================================
#ifdef CONV_CHECK
      tdx => wfld%tdx
      tdy => wfld%tdy
#endif

      dz => dfld%dz
      dx => dfld%dx
      dy => dfld%dy

! === Dispersive ===============================================================
#ifndef MPI
!$omp do private(i)
      do j = 0, nlat
         do i = -1, nlon
            fx_old(i,j) = fx(i,j)
         end do
      end do
!$omp do private(i)
      do j = -1, nlat
         do i = 0, nlon
            fy_old(i,j) = fy(i,j)
         end do
      end do
#else
!$omp single
      ist_ = 0
      jst_ = 1
      if(iand(bflag, WEST_BOUND)  /= 0) ist_ = -1
      if(iand(bflag, NORTH_BOUND) /= 0) jst_ = 0
!$omp end single
!$omp do private(i)
      do j = jst_, nlat
         do i = ist_, nlon
            fx_old(i,j) = fx(i,j)
         end do
      end do
!$omp single
      ist_ = 1
      jst_ = 0
      if(iand(bflag, WEST_BOUND)  /= 0) ist_ = 0
      if(iand(bflag, NORTH_BOUND) /= 0) jst_ = -1
!$omp end single
!$omp do private(i)
      do j = jst_, nlat
         do i = ist_, nlon
            fy_old(i,j) = fy(i,j)
         end do
      end do
#endif
! ==============================================================================
      rote = 6371.0d0 * 1000.0d0
      g = 9.8d0
      gts = g * dt /(dth * rote)

! === Coriolis force is supported on linear calc. ==============================
      jst = 1
      jnd = nlat - 1
      ist = 1
      ind = nlon - 1
      if(gflag == 1) then
         jst = 2
         jnd = nlat - 2
         ist = 2
         ind = nlon - 2
      end if
#ifdef MPI
      if(iand(bflag, NORTH_BOUND) == 0) jst = 2
      if(iand(bflag, WEST_BOUND)  == 0) ist = 2
      if(iand(bflag, SOUTH_BOUND) == 0) jnd = nlat - 1
      if(iand(bflag, EAST_BOUND)  == 0) ind = nlon - 1
#endif
! ==============================================================================
! === Coriolis force is supported on linear calc. ==============================
!!$omp parallel do private(theta, sint, cfc, i)
!     do j = 1, nlat-1
!$omp parallel do private(theta, sint, cfc, i, crls, fybar, fxbar)
      do j = jst, jnd
! ==============================================================================
#ifndef MPI
         theta = th0 + (j-1)*dth
#else
         theta = th0 + (j+joff-1)*dth
#endif
         sint = sin(theta)
         cfc = gts/sint
! === Coriolis force is supported on linear calc. ==============================
!        do i = 1, nlon-1
         crls = 2.0d0*cflag*cfreq*cos(theta)*dt
         do i = ist, ind
! ==============================================================================
            if(dz(i,j) > zap) then
! === Coriolis force is supported on linear calc. ==============================
!              fx(i,j) = fx(i,j) - dx(i,j)*cfc*(hz(i+1,j)  -hz(i,j))
!              fy(i,j) = fy(i,j) - dy(i,j)*gts*(hz(i,  j+1)-hz(i,j))
               fybar = quart*(fy_old(i,j) + fy_old(i+1,j) + fy_old(i,j-1) + fy_old(i+1,j-1))
               fxbar = quart*(fx_old(i,j) + fx_old(i-1,j) + fx_old(i,j+1) + fx_old(i-1,j+1))
               fx(i,j) = fx(i,j) - dx(i,j)*cfc*(hz(i+1,j)  -hz(i,j)) - crls*fybar
               fy(i,j) = fy(i,j) - dy(i,j)*gts*(hz(i,  j+1)-hz(i,j)) + crls*fxbar
! ==============================================================================
            else
               fx(i,j) = zap
               fy(i,j) = zap
            end if
         end do
      end do
! === Coriolis force is supported on linear calc. ==============================
      if(gflag == 1) then
#ifndef MPI
            theta = th0
#else
         if(iand(bflag, NORTH_BOUND) /= 0) then
            theta = th0 + joff*dth
#endif
            sint = sin(theta)
            cfc = gts/sint
#ifndef MPI
!$omp parallel do
            do i = 1, nlon-1
#else
            ist = 1
            ind = nlon - 1
            if(iand(bflag, WEST_BOUND)  == 0) ist = 2
!$omp parallel do
            do i = ist, ind
#endif
               if(dz(i,1) > zap) then
                  fx(i,1) = fx(i,1) - dx(i,1)*cfc*(hz(i+1,1)-hz(i,1))
                  fy(i,1) = fy(i,1) - dy(i,1)*gts*(hz(i,  2)-hz(i,1))
               else
                  fx(i,1) = zap
                  fy(i,1) = zap
               end if
            end do
#ifndef MPI
            theta = th0 + (nlat-2)*dth
#else
         end if
         if(iand(bflag, SOUTH_BOUND) /= 0) then
            theta = th0 + (nlat+joff-2)*dth
#endif
            sint = sin(theta)
            cfc = gts/sint
#ifndef MPI
!$omp parallel do
            do i = 1, nlon-1
#else
            ist = 1
            ind = nlon - 1
            if(iand(bflag, WEST_BOUND)  == 0) ist = 2
!$omp parallel do
            do i = ist, ind
#endif
               if(dz(i,nlat-1) > zap) then
                  fx(i,nlat-1) = fx(i,nlat-1) - dx(i,nlat-1)*cfc*(hz(i+1,nlat-1)-hz(i,nlat-1))
                  fy(i,nlat-1) = fy(i,nlat-1) - dy(i,nlat-1)*gts*(hz(i,  nlat)  -hz(i,nlat-1))
               else
                  fx(i,nlat-1) = zap
                  fy(i,nlat-1) = zap
               end if
            end do
#ifndef MPI
!$omp parallel do private(theta, sint, cfc)
            do j = 2, nlat-2
               theta = th0 + (j-1)*dth
#else
         end if
         if(iand(bflag, WEST_BOUND) /= 0) then
            jst = 2
            jnd = nlat - 2
            if(iand(bflag, SOUTH_BOUND) == 0) jnd = nlat - 1
!$omp parallel do private(theta, sint, cfc)
            do j = jst, jnd
               theta = th0 + (j+joff-1)*dth
#endif
               sint = sin(theta)
               cfc = gts/sint
               if(dz(1,j) > zap) then
                  fx(1,j) = fx(1,j) - dx(1,j)*cfc*(hz(2,j)  -hz(1,j))
                  fy(1,j) = fy(1,j) - dy(1,j)*gts*(hz(1,j+1)-hz(1,j))
               else
                  fx(1,j) = zap
                  fy(1,j) = zap
               end if
            end do
#ifndef MPI
!$omp parallel do private(theta, sint, cfc)
            do j = 2, nlat-2
               theta = th0 + (j-1)*dth
#else
         end if
         if(iand(bflag, EAST_BOUND) /= 0) then
            jst = 2
            jnd = nlat - 2
            if(iand(bflag, SOUTH_BOUND) == 0) jnd = nlat - 1
!$omp parallel do private(theta, sint, cfc)
            do j = jst, jnd
               theta = th0 + (j+joff-1)*dth
#endif
               sint = sin(theta)
               cfc = gts/sint
               if(dz(nlon-1,j) > zap) then
                  fx(nlon-1,j) = fx(nlon-1,j) - dx(nlon-1,j)*cfc*(hz(nlon,  j)  -hz(nlon-1,j))
                  fy(nlon-1,j) = fy(nlon-1,j) - dy(nlon-1,j)*gts*(hz(nlon-1,j+1)-hz(nlon-1,j))
               else
                  fx(nlon-1,j) = zap
                  fy(nlon-1,j) = zap
               end if
            end do
#ifdef MPI
         end if
#endif
      end if
! ==============================================================================
! === Coriolis force is supported on linear calc. ==============================
#ifdef MPI
      call exchange_edges(VEL,fg)

      ist_ = 1
      jst_ = 1
      if(iand(bflag, WEST_BOUND)  /= 0) ist_ = 0
      if(iand(bflag, NORTH_BOUND) /= 0) jst_ = 0
#endif
! ==============================================================================
! === Dispersive ===============================================================
      jst = 1
      jnd = nlat - 1
      ist = 1
      ind = nlon - 1

      if(gflag == 1) then
         jst = 2
         jnd = nlat - 1
         ist = 2
         ind = nlon - 1
      end if

      jnd = jnd - jst + 1
      ind = ind - ist + 1
#ifdef MPI
      if(gflag == 1) then
         jst = 2
         jnd = nlat - 1
         ist = 2
         ind = nlon - 1
         if(iand(bflag, SOUTH_BOUND) /= 0) jnd = nlat - 2
         if(iand(bflag, EAST_BOUND)  /= 0) ind = nlon - 2
      else
         jst = 1
         jnd = nlat - 1
         ist = 1
         ind = nlon - 1
         if(iand(bflag, NORTH_BOUND) == 0) jst = 2
         if(iand(bflag, WEST_BOUND)  == 0) ist = 2
      end if
#endif

      rote = 6371.0d0 * 1000.0d0
      g = 9.8d0
      gts = g * dt /(dth * rote)

#ifndef __FUJITSU
!$omp parallel private(conv)
#else
!$omp parallel private(conv, ta0, ta1)
      allocate(ta0(ist:ind))
      allocate(ta1(ist:ind))
#endif
!$omp do private(theta, sint, cfc, i)
      do j = jst, jnd
#ifndef MPI
         theta = th0 + (j-1)*dth
#else
         theta = th0 + (j+joff-1)*dth
#endif
         sint = sin(theta)
         cfc = gts/sint
         do i = ist, ind
            if(dz(i,j) > min_depth) then
               cu(i,j) = ((1.0d0/(rote*dth*sint))**2/3.0d0)*(0.5d0*(dz(i+1,j)+dz(i,j)))**2
               fx(i,j) = fx(i,j) - cu(i,j)*( &
               ! U_n
               &   fx_old(i+1,j) - 2.0d0*fx_old(i,j) + fx_old(i-1,j) &
               ! V_n
               & + (fy_old(i+1,j  )-fy_old(i,  j  ))*sin(theta+dth/2.0d0) &
               & - (fy_old(i+1,j-1)-fy_old(i,  j-1))*sin(theta-dth/2.0d0) &
               & )
               cv(i,j) = ((1.0d0/(rote*dth))**2/3.0d0)*(0.5d0*(dz(i,j+1)+dz(i,j)))**2
               fy(i,j) = fy(i,j)  - cv(i,j)*( &
               ! V_n
               &   fy_old(i  ,j+1)*sin(theta+dth)/sin(theta+dth/2.0d0) &
               & - fy_old(i  ,j  )*sint/sin(theta-dth/2.0d0)           &
               & - fy_old(i  ,j  )*sint/sin(theta+dth/2.0d0)           &
               & + fy_old(i  ,j-1)*sin(theta-dth)/sin(theta-dth/2.0d0) &
               ! U_n
               & + (fx_old(i  ,j+1)-fx_old(i-1,j+1))/sin(theta+dth/2.0d0) &
               & - (fx_old(i,  j  )-fx_old(i-1,j  ))/sin(theta-dth/2.0d0) &
               & )
            end if
         end do
      end do

#ifndef MPI
!$omp do private(i)
      do j = 0, nlat
         do i = 0, nlon
            yu(i,j) = fx(i,j)
            fx(i,j) = fx_old(i,j)
            yv(i,j) = fy(i,j)
            fy(i,j) = fy_old(i,j)
         end do
      end do

      if(gflag /= 1) then
!$omp single
         call interp2fine(VEL,cg,fg)
!$omp end single
!$omp do private(i)
         do j = 0, nlat
            do i = 0, nlon
               fx_old(i,j) = fx(i,j)
               fy_old(i,j) = fy(i,j)
            end do
         end do
      end if
#else
!$omp single
      call exchange_edges_disp_fx(fg,1)
      call exchange_edges_disp_fy(fg,1)
!$omp end single
!$omp do private(i)
      do j = jst_, nlat
         do i = ist_, nlon
            yu(i,j) = fx(i,j)
            fx(i,j) = fx_old(i,j)
            yv(i,j) = fy(i,j)
            fy(i,j) = fy_old(i,j)
         end do
      end do

      if(gflag /= 1) then
!$omp single
         call interp2fine(VEL,cg,fg)
         call exchange_edges_disp_fx(fg,1)
         call exchange_edges_disp_fy(fg,1)
!$omp end single
!$omp do private(i)
         do j = jst_, nlat
            do i = ist_, nlon
               fx_old(i,j) = fx(i,j)
               fy_old(i,j) = fy(i,j)
            end do
         end do
      end if
! ==============================================================================
#endif
#ifdef CONV_CHECK
!$omp do private(i, tmpx, tmpy)
      do j = 1, nlat
         do i = 1, nlon
            tmpx = 0.5d0*(dz(i+1,j)+dz(i,j)+hz(i+1,j)+hz(i,j))
            tmpy = 0.5d0*(dz(i,j+1)+dz(i,j)+hz(i,j+1)+hz(i,j))
            if(abs(tmpx) > 0.0d0) then
               tmpx = 1.0d0/tmpx
            else
               tmpx = 0.0d0
            end if
            if(abs(tmpy) > 0.0d0) then
               tmpy = 1.0d0/tmpy
            else
               tmpy = 0.0d0
            end if
            tdx(i,j) = tmpx
            tdy(i,j) = tmpy
         end do
      end do
#endif
      do conv = 1, max_step
!$omp do private(theta, i, c0, c1)
         do j = jst, jnd
#ifndef MPI
            theta = th0 + (j-1)*dth
#else
            theta = th0 + (j+joff-1)*dth
#endif
            c0 = sin(theta+0.5d0*dth)
            c1 = sin(theta-0.5d0*dth)
            do i = ist, ind
#ifndef __FUJITSU
               fx(i,j) = (yu(i,j) + cu(i,j)*( &
               ! V_n+1
               & + (fy_old(i+1,j  )-fy_old(i,  j  ))*c0 &
               & - (fy_old(i+1,j-1)-fy_old(i,  j-1))*c1 &
               ! U_n+1
               & + fx_old(i+1,j)+fx_old(i-1,j)))/(1.0d0+2.0d0*cu(i,j))
#else
               ta0(i) = yu(i,j) + cu(i,j)*( &
               & + (fy_old(i+1,j  )-fy_old(i,  j  ))*c0 &
               & - (fy_old(i+1,j-1)-fy_old(i,  j-1))*c1 &
               & + fx_old(i+1,j)+fx_old(i-1,j))
            end do
            do i = ist, ind
               ta1(i) = 1.0d0/(1.0d0+2.0d0*cu(i,j))
            end do
            do i = ist, ind
               fx(i,j) = ta0(i)*ta1(i)
#endif
            end do
         end do
#ifdef MPI
!$omp single
         call exchange_edges_disp_fx(fg,mod(conv,2))
!$omp end single
#endif
!$omp do private(theta, i, c0, c1, c2, c3, c4)
         do j = jst, jnd
#ifndef MPI
            theta = th0 + (j-1)*dth
#else
            theta = th0 + (j+joff-1)*dth
#endif
            c0 = 1.0d0/sin(theta+0.5d0*dth)
            c1 = 1.0d0/sin(theta-0.5d0*dth)
            c2 = sin(theta+dth)/sin(theta+0.5d0*dth)
            c3 = sin(theta-dth)/sin(theta-0.5d0*dth)
            c4 = sin(theta)*(1.0d0/sin(theta-0.5d0*dth)+1.0d0/sin(theta+0.5d0*dth))
            do i = ist, ind
#ifndef __FUJITSU
               fy(i,j) = (yv(i,j) + cv(i,j)*( &
               ! U_n+1
               & + (fx(i  ,j+1)-fx(i-1,j+1))*c0 &
               & - (fx(i,  j  )-fx(i-1,j  ))*c1 &
               ! V_n+1
               & + fy_old(i,j+1)*c2+fy_old(i,j-1)*c3))/(1.0d0+cv(i,j)*c4)
#else
               ta0(i) = yv(i,j) + cv(i,j)*( &
               & + (fx(i  ,j+1)-fx(i-1,j+1))*c0 &
               & - (fx(i,  j  )-fx(i-1,j  ))*c1 &
               & + fy_old(i,j+1)*c2+fy_old(i,j-1)*c3)
            end do
            do i = ist, ind
               ta1(i) = 1.0d0/(1.0d0+cv(i,j)*c4)
            end do
            do i = ist, ind
               fy(i,j) = ta0(i)*ta1(i)
#endif
            end do
         end do
#ifdef MPI
!$omp single
         call exchange_edges_disp_fy(fg,mod(conv,2))
!$omp end single
#endif
#ifdef CONV_CHECK
#ifdef LESS_CC
         if(mod(conv,check) == 0) then
#endif
!$omp single
         diffxy = 0.0d0
!$omp end single
!$omp do private(i, diff, diffx, diffy) reduction(max:diffxy)
         do j = jst, jnd
            do i = ist, ind
               diffx = abs((fx(i,j)-fx_old(i,j))*tdx(i,j))
               diffy = abs((fy(i,j)-fy_old(i,j))*tdy(i,j))
               diff = max(diffx,diffy)
               diffxy = max(diffxy,diff)
            end do
         end do
#ifdef MPI
!$omp single
#ifndef MULTI
         call MPI_Allreduce(MPI_IN_PLACE, diffxy, 1, REAL_MPI, MPI_MAX, MPI_COMM_WORLD, ierr)
#else
         call MPI_Allreduce(MPI_IN_PLACE, diffxy, 1, REAL_MPI, MPI_MAX, MPI_MEMBER_WORLD, ierr)
#endif
!$omp end single
#endif
         if(diffxy < conv_val) then
            exit
         endif
#ifdef LESS_CC
         end if
#endif
#endif
!$omp single
         p => fx_old
         fx_old => fx
         fx => p
         p => fy_old
         fy_old => fy
         fy => p
!$omp end single
      end do
#ifdef CONV_CHECK
!$omp single
      conv_step = conv
!$omp end single
#endif
#ifndef MPI
!$omp do private(i)
      do j = 0, nlat
         do i = 0, nlon
            fx_old(i,j) = fx(i,j)
            fy_old(i,j) = fy(i,j)
         end do
      end do
#else
!$omp do private(i)
      do j = jst_, nlat
         do i = ist_, nlon
            fx_old(i,j) = fx(i,j)
            fy_old(i,j) = fy(i,j)
         end do
      end do
#endif
#ifdef __FUJITSU
      deallocate(ta0)
      deallocate(ta1)
#endif
!$omp end parallel
! ==============================================================================

      return
   end subroutine fxy_rwg_Coriolis_disp

end module mod_fxy_Coriolis_disp


program main3
    use Matrix

    implicit none

!   Command-line Args
    integer :: argc

    character(len=32) :: vecx_fname, vecy_fname

!   Vectors
    integer :: m, n
    double precision, allocatable :: x(:)
    double precision, allocatable :: y(:)
    double precision, allocatable :: s(:)

!   Get Command-Line Args
    vecx_fname = 'vecx.txt'
    vecy_fname = 'vecy.txt'

    argc = iargc()

    if (argc == 1) then
        call getarg(1, vecx_fname)
    elseif(argc == 2) then
        call getarg(1, vecx_fname)
        call getarg(2, vecy_fname)
    elseif (argc > 2) then
        goto 92
    end if

    call read_vector(vecx_fname, x, m)
    call read_vector(vecy_fname, y, n)

    if (m /= n) then
        goto 90
    end if

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'x:'
    call print_vector(x, m)

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'y:'
    call print_vector(y, n)

!   Least Squares
    allocate(s(2))
    if (.not. least_squares(x, y, s, n)) then
        goto 80
    end if

    write(*, *) 'a:'
    write(*, *) s(2)
    write(*, *) 'b:'
    write(*, *) s(1)

    goto 85

80  call error('Falho no método de mínimos quadrados.')
    goto 100
85  call info('Sucesso!')
    goto 100

90  call error('Os vetores x e y devem ter o mesmo tamnho.')
    goto 100
92  call error('Parâmetros em excesso: O programa espera apenas o nome do arquivo da matriz.')
    goto 100

100 deallocate(x)
    deallocate(y)
    deallocate(s)
    stop

end program main3


module geom_types
  implicit none
  integer, parameter :: dp = selected_real_kind(15)

  type Point_t
     real(dp), dimension(3) :: pos
  end type Point_t

  type Box_t
     real(dp), dimension(3) :: origin ! Center
     real(dp), dimension(3) :: u, v, w
     real(dp), dimension(3) :: extents
  end type Box_t

  type Segment_t
     real(dp), dimension(3) :: start, end
  end type Segment_t

  type Line_t
     real(dp), dimension(3) :: origin ! Starting point
     real(dp), dimension(3) :: direction ! Direction
  end type Line_T

  type Capsule_t
     type(Segment_t) :: segment
     real(dp) :: r
  end type Capsule_t

end module geom_types


program fd3d

    integer, parameter  :: dp = kind(1.d0)
    real(dp), parameter :: two_pi = 8.d0 * atan(1.d0)

    integer  :: n(3), num_iters, block_size(3), itime
    real(dp) :: length, dl, dl_inv
    real(dp) :: factors(5)
    real(4)  :: cpuStart, cpuFinish

    real(dp), dimension(:, :, :), allocatable :: u, du, du_exact

    call box_init('der3d.nml')
    call allocate_arrays()
    call initial_condition()
    call set_factors()

    call cpu_time(cpuStart)
    do itime = 0, num_iters
        call divergence_cpu()
    end do
    call cpu_time(cpuFinish)
    write (*, *) 'Timing : ', cpuStart - cpuFinish, maxval(du_exact - du)

contains

    subroutine box_init(filename)
        character(*), intent(in) :: filename
        namelist /box_nml/ n, length, num_iters

        open (unit=10, file=filename, status='old')
        read (10, nml=box_nml)
        close (10)

        length = length * two_pi
        dl = length / n(1)
        dl_inv = 1.d0 / dl
    end subroutine box_init

    subroutine set_factors()
        factors = dl_inv * (1.d0 / 12.d0)*[1, -8, 0, 8, -1]
    end subroutine set_factors

    subroutine allocate_arrays()
        allocate (u(n(1), n(2), n(3)))
        allocate (du(n(1), n(2), n(3)))
        allocate (du_exact(n(1), n(2), n(3)))

        u = 0.d0
        du = 0.d0
        du_exact = 0.d0
    end subroutine allocate_arrays

    subroutine initial_condition()
        integer  :: i, j, k
        real(dp) :: x, y, z

        u(:, :, :) = 0.d0
        du_exact(:, :, :) = 0.d0

        !$OMP PARALLEL DO PRIVATE(i,j,x,y,z)
        do k = 1, n(2)
            z = dl * (k - 1)
            do j = 1, n(2)
                y = dl * (j - 1)
                do i = 1, n(1)
                    x = dl * (i - 1)
                    u(i, j, k) = sin(x) + sin(y) + sin(z)
                    du_exact(i, j, k) = cos(x) + cos(y) + cos(z)
                end do
            end do
        end do
    end subroutine initial_condition

    subroutine divergence_cpu()
        integer  :: i, j, k, l, xn(5), yn(5), zn(5)
        real(dp) :: ux(5), uy(5), uz(5)

        !$OMP PARALLEL DO PRIVATE(i,j,l,xn,yn,zn,ux,uy,uz)
        do k = 1, n(3)
            do j = 1, n(2)
                do i = 1, n(1)
                    do l = -2, 2
                        xn(l + 3) = mod(i + l + n(1) - 1, n(1)) + 1
                        yn(l + 3) = mod(j + l + n(2) - 1, n(2)) + 1
                        zn(l + 3) = mod(k + l + n(3) - 1, n(3)) + 1
                    end do

                    ux = u(xn, j, k)
                    uy = u(i, yn, k)
                    uz = u(i, j, zn)
                    du(i, j, k) = (ux(1) + uy(1) + uz(1)) * factors(1) &
                                  + (ux(2) + uy(2) + uz(2)) * factors(2) &
                                  + (ux(3) + uy(3) + uz(3)) * factors(3) &
                                  + (ux(4) + uy(4) + uz(4)) * factors(4) &
                                  + (ux(5) + uy(5) + uz(5)) * factors(5)
                end do
            end do
        end do
    end subroutine divergence_cpu

end program fd3d


C Testing SAVE statements.  This program has two different subroutines
C both of which contain SAVE statements and both of which contain a
C local variable W whose value needs to be SAVEd.  This addresses the
C issue of potential name conflicts between SAVEd locals in different
C subprograms.

      subroutine f(n, x)

      implicit none
      integer n, x
      integer, dimension(1) :: w

      save

      ! If n == 0, set w to 111; else set w to 2*w.  Then set x to w.
      ! The "save" statement causes the value of w to persist across
      ! calls to f().  This means that the sequence of calls
      !
      !    call f(0, a)
      !    call f(1, a)
      !    call f(1, a)
      !
      ! will set a to the values 111, 222, and 444 respectively.

      if (n .eq. 0) then
          w(1) = 111
      else
          w(1) = 2*w(1)
      end if

      x = w(1)
      end subroutine f
C ********************************************************************
      subroutine g(n, x)

      implicit none
      integer n, x
      integer, dimension(10) :: w

      save

      ! If n == 0, set w to 999; else set w to w/3.  Then set x to w.
      ! The "save" statement causes the value of w to persist across
      ! calls to g().  This means that the sequence of calls
      !
      !    call g(0, a)
      !    call g(1, a)
      !    call g(1, a)
      !
      ! will set a to the values 999, 333, and 111 respectively.

      if (n .eq. 0) then
          w(1) = 999
      else
          w(1) = w(1)/3
      end if

      x = w(1)
      end subroutine g
C ********************************************************************
      program main
      implicit none
      integer a, b

      call f(0, a)
      call g(0, b)

 10   format("a = ", I5, ";   b = ", I5)
      write (*,10) a, b

      call f(1, a)
      call g(1, b)
      write (*,10) a, b

      call f(1, a)
      call g(1, b)
      write (*,10) a, b

      stop
      end program main


! we have changed the dummy parameters from type(Circle) to class(Circle).
! We can then call the class functions in an object-oriented fashion as
! a = c%area and call c%print
module class_Circle
    implicit none
    private
    real :: pi = 3.1415926535897931 ! Class-wide private constant

    type, public :: Circle
        real :: radius
    contains
        procedure :: area => circle_area
        procedure :: print => circle_print
    end type Circle

contains
    function circle_area(this) result(area)
      class(Circle), intent(in) :: this
      ! intent(out) is inappropriate for the result
      ! Intent can be specified for the function arguments only
      ! real, intent(out) :: area
      real :: area
      area = pi * this%radius**2
    end function circle_area

    subroutine circle_print(this)
      class(Circle), intent(in) :: this
      real :: area
      area = this%area()  ! Call the type-bound function
      print *, 'Circle: r = ', this%radius, ' area = ', area
    end subroutine circle_print
  end module class_Circle

  program circle_test
    use class_Circle
    implicit none

    type(Circle) :: c     ! Declare a variable of type Circle.
    !c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
    c%radius = 1.5
    call c%print          ! Call the type-bound subroutine
  end program circle_test


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE CONSTANTS

    IMPLICIT NONE

    REAL*8, PARAMETER :: PI = 4. * ATAN(1.) ! PI

END MODULE CONSTANTS


module conversion

  implicit none
  public binary_representation
  private

contains

  pure function binary_representation(n_decimal)
    integer, intent(in) :: n_decimal
    integer :: binary_representation(8)
    integer :: pos
    integer :: n

    binary_representation = 0
    pos = 8
    n = n_decimal
    do while (n > 0)
      binary_representation(pos) = mod(n, 2)
      n = (n - binary_representation(pos))/2
      pos = pos - 1
    end do
  end function

end module


program xygrd

integer :: nx , ny
real    :: sx , sy
real    :: x0 , y0
integer :: i  ,  j

write(*,*)'enter nx,ny '
read(*,*)nx,ny
write(*,*)'nx,ny = ',nx,ny
write(*,*)'enter sx,sy '
read(*,*)sx,sy
write(*,*)'sx,sy = ',sx,sy
write(*,*)'enter x0,y0 '
read(*,*)x0,y0
write(*,*)'x0,y0 = ',x0,y0

open(10,file='xgrd.inp')
open(11,file='ygrd.inp')

do j=1,ny
  do i=1,nx
    write(10,'(1x,e12.6)',advance='no') x0+real(i-1)*sx
    write(11,'(1x,e12.6)',advance='no') y0+real(j-1)*sy
  enddo
  write(10,*)
  write(11,*)
enddo

write(*,*)'x0/1000 = ',(x0/1000.0)
write(*,*)'y0/1000 = ',(y0/1000.0)
write(*,*)'xmax/1000 = ',((x0+real(nx-1)*sx)/1000.0)
write(*,*)'ymax/1000 = ',((y0+real(ny-1)*sy)/1000.0)

write(*,*)' X range (km) : ',(x0/1000.0),'   ',((x0+real(nx-1)*sx)/1000.0)
write(*,*)' Y range (km) : ',(y0/1000.0),'   ',((y0+real(ny-1)*sy)/1000.0)

close(10)
close(11)

end program xygrd


!*==slansf.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SLANSF
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SLANSF + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       REAL FUNCTION SLANSF( NORM, TRANSR, UPLO, N, A, WORK )
!
!       .. Scalar Arguments ..
!       CHARACTER          NORM, TRANSR, UPLO
!       INTEGER            N
!       ..
!       .. Array Arguments ..
!       REAL               A( 0: * ), WORK( 0: * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SLANSF returns the value of the one norm, or the Frobenius norm, or
!> the infinity norm, or the element of largest absolute value of a
!> real symmetric matrix A in RFP format.
!> \endverbatim
!>
!> \return SLANSF
!> \verbatim
!>
!>    SLANSF = ( max(abs(A(i,j))), NORM = 'M' or 'm'
!>             (
!>             ( norm1(A),         NORM = '1', 'O' or 'o'
!>             (
!>             ( normI(A),         NORM = 'I' or 'i'
!>             (
!>             ( normF(A),         NORM = 'F', 'f', 'E' or 'e'
!>
!> where  norm1  denotes the  one norm of a matrix (maximum column sum),
!> normI  denotes the  infinity norm  of a matrix  (maximum row sum) and
!> normF  denotes the  Frobenius norm of a matrix (square root of sum of
!> squares).  Note that  max(abs(A(i,j)))  is not a  matrix norm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] NORM
!> \verbatim
!>          NORM is CHARACTER*1
!>          Specifies the value to be returned in SLANSF as described
!>          above.
!> \endverbatim
!>
!> \param[in] TRANSR
!> \verbatim
!>          TRANSR is CHARACTER*1
!>          Specifies whether the RFP format of A is normal or
!>          transposed format.
!>          = 'N':  RFP format is Normal;
!>          = 'T':  RFP format is Transpose.
!> \endverbatim
!>
!> \param[in] UPLO
!> \verbatim
!>          UPLO is CHARACTER*1
!>           On entry, UPLO specifies whether the RFP matrix A came from
!>           an upper or lower triangular matrix as follows:
!>           = 'U': RFP A came from an upper triangular matrix;
!>           = 'L': RFP A came from a lower triangular matrix.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The order of the matrix A. N >= 0. When N = 0, SLANSF is
!>          set to zero.
!> \endverbatim
!>
!> \param[in] A
!> \verbatim
!>          A is REAL array, dimension ( N*(N+1)/2 );
!>          On entry, the upper (if UPLO = 'U') or lower (if UPLO = 'L')
!>          part of the symmetric matrix A stored in RFP format. See the
!>          "Notes" below for more details.
!>          Unchanged on exit.
!> \endverbatim
!>
!> \param[out] WORK
!> \verbatim
!>          WORK is REAL array, dimension (MAX(1,LWORK)),
!>          where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
!>          WORK is not referenced.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realOTHERcomputational
!
!> \par Further Details:
!  =====================
!>
!> \verbatim
!>
!>  We first consider Rectangular Full Packed (RFP) Format when N is
!>  even. We give an example where N = 6.
!>
!>      AP is Upper             AP is Lower
!>
!>   00 01 02 03 04 05       00
!>      11 12 13 14 15       10 11
!>         22 23 24 25       20 21 22
!>            33 34 35       30 31 32 33
!>               44 45       40 41 42 43 44
!>                  55       50 51 52 53 54 55
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:5,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(4:6,0:2) consists of
!>  the transpose of the first three columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(1:6,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:2,0:2) consists of
!>  the transpose of the last three columns of AP lower.
!>  This covers the case N even and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>        03 04 05                33 43 53
!>        13 14 15                00 44 54
!>        23 24 25                10 11 55
!>        33 34 35                20 21 22
!>        00 44 45                30 31 32
!>        01 11 55                40 41 42
!>        02 12 22                50 51 52
!>
!>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
!>  transpose of RFP A above. One therefore gets:
!>
!>
!>           RFP A                   RFP A
!>
!>     03 13 23 33 00 01 02    33 00 10 20 30 40 50
!>     04 14 24 34 44 11 12    43 44 11 21 31 41 51
!>     05 15 25 35 45 55 22    53 54 55 22 32 42 52
!>
!>
!>  We then consider Rectangular Full Packed (RFP) Format when N is
!>  odd. We give an example where N = 5.
!>
!>     AP is Upper                 AP is Lower
!>
!>   00 01 02 03 04              00
!>      11 12 13 14              10 11
!>         22 23 24              20 21 22
!>            33 34              30 31 32 33
!>               44              40 41 42 43 44
!>
!>
!>  Let TRANSR = 'N'. RFP holds AP as follows:
!>  For UPLO = 'U' the upper trapezoid A(0:4,0:2) consists of the last
!>  three columns of AP upper. The lower triangle A(3:4,0:1) consists of
!>  the transpose of the first two columns of AP upper.
!>  For UPLO = 'L' the lower trapezoid A(0:4,0:2) consists of the first
!>  three columns of AP lower. The upper triangle A(0:1,1:2) consists of
!>  the transpose of the last two columns of AP lower.
!>  This covers the case N odd and TRANSR = 'N'.
!>
!>         RFP A                   RFP A
!>
!>        02 03 04                00 33 43
!>        12 13 14                10 11 44
!>        22 23 24                20 21 22
!>        00 33 34                30 31 32
!>        01 11 44                40 41 42
!>
!>  Now let TRANSR = 'T'. RFP A in both UPLO cases is just the
!>  transpose of RFP A above. One therefore gets:
!>
!>           RFP A                   RFP A
!>
!>     02 12 22 00 01             00 10 20 30 40 50
!>     03 13 23 33 11             33 11 21 31 41 51
!>     04 14 24 34 44             43 44 22 32 42 52
!> \endverbatim
!
!  =====================================================================
      REAL FUNCTION SLANSF(Norm,Transr,Uplo,N,A,Work)
      IMPLICIT NONE
!*--SLANSF213
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      CHARACTER Norm , Transr , Uplo
      INTEGER N
!     ..
!     .. Array Arguments ..
      REAL A(0:*) , Work(0:*)
!     ..
!
!  =====================================================================
!
!     ..
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      INTEGER i , j , ifm , ilu , noe , n1 , k , l , lda
      REAL scale , s , value , aa , temp
!     ..
!     .. External Functions ..
      LOGICAL LSAME , SISNAN
      EXTERNAL LSAME , SISNAN
!     ..
!     .. External Subroutines ..
      EXTERNAL SLASSQ
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC ABS , SQRT
!     ..
!     .. Executable Statements ..
!
      IF ( N==0 ) THEN
         SLANSF = ZERO
         RETURN
      ELSEIF ( N==1 ) THEN
         SLANSF = ABS(A(0))
         RETURN
      ENDIF
!
!     set noe = 1 if n is odd. if n is even set noe=0
!
      noe = 1
      IF ( MOD(N,2)==0 ) noe = 0
!
!     set ifm = 0 when form='T or 't' and 1 otherwise
!
      ifm = 1
      IF ( LSAME(Transr,'T') ) ifm = 0
!
!     set ilu = 0 when uplo='U or 'u' and 1 otherwise
!
      ilu = 1
      IF ( LSAME(Uplo,'U') ) ilu = 0
!
!     set lda = (n+1)/2 when ifm = 0
!     set lda = n when ifm = 1 and noe = 1
!     set lda = n+1 when ifm = 1 and noe = 0
!
      IF ( ifm/=1 ) THEN
!        ifm=0
         lda = (N+1)/2
      ELSEIF ( noe==1 ) THEN
         lda = N
      ELSE
!           noe=0
         lda = N + 1
      ENDIF
!
      IF ( LSAME(Norm,'M') ) THEN
!
!       Find max(abs(A(i,j))).
!
         k = (N+1)/2
         value = ZERO
         IF ( noe==1 ) THEN
!           n is odd
            IF ( ifm==1 ) THEN
!           A is n by k
               DO j = 0 , k - 1
                  DO i = 0 , N - 1
                     temp = ABS(A(i+j*lda))
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ENDDO
            ELSE
!              xpose case; A is k by n
               DO j = 0 , N - 1
                  DO i = 0 , k - 1
                     temp = ABS(A(i+j*lda))
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ENDDO
            ENDIF
!           n is even
         ELSEIF ( ifm==1 ) THEN
!              A is n+1 by k
            DO j = 0 , k - 1
               DO i = 0 , N
                  temp = ABS(A(i+j*lda))
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ENDDO
         ELSE
!              xpose case; A is k by n+1
            DO j = 0 , N
               DO i = 0 , k - 1
                  temp = ABS(A(i+j*lda))
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ENDDO
         ENDIF
      ELSEIF ( (LSAME(Norm,'I')) .OR. (LSAME(Norm,'O')) .OR. (Norm=='1')&
     &         ) THEN
!
!        Find normI(A) ( = norm1(A), since A is symmetric).
!
         IF ( ifm==1 ) THEN
            k = N/2
            IF ( noe==1 ) THEN
!              n is odd
               IF ( ilu==0 ) THEN
                  DO i = 0 , k - 1
                     Work(i) = ZERO
                  ENDDO
                  DO j = 0 , k
                     s = ZERO
                     DO i = 0 , k + j - 1
                        aa = ABS(A(i+j*lda))
!                       -> A(i,j+k)
                        s = s + aa
                        Work(i) = Work(i) + aa
                     ENDDO
                     aa = ABS(A(i+j*lda))
!                    -> A(j+k,j+k)
                     Work(j+k) = s + aa
                     IF ( i==k+k ) EXIT
                     i = i + 1
                     aa = ABS(A(i+j*lda))
!                    -> A(j,j)
                     Work(j) = Work(j) + aa
                     s = ZERO
                     DO l = j + 1 , k - 1
                        i = i + 1
                        aa = ABS(A(i+j*lda))
!                       -> A(l,j)
                        s = s + aa
                        Work(l) = Work(l) + aa
                     ENDDO
                     Work(j) = Work(j) + s
                  ENDDO
                  value = Work(0)
                  DO i = 1 , N - 1
                     temp = Work(i)
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ELSE
!                 ilu = 1
                  k = k + 1
!                 k=(n+1)/2 for n odd and ilu=1
                  DO i = k , N - 1
                     Work(i) = ZERO
                  ENDDO
                  DO j = k - 1 , 0 , -1
                     s = ZERO
                     DO i = 0 , j - 2
                        aa = ABS(A(i+j*lda))
!                       -> A(j+k,i+k)
                        s = s + aa
                        Work(i+k) = Work(i+k) + aa
                     ENDDO
                     IF ( j>0 ) THEN
                        aa = ABS(A(i+j*lda))
!                       -> A(j+k,j+k)
                        s = s + aa
                        Work(i+k) = Work(i+k) + s
!                       i=j
                        i = i + 1
                     ENDIF
                     aa = ABS(A(i+j*lda))
!                    -> A(j,j)
                     Work(j) = aa
                     s = ZERO
                     DO l = j + 1 , N - 1
                        i = i + 1
                        aa = ABS(A(i+j*lda))
!                       -> A(l,j)
                        s = s + aa
                        Work(l) = Work(l) + aa
                     ENDDO
                     Work(j) = Work(j) + s
                  ENDDO
                  value = Work(0)
                  DO i = 1 , N - 1
                     temp = Work(i)
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ENDIF
!              n is even
            ELSEIF ( ilu==0 ) THEN
               DO i = 0 , k - 1
                  Work(i) = ZERO
               ENDDO
               DO j = 0 , k - 1
                  s = ZERO
                  DO i = 0 , k + j - 1
                     aa = ABS(A(i+j*lda))
!                       -> A(i,j+k)
                     s = s + aa
                     Work(i) = Work(i) + aa
                  ENDDO
                  aa = ABS(A(i+j*lda))
!                    -> A(j+k,j+k)
                  Work(j+k) = s + aa
                  i = i + 1
                  aa = ABS(A(i+j*lda))
!                    -> A(j,j)
                  Work(j) = Work(j) + aa
                  s = ZERO
                  DO l = j + 1 , k - 1
                     i = i + 1
                     aa = ABS(A(i+j*lda))
!                       -> A(l,j)
                     s = s + aa
                     Work(l) = Work(l) + aa
                  ENDDO
                  Work(j) = Work(j) + s
               ENDDO
               value = Work(0)
               DO i = 1 , N - 1
                  temp = Work(i)
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ELSE
!                 ilu = 1
               DO i = k , N - 1
                  Work(i) = ZERO
               ENDDO
               DO j = k - 1 , 0 , -1
                  s = ZERO
                  DO i = 0 , j - 1
                     aa = ABS(A(i+j*lda))
!                       -> A(j+k,i+k)
                     s = s + aa
                     Work(i+k) = Work(i+k) + aa
                  ENDDO
                  aa = ABS(A(i+j*lda))
!                    -> A(j+k,j+k)
                  s = s + aa
                  Work(i+k) = Work(i+k) + s
!                    i=j
                  i = i + 1
                  aa = ABS(A(i+j*lda))
!                    -> A(j,j)
                  Work(j) = aa
                  s = ZERO
                  DO l = j + 1 , N - 1
                     i = i + 1
                     aa = ABS(A(i+j*lda))
!                       -> A(l,j)
                     s = s + aa
                     Work(l) = Work(l) + aa
                  ENDDO
                  Work(j) = Work(j) + s
               ENDDO
               value = Work(0)
               DO i = 1 , N - 1
                  temp = Work(i)
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ENDIF
         ELSE
!           ifm=0
            k = N/2
            IF ( noe==1 ) THEN
!              n is odd
               IF ( ilu==0 ) THEN
                  n1 = k
!                 n/2
                  k = k + 1
!                 k is the row size and lda
                  DO i = n1 , N - 1
                     Work(i) = ZERO
                  ENDDO
                  DO j = 0 , n1 - 1
                     s = ZERO
                     DO i = 0 , k - 1
                        aa = ABS(A(i+j*lda))
!                       A(j,n1+i)
                        Work(i+n1) = Work(i+n1) + aa
                        s = s + aa
                     ENDDO
                     Work(j) = s
                  ENDDO
!                 j=n1=k-1 is special
                  s = ABS(A(0+j*lda))
!                 A(k-1,k-1)
                  DO i = 1 , k - 1
                     aa = ABS(A(i+j*lda))
!                    A(k-1,i+n1)
                     Work(i+n1) = Work(i+n1) + aa
                     s = s + aa
                  ENDDO
                  Work(j) = Work(j) + s
                  DO j = k , N - 1
                     s = ZERO
                     DO i = 0 , j - k - 1
                        aa = ABS(A(i+j*lda))
!                       A(i,j-k)
                        Work(i) = Work(i) + aa
                        s = s + aa
                     ENDDO
!                    i=j-k
                     aa = ABS(A(i+j*lda))
!                    A(j-k,j-k)
                     s = s + aa
                     Work(j-k) = Work(j-k) + s
                     i = i + 1
                     s = ABS(A(i+j*lda))
!                    A(j,j)
                     DO l = j + 1 , N - 1
                        i = i + 1
                        aa = ABS(A(i+j*lda))
!                       A(j,l)
                        Work(l) = Work(l) + aa
                        s = s + aa
                     ENDDO
                     Work(j) = Work(j) + s
                  ENDDO
                  value = Work(0)
                  DO i = 1 , N - 1
                     temp = Work(i)
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ELSE
!                 ilu=1
                  k = k + 1
!                 k=(n+1)/2 for n odd and ilu=1
                  DO i = k , N - 1
                     Work(i) = ZERO
                  ENDDO
                  DO j = 0 , k - 2
!                    process
                     s = ZERO
                     DO i = 0 , j - 1
                        aa = ABS(A(i+j*lda))
!                       A(j,i)
                        Work(i) = Work(i) + aa
                        s = s + aa
                     ENDDO
                     aa = ABS(A(i+j*lda))
!                    i=j so process of A(j,j)
                     s = s + aa
                     Work(j) = s
!                    is initialised here
                     i = i + 1
!                    i=j process A(j+k,j+k)
                     aa = ABS(A(i+j*lda))
                     s = aa
                     DO l = k + j + 1 , N - 1
                        i = i + 1
                        aa = ABS(A(i+j*lda))
!                       A(l,k+j)
                        s = s + aa
                        Work(l) = Work(l) + aa
                     ENDDO
                     Work(k+j) = Work(k+j) + s
                  ENDDO
!                 j=k-1 is special :process col A(k-1,0:k-1)
                  s = ZERO
                  DO i = 0 , k - 2
                     aa = ABS(A(i+j*lda))
!                    A(k,i)
                     Work(i) = Work(i) + aa
                     s = s + aa
                  ENDDO
!                 i=k-1
                  aa = ABS(A(i+j*lda))
!                 A(k-1,k-1)
                  s = s + aa
                  Work(i) = s
!                 done with col j=k+1
                  DO j = k , N - 1
!                    process col j of A = A(j,0:k-1)
                     s = ZERO
                     DO i = 0 , k - 1
                        aa = ABS(A(i+j*lda))
!                       A(j,i)
                        Work(i) = Work(i) + aa
                        s = s + aa
                     ENDDO
                     Work(j) = Work(j) + s
                  ENDDO
                  value = Work(0)
                  DO i = 1 , N - 1
                     temp = Work(i)
                     IF ( value<temp .OR. SISNAN(temp) ) value = temp
                  ENDDO
               ENDIF
!              n is even
            ELSEIF ( ilu==0 ) THEN
               DO i = k , N - 1
                  Work(i) = ZERO
               ENDDO
               DO j = 0 , k - 1
                  s = ZERO
                  DO i = 0 , k - 1
                     aa = ABS(A(i+j*lda))
!                       A(j,i+k)
                     Work(i+k) = Work(i+k) + aa
                     s = s + aa
                  ENDDO
                  Work(j) = s
               ENDDO
!                 j=k
               aa = ABS(A(0+j*lda))
!                 A(k,k)
               s = aa
               DO i = 1 , k - 1
                  aa = ABS(A(i+j*lda))
!                    A(k,k+i)
                  Work(i+k) = Work(i+k) + aa
                  s = s + aa
               ENDDO
               Work(j) = Work(j) + s
               DO j = k + 1 , N - 1
                  s = ZERO
                  DO i = 0 , j - 2 - k
                     aa = ABS(A(i+j*lda))
!                       A(i,j-k-1)
                     Work(i) = Work(i) + aa
                     s = s + aa
                  ENDDO
!                     i=j-1-k
                  aa = ABS(A(i+j*lda))
!                    A(j-k-1,j-k-1)
                  s = s + aa
                  Work(j-k-1) = Work(j-k-1) + s
                  i = i + 1
                  aa = ABS(A(i+j*lda))
!                    A(j,j)
                  s = aa
                  DO l = j + 1 , N - 1
                     i = i + 1
                     aa = ABS(A(i+j*lda))
!                       A(j,l)
                     Work(l) = Work(l) + aa
                     s = s + aa
                  ENDDO
                  Work(j) = Work(j) + s
               ENDDO
!                 j=n
               s = ZERO
               DO i = 0 , k - 2
                  aa = ABS(A(i+j*lda))
!                    A(i,k-1)
                  Work(i) = Work(i) + aa
                  s = s + aa
               ENDDO
!                 i=k-1
               aa = ABS(A(i+j*lda))
!                 A(k-1,k-1)
               s = s + aa
               Work(i) = Work(i) + s
               value = Work(0)
               DO i = 1 , N - 1
                  temp = Work(i)
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ELSE
!                 ilu=1
               DO i = k , N - 1
                  Work(i) = ZERO
               ENDDO
!                 j=0 is special :process col A(k:n-1,k)
               s = ABS(A(0))
!                 A(k,k)
               DO i = 1 , k - 1
                  aa = ABS(A(i))
!                    A(k+i,k)
                  Work(i+k) = Work(i+k) + aa
                  s = s + aa
               ENDDO
               Work(k) = Work(k) + s
               DO j = 1 , k - 1
!                    process
                  s = ZERO
                  DO i = 0 , j - 2
                     aa = ABS(A(i+j*lda))
!                       A(j-1,i)
                     Work(i) = Work(i) + aa
                     s = s + aa
                  ENDDO
                  aa = ABS(A(i+j*lda))
!                    i=j-1 so process of A(j-1,j-1)
                  s = s + aa
                  Work(j-1) = s
!                    is initialised here
                  i = i + 1
!                    i=j process A(j+k,j+k)
                  aa = ABS(A(i+j*lda))
                  s = aa
                  DO l = k + j + 1 , N - 1
                     i = i + 1
                     aa = ABS(A(i+j*lda))
!                       A(l,k+j)
                     s = s + aa
                     Work(l) = Work(l) + aa
                  ENDDO
                  Work(k+j) = Work(k+j) + s
               ENDDO
!                 j=k is special :process col A(k,0:k-1)
               s = ZERO
               DO i = 0 , k - 2
                  aa = ABS(A(i+j*lda))
!                    A(k,i)
                  Work(i) = Work(i) + aa
                  s = s + aa
               ENDDO
!                 i=k-1
               aa = ABS(A(i+j*lda))
!                 A(k-1,k-1)
               s = s + aa
               Work(i) = s
!                 done with col j=k+1
               DO j = k + 1 , N
!                    process col j-1 of A = A(j-1,0:k-1)
                  s = ZERO
                  DO i = 0 , k - 1
                     aa = ABS(A(i+j*lda))
!                       A(j-1,i)
                     Work(i) = Work(i) + aa
                     s = s + aa
                  ENDDO
                  Work(j-1) = Work(j-1) + s
               ENDDO
               value = Work(0)
               DO i = 1 , N - 1
                  temp = Work(i)
                  IF ( value<temp .OR. SISNAN(temp) ) value = temp
               ENDDO
            ENDIF
         ENDIF
      ELSEIF ( (LSAME(Norm,'F')) .OR. (LSAME(Norm,'E')) ) THEN
!
!       Find normF(A).
!
         k = (N+1)/2
         scale = ZERO
         s = ONE
         IF ( noe==1 ) THEN
!           n is odd
            IF ( ifm==1 ) THEN
!              A is normal
               IF ( ilu==0 ) THEN
!                 A is upper
                  DO j = 0 , k - 3
                     CALL SLASSQ(k-j-2,A(k+j+1+j*lda),1,scale,s)
!                    L at A(k,0)
                  ENDDO
                  DO j = 0 , k - 1
                     CALL SLASSQ(k+j-1,A(0+j*lda),1,scale,s)
!                    trap U at A(0,0)
                  ENDDO
                  s = s + s
!                 double s for the off diagonal elements
                  CALL SLASSQ(k-1,A(k),lda+1,scale,s)
!                 tri L at A(k,0)
                  CALL SLASSQ(k,A(k-1),lda+1,scale,s)
!                 tri U at A(k-1,0)
               ELSE
!                 ilu=1 & A is lower
                  DO j = 0 , k - 1
                     CALL SLASSQ(N-j-1,A(j+1+j*lda),1,scale,s)
!                    trap L at A(0,0)
                  ENDDO
                  DO j = 0 , k - 2
                     CALL SLASSQ(j,A(0+(1+j)*lda),1,scale,s)
!                    U at A(0,1)
                  ENDDO
                  s = s + s
!                 double s for the off diagonal elements
                  CALL SLASSQ(k,A(0),lda+1,scale,s)
!                 tri L at A(0,0)
                  CALL SLASSQ(k-1,A(0+lda),lda+1,scale,s)
!                 tri U at A(0,1)
               ENDIF
!              A is xpose
            ELSEIF ( ilu==0 ) THEN
!                 A**T is upper
               DO j = 1 , k - 2
                  CALL SLASSQ(j,A(0+(k+j)*lda),1,scale,s)
!                    U at A(0,k)
               ENDDO
               DO j = 0 , k - 2
                  CALL SLASSQ(k,A(0+j*lda),1,scale,s)
!                    k by k-1 rect. at A(0,0)
               ENDDO
               DO j = 0 , k - 2
                  CALL SLASSQ(k-j-1,A(j+1+(j+k-1)*lda),1,scale,s)
!                    L at A(0,k-1)
               ENDDO
               s = s + s
!                 double s for the off diagonal elements
               CALL SLASSQ(k-1,A(0+k*lda),lda+1,scale,s)
!                 tri U at A(0,k)
               CALL SLASSQ(k,A(0+(k-1)*lda),lda+1,scale,s)
!                 tri L at A(0,k-1)
            ELSE
!                 A**T is lower
               DO j = 1 , k - 1
                  CALL SLASSQ(j,A(0+j*lda),1,scale,s)
!                    U at A(0,0)
               ENDDO
               DO j = k , N - 1
                  CALL SLASSQ(k,A(0+j*lda),1,scale,s)
!                    k by k-1 rect. at A(0,k)
               ENDDO
               DO j = 0 , k - 3
                  CALL SLASSQ(k-j-2,A(j+2+j*lda),1,scale,s)
!                    L at A(1,0)
               ENDDO
               s = s + s
!                 double s for the off diagonal elements
               CALL SLASSQ(k,A(0),lda+1,scale,s)
!                 tri U at A(0,0)
               CALL SLASSQ(k-1,A(1),lda+1,scale,s)
!                 tri L at A(1,0)
            ENDIF
!           n is even
         ELSEIF ( ifm==1 ) THEN
!              A is normal
            IF ( ilu==0 ) THEN
!                 A is upper
               DO j = 0 , k - 2
                  CALL SLASSQ(k-j-1,A(k+j+2+j*lda),1,scale,s)
!                    L at A(k+1,0)
               ENDDO
               DO j = 0 , k - 1
                  CALL SLASSQ(k+j,A(0+j*lda),1,scale,s)
!                    trap U at A(0,0)
               ENDDO
               s = s + s
!                 double s for the off diagonal elements
               CALL SLASSQ(k,A(k+1),lda+1,scale,s)
!                 tri L at A(k+1,0)
               CALL SLASSQ(k,A(k),lda+1,scale,s)
!                 tri U at A(k,0)
            ELSE
!                 ilu=1 & A is lower
               DO j = 0 , k - 1
                  CALL SLASSQ(N-j-1,A(j+2+j*lda),1,scale,s)
!                    trap L at A(1,0)
               ENDDO
               DO j = 1 , k - 1
                  CALL SLASSQ(j,A(0+j*lda),1,scale,s)
!                    U at A(0,0)
               ENDDO
               s = s + s
!                 double s for the off diagonal elements
               CALL SLASSQ(k,A(1),lda+1,scale,s)
!                 tri L at A(1,0)
               CALL SLASSQ(k,A(0),lda+1,scale,s)
!                 tri U at A(0,0)
            ENDIF
!              A is xpose
         ELSEIF ( ilu==0 ) THEN
!                 A**T is upper
            DO j = 1 , k - 1
               CALL SLASSQ(j,A(0+(k+1+j)*lda),1,scale,s)
!                    U at A(0,k+1)
            ENDDO
            DO j = 0 , k - 1
               CALL SLASSQ(k,A(0+j*lda),1,scale,s)
!                    k by k rect. at A(0,0)
            ENDDO
            DO j = 0 , k - 2
               CALL SLASSQ(k-j-1,A(j+1+(j+k)*lda),1,scale,s)
!                    L at A(0,k)
            ENDDO
            s = s + s
!                 double s for the off diagonal elements
            CALL SLASSQ(k,A(0+(k+1)*lda),lda+1,scale,s)
!                 tri U at A(0,k+1)
            CALL SLASSQ(k,A(0+k*lda),lda+1,scale,s)
!                 tri L at A(0,k)
         ELSE
!                 A**T is lower
            DO j = 1 , k - 1
               CALL SLASSQ(j,A(0+(j+1)*lda),1,scale,s)
!                    U at A(0,1)
            ENDDO
            DO j = k + 1 , N
               CALL SLASSQ(k,A(0+j*lda),1,scale,s)
!                    k by k rect. at A(0,k+1)
            ENDDO
            DO j = 0 , k - 2
               CALL SLASSQ(k-j-1,A(j+1+j*lda),1,scale,s)
!                    L at A(0,0)
            ENDDO
            s = s + s
!                 double s for the off diagonal elements
            CALL SLASSQ(k,A(lda),lda+1,scale,s)
!                 tri L at A(0,1)
            CALL SLASSQ(k,A(0),lda+1,scale,s)
!                 tri U at A(0,0)
         ENDIF
         value = scale*SQRT(s)
      ENDIF
!
      SLANSF = value
!
!     End of SLANSF
!
      END FUNCTION SLANSF