!-------------------------------------------------------------------------------
!
!+  Module of Dynamical Core Test initial condition
!
!-------------------------------------------------------------------------------
module mod_dycoretest
  !-----------------------------------------------------------------------------
  !
  !++ Description:
  !       This module is for the Dyn Core Test Initialization.
  !
  !
  !++ Current Corresponding Author : R.Yoshida
  !
  !++ History:
  !      Version   Date       Comment
  !      -----------------------------------------------------------------------
  !      0.00      12-10-19   Imported from mod_restart.f90 of NICAM
  !      0.01      13-06-12   Test cases in DCMIP2012 were imported
  !
  !      -----------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  !
  !++ Used modules
  !
  use mod_adm, only: &
     ADM_LOG_FID,  &
     ADM_NSYS
  use mod_dcmip, only: &
     test1_advection_deformation,  &
     test1_advection_hadley,       &
     test2_steady_state_mountain,  &
     test2_schaer_mountain,        &
     test3_gravity_wave
  use mod_cnst, only: &
     Rd    => CNST_RAIR,    &  ! ideal gas constant of dry air
     Cp    => CNST_CP,      &  ! heat capacity of const. pressure
     g     => CNST_EGRAV,   &  ! gravity accelaration [ms^-2]
     a     => CNST_ERADIUS, &  ! mean radis of the earth [m]
     omega => CNST_EOHM,    &  ! rotation of the earth [s^-1]
     pi    => CNST_PI
  !
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters
  !
  ! physical parameters configurations
  real(8), private, save :: kai                    ! temporal value
  real(8), private, save :: d2r                    ! Degree to Radian
  real(8), private, save :: r2d                    ! Radian to Degree
  real(8), private, save :: eps = 1.D-14           ! minimum value
  real(8), private, save :: zero = 0.D0            ! zero

  ! test configurations
  integer, private, parameter :: PRCS_D = 8
  ! for Held and Suarez
  real(8), private, save :: deltaT = 60.D0
  real(8), private, save :: deltaTh = 10.D0
  ! for Jablonowski
  real(8), private, save :: clat = 40.D0              ! perturbation center: latitude [deg]
  real(8), private, save :: clon = 20.D0              ! perturbation center: longitude [deg]
  real(8), private, save :: etaS = 1.D0               ! surface eta level
  real(8), private, save :: etaT = 0.2d0              ! threashold of vertical profile
  real(8), private, save :: eta0 = 0.252d0            ! threashold of vertical profile
  real(8), private, save :: t0 = 288.D0               ! [K]
  real(8), private, save :: delT = 4.8d+5             ! [K]
  real(8), private, save :: ganma = 0.005d0           ! [K m^-1]
  real(8), private, save :: u0 = 35.D0                ! [m s^-1]
  real(8), private, save :: uP = 1.D0                 ! [m s^-1]
  real(8), private, save :: p0 = 1.D+5                ! [Pa]
  real(8), private, save :: ps = 1.D+5                ! [Pa]
  logical, private, parameter :: message = .false.
  integer, private, parameter :: itrmax = 100       ! # of iteration maximum

  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: dycore_input
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedures
  !
  private :: hs_init
  private :: jbw_init
  private :: tracer_init
  private :: mountwave_init
  private :: gravwave_init
  private :: sphere_xyz_to_lon
  private :: sphere_xyz_to_lat
  private :: eta_vert_coord_NW
  private :: steady_state
  private :: geo2prs
  private :: geost_rebalance
  private :: perturbation
  private :: conv_vxvyvz
  private :: Sp_Unit_East
  private :: Sp_Unit_North
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine dycore_input( DIAG_var )
    use mod_adm, only: &
       ADM_CTL_FID,   &
       ADM_proc_stop, &
       ADM_gall,      &
       ADM_kall,      &
       ADM_lall
    use mod_runconf, only: &
       TRC_vmax
    implicit none

    real(8), intent(out) :: DIAG_var(ADM_gall,ADM_kall,ADM_lall,6+TRC_VMAX)

    character(len=ADM_NSYS) :: init_type
    character(len=ADM_NSYS) :: test_case

    namelist / DYCORETESTPARAM / &
       init_type, &
       test_case

    integer :: ierr
    !---------------------------------------------------------------------------

    kai = Rd / Cp
    d2r = pi/180.D0
    r2d = 180.D0/pi

    !--- read parameters
    write(ADM_LOG_FID,*)
    write(ADM_LOG_FID,*) '+++ Module[dycoretest]/Category[nhm share]'
    rewind(ADM_CTL_FID)
    read(ADM_CTL_FID,nml=DYCORETESTPARAM,iostat=ierr)
    if ( ierr < 0 ) then
       write(ADM_LOG_FID,*) '*** DYCORETESTPARAM is not specified. use default.'
    elseif( ierr > 0 ) then
       write(*,          *) 'xxx Not appropriate names in namelist DYCORETESTPARAM. STOP.'
       write(ADM_LOG_FID,*) 'xxx Not appropriate names in namelist DYCORETESTPARAM. STOP.'
       call ADM_proc_stop
    endif
    write(ADM_LOG_FID,DYCORETESTPARAM)

    write(ADM_LOG_FID,*) '*** type: ', trim(init_type)

    if (      init_type == "Jablonowski"     &
         .OR. init_type == "Traceradvection" &
         .OR. init_type == "Mountainwave"    ) then

       write(ADM_LOG_FID,*) '*** test case: ', trim(test_case)

    endif

    if ( init_type == "Heldsuarez" ) then

       call hs_init ( ADM_gall, ADM_kall, ADM_lall, DIAG_var(:,:,:,:) )

    elseif( init_type == "Jablonowski" ) then

       call jbw_init( ADM_gall, ADM_kall, ADM_lall, test_case, DIAG_var(:,:,:,:) )

    elseif( init_type == "Traceradvection" ) then

       call tracer_init( ADM_gall, ADM_kall, ADM_lall, test_case, DIAG_var(:,:,:,:) )

    elseif( init_type == "Mountainwave" ) then

       call mountwave_init( ADM_gall, ADM_kall, ADM_lall, test_case, DIAG_var(:,:,:,:) )

    elseif( init_type == "Gravitywave" ) then

       call gravwave_init( ADM_gall, ADM_kall, ADM_lall, DIAG_var(:,:,:,:) )

    else
       write(ADM_LOG_FID,*) 'xxx Invalid input_io_mode. STOP.'
       call ADM_proc_stop
    endif

    return
  end subroutine dycore_input

  !-----------------------------------------------------------------------------
  subroutine hs_init( &
       ijdim,   &
       kdim,    &
       lall,    &
       DIAG_var )
    use mod_misc, only: &
       MISC_get_latlon
    use mod_adm, only: &
       ADM_KNONE, &
       ADM_kmin,  &
       ADM_kmax
    use mod_cnst, only: &
       GRAV  => CNST_EGRAV, &
       RAIR  => CNST_RAIR,  &
       KAPPA => CNST_KAPPA, &
       PRE00 => CNST_PRE00
    use mod_grd, only: &
       GRD_XDIR, &
       GRD_YDIR, &
       GRD_ZDIR, &
       GRD_Z,    &
       GRD_x,    &
       GRD_vz
    use mod_runconf, only: &
       TRC_vmax
    implicit none

    integer, intent(in)    :: ijdim
    integer, intent(in)    :: kdim
    integer, intent(in)    :: lall
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,6+TRC_VMAX)

    real(8) :: pre(kdim), tem(kdim), dz(kdim)
    real(8) :: pre_sfc, tem_sfc
    real(8) :: pre_save

    real(8) :: dT, f, df
    real(8) :: lat, lon

    integer :: n, k, l, itr
    !---------------------------------------------------------------------------

    DIAG_var(:,:,:,:) = 0.D0

    do l = 1, lall
    do n = 1, ijdim

       dz(ADM_kmin) = GRD_vz(n,ADM_kmin,l,GRD_Z)
       do k = ADM_kmin+1, ADM_kmax+1
          dz(k) = GRD_vz(n,k,l,GRD_Z) - GRD_vz(n,k-1,l,GRD_Z)
       enddo

       call MISC_get_latlon( lat, lon,                      &
                             GRD_x(n,ADM_KNONE,l,GRD_XDIR), &
                             GRD_x(n,ADM_KNONE,l,GRD_YDIR), &
                             GRD_x(n,ADM_KNONE,l,GRD_ZDIR)  )

       pre_sfc = PRE00
!       tem_sfc = 300.D0
       tem_sfc = 315.D0 - deltaT*sin(lat)**2

       !---< from ground surface to lowermost atmosphere >---
       k = ADM_kmin
       ! first guess
       pre(k) = pre_sfc
       tem(k) = tem_sfc

       ! Newton-Lapson
       do itr = 1, itrmax
          pre_save = pre(k) ! save

          f  = log(pre(k)/pre_sfc) / dz(k) + GRAV / ( RAIR * 0.5D0 * (tem(k)+tem_sfc) )
          df = 1.D0 / (pre(k)*dz(k))

          pre(k) = pre(k) - f / df
!          tem(k) = 300.D0 * ( pre(k)/PRE00 )**KAPPA
          tem(k) = ( 315.D0 - deltaT*sin(lat)**2 - deltaTh*log(pre(k)/PRE00)*cos(lat)**2 ) &
                 * ( pre(k)/PRE00 )**KAPPA
          tem(k) = max( 200.D0, tem(k) )

          if( abs(pre_save-pre(k)) <= eps ) exit
       enddo

       if ( itr > itrmax ) then
          write(ADM_LOG_FID,*) 'xxx iteration not converged!', k, pre_save-pre(k), pre(k), pre_sfc, tem(k), tem_sfc
          write(*,          *) 'xxx iteration not converged!', k, pre_save-pre(k), pre(k), pre_sfc, tem(k), tem_sfc
          stop
       endif

       !---< from lowermost to uppermost atmosphere >---
       do k = ADM_kmin+1, ADM_kmax+1

          ! first guess
          pre(k) = pre(k-1)
          tem(k) = 300.D0 * ( pre(k)/PRE00 )**KAPPA
          tem(k) = max( 200.D0, tem(k) )

          ! Newton-Lapson
          do itr = 1, itrmax
             pre_save = pre(k) ! save

             f  = log(pre(k)/pre(k-1)) / dz(k) + GRAV / ( RAIR * 0.5D0 * (tem(k)+tem(k-1)) )
             df = 1.D0 / (pre(k)*dz(k))

             pre(k) = pre(k) - f / df
!             tem(k) = 300.D0 * ( pre(k)/PRE00 )**KAPPA
             tem(k) = ( 315.D0 - deltaT*sin(lat)**2 - deltaTh*log(pre(k)/PRE00)*cos(lat)**2 ) &
                    * ( pre(k)/PRE00 )**KAPPA
             tem(k) = max( 200.D0, tem(k) )

             if( abs(pre_save-pre(k)) <= eps ) exit

          enddo

          if ( itr > itrmax ) then
             write(ADM_LOG_FID,*) 'xxx iteration not converged!', k, pre_save-pre(k), pre(k), pre(k-1), tem(k), tem(k-1)
             write(*,          *) 'xxx iteration not converged!', k, pre_save-pre(k), pre(k), pre(k-1), tem(k), tem(k-1)
             stop
          endif
       enddo

       DIAG_var(n,ADM_kmin-1,l,1) = pre_sfc ! tentative
       DIAG_var(n,ADM_kmin-1,l,2) = tem_sfc ! tentative
       do k = ADM_kmin, ADM_kmax+1
          DIAG_var(n,k,l,1) = pre(k)
          DIAG_var(n,k,l,2) = tem(k)
       enddo

    enddo
    enddo

    return
  end subroutine hs_init

  !-----------------------------------------------------------------------------
  subroutine jbw_init( &
       ijdim,      &
       kdim,       &
       lall,       &
       test_case,  &
       DIAG_var    )
    use mod_misc, only: &
       MISC_get_latlon
    use mod_adm, only: &
       ADM_KNONE,      &
       ADM_NSYS
    use mod_grd, only: &
       GRD_vz,         &
       GRD_x,          &
       GRD_x_pl,       &
       GRD_XDIR,       &
       GRD_YDIR,       &
       GRD_ZDIR,       &
       GRD_Z,          &
       GRD_ZH
    use mod_runconf, only: &
       TRC_vmax
    implicit none

    integer, intent(in)  :: ijdim
    integer, intent(in)  :: kdim
    integer, intent(in)  :: lall
    character(len=ADM_NSYS), intent(in) :: test_case
    real(8), intent(out) :: DIAG_var(ijdim,kdim,lall,6+TRC_VMAX)

    ! work paramters
    real(PRCS_D) :: lat, lon                 ! latitude, longitude on Icosahedral grid
    real(PRCS_D) :: eta(kdim,2), geo(kdim)   ! eta & geopotential in ICO-grid field
    real(PRCS_D) :: prs(kdim),   tmp(kdim)   ! pressure & temperature in ICO-grid field
    real(PRCS_D) :: wix(kdim),   wiy(kdim)   ! zonal/meridional wind components in ICO-grid field

    real(8) :: z_local (kdim)
    real(8) :: vx_local(kdim)
    real(8) :: vy_local(kdim)
    real(8) :: vz_local(kdim)

    logical :: signal ! if ture, continue iteration
    logical :: pertb  ! if ture, with perturbation
    logical :: rebalance ! if ture, with geostophic wind rebalance
    integer :: n, l, k, itr, K0
    !---------------------------------------------------------------------------

    K0 = ADM_KNONE

    DIAG_var(:,:,:,:) = 0.D0

    select case( trim(test_case) )
    case ('1', '4-1')  ! with perturbation
       write(ADM_LOG_FID,*) "Jablonowski Initialize - case 1: with perturbation (no rebalance)"
       pertb = .true.
       rebalance = .false.
    case ('2', '4-2')  ! without perturbation
       write(ADM_LOG_FID,*) "Jablonowski Initialize - case 2: without perturbation (no rebalance)"
       pertb = .false.
       rebalance = .false.
    case ('3')  ! with perturbation & with rebalance
       write(ADM_LOG_FID,*) "Jablonowski Initialize - case 3: with perturbation (with rebalance)"
       pertb = .true.
       rebalance = .true.
    case ('4')  ! without perturbation & with rebalance
       write(ADM_LOG_FID,*) "Jablonowski Initialize - case 4: without perturbation (with rebalance)"
       pertb = .false.
       rebalance = .true.
    case default
       write(ADM_LOG_FID,*) "Unknown test_case: '"//trim(test_case)//"' specified."
       write(ADM_LOG_FID,*) "Force changed to case 1 (with perturbation)"
       pertb = .true.
    end select

    do l = 1, lall
    do n = 1, ijdim
       z_local(1) = GRD_vz(n,2,l,GRD_ZH)
       do k = 2, kdim
          z_local(k) = GRD_vz(n,k,l,GRD_Z)
       enddo

       call MISC_get_latlon( lat, lon,               &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )

       signal = .true.
       ! iteration -----
       do itr = 1, itrmax

          if( itr == 1 ) then
             eta(:,:) = 1.D-7 ! This initial value is recommended by Jablonowsky.
          else
             call eta_vert_coord_NW( kdim, itr, z_local, tmp, geo, eta, signal )
          endif

          call steady_state( kdim, lat, eta, wix, wiy, tmp, geo )

          if( .NOT. signal ) exit
       enddo

       if ( itr > itrmax ) then
          write(ADM_LOG_FID,*) 'ETA ITERATION ERROR: NOT CONVERGED', n, l
          stop
       endif

       call geo2prs     ( kdim, tmp, geo, prs )
       call conv_vxvyvz ( kdim, lat, lon, wix, wiy, vx_local, vy_local, vz_local )

       do k=1, kdim
          DIAG_var(n,k,l,1) = prs(k)
          DIAG_var(n,k,l,2) = tmp(k)
          DIAG_var(n,k,l,3) = vx_local(k)
          DIAG_var(n,k,l,4) = vy_local(k)
          DIAG_var(n,k,l,5) = vz_local(k)
       enddo

    enddo
    enddo

    if(rebalance) call geost_rebalance( ijdim, kdim, lall, 5, DIAG_var(:,:,:,1:5) )
    if(pertb) call perturbation( ijdim, kdim, lall, 5, DIAG_var(:,:,:,1:5) )

    return
  end subroutine jbw_init
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  subroutine tracer_init( &
     ijdim,      &
     kdim,       &
     lall,       &
     test_case,  &
     DIAG_var    )
    use mod_misc, only: &
       MISC_get_latlon, &
       MISC_get_distance
    use mod_adm, only: &
       ADM_KNONE,      &
       ADM_NSYS,       &
       ADM_proc_stop
    use mod_cnst, only: &
       CNST_PI, &
       CNST_ERADIUS
    use mod_grd, only: &
       GRD_vz,         &
       GRD_x,          &
       GRD_x_pl,       &
       GRD_XDIR,       &
       GRD_YDIR,       &
       GRD_ZDIR,       &
       GRD_Z,          &
       GRD_ZH
    use mod_gmtr, only: &
       GMTR_lon, &
       GMTR_lat
    use mod_runconf, only: &
       TRC_vmax, &
       NCHEM_STR
    use mod_chemvar, only: &
       chemvar_getid
    implicit none

    integer, intent(in)    :: ijdim
    integer, intent(in)    :: kdim
    integer, intent(in)    :: lall
    character(len=ADM_NSYS), intent(in) :: test_case
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,6+TRC_VMAX)

    ! work paramters
    real(8) :: lat, lon                  ! latitude, longitude on Icosahedral grid
    real(8) :: prs(kdim),   tmp(kdim)    ! pressure & temperature in ICO-grid field
    real(8) :: wix(kdim),   wiy(kdim)    ! zonal/meridional wind components in ICO-grid field
    real(8) :: wiz(kdim)                 ! vertical wind components in ICO-grid field
    real(8) :: q(kdim),     rho(kdim)    ! Qvapor and rho in ICO-grid field
    real(8) :: q1(kdim), q2(kdim)        ! passive tracer in ICO-grid field
    real(8) :: q3(kdim), q4(kdim)        ! passive tracer in ICO-grid field

    real(8) :: z_local (kdim)
    real(8) :: vx_local(kdim)
    real(8) :: vy_local(kdim)
    real(8) :: vz_local(kdim)

    integer :: I_passive1, I_passive2
    integer :: I_passive3, I_passive4
    integer :: n, l, k, K0

    logical :: fault = .true.
    logical :: hybrid_eta = .false.
    real(8) :: hyam, hybm, phis, ps
    integer, parameter :: zcoords = 1
    !---------------------------------------------------------------------------

    hyam = 0.0d0
    hybm = 0.0d0
    fault = .false.
    hybrid_eta = .false.

    K0 = ADM_KNONE

    DIAG_var(:,:,:,:) = 0.D0

    I_passive1 = 6 + chemvar_getid( "passive1" ) + NCHEM_STR - 1
    I_passive2 = 6 + chemvar_getid( "passive2" ) + NCHEM_STR - 1
    I_passive3 = 6 + chemvar_getid( "passive3" ) + NCHEM_STR - 1
    I_passive4 = 6 + chemvar_getid( "passive4" ) + NCHEM_STR - 1

    do l = 1, lall
    do n = 1, ijdim
       z_local(1) = GRD_vz(n,2,l,GRD_ZH)
       do k = 2, kdim
          z_local(k) = GRD_vz(n,k,l,GRD_Z)
       enddo

       call MISC_get_latlon( lat, lon,               &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )

       select case( trim(test_case) )
       ! DCMIP: TEST CASE 11 - Pure Advection - 3D deformational flow
       case ('1', '1-1')
          do k=1, kdim
             call test1_advection_deformation (lon, lat, prs(k), z_local(k), zcoords,    &
                                                wix(k), wiy(k), wiz(k), tmp(k), phis, ps, &
                                                rho(k), q(k), q1(k), q2(k), q3(k), q4(k)  )
          enddo
       ! DCMIP: TEST CASE 12 - Pure Advection - 3D HADLEY-like flow
       case ('2', '1-2')
          do k=1, kdim
             call test1_advection_hadley (lon, lat, prs(k), z_local(k), zcoords,    &
                                           wix(k), wiy(k), wiz(k), tmp(k), phis, ps, &
                                           rho(k), q(k), q1(k)  )
             q2(k) = 0.0d0
             q3(k) = 0.0d0
             q4(k) = 0.0d0
          enddo
       case default
          write(ADM_LOG_FID,*) "Unknown test_case: '"//trim(test_case)//"' specified."
          call ADM_proc_stop
       end select

       call conv_vxvyvz ( kdim, lat, lon, wix, wiy, vx_local, vy_local, vz_local )

       do k=1, kdim
          DIAG_var(n,k,l,1) = prs(k)
          DIAG_var(n,k,l,2) = tmp(k)
          DIAG_var(n,k,l,3) = vx_local(k)
          DIAG_var(n,k,l,4) = vy_local(k)
          DIAG_var(n,k,l,5) = vz_local(k)
          DIAG_var(n,k,l,6) = wiz(k)
          !DIAG_var(n,k,l,XXXXXXXXX) = q(k)  ! this has not prepared yet (20130612)
          DIAG_var(n,k,l,I_passive1) = q1(k)
          DIAG_var(n,k,l,I_passive2) = q2(k)
          DIAG_var(n,k,l,I_passive3) = q3(k)
          DIAG_var(n,k,l,I_passive4) = q4(k)
       enddo
    enddo
    enddo

    return
  end subroutine tracer_init
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  subroutine mountwave_init( &
     ijdim,      &
     kdim,       &
     lall,       &
     test_case,  &
     DIAG_var    )
    use mod_misc, only: &
       MISC_get_latlon, &
       MISC_get_distance
    use mod_adm, only: &
       ADM_KNONE,      &
       ADM_NSYS,       &
       ADM_proc_stop
    use mod_cnst, only: &
       CNST_PI, &
       CNST_ERADIUS
    use mod_grd, only: &
       GRD_vz,         &
       GRD_x,          &
       GRD_x_pl,       &
       GRD_XDIR,       &
       GRD_YDIR,       &
       GRD_ZDIR,       &
       GRD_Z,          &
       GRD_ZH
    use mod_gmtr, only: &
       GMTR_lon, &
       GMTR_lat
    use mod_runconf, only: &
       TRC_vmax, &
       NCHEM_STR
    use mod_chemvar, only: &
       chemvar_getid
    implicit none

    integer, intent(in)    :: ijdim
    integer, intent(in)    :: kdim
    integer, intent(in)    :: lall
    character(len=ADM_NSYS), intent(in) :: test_case
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,6+TRC_VMAX)

    ! work paramters
    real(8) :: lat, lon                 ! latitude, longitude on Icosahedral grid
    real(8) :: prs(kdim),   tmp(kdim)   ! pressure & temperature in ICO-grid field
    real(8) :: wix(kdim),   wiy(kdim)   ! zonal/meridional wind components in ICO-grid field
    real(8) :: wiz(kdim)                ! vertical wind components in ICO-grid field
    real(8) :: q(kdim),     rho(kdim)   ! tracer and rho in ICO-grid field

    real(8) :: z_local (kdim)
    real(8) :: vx_local(kdim)
    real(8) :: vy_local(kdim)
    real(8) :: vz_local(kdim)

    integer :: I_passive1
    integer :: n, l, k, K0

    integer :: shear
    logical :: fault = .true.
    logical :: hybrid_eta = .false.
    real(8) :: hyam, hybm, phis, ps
    integer, parameter :: zcoords = 1
    !---------------------------------------------------------------------------

    hyam = 0.0d0
    hybm = 0.0d0
    fault = .false.
    hybrid_eta = .false.

    K0 = ADM_KNONE

    DIAG_var(:,:,:,:) = 0.D0

    I_passive1 = 6 + chemvar_getid( "passive1" ) + NCHEM_STR - 1

    do l = 1, lall
    do n = 1, ijdim
       z_local(1) = GRD_vz(n,2,l,GRD_ZH)
       do k = 2, kdim
          z_local(k) = GRD_vz(n,k,l,GRD_Z)
       enddo

       call MISC_get_latlon( lat, lon,               &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )

       select case( trim(test_case) )
       ! DCMIP: TEST CASE 2-0 - Steady-State Atmosphere at Rest in the Presence of Orography
       case ('0', '2-0')
          do k=1, kdim
             call test2_steady_state_mountain (lon, lat, prs(k), z_local(k), zcoords, &
                      hybrid_eta, hyam, hybm, wix(k), wiy(k), wiz(k), tmp(k), phis, &
                      ps, rho(k), q(k) )
          enddo
       ! DCMIP: TEST CASE 2-1 - Non-hydrostatic Mountain Waves over a Schaer-type Mountain
       case ('1', '2-1')
          shear = 0   ! test case: 2-1 (constant u)
          do k=1, kdim
             call test2_schaer_mountain (lon, lat, prs(k), z_local(k), zcoords, &
                      hybrid_eta, hyam, hybm, shear, wix(k), wiy(k), wiz(k), tmp(k), phis, &
                      ps, rho(k), q(k) )
          enddo
       ! DCMIP: TEST CASE 2-2 - Non-hydrostatic Mountain Waves over a Schaer-type Mountain
       case ('2', '2-2')
          shear = 1   ! test case: 2-2 (sheared u)
          do k=1, kdim
             call test2_schaer_mountain (lon, lat, prs(k), z_local(k), zcoords, &
                      hybrid_eta, hyam, hybm, shear, wix(k), wiy(k), wiz(k), tmp(k), phis, &
                      ps, rho(k), q(k) )
          enddo
       case default
          write(ADM_LOG_FID,*) "Unknown test_case: '"//trim(test_case)//"' specified."
          call ADM_proc_stop
       end select

       call conv_vxvyvz ( kdim, lat, lon, wix, wiy, vx_local, vy_local, vz_local )

       do k=1, kdim
          DIAG_var(n,k,l,1) = prs(k)
          DIAG_var(n,k,l,2) = tmp(k)
          DIAG_var(n,k,l,3) = vx_local(k)
          DIAG_var(n,k,l,4) = vy_local(k)
          DIAG_var(n,k,l,5) = vz_local(k)
          DIAG_var(n,k,l,6) = wiz(k)
          DIAG_var(n,k,l,I_passive1) = q(k)
       enddo
    enddo
    enddo

    return
  end subroutine mountwave_init
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  subroutine gravwave_init( &
     ijdim,   &
     kdim,    &
     lall,    &
     DIAG_var )
    use mod_misc, only: &
       MISC_get_latlon, &
       MISC_get_distance
    use mod_adm, only: &
       ADM_KNONE
    use mod_cnst, only: &
       CNST_PI, &
       CNST_ERADIUS
    use mod_grd, only: &
       GRD_vz,         &
       GRD_x,          &
       GRD_x_pl,       &
       GRD_XDIR,       &
       GRD_YDIR,       &
       GRD_ZDIR,       &
       GRD_Z,          &
       GRD_ZH
    use mod_gmtr, only: &
       GMTR_lon, &
       GMTR_lat
    use mod_runconf, only: &
       TRC_vmax, &
       NCHEM_STR
    use mod_chemvar, only: &
       chemvar_getid
    implicit none

    integer, intent(in)    :: ijdim
    integer, intent(in)    :: kdim
    integer, intent(in)    :: lall
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,6+TRC_VMAX)

    ! work paramters
    real(8) :: lat, lon                 ! latitude, longitude on Icosahedral grid
    real(8) :: prs(kdim),   tmp(kdim)   ! pressure & temperature in ICO-grid field
    real(8) :: wix(kdim),   wiy(kdim)   ! zonal/meridional wind components in ICO-grid field
    real(8) :: wiz(kdim)                ! vertical wind components in ICO-grid field
    real(8) :: q(kdim),     rho(kdim)   ! tracer and rho in ICO-grid field

    real(8) :: z_local (kdim)
    real(8) :: vx_local(kdim)
    real(8) :: vy_local(kdim)
    real(8) :: vz_local(kdim)

    integer :: I_passive1
    integer :: n, l, k, K0

    logical :: fault = .true.
    logical :: hybrid_eta = .false.
    real(8) :: hyam, hybm, phis, ps
    integer, parameter :: zcoords = 1
    !---------------------------------------------------------------------------

    hyam = 0.0d0
    hybm = 0.0d0
    fault = .false.
    hybrid_eta = .false.

    K0 = ADM_KNONE

    DIAG_var(:,:,:,:) = 0.D0

    I_passive1 = 6 + chemvar_getid( "passive1" ) + NCHEM_STR - 1

    do l = 1, lall
    do n = 1, ijdim
       z_local(1) = GRD_vz(n,2,l,GRD_ZH)
       do k = 2, kdim
          z_local(k) = GRD_vz(n,k,l,GRD_Z)
       enddo

       call MISC_get_latlon( lat, lon,               &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )

       do k=1, kdim
          call test3_gravity_wave (lon, lat, prs(k), z_local(k), zcoords, &
                   wix(k), wiy(k), wiz(k), tmp(k), phis, &
                   ps, rho(k), q(k) )
       enddo

       call conv_vxvyvz ( kdim, lat, lon, wix, wiy, vx_local, vy_local, vz_local )

       do k=1, kdim
          DIAG_var(n,k,l,1) = prs(k)
          DIAG_var(n,k,l,2) = tmp(k)
          DIAG_var(n,k,l,3) = vx_local(k)
          DIAG_var(n,k,l,4) = vy_local(k)
          DIAG_var(n,k,l,5) = vz_local(k)
          DIAG_var(n,k,l,6) = wiz(k)
          DIAG_var(n,k,l,I_passive1) = q(k)
       enddo
    enddo
    enddo

    return
  end subroutine gravwave_init
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  ! eta vertical coordinate by Newton Method
  subroutine eta_vert_coord_NW( &
      kdim,   &  !--- IN : # of z dimension
      itr,    &  !--- IN : iteration number
      z,      &  !--- IN : z-height vertical coordinate
      tmp,    &  !--- IN : guessed temperature
      geo,    &  !--- IN : guessed geopotential
      eta,    &  !--- INOUT : eta level vertical coordinate
      signal  )  !--- INOUT : iteration signal
    !
    implicit none
    integer, intent(in) :: itr
    integer, intent(in) :: kdim
    real(PRCS_D), intent(in) :: z(kdim)
    real(PRCS_D), intent(in) :: geo(kdim), tmp(kdim)
    real(PRCS_D), intent(inout) :: eta(kdim,2)
    logical, intent(inout) :: signal
    integer :: k
    real(PRCS_D) :: diffmax, diff(kdim)
    real(PRCS_D) :: F(kdim), Feta(kdim)
    !
    do k=1, kdim
       F(k) = -g*z(k) + geo(k)
       Feta(k) = -1.D0 * ( Rd/eta(k,1) ) * tmp(k)
       eta(k,2) = eta(k,1) - ( F(k)/Feta(k) )
       if(eta(k,2) > 1.D0) eta(k,2) = 1.D0     ! not allow over 1.0 for eta
       if(eta(k,2) < 0.D0) eta(k,2) = 1.D-20
       diff(k) = abs( eta(k,2) - eta(k,1) )
    enddo
    !
    eta(:,1) = eta(:,2)
    diffmax = maxval(diff)
    if (message) write (*, '("| Eta  ",I4,": -- MAX: ",F23.20,3X,"MIN: ",F23.20)') itr, maxval(eta(:,1)), minval(eta(:,1))
    if (message) write (*, '("| Diff ",I4,": -- MAX: ",F23.20,3X,"MIN: ",F23.20)') itr, diffmax, minval(diff)
    !
    if(diffmax < eps) then
       signal = .false.
    else
       if (message) write (ADM_LOG_FID,*) "| ----- Iterating ", itr
    endif
    !
    return
  end subroutine eta_vert_coord_NW
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  ! calculation of steady state
  subroutine steady_state( &
      kdim,   &  !--- IN : # of z dimension
      lat,  &  !--- IN : latitude information
      eta,  &  !--- IN : eta level vertical coordinate
      wix,  &  !--- INOUT : zonal wind component
      wiy,  &  !--- INOUT : meridional wind component
      tmp,  &  !--- INOUT : mean temperature
      geo   )  !--- INOUT : mean geopotential height
    !
    implicit none
    integer :: k
    integer, intent(in) :: kdim
    real(PRCS_D), intent(in) :: lat
    real(PRCS_D), intent(in) :: eta(kdim,2)
    real(PRCS_D), intent(inout) :: wix(kdim)
    real(PRCS_D), intent(inout) :: wiy(kdim)
    real(PRCS_D), intent(inout) :: tmp(kdim)
    real(PRCS_D), intent(inout) :: geo(kdim)
    real(PRCS_D) :: eta_v
    real(PRCS_D) :: work1, work2
    !
    ! ---------- horizontal mean
    work1 = pi/2.D0
    work2 = Rd*ganma/g
    do k=1, kdim
       eta_v = (eta(k,1) - eta0)*(work1)
       wix(k) = u0 * (cos(eta_v))**1.5d0 * (sin(2.D0*lat))**2.D0
       !
      !if( etaS >= eta(k,1) .and. eta(k,1) >= etaT ) then  ! not allow over 1.0 for eta
        if( eta(k,1) >= etaT ) then
           tmp(k) = t0 * eta(k,1)**work2
           geo(k) = t0*g/ganma * ( 1.D0 - eta(k,1)**work2 )
        elseif( eta(k,1) < etaT ) then
           tmp(k) = t0 * eta(k,1)**work2 + delT*(etaT - eta(k,1))**5.D0
           !
           geo(k) = t0*g/ganma * ( 1.D0 - eta(k,1)**work2 ) - Rd * delT *                              &
                   ( ( log(eta(k,1)/etaT) + 137.D0/60.D0 )*etaT**5.D0 - 5.D0*(etaT**4.D0)*eta(k,1)     &
                     + 5.D0*(etaT**3.D0)*(eta(k,1)**2.D0) - (10.D0/3.D0)*(etaT**2.D0)*(eta(k,1)**3.D0) &
                     + (5.D0/4.D0)*etaT*(eta(k,1)**4.D0) - (1.D0/5.D0)*(eta(k,1)**5.D0)                &
                   )
        else
           write (ADM_LOG_FID,'(A)') "|-- ETA BOUNDARY ERROR: [steady state calc.]"
           write (ADM_LOG_FID,'("|-- (",I3,")  eta: ",F10.4)') k, eta(k,1)
           stop
        endif
      !else
      !   write (ADM_LOG_FID,'(A)') "|-- OVER 1.0 for eta: [steady state calc.]"
      !   stop
      !endif
       !
    enddo
    !
    ! ---------- meridional distribution for temeperature and geopotential
    work1 = pi/2.D0
    work2 = 3.D0/4.D0 * ( pi*u0 / Rd )
    do k=1, kdim
       eta_v = (eta(k,1) - eta0)*(work1)
       tmp(k) = tmp(k)                                           &
                    + work2*eta(k,1) * sin(eta_v) * (cos(eta_v))**0.5d0  &
                    * ( ( -2.D0 * (sin(lat))**6.D0 * (cos(lat)**2.D0 + 1.D0/3.D0) + 10.D0/63.D0 )   &
                         * 2.D0*u0*(cos(eta_v))**1.5d0                   &
                        + ( 8.D0/5.D0 * (cos(lat))**3.D0 * ((sin(lat))**2.D0 + 2.D0/3.D0) - pi/4.D0 ) &
                         * a*omega                                       &
                      )
       geo(k) = geo(k)                                           &
                    + u0*(cos(eta_v))**1.5d0  &
                    * ( ( -2.D0 * (sin(lat))**6.D0 * (cos(lat)**2.D0 + 1.D0/3.D0) + 10.D0/63.D0 )   &
                         * u0*(cos(eta_v))**1.5d0                        &
                        + ( 8.D0/5.D0 * (cos(lat))**3.D0 * ((sin(lat))**2.D0 + 2.D0/3.D0) - pi/4.D0 ) &
                         * a*omega                                       &
                      )
    enddo
    !
    wiy(:) = 0.D0
    !
    return
  end subroutine steady_state
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  ! convert geopotential height to pressure
  subroutine geo2prs( &
      kdim,   &  !--- IN : # of z dimension
      tmp,  &  !--- IN : temperature
      geo,  &  !--- IN : geopotential height at full height
      prs   )  !--- INOUT : pressure
    !
    implicit none
    integer :: k
    integer, intent(in) :: kdim
    real(PRCS_D), intent(in) :: tmp(kdim)
    real(PRCS_D), intent(in) :: geo(kdim)
    real(PRCS_D), intent(inout) :: prs(kdim)
    real(PRCS_D) :: dZ, dT, e

    e = exp(1.D0)
    prs(1) = p0
    ! guess pressure field upper k=0
    do k=2, kdim
       dZ = ( geo(k) - geo(k-1) )/g
       dT = ( tmp(k) + tmp(k-1) )/2.D0
       prs(k) = prs(k-1) * e**( -1.D0 * dZ * (g/(Rd*dT)) )
    enddo
    !
    if (message) then
       write (*,'(A)') "| ----- Pressure (Final Guess) -----"
       do k=1, kdim
          write(ADM_LOG_FID, '("| K(",I3,") -- ",F20.13)') k, prs(k)
       enddo
    endif
    !
    return
  end subroutine geo2prs
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  ! Reproduce zonal wind by geostophic wind balance
  subroutine geost_rebalance( &
      ijdim,    &  !--- IN : # of ij dimension
      kdim,     &  !--- IN : # of z dimension
      lall,     &  !--- IN : # of region
      vmax,     &  !--- IN : # of variables
      DIAG_var  )  !--- INOUT : variables container
    use mod_adm, only: &
       ADM_prc_me,  &
       ADM_prc_pl,  &
       K0       => ADM_KNONE,   &
       ijdim_pl => ADM_gall_pl, &
       lall_pl  => ADM_lall_pl
    use mod_comm, only: &
       COMM_var,           &
       COMM_data_transfer, &
       COMM_Stat_max
    use mod_grd, only: &
       GRD_x,      &
       GRD_x_pl,   &
       GRD_XDIR,   &
       GRD_YDIR,   &
       GRD_ZDIR
    use mod_misc, only: &
       MISC_get_latlon
    use mod_vmtr, only: &
       VMTR_GSGAM2,     &
       VMTR_GSGAM2_pl
    use mod_src, only: &
       src_gradient,              &
       I_SRC_default,             &
       I_SRC_horizontal
    !
    implicit none
    integer, intent(in) :: ijdim, kdim, lall, vmax
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,vmax)

    integer, parameter :: ID_prs = 1
    integer, parameter :: ID_tmp = 2
    integer, parameter :: ID_vx  = 3
    integer, parameter :: ID_vy  = 4
    integer, parameter :: ID_vz  = 5
    integer :: n, k, l
    real(8) :: lat, lon
    real(8) :: f, rho
    real(8) :: ws, max_ws, global_max_ws, fit_fact
    real(8) :: pre_bs, pre_bs_pl
    real(8) :: unit_east(3)
    real(8), parameter :: thres_f = 1.0d-12
    real(8), allocatable :: DIAG_var_pl(:,:,:,:)
    real(8), allocatable :: pregd(:,:,:), pregd_pl(:,:,:)
    real(8), allocatable :: pgf(:,:,:,:), pgf_pl(:,:,:,:)
    real(8), allocatable :: pgfz(:,:,:), pgfz_pl(:,:,:)
    !-----
    allocate( DIAG_var_pl(ijdim_pl,kdim,lall_pl,vmax) )
    allocate( pregd(ijdim,kdim,lall) )
    allocate( pregd_pl(ijdim_pl,kdim,lall_pl) )
    allocate( pgf(ijdim,kdim,lall,3) )
    allocate( pgf_pl(ijdim_pl,kdim,lall_pl,3) )
    allocate( pgfz(ijdim,kdim,lall) )
    allocate( pgfz_pl(ijdim_pl,kdim,lall_pl) )

    pre_bs    = 0.0d0
    pre_bs_pl = 0.0d0

    write (ADM_LOG_FID,*) " Re-Balance Geostophic Wind ---[ original ]---"
    write (ADM_LOG_FID,*) "  vx - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))
    write (ADM_LOG_FID,*) "  vy - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))

    !--- fill HALO (to make DIAG_var_pl)
    call comm_var( DIAG_var, DIAG_var_pl, kdim, vmax, comm_type=2, NSval_fix=.true. )
    pregd(:,:,:)    = ( DIAG_var(:,:,:,ID_prs)    - pre_bs )    * VMTR_GSGAM2(:,:,:)
    pregd_pl(:,:,:) = ( DIAG_var_pl(:,:,:,ID_prs) - pre_bs_pl ) * VMTR_GSGAM2_pl(:,:,:)

    !--- take pressure gradient force
    call src_gradient( pregd,        pregd_pl,         & !--- [IN]
                       pgf(:,:,:,1),  pgf_pl(:,:,:,1),  & !--- [OUT]
                       pgf(:,:,:,2),  pgf_pl(:,:,:,2),  & !--- [OUT]
                       pgf(:,:,:,3),  pgf_pl(:,:,:,3),  & !--- [OUT]
                       pgfz(:,:,:),   pgfz_pl(:,:,:),   & !--- [OUT]
                       I_SRC_horizontal                 ) !--- [IN]
    write (ADM_LOG_FID,*) "  pgf (x) - max:",maxval(pgf(:,:,:,1)), "  min:",minval(pgf(:,:,:,1))

    !--- geostophic wind
    do l = 1, lall
    do n = 1, ijdim
       call MISC_get_latlon( lat, lon,              &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )
       unit_east  = Sp_Unit_East(lon)
       f = 2.0d0 * omega * sin(lat)

       do k = 2, kdim
          rho = DIAG_var(n,k,l,ID_prs) / ( Rd*DIAG_var(n,k,l,ID_tmp) )

          ! x-direction
          if(abs(f) > thres_f) then
             DIAG_var(n,k,l,ID_vx) = (-1.0d0/f) * (1.0d0/rho) * (  pgf(n,k,l,3)*unit_east(1) &
                                                                 + pgf(n,k,l,2)*sign(1.0d0,lat) )
          else
             DIAG_var(n,k,l,ID_vx) = 0.0d0
          endif

          ! y-direction
          if(abs(f) > thres_f) then
             DIAG_var(n,k,l,ID_vy) = (-1.0d0/f) * (1.0d0/rho) * (  pgf(n,k,l,3)*unit_east(2) &
                                                                 + pgf(n,k,l,1)*sign(1.0d0,lat*(-1)) )
          else
             DIAG_var(n,k,l,ID_vy) = 0.0d0
          endif
       enddo
    enddo
    enddo
    DIAG_var(:,1,:,ID_vx) = DIAG_var(:,2,:,ID_vx)
    DIAG_var(:,1,:,ID_vy) = DIAG_var(:,2,:,ID_vy)

    if ( ADM_prc_me == ADM_prc_pl ) then
       do l = 1, lall_pl
       do n = 1, ijdim_pl
          call MISC_get_latlon( lat, lon,               &
                                GRD_x_pl(n,K0,l,GRD_XDIR), &
                                GRD_x_pl(n,K0,l,GRD_YDIR), &
                                GRD_x_pl(n,K0,l,GRD_ZDIR)  )
          unit_east  = Sp_Unit_East(lon)
          f = 2.0d0 * omega * sin(lat)

          do k = 2, kdim
             rho = DIAG_var_pl(n,k,l,ID_prs) / ( Rd*DIAG_var_pl(n,k,l,ID_tmp) )

             ! x-direction
             if(abs(f) > thres_f) then
                DIAG_var_pl(n,k,l,ID_vx) = (-1.0d0/f) * (1.0d0/rho) * (  pgf_pl(n,k,l,3)*unit_east(1) &
                                                                       + pgf_pl(n,k,l,2)*sign(1.0d0,lat) )
             else
                DIAG_var_pl(n,k,l,ID_vx) = 0.0d0
             endif

             ! y-direction
             if(abs(f) > thres_f) then
                DIAG_var_pl(n,k,l,ID_vy) = (-1.0d0/f) * (1.0d0/rho) * (  pgf_pl(n,k,l,3)*unit_east(2) &
                                                                       + pgf_pl(n,k,l,1)*sign(1.0d0,lat*(-1)) )
             else
                DIAG_var_pl(n,k,l,ID_vy) = 0.0d0
             endif
          enddo
       enddo
       enddo
       DIAG_var_pl(:,1,:,ID_vx) = DIAG_var_pl(:,2,:,ID_vx)
       DIAG_var_pl(:,1,:,ID_vy) = DIAG_var_pl(:,2,:,ID_vy)
    endif

    !--- fill HALO
    call COMM_data_transfer( DIAG_var, DIAG_var_pl )

    write (ADM_LOG_FID,*) " Re-Balance Geostophic Wind ---[ calc ]---"
    write (ADM_LOG_FID,*) "  vx - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))
    write (ADM_LOG_FID,*) "  vy - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))

    !--- evaluate max windspeed setting
    max_ws = 1.0d-14
    do l = 1, lall
    do n = 1, ijdim
    do k = 1, kdim
        ws = sqrt(DIAG_var(n,k,l,ID_vx)**2 + DIAG_var(n,k,l,ID_vy)**2)
        if( max_ws < ws ) max_ws = ws
    enddo
    enddo
    enddo
    call COMM_Stat_max( max_ws, global_max_ws )
    fit_fact = abs( u0 / global_max_ws )
    write (ADM_LOG_FID,*) "  JBW Re-Balance: Fitting - max windspeed:",global_max_ws
    write (ADM_LOG_FID,*) "  JBW Re-Balance: Fitting - fitting factor:",fit_fact
    DIAG_var(:,:,:,ID_vx) = DIAG_var(:,:,:,ID_vx) * fit_fact
    DIAG_var(:,:,:,ID_vy) = DIAG_var(:,:,:,ID_vy) * fit_fact
    if ( ADM_prc_me == ADM_prc_pl ) then
       DIAG_var_pl(:,:,:,ID_vx) = DIAG_var_pl(:,:,:,ID_vx) * fit_fact
       DIAG_var_pl(:,:,:,ID_vy) = DIAG_var_pl(:,:,:,ID_vy) * fit_fact
    endif

    write (ADM_LOG_FID,*) " Re-Balance Geostophic Wind ---[ fitted ]---"
    write (ADM_LOG_FID,*) "  vx - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))
    write (ADM_LOG_FID,*) "  vy - max:",maxval(DIAG_var(:,:,:,ID_vx)), "  min:",minval(DIAG_var(:,:,:,ID_vx))
    write (ADM_LOG_FID,*) "  vz - force to zero"

    deallocate( DIAG_var_pl, pregd, pregd_pl )
    deallocate( pgf, pgf_pl, pgfz, pgfz_pl )
    return
  end subroutine geost_rebalance
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  ! setting perturbation
  subroutine perturbation( &
      ijdim,     &  !--- IN : # of ij dimension
      kdim,      &  !--- IN : # of z dimension
      lall,      &  !--- IN : # of region
      vmax,      &  !--- IN : # of variables
      DIAG_var   )  !--- INOUT : variables container
    use mod_grd, only: &
       GRD_x,      &
       GRD_x_pl,   &
       GRD_XDIR,   &
       GRD_YDIR,   &
       GRD_ZDIR
    use mod_misc, only: &
       MISC_get_latlon
    use mod_adm, only: &
       K0 => ADM_KNONE
    implicit none
    integer, intent(in) :: ijdim, kdim, lall, vmax
    real(8), intent(inout) :: DIAG_var(ijdim,kdim,lall,vmax)

    integer, parameter :: ID_prs = 1
    integer, parameter :: ID_tmp = 2
    integer, parameter :: ID_vx  = 3
    integer, parameter :: ID_vy  = 4
    integer, parameter :: ID_vz  = 5
    integer :: n, k, l
    real(8) :: lat, lon
    real(8) :: r, rr, rbyrr, cla, clo
    real(8) :: ptb_wix(kdim), ptb_wiy(kdim)
    real(8) :: ptb_vx(kdim), ptb_vy(kdim), ptb_vz(kdim)

    cla = clat * d2r
    clo = clon * d2r

    do l = 1, lall
    do n = 1, ijdim
       call MISC_get_latlon( lat, lon,              &
                             GRD_x(n,K0,l,GRD_XDIR), &
                             GRD_x(n,K0,l,GRD_YDIR), &
                             GRD_x(n,K0,l,GRD_ZDIR)  )
       r = a * acos( sin(cla)*sin(lat) + cos(cla)*cos(lat)*cos(lon-clo) )
       rr = a / 10.D0
       rbyrr = r/rr
       do k = 1, kdim
          ptb_wix(k) = uP * exp( -1.D0*rbyrr**2.D0 )
          ptb_wiy(k) = 0.0d0
       enddo

       call conv_vxvyvz( kdim, lat, lon, ptb_wix, ptb_wiy, ptb_vx, ptb_vy, ptb_vz )
       do k = 1, kdim
          DIAG_var(n,k,l,ID_vx) = DIAG_var(n,k,l,ID_vx) + ptb_vx(k)
          DIAG_var(n,k,l,ID_vy) = DIAG_var(n,k,l,ID_vy) + ptb_vy(k)
          DIAG_var(n,k,l,ID_vz) = DIAG_var(n,k,l,ID_vz) + ptb_vz(k)
       enddo
    enddo
    enddo
    !
    return
  end subroutine perturbation
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  subroutine conv_vxvyvz( &
      kdim, &  !--- IN : # of z dimension
      lat,  &  !--- IN : latitude information
      lon,  &  !--- IN : longitude information
      wix,  &  !--- IN : zonal wind component on latlon
      wiy,  &  !--- IN : meridional wind component on latlon
      vx1d, &  !--- INOUT : horizontal-x component on absolute system for horizontal wind
      vy1d, &  !--- INOUT : horizontal-y component on absolute system for horizontal wind
      vz1d  )  !--- INOUT : vertical component on absolute system for horizontal wind
    !
    implicit none
    integer, intent(in) :: kdim
    real(PRCS_D), intent(in) :: lat, lon
    real(PRCS_D), intent(in) :: wix(kdim)
    real(PRCS_D), intent(in) :: wiy(kdim)
    real(PRCS_D), intent(inout) :: vx1d(kdim)
    real(PRCS_D), intent(inout) :: vy1d(kdim)
    real(PRCS_D), intent(inout) :: vz1d(kdim)
    !
    integer :: k
    real(PRCS_D) :: unit_east(3), unit_north(3)
    !
    ! imported from NICAM/nhm/mkinit/prg_mkinit_ncep.f90 (original written by H.Miura)
    ! *** compute vx, vy, vz as 1-dimensional variables
    do k=1, kdim
       unit_east  = Sp_Unit_East( lon )
       unit_north = Sp_Unit_North( lon, lat )
       !
       vx1d(k) = unit_east(1) * wix(k) + unit_north(1) * wiy(k)
       vy1d(k) = unit_east(2) * wix(k) + unit_north(2) * wiy(k)
       vz1d(k) = unit_east(3) * wix(k) + unit_north(3) * wiy(k)
    enddo
    !
    return
  end subroutine conv_vxvyvz
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function sphere_xyz_to_lon (xyz) result (lon)  !(x,y,z) to longitude [-pi,pi].
    real(PRCS_D),intent(in) :: xyz(3) !< (x,y,z)
    real(PRCS_D) :: lon !< longitude [rad]
    real(PRCS_D) :: proj
    !
    proj=sqrt (xyz(1)*xyz(1) + xyz(2)*xyz(2))
    if (proj<eps) then
       lon=0.0_PRCS_D       !# pole points
    else
       lon=atan2 (xyz(2),xyz(1))
    end if
    return
  end function sphere_xyz_to_lon
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function sphere_xyz_to_lat (xyz) result (lat)  !(x,y,z) to latitude [-pi/2,pi/2].
    real(PRCS_D),intent(in) :: xyz(3) !< (x,y,z)
    real(PRCS_D) :: lat !< latitude [rad]
    real(PRCS_D) :: proj
    !
    proj=sqrt (xyz(1)*xyz(1) + xyz(2)*xyz(2))
    if (proj<eps) then
       lat=sign (0.5_PRCS_D*pi,xyz(3))       !# pole points
    else
       lat=atan (xyz(3)/proj)
    end if
    return
  end function sphere_xyz_to_lat
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function Sp_Unit_East( lon ) result( unit_east )
    ! imported from prg_mkinit_ncep.f90 (original written by H.Miura)
    ! ------
    ! Compute local eastward unit vector (unit_east)
    ! in the Cartesian coordinate system
    ! given longitude (lon) of a position.
    !
    implicit none
    real(PRCS_D), intent(in) :: lon  ! [ rad ]
    real(PRCS_D) :: unit_east(3)
    !
    unit_east(1) = - sin( lon )    ! --- x-direction
    unit_east(2) =   cos( lon )    ! --- y-direction
    unit_east(3) = 0.0_PRCS_D      ! --- z-direction
    return
  end function Sp_Unit_East
  !-----------------------------------------------------------------------------
  !
  !-----------------------------------------------------------------------------
  function Sp_Unit_North( lon, lat ) result( unit_north )
    ! imported from prg_mkinit_ncep.f90 (original written by H.Miura)
    ! ------
    ! Compute local northward unit vector (unit_north)
    ! in the Cartesian coordinate system
    ! given longitude (lon) and latitude (lat) of a position.
    !
    implicit none
    real(PRCS_D), intent(in) :: lon, lat  ! [ rad ]
    real(PRCS_D) :: unit_north(3)
    !
    unit_north(1) = - sin( lat ) * cos( lon )    ! --- x-direction
    unit_north(2) = - sin( lat ) * sin( lon )    ! --- y-direction
    unit_north(3) =   cos( lat )                 ! --- z-direction
    return
  end function Sp_Unit_North
  !-----------------------------------------------------------------------------
  !
  !
  !  "subroutine surface_height" was moved to share/mod_grd.f90
  !-----------------------------------------------------------------------------
  !
end module mod_dycoretest
!-------------------------------------------------------------------------------


      SUBROUTINE QUADR(F0,F1,F2, X1,X2, A,B,C)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
****************************************************
*                                                  *
*    QUADR CALCULATES THE A, B AND C IN THE EQUNS. *
*                                                  *
*     A                   =   F0                   *
*     A + B.X0 + C.X0**2  =   F1                   *
*     A + B.X2 + C.X2**2  =   F2                   *
*                                                  *
****************************************************
      C=(X2*(F1-F0)-X1*(F2-F0))/(X2*X1**2-X1*X2**2)
      B=(F1-F0-C*X1**2)/X1
      A=F0
      RETURN
      END


*DECK SCGN
      SUBROUTINE SCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
     $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P,
     $     ATP, ATZ, DZ, ATDZ, RWORK, IWORK)
C***BEGIN PROLOGUE  SCGN
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=SINGLE PRECISION(SCGN-S),
C             Non-Symmetric Linear system solve, Sparse,
C             Iterative Precondition, Normal Equations.
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned CG Sparse Ax=b Solver for Normal Equations.
C            Routine  to solve a general linear system Ax = b using the
C            Preconditioned Conjugate Gradient method  applied to   the
C            normal equations AA'y = b, x=A'y.
C***DESCRIPTION
C *Usage:
C     INTEGER  N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER  ITER, IERR, IUNIT, IWORK(USER DEFINABLE)
C     REAL     B(N), X(N), A(NELT), TOL, ERR, R(N), Z(N), P(N), ATP(N)
C     REAL     ATZ(N), DZ(N), ATDZ(N)
C     REAL     RWORK(USER DEFINABLE)
C     EXTERNAL MATVEC, MTTVEC, MSOLVE
C
C     CALL SCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
C    $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R,
C    $     Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :INOUT    Real X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Integer A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description", below
C         for more late breaking details...
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which performs the matrix vector multiply
C         y = A*X given A and X.  The name of the MATVEC routine must
C         be declared external in the calling program.  The calling
C         sequence to MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X
C         upon return X is an input vector, NELT is the number of
C         non-zeros in the SLAP-Column IA, JA, A storage for the matrix
C         A.  ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MTTVEC :EXT      External.
C         Name of a routine which performs the matrix transpose vector
C         multiply y = A'*X given A and X (where ' denotes transpose).
C         The name of the MTTVEC routine must be declared external in
C         the calling program.  The calling sequence to MTTVEC is the
C         same as that for MATVEC, viz.:
C             CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A'*X
C         upon return X is an input vector, NELT is the number of
C         non-zeros in the SLAP-Column IA, JA, A storage for the matrix
C         A.  ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R for
C         Z given R with the preconditioning matrix M (M is supplied via
C         RWORK and IWORK arrays).  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is the right-hand side
C         vector, and Z is the solution upon return.  RWORK is a real
C         array that can be used to pass necessary preconditioning
C         information and/or workspace to MSOLVE.  IWORK is an integer
C         work array for the same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Real.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Real.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*R1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :WORK     Real R(N).
C Z      :WORK     Real Z(N).
C P      :WORK     Real P(N).
C ATP    :WORK     Real ATP(N).
C ATZ    :WORK     Real ATZ(N).
C DZ     :WORK     Real DZ(N).
C ATDZ   :WORK     Real ATDZ(N).
C RWORK  :WORK     Real RWORK(USER DEFINABLE).
C         Real array that can be used by  MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINABLE).
C         Integer array that can be used by  MSOLVE.
C
C *Description:
C       This  routine applies the  preconditioned conjugate gradient
C       (PCG) method to a non-symmetric system of equations Ax=b. To
C       do this the normal equations are solved:
C               AA' y  = b, where  x  = A'y.
C       In PCG method the iteration count is determined by condition
C                               -1
C       number of the  matrix (M  A).   In the  situation where  the
C       normal equations are  used  to solve a  non-symmetric system
C       the condition number depends on  AA' and should therefore be
C       much worse than that of A.  This is the conventional wisdom.
C       When one has a good preconditioner for AA' this may not hold.
C       The latter is the situation when SCGN should be tried.
C
C       If one is trying to solve  a symmetric system, SCG should be
C       used instead.
C
C       This routine does  not care  what matrix data   structure is
C       used for  A and M.  It simply   calls  the MATVEC and MSOLVE
C       routines, with  the arguments as  described above.  The user
C       could write any type of structure and the appropriate MATVEC
C       and MSOLVE routines.  It is assumed  that A is stored in the
C       IA, JA, A  arrays in some fashion and  that M (or INV(M)) is
C       stored  in  IWORK  and  RWORK)  in  some fashion.   The SLAP
C       routines SSDCGN and SSLUCN are examples of this procedure.
C
C       Two  examples  of  matrix  data structures  are the: 1) SLAP
C       Triad  format and 2) SLAP Column format.
C
C       =================== S L A P Triad format ===================
C
C       In  this   format only the  non-zeros are  stored.  They may
C       appear  in *ANY* order.   The user  supplies three arrays of
C       length NELT, where  NELT  is the number  of non-zeros in the
C       matrix:  (IA(NELT), JA(NELT),  A(NELT)).  For each  non-zero
C       the  user puts   the row  and  column index   of that matrix
C       element in the IA and JA arrays.  The  value of the non-zero
C       matrix  element is  placed in  the corresponding location of
C       the A  array.  This is  an extremely easy data  structure to
C       generate.  On  the other hand it  is  not too  efficient  on
C       vector  computers   for the  iterative  solution  of  linear
C       systems.  Hence, SLAP  changes this input  data structure to
C       the SLAP   Column  format for the  iteration (but   does not
C       change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C
C       In  this format   the non-zeros are    stored counting  down
C       columns (except  for the diagonal  entry, which must  appear
C       first in each "column") and are  stored in the real array A.
C       In other words,  for  each column    in the matrix   put the
C       diagonal  entry  in A.   Then   put  in the  other  non-zero
C       elements going   down the  column (except  the  diagonal) in
C       order.  The IA array holds the row index  for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning   of   each  column.      That is,   IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1), A(JA(ICOL+1)-1)  points to the
C       end of the ICOL-th column.  Note that we always have JA(N+1)
C       = NELT+1, where N is the number of columns in the matrix and
C       NELT is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C
C *Precision:           Single Precision
C *See Also:
C         SSDCGN, SSLUCN, ISSCGN
C***REFERENCES  (NONE)
C***ROUTINES CALLED  MATVEC, MTTVEC, MSOLVE, ISSCGN,
C                    SCOPY, SDOT, SAXPY, R1MACH
C***END PROLOGUE  SCGN
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IUNIT, IWORK(*)
      REAL    B(N), X(N), A(N), R(N), Z(N), P(N), ATP(N), ATZ(N)
      REAL    DZ(N), ATDZ(N), RWORK(*)
      EXTERNAL MATVEC, MTTVEC, MSOLVE
C
C         Check user input.
C***FIRST EXECUTABLE STATEMENT  SCGN
      ITER = 0
      IERR = 0
      IF( N.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      TOLMIN = 500.0*R1MACH(3)
      IF( TOL.LT.TOLMIN ) THEN
         TOL = TOLMIN
         IERR = 4
      ENDIF
C         Calculate initial residual and pseudo-residual, and check
C         stopping criterion.
      CALL MATVEC(N, X, R, NELT, IA, JA, A, ISYM)
      DO 10 I = 1, N
         R(I) = B(I) - R(I)
 10   CONTINUE
      CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
      CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM)
C
      IF( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC, MSOLVE,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P, ATP, ATZ,
     $     DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM) .NE. 0 )
     $     GO TO 200
      IF( IERR.NE.0 ) RETURN
C
C         ***** iteration loop *****
C
      DO 100 K=1,ITMAX
         ITER = K
C
C         Calculate coefficient BK and direction vector P.
         BKNUM = SDOT(N, Z, 1, R, 1)
         IF( BKNUM.LE.0.0 ) THEN
            IERR = 6
            RETURN
         ENDIF
         IF(ITER .EQ. 1) THEN
            CALL SCOPY(N, Z, 1, P, 1)
         ELSE
            BK = BKNUM/BKDEN
            DO 20 I = 1, N
               P(I) = Z(I) + BK*P(I)
 20         CONTINUE
         ENDIF
         BKDEN = BKNUM
C
C         Calculate coefficient AK, new iterate X, new residual R,
C         and new pseudo-residual ATZ.
         IF(ITER .NE. 1) CALL SAXPY(N, BK, ATP, 1, ATZ, 1)
         CALL SCOPY(N, ATZ, 1, ATP, 1)
         AKDEN = SDOT(N, ATP, 1, ATP, 1)
         IF( AKDEN.LE.0.0 ) THEN
            IERR = 6
            RETURN
         ENDIF
         AK = BKNUM/AKDEN
         CALL SAXPY(N, AK, ATP, 1, X, 1)
         CALL MATVEC(N, ATP, Z, NELT, IA, JA, A, ISYM)
         CALL SAXPY(N, -AK, Z, 1, R, 1)
         CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
         CALL MTTVEC(N, Z, ATZ, NELT, IA, JA, A, ISYM)
C
C         check stopping criterion.
         IF( ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
     $        MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R,
     $        Z, P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM,
     $        SOLNRM) .NE. 0) GOTO 200
C
 100  CONTINUE
C
C         *****   end of loop  *****
C
C         stopping criterion not satisfied.
      ITER = ITMAX + 1
C
 200  RETURN
C------------- LAST LINE OF SCGN FOLLOWS ----------------------------
      END
*DECK SSDCGN
      SUBROUTINE SSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  SSDCGN
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=SINGLE PRECISION(SSDCGN-S),
C             Non-Symmetric Linear system solve, Sparse,
C             Iterative Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Diagonally Scaled CG Sparse Ax=b Solver for Normal Eqn's.
C            Routine to solve a general linear system Ax = b using
C            diagonal scaling with the Conjugate  Gradient  method
C            applied to the the normal equations, viz.,  AA'y = b,
C            where x = A'y.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK, LENIW
C     REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(8*N)
C
C     CALL SSDCGN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW)
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :INOUT    Real X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Integer A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Real.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Real.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*R1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Real RWORK(LENW).
C         Real array used for workspace.
C LENW   :IN       Integer.
C         Length of the real workspace, RWORK.  LENW >= 8*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Used to hold pointers into the RWORK array.
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Real    workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >= 10.
C
C *Description:
C       This  routine is simply a driver  for the  SCGN routine.  It
C       calls the   SSD2S  routine to set up the preconditioning and
C       then calls SCGN with the appropriate   MATVEC  and    MSOLVE
C       routines.
C
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix      SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C
C       This routine  requires that  the matrix A  be stored in  the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except  for the diagonal entry, which
C       must appear first in each  "column") and  are stored  in the
C       real array A.  In other words, for each column in the matrix
C       put the diagonal entry in A.  Then put in the other non-zero
C       elements going down   the  column (except  the diagonal)  in
C       order.  The IA array holds the row  index for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning of   each    column.    That  is,    IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1),  A(JA(ICOL+1)-1) points to the
C       end  of   the ICOL-th  column.  Note   that  we  always have
C       JA(N+1) = NELT+1, where  N  is the number of columns in  the
C       matrix and  NELT   is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Single Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is modified internally to be
C       the SLAP Column format.  See above.
C
C *See Also:
C       SCGN, SSD2S, SSMV, SSMTV, SSDI
C***REFERENCES  (NONE)
C***ROUTINES CALLED  SS2Y, SCHKW, SSD2S, SCGN, SSMV, SSMTV, SSDI
C***END PROLOGUE  SSDCGN
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL
      INTEGER ITMAX, ITER, IERR, IUNIT, LENW, IWORK(LENIW), LENIW
      REAL    B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW)
      EXTERNAL SSMV, SSMTV, SSDI
      PARAMETER (LOCRB=1, LOCIB=11)
C
C         Modify the SLAP matrix data structure to YSMP-Column.
C***FIRST EXECUTABLE STATEMENT  SSDCGN
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL SS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Set up the work arrays.
C         Compute the inverse of the diagonal of AA'.  This will be
C         used as the preconditioner.
      LOCIW = LOCIB
C
      LOCD = LOCRB
      LOCR = LOCD + N
      LOCZ = LOCR + N
      LOCP = LOCZ + N
      LOCATP = LOCP + N
      LOCATZ = LOCATP + N
      LOCDZ = LOCATZ + N
      LOCATD = LOCDZ + N
      LOCW = LOCATD + N
C
C         Check the workspace allocations.
      CALL SCHKW( 'SSDCGN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(4) = LOCD
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
      CALL SSD2S(N, NELT, IA, JA, A, ISYM, RWORK(1))
C
C         Perform Conjugate Gradient algorithm on the normal equations.
      CALL SCGN( N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSDI,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR),
     $     RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ),
     $     RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK )
C
      IF( ITER.GT.ITMAX ) IERR = 2
      RETURN
C------------- LAST LINE OF SSDCGN FOLLOWS ----------------------------
      END
*DECK SSLUCN
      SUBROUTINE SSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
     $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C***BEGIN PROLOGUE  SSLUCN
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2B4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=SINGLE PRECISION(SSLUCN-S),
C             Non-Symmetric Linear system, Sparse,
C             Iterative Incomplete LU Precondition
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Incomplete LU CG Sparse Ax=b Solver for Normal Equations.
C            Routine to solve  a general linear system Ax = b using the
C            incomplete  LU decomposition  with  the Conjugate Gradient
C            method  applied to the normal equations,  viz., AA'y =  b,
C            x=A'y.
C***DESCRIPTION
C *Usage:
C     INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX
C     INTEGER ITER, IERR, IUNIT, LENW, IWORK(NEL+NU+4*N+2), LENIW
C     REAL B(N), X(N), A(NELT), TOL, ERR, RWORK(NEL+NU+8*N)
C
C     CALL SSLUCN(N, B, X, NELT, IA, JA, A, ISYM, ITOL, TOL,
C    $     ITMAX, ITER, ERR, IERR, IUNIT, RWORK, LENW, IWORK, LENIW )
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :INOUT    Real X(N).
C         On input X is your initial guess for solution vector.
C         On output X is the final approximate solution.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :INOUT    Integer IA(NELT).
C JA     :INOUT    Integer JA(NELT).
C A      :INOUT    Integer A(NELT).
C         These arrays should hold the matrix A in either the SLAP
C         Triad format or the SLAP Column format.  See "Description",
C         below.  If the SLAP Triad format is chosen it is changed
C         internally to the SLAP Column format.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than TOL, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Real.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :OUT      Integer.
C         Number of iterations required to reach convergence, or
C         ITMAX+1 if convergence criterion could not be achieved in
C         ITMAX iterations.
C ERR    :OUT      Real.
C         Error estimate of error in final approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Return error flag.
C           IERR = 0 => All went well.
C           IERR = 1 => Insufficient storage allocated
C                       for WORK or IWORK.
C           IERR = 2 => Method failed to converge in
C                       ITMAX steps.
C           IERR = 3 => Error in user input.  Check input
C                       value of N, ITOL.
C           IERR = 4 => User error tolerance set too tight.
C                       Reset to 500.0*R1MACH(3).  Iteration proceeded.
C           IERR = 5 => Preconditioning matrix, M,  is not
C                       Positive Definite.  $(r,z) < 0.0$.
C           IERR = 6 => Matrix A is not Positive Definite.
C                       $(p,Ap) < 0.0$.
C           IERR = 7 => Incomplete factorization broke down
C                       and was fudged.  Resulting preconditioning may
C                       be less than the best.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C RWORK  :WORK     Real RWORK(LENW).
C         Real array used for workspace.  NEL is the number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C LENW   :IN       Integer.
C         Length of the real workspace, RWORK.  LENW >= NEL+NU+8*N.
C IWORK  :WORK     Integer IWORK(LENIW).
C         Integer array used for workspace.  NEL is the number of non-
C         zeros in the lower triangle of the matrix (including the
C         diagonal).  NU is the number of nonzeros in the upper
C         triangle of the matrix (including the diagonal).
C         Upon return the following locations of IWORK hold information
C         which may be of use to the user:
C         IWORK(9)  Amount of Integer workspace actually used.
C         IWORK(10) Amount of Real    workspace actually used.
C LENIW  :IN       Integer.
C         Length of the integer workspace, IWORK.  LENIW >=
C         NEL+NU+4*N+12.
C
C *Description:
C       This  routine is simply a driver  for the  SCGN  routine.    It
C       calls the SSILUS routine to set up the preconditioning and then
C       calls SCGN with the appropriate  MATVEC  and  MSOLVE  routines.
C
C       The Sparse Linear Algebra Package (SLAP) utilizes two matrix
C       data structures: 1) the  SLAP Triad  format or  2)  the SLAP
C       Column format.  The user can hand this routine either of the
C       of these data structures and SLAP  will figure out  which on
C       is being used and act accordingly.
C
C       =================== S L A P Triad format ===================
C
C       This routine requires that the  matrix A be   stored in  the
C       SLAP  Triad format.  In  this format only the non-zeros  are
C       stored.  They may appear in  *ANY* order.  The user supplies
C       three arrays of  length NELT, where  NELT is  the number  of
C       non-zeros in the matrix: (IA(NELT), JA(NELT), A(NELT)).  For
C       each non-zero the user puts the row and column index of that
C       matrix element  in the IA and  JA arrays.  The  value of the
C       non-zero   matrix  element is  placed  in  the corresponding
C       location of the A array.   This is  an  extremely  easy data
C       structure to generate.  On  the  other hand it   is  not too
C       efficient on vector computers for  the iterative solution of
C       linear systems.  Hence,   SLAP changes   this  input    data
C       structure to the SLAP Column format  for  the iteration (but
C       does not change it back).
C
C       Here is an example of the  SLAP Triad   storage format for a
C       5x5 Matrix.  Recall that the entries may appear in any order.
C
C           5x5 Matrix       SLAP Triad format for 5x5 matrix on left.
C                              1  2  3  4  5  6  7  8  9 10 11
C       |11 12  0  0 15|   A: 51 12 11 33 15 53 55 22 35 44 21
C       |21 22  0  0  0|  IA:  5  1  1  3  1  5  5  2  3  4  2
C       | 0  0 33  0 35|  JA:  1  2  1  3  5  3  5  2  5  4  1
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C       =================== S L A P Column format ==================
C
C       This routine  requires that  the matrix A  be stored in  the
C       SLAP Column format.  In this format the non-zeros are stored
C       counting down columns (except  for the diagonal entry, which
C       must appear first in each  "column") and  are stored  in the
C       real array A.  In other words, for each column in the matrix
C       put the diagonal entry in A.  Then put in the other non-zero
C       elements going down   the  column (except  the diagonal)  in
C       order.  The IA array holds the row  index for each non-zero.
C       The JA array holds the offsets into the IA, A arrays for the
C       beginning of   each    column.    That  is,    IA(JA(ICOL)),
C       A(JA(ICOL)) points to the beginning of the ICOL-th column in
C       IA and  A.  IA(JA(ICOL+1)-1),  A(JA(ICOL+1)-1) points to the
C       end  of   the ICOL-th  column.  Note   that  we  always have
C       JA(N+1) = NELT+1, where  N  is the number of columns in  the
C       matrix and  NELT   is the number of non-zeros in the matrix.
C
C       Here is an example of the  SLAP Column  storage format for a
C       5x5 Matrix (in the A and IA arrays '|'  denotes the end of a
C       column):
C
C           5x5 Matrix      SLAP Column format for 5x5 matrix on left.
C                              1  2  3    4  5    6  7    8    9 10 11
C       |11 12  0  0 15|   A: 11 21 51 | 22 12 | 33 53 | 44 | 55 15 35
C       |21 22  0  0  0|  IA:  1  2  5 |  2  1 |  3  5 |  4 |  5  1  3
C       | 0  0 33  0 35|  JA:  1  4  6    8  9   12
C       | 0  0  0 44  0|
C       |51  0 53  0 55|
C
C *Precision:           Single Precision
C *Side Effects:
C       The SLAP Triad format (IA, JA, A) is modified internally to be
C       the SLAP Column format.  See above.
C
C *See Also:
C       SCGN, SDCGN, SSILUS
C***REFERENCES  (NONE)
C***ROUTINES CALLED  SS2Y, SSILUS, SCHKW, SSMV, SSMTV, SSMMTI, SCGN
C***END PROLOGUE  SSLUCN
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IERR, IUNIT, LENW, IWORK(LENIW), LENIW
      REAL    B(N), X(N), A(NELT), TOL, ERR, RWORK(LENW)
      PARAMETER (LOCRB=1, LOCIB=11)
C
      EXTERNAL SSMV, SSMTV, SSMMTI
C
C         Change the SLAP input matrix IA, JA, A to SLAP-Column format.
C***FIRST EXECUTABLE STATEMENT  SSLUCN
      IERR = 0
      IF( N.LT.1 .OR. NELT.LT.1 ) THEN
         IERR = 3
         RETURN
      ENDIF
      CALL SS2Y( N, NELT, IA, JA, A, ISYM )
C
C         Count number of Non-Zero elements preconditioner ILU matrix.
C         Then set up the work arrays.
      NL = 0
      NU = 0
      DO 20 ICOL = 1, N
C         Don't count diagional.
         JBGN = JA(ICOL)+1
         JEND = JA(ICOL+1)-1
         IF( JBGN.LE.JEND ) THEN
CVD$ NOVECTOR
            DO 10 J = JBGN, JEND
               IF( IA(J).GT.ICOL ) THEN
                  NL = NL + 1
                  IF( ISYM.NE.0 ) NU = NU + 1
               ELSE
                  NU = NU + 1
               ENDIF
 10         CONTINUE
         ENDIF
 20   CONTINUE
C
      LOCIL = LOCIB
      LOCJL = LOCIL + N+1
      LOCIU = LOCJL + NL
      LOCJU = LOCIU + NU
      LOCNR = LOCJU + N+1
      LOCNC = LOCNR + N
      LOCIW = LOCNC + N
C
      LOCL = LOCRB
      LOCDIN = LOCL + NL
      LOCU = LOCDIN + N
      LOCR = LOCU + NU
      LOCZ = LOCR + N
      LOCP = LOCZ + N
      LOCATP = LOCP + N
      LOCATZ = LOCATP + N
      LOCDZ = LOCATZ + N
      LOCATD = LOCDZ + N
      LOCW = LOCATD + N
C
C         Check the workspace allocations.
      CALL SCHKW( 'SSLUCN', LOCIW, LENIW, LOCW, LENW, IERR, ITER, ERR )
      IF( IERR.NE.0 ) RETURN
C
      IWORK(1) = LOCIL
      IWORK(2) = LOCJL
      IWORK(3) = LOCIU
      IWORK(4) = LOCJU
      IWORK(5) = LOCL
      IWORK(6) = LOCDIN
      IWORK(7) = LOCU
      IWORK(9) = LOCIW
      IWORK(10) = LOCW
C
C         Compute the Incomplete LU decomposition.
      CALL SSILUS( N, NELT, IA, JA, A, ISYM, NL, IWORK(LOCIL),
     $     IWORK(LOCJL), RWORK(LOCL), RWORK(LOCDIN), NU, IWORK(LOCIU),
     $     IWORK(LOCJU), RWORK(LOCU), IWORK(LOCNR), IWORK(LOCNC) )
C
C         Perform Conjugate Gradient algorithm on the normal equations.
      CALL SCGN(N, B, X, NELT, IA, JA, A, ISYM, SSMV, SSMTV, SSMMTI,
     $     ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, RWORK(LOCR),
     $     RWORK(LOCZ), RWORK(LOCP), RWORK(LOCATP), RWORK(LOCATZ),
     $     RWORK(LOCDZ), RWORK(LOCATD), RWORK, IWORK )
C
      IF( ITER.GT.ITMAX ) IERR = 2
      RETURN
C------------- LAST LINE OF SSLUCN FOLLOWS ----------------------------
      END
*DECK ISSCGN
      FUNCTION ISSCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
     $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z,
     $     P, ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM)
C***BEGIN PROLOGUE  ISSCGN
C***REFER TO  SCGN, SSDCGN, SSLUCN
C***DATE WRITTEN   871119   (YYMMDD)
C***REVISION DATE  881213   (YYMMDD)
C***CATEGORY NO.  D2A4
C***KEYWORDS  LIBRARY=SLATEC(SLAP),
C             TYPE=SINGLE PRECISION(ISSCGN-S),
C             Non-Symmetric Linear system, Sparse,
C             Iterative Precondition, Normal Equations
C***AUTHOR  Greenbaum, Anne, Courant Institute
C           Seager, Mark K., (LLNL)
C             Lawrence Livermore National Laboratory
C             PO BOX 808, L-300
C             Livermore, CA 94550 (415) 423-3141
C             seager@lll-crg.llnl.gov
C***PURPOSE  Preconditioned CG on Normal Equations Stop Test.
C            This routine calculates the stop test for the Conjugate
C            Gradient iteration   scheme applied  to     the  normal
C            equations.  It returns a nonzero  if the error estimate
C            (the type of which is determined by  ITOL) is less than
C            the user specified tolerance TOL.
C***DESCRIPTION
C *Usage:
C     INTEGER  N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
C     INTEGER  IERR, IUNIT, IWORK(USER DEFINED)
C     REAL     B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N), ATP(N)
C     REAL     ATZ(N), DZ(N), ATDZ(N)
C     REAL     RWORK(USER DEFINED), AK, BK, BNRM, SOLNRM
C     EXTERNAL MATVEC, MTTVEC, MSOLVE
C
C     IF( ISTPCGN(N, B, X, NELT, IA, JA, A, ISYM, MATVEC, MTTVEC,
C    $     MSOLVE, ITOL, TOL, ITMAX, ITER, ERR, IERR, IUNIT, R, Z, P,
C    $     ATP, ATZ, DZ, ATDZ, RWORK, IWORK, AK, BK, BNRM, SOLNRM)
C    $     .NE. 0 ) THEN ITERATION DONE
C
C *Arguments:
C N      :IN       Integer
C         Order of the Matrix.
C B      :IN       Real B(N).
C         Right-hand side vector.
C X      :IN       Real X(N).
C         The current approximate solution vector.
C NELT   :IN       Integer.
C         Number of Non-Zeros stored in A.
C IA     :IN       Integer IA(NELT).
C JA     :IN       Integer JA(NELT).
C A      :IN       Real A(NELT).
C         These arrays contain the matrix data structure for A.
C         It could take any form.  See "Description" in the
C         SSCGN routine.
C ISYM   :IN       Integer.
C         Flag to indicate symmetric storage format.
C         If ISYM=0, all nonzero entries of the matrix are stored.
C         If ISYM=1, the matrix is symmetric, and only the upper
C         or lower triangle of the matrix is stored.
C MATVEC :EXT      External.
C         Name of a routine which performs the matrix vector multiply
C         Y = A*X given A and X.  The name of the MATVEC routine must
C         be declared external in the calling program.  The calling
C         sequence to MATVEC is:
C             CALL MATVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A*X
C         upon return X is an input vector, NELT is the number of
C         non-zeros in the SLAP-Column IA, JA, A storage for the matrix
C         A.  ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MTTVEC :EXT      External.
C         Name of a routine which performs the matrix transpose vector
C         multiply y = A'*X given A and X (where ' denotes transpose).
C         The name of the MTTVEC routine must be declared external in
C         the calling program.  The calling sequence to MTTVEC is the
C         same as that for MATVEC, viz.:
C             CALL MTTVEC( N, X, Y, NELT, IA, JA, A, ISYM )
C         Where N is the number of unknowns, Y is the product A'*X
C         upon return X is an input vector, NELT is the number of
C         non-zeros in the SLAP-Column IA, JA, A storage for the matrix
C         A.  ISYM is a flag which, if non-zero, denotes that A is
C         symmetric and only the lower or upper triangle is stored.
C MSOLVE :EXT      External.
C         Name of a routine which solves a linear system MZ = R for
C         Z given R with the preconditioning matrix M (M is supplied via
C         RWORK and IWORK arrays).  The name of the MSOLVE routine must
C         be declared external in the calling program.  The calling
C         sequence to MSOLVE is:
C             CALL MSOLVE(N, R, Z, NELT, IA, JA, A, ISYM, RWORK, IWORK)
C         Where N is the number of unknowns, R is the right-hand side
C         vector, and Z is the solution upon return.  RWORK is a real
C         array that can be used to pass necessary preconditioning
C         information and/or workspace to MSOLVE.  IWORK is an integer
C         work array for the same purpose as RWORK.
C ITOL   :IN       Integer.
C         Flag to indicate type of convergence criterion.
C         If ITOL=1, iteration stops when the 2-norm of the residual
C         divided by the 2-norm of the right-hand side is less than TOL.
C         If ITOL=2, iteration stops when the 2-norm of M-inv times the
C         residual divided by the 2-norm of M-inv times the right hand
C         side is less than tol, where M-inv is the inverse of the
C         diagonal of A.
C         ITOL=11 is often useful for checking and comparing different
C         routines.  For this case, the user must supply the "exact"
C         solution or a very accurate approximation (one with an error
C         much less than TOL) through a common block,
C                     COMMON /SOLBLK/ SOLN(1)
C         if ITOL=11, iteration stops when the 2-norm of the difference
C         between the iterative approximation and the user-supplied
C         solution divided by the 2-norm of the user-supplied solution
C         is less than TOL.  Note that this requires the user to set up
C         the "COMMON /SOLBLK/ SOLN(LENGTH)" in the calling routine.
C         The routine with this declaration should be loaded before the
C         stop test so that the correct length is used by the loader.
C         This procedure is not standard Fortran and may not work
C         correctly on your system (although it has worked on every
C         system the authors have tried).  If ITOL is not 11 then this
C         common block is indeed standard Fortran.
C TOL    :IN       Real.
C         Convergence criterion, as described above.
C ITMAX  :IN       Integer.
C         Maximum number of iterations.
C ITER   :IN       Integer.
C         The iteration for which to check for convergence.
C ERR    :OUT      Real.
C         Error estimate of error in the X(N) approximate solution, as
C         defined by ITOL.
C IERR   :OUT      Integer.
C         Error flag.  IERR is set to 3 if ITOL is not on of the
C         acceptable values, see above.
C IUNIT  :IN       Integer.
C         Unit number on which to write the error at each iteration,
C         if this is desired for monitoring convergence.  If unit
C         number is 0, no writing will occur.
C R      :IN       Real R(N).
C         The residual R = B-AX.
C Z      :WORK     Real Z(N).
C P      :IN       Real P(N).
C         The conjugate direction vector.
C ATP    :IN       Real ATP(N).
C         A-transpose times the conjugate direction vector.
C ATZ    :IN       Real ATZ(N).
C         A-transpose times the pseudo-residual.
C DZ     :IN       Real DZ(N).
C         Workspace used to hold temporary vector(s).
C ATDZ   :WORK       Real ATDZ(N).
C         Workspace.
C RWORK  :WORK     Real RWORK(USER DEFINABLE).
C         Real array that can be used by MSOLVE.
C IWORK  :WORK     Integer IWORK(USER DEFINABLE).
C         Integer array that can be used by MSOLVE.
C BNRM   :INOUT    Real.
C         Norm of the right hand side.  Type of norm depends on ITOL.
C         Calculated only on the first call.
C SOLNRM :INOUT    Real.
C         2-Norm of the true solution, SOLN.  Only computed and used
C         if ITOL = 11.
C
C *Function Return Values:
C       0 : Error estimate (determined by ITOL) is *NOT* less than the
C           specified tolerance, TOL.  The iteration must continue.
C       1 : Error estimate (determined by ITOL) is less than the
C           specified tolerance, TOL.  The iteration can be considered
C           complete.
C
C *Precision:           Single Precision
C *See Also:
C       SSCGN
C
C *Cautions:
C     This routine will attempt to write to the fortran logical output
C     unit IUNIT, if IUNIT .ne. 0.  Thus, the user must make sure that
C     this  logical  unit  must  be  attached  to  a  file or terminal
C     before calling this routine with a non-zero  value  for   IUNIT.
C     This routine does not check for the validity of a non-zero IUNIT
C     unit number.
C***REFERENCES  (NONE)
C***ROUTINES CALLED  MATVEC, MTTVEC, MSOLVE and the BLAS
C***COMMON BLOCKS    SOLBLK
C***END PROLOGUE  ISSCGN
      INTEGER N, NELT, IA(NELT), JA(NELT), ISYM, ITOL, ITMAX, ITER
      INTEGER IUNIT, IWORK(*)
      REAL    B(N), X(N), A(N), TOL, ERR, R(N), Z(N), P(N), ATP(N)
      REAL    ATZ(N), DZ(N), ATDZ(N), RWORK(*), AK, BK, BNRM, SOLNRM
      EXTERNAL MATVEC, MTTVEC, MSOLVE
      COMMON /SOLBLK/ SOLN(1)
C
C***FIRST EXECUTABLE STATEMENT  ISSCGN
      ISSCGN = 0
C
      IF( ITOL.EQ.1 ) THEN
C         err = ||Residual||/||RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) BNRM = SNRM2(N, B, 1)
         ERR = SNRM2(N, R, 1)/BNRM
      ELSE IF( ITOL.EQ.2 ) THEN
C                  -1              -1
C         err = ||M  Residual||/||M  RightHandSide|| (2-Norms).
         IF(ITER .EQ. 0) THEN
            CALL MSOLVE(N, B, DZ, NELT, IA, JA, A, ISYM, RWORK, IWORK)
            CALL MTTVEC(N, DZ, ATDZ, NELT, IA, JA, A, ISYM)
            BNRM = SNRM2(N, ATDZ, 1)
         ENDIF
         ERR = SNRM2(N, ATZ, 1)/BNRM
      ELSE IF( ITOL.EQ.11 ) THEN
C         err = ||x-TrueSolution||/||TrueSolution|| (2-Norms).
         IF(ITER .EQ. 0) SOLNRM = SNRM2(N, SOLN, 1)
         DO 10 I = 1, N
            DZ(I) = X(I) - SOLN(I)
 10      CONTINUE
         ERR = SNRM2(N, DZ, 1)/SOLNRM
      ELSE
C
C         If we get here ITOL is not one of the acceptable values.
         ERR = 1.0E10
         IERR = 3
      ENDIF
C
      IF( IUNIT.NE.0 ) THEN
         IF( ITER.EQ.0 ) THEN
            WRITE(IUNIT,1000) N, ITOL
         ENDIF
         WRITE(IUNIT,1010) ITER, ERR, AK, BK
      ENDIF
      IF( ERR.LE.TOL ) ISSCGN = 1
C
      RETURN
 1000 FORMAT(' PCG Applied to the Normal Equations for ',
     $     'N, ITOL = ',I5, I5,
     $     /' ITER','   Error Estimate','            Alpha',
     $     '             Beta')
 1010 FORMAT(1X,I4,1X,E16.7,1X,E16.7,1X,E16.7)
C------------- LAST LINE OF ISSCGN FOLLOWS ----------------------------
      END