!
!  Copyright 2017 SALMON developers
!
!  Licensed under the Apache License, Version 2.0 (the "License");
!  you may not use this file except in compliance with the License.
!  You may obtain a copy of the License at
!
!      http://www.apache.org/licenses/LICENSE-2.0
!
!  Unless required by applicable law or agreed to in writing, software
!  distributed under the License is distributed on an "AS IS" BASIS,
!  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
!  See the License for the specific language governing permissions and
!  limitations under the License.
!
MODULE init_sendrecv_sub

use scf_data
implicit none
integer :: iup_array(4)
integer :: idw_array(4)
integer :: jup_array(4)
integer :: jdw_array(4)
integer :: kup_array(4)
integer :: kdw_array(4)

integer :: itype_r(24)
integer :: itype_c(24)

real(8),allocatable :: rmatbox1_x_s(:,:,:),rmatbox1_y_s(:,:,:),rmatbox1_z_s(:,:,:)
real(8),allocatable :: rmatbox2_x_s(:,:,:),rmatbox2_y_s(:,:,:),rmatbox2_z_s(:,:,:)

complex(8),allocatable :: cmatbox1_x_s(:,:,:),cmatbox1_y_s(:,:,:),cmatbox1_z_s(:,:,:)
complex(8),allocatable :: cmatbox2_x_s(:,:,:),cmatbox2_y_s(:,:,:),cmatbox2_z_s(:,:,:)

real(8),allocatable :: rmatbox1_x_h(:,:,:),rmatbox1_y_h(:,:,:),rmatbox1_z_h(:,:,:)
real(8),allocatable :: rmatbox2_x_h(:,:,:),rmatbox2_y_h(:,:,:),rmatbox2_z_h(:,:,:)
real(8),allocatable :: rmatbox3_x_h(:,:,:),rmatbox3_y_h(:,:,:),rmatbox3_z_h(:,:,:)
real(8),allocatable :: rmatbox4_x_h(:,:,:),rmatbox4_y_h(:,:,:),rmatbox4_z_h(:,:,:)

complex(8),allocatable :: cmatbox1_x_h(:,:,:),cmatbox1_y_h(:,:,:),cmatbox1_z_h(:,:,:)
complex(8),allocatable :: cmatbox2_x_h(:,:,:),cmatbox2_y_h(:,:,:),cmatbox2_z_h(:,:,:)

CONTAINS

!=======================================================================
!=======================================================================

SUBROUTINE init_updown
use inputoutput, only: iperiodic
use salmon_parallel
use salmon_communication, only: comm_proc_null
use new_world_sub

implicit none

iup_array(1)=nproc_id_korbital+1
idw_array(1)=nproc_id_korbital-1
select case(iperiodic)
case(0)
  if(imr(1)==nproc_Mxin(1)-1) iup_array(1)=comm_proc_null
  if(imr(1)==0) idw_array(1)=comm_proc_null
case(3)
  if(imr(1)==nproc_Mxin(1)-1) then
    iup_array(1)=nproc_id_korbital-(nproc_Mxin(1)-1)
  end if
  if(imr(1)==0) then
    idw_array(1)=nproc_id_korbital+(nproc_Mxin(1)-1)
  end if
end select

jup_array(1)=nproc_id_korbital+nproc_Mxin(1)
jdw_array(1)=nproc_id_korbital-nproc_Mxin(1)
select case(iperiodic)
case(0)
  if(imr(2)==nproc_Mxin(2)-1) jup_array(1)=comm_proc_null
  if(imr(2)==0) jdw_array(1)=comm_proc_null
case(3)
  if(imr(2)==nproc_Mxin(2)-1) then
    jup_array(1)=nproc_id_korbital-(nproc_Mxin(2)-1)*nproc_Mxin(1)
  end if
  if(imr(2)==0) then
    jdw_array(1)=nproc_id_korbital+(nproc_Mxin(2)-1)*nproc_Mxin(1)
  end if
end select

kup_array(1)=nproc_id_korbital+nproc_Mxin(1)*nproc_Mxin(2)
kdw_array(1)=nproc_id_korbital-nproc_Mxin(1)*nproc_Mxin(2)
select case(iperiodic)
case(0)
  if(imr(3)==nproc_Mxin(3)-1) kup_array(1)=comm_proc_null
  if(imr(3)==0) kdw_array(1)=comm_proc_null
case(3)
  if(imr(3)==nproc_Mxin(3)-1) then
    kup_array(1)=nproc_id_korbital-(nproc_Mxin(3)-1)*nproc_Mxin(1)*nproc_Mxin(2)
  end if
  if(imr(3)==0) then
    kdw_array(1)=nproc_id_korbital+(nproc_Mxin(3)-1)*nproc_Mxin(1)*nproc_Mxin(2)
  end if
end select

if(isequential==1)then
  if(imr(1)==nproc_Mxin(1)-1.and.imrs(1)==nproc_Mxin_s_dm(1)-1) then
    select case(iperiodic)
    case(0)
      iup_array(2)=comm_proc_null
    case(3)
      iup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm-nproc_Mxin_s_dm(1)+1-nproc_Mxin_mul_s_dm*nproc_Mxin(1)
    end select
  else if(imrs(1)==nproc_Mxin_s_dm(1)-1) then
    iup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm-nproc_Mxin_s_dm(1)+1
  else
    iup_array(2)=nproc_id_h+1
  end if
else if(isequential==2)then
  if(imr(1)==nproc_Mxin(1)-1.and.imrs(1)==nproc_Mxin_s_dm(1)-1) then
    select case(iperiodic)
    case(0)
      iup_array(2)=comm_proc_null
    case(3)
      iup_array(2)=nproc_id_h+nproc_Mxin_mul+1-nproc_Mxin_mul*nproc_Mxin_s_dm(1)-nproc_Mxin(1)
    end select
  else if(imrs(1)==nproc_Mxin_s_dm(1)-1) then
    iup_array(2)=nproc_id_h+nproc_Mxin_mul+1-nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  else
    iup_array(2)=nproc_id_h+nproc_Mxin_mul
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(1)==1.and.nproc_Mxin_s_dm(1)==1)then
    iup_array(4)=comm_proc_null
  else if(imr(1)==nproc_Mxin(1)-1.and.imrs(1)==nproc_Mxin_s_dm(1)-1) then
    iup_array(4)=nproc_id_h+nproc_Mxin_mul+1-nproc_Mxin_mul*nproc_Mxin_s_dm(1)-nproc_Mxin(1)
  else if(imrs(1)==nproc_Mxin_s_dm(1)-1) then
    iup_array(4)=nproc_id_h+nproc_Mxin_mul+1-nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  else
    iup_array(4)=nproc_id_h+nproc_Mxin_mul
  end if
end if

if(isequential==1)then
  if(imr(1)==0.and.imrs(1)==0) then
    select case(iperiodic)
    case(0)
      idw_array(2)=comm_proc_null
    case(3)
      idw_array(2)=nproc_id_h-nproc_Mxin_mul-1+nproc_Mxin_mul*nproc_Mxin_s_dm(1)+nproc_Mxin(1)
    end select
  else if(imrs(1)==0) then
    idw_array(2)=nproc_id_h-nproc_Mxin_mul_s_dm+nproc_Mxin_s_dm(1)-1
  else
    idw_array(2)=nproc_id_h-1
  end if
else if(isequential==2)then
  if(imr(1)==0.and.imrs(1)==0) then
    idw_array(2)=comm_proc_null
  else if(imrs(1)==0) then
    idw_array(2)=nproc_id_h-nproc_Mxin_mul-1+nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  else
    idw_array(2)=nproc_id_h-nproc_Mxin_mul
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(1)==1.and.nproc_Mxin_s_dm(1)==1)then
    idw_array(4)=comm_proc_null
  else if(imr(1)==0.and.imrs(1)==0) then
    idw_array(4)=nproc_id_h-nproc_Mxin_mul-1+nproc_Mxin_mul*nproc_Mxin_s_dm(1)+nproc_Mxin(1)
  else if(imrs(1)==0) then
    idw_array(4)=nproc_id_h-nproc_Mxin_mul-1+nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  else
    idw_array(4)=nproc_id_h-nproc_Mxin_mul
  end if
end if

if(isequential==1)then
  if(imr(2)==nproc_Mxin(2)-1.and.imrs(2)==nproc_Mxin_s_dm(2)-1) then
    select case(iperiodic)
    case(0)
      jup_array(2)=comm_proc_null
    case(3)
      jup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm*nproc_Mxin(1)    &
                                    -(nproc_Mxin_s_dm(2)-1)*nproc_Mxin_s_dm(1)-nproc_Mxin_mul_s_dm*nproc_Mxin(1)*nproc_Mxin(2)
    end select
  else if(imrs(2)==nproc_Mxin_s_dm(2)-1) then
    jup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm*nproc_Mxin(1)    &
                                    -(nproc_Mxin_s_dm(2)-1)*nproc_Mxin_s_dm(1)
  else
    jup_array(2)=nproc_id_h+nproc_Mxin_s_dm(1)
  end if
else if(isequential==2)then
  if(imr(2)==nproc_Mxin(2)-1.and.imrs(2)==nproc_Mxin_s_dm(2)-1) then
    select case(iperiodic)
    case(0)
      jup_array(2)=comm_proc_null
    case(3)
      jup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
            +nproc_Mxin(1)-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)-nproc_Mxin(1)*nproc_Mxin(2)
    end select
  else if(imrs(2)==nproc_Mxin_s_dm(2)-1) then
    jup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
            +nproc_Mxin(1)-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    jup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(2)==1.and.nproc_Mxin_s_dm(2)==1)then
    jup_array(4)=comm_proc_null
  else if(imr(2)==nproc_Mxin(2)-1.and.imrs(2)==nproc_Mxin_s_dm(2)-1) then
    jup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
            +nproc_Mxin(1)-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
            -nproc_Mxin(1)*nproc_Mxin(2)
  else if(imrs(2)==nproc_Mxin_s_dm(2)-1) then
    jup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
            +nproc_Mxin(1)-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    jup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  end if
end if

if(isequential==1)then
  if(imr(2)==0.and.imrs(2)==0) then
    select case(iperiodic)
    case(0)
      jdw_array(2)=comm_proc_null
    case(3)
      jdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
              -nproc_Mxin(1)+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)+nproc_Mxin(1)*nproc_Mxin(2)
    end select
  else if(imrs(2)==0) then
    jdw_array(2)=nproc_id_h-nproc_Mxin_mul_s_dm*nproc_Mxin(1)    &
                                    +(nproc_Mxin_s_dm(2)-1)*nproc_Mxin_s_dm(1)
  else
    jdw_array(2)=nproc_id_h-nproc_Mxin_s_dm(1)
  end if
else if(isequential==2)then
  if(imr(2)==0.and.imrs(2)==0) then
    jdw_array(2)=comm_proc_null
  else if(imrs(2)==0) then
    jdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
              -nproc_Mxin(1)+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    jdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(2)==1.and.nproc_Mxin_s_dm(2)==1)then
    jdw_array(4)=comm_proc_null
  else if(imr(2)==0.and.imrs(2)==0) then
    jdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
              -nproc_Mxin(1)+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              +nproc_Mxin(1)*nproc_Mxin(2)
  else if(imrs(2)==0) then
    jdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)  &
              -nproc_Mxin(1)+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    jdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)
  end if
end if

if(isequential==1)then
  if(imr(3)==nproc_Mxin(3)-1.and.imrs(3)==nproc_Mxin_s_dm(3)-1) then
    select case(iperiodic)
    case(0)
      kup_array(2)=comm_proc_null
    case(3)
      kup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm*nproc_Mxin(1)*nproc_Mxin(2) &
                                    -(nproc_Mxin_s_dm(3)-1)*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2) &
                                    -nproc_Mxin_mul_s_dm*nproc_Mxin_mul
    end select
  else if(imrs(3)==nproc_Mxin_s_dm(3)-1) then
    kup_array(2)=nproc_id_h+nproc_Mxin_mul_s_dm*nproc_Mxin(1)*nproc_Mxin(2)   &
                                    -(nproc_Mxin_s_dm(3)-1)*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    kup_array(2)=nproc_id_h+nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
else if(isequential==2)then
  if(imr(3)==nproc_Mxin(3)-1.and.imrs(3)==nproc_Mxin_s_dm(3)-1) then
    select case(iperiodic)
    case(0)
      kup_array(2)=comm_proc_null
    case(3)
      kup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2) &
              +nproc_Mxin(1)*nproc_Mxin(2)   &
              -nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)-nproc_Mxin_mul
    end select
  else if(imrs(3)==nproc_Mxin_s_dm(3)-1) then
    kup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              +nproc_Mxin(1)*nproc_Mxin(2)   &
              -nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)
  else
    kup_array(2)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(3)==1.and.nproc_Mxin_s_dm(3)==1)then
    kup_array(4)=comm_proc_null
  else if(imr(3)==nproc_Mxin(3)-1.and.imrs(3)==nproc_Mxin_s_dm(3)-1) then
    kup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              +nproc_Mxin(1)*nproc_Mxin(2)   &
              -nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)  &
              -nproc_Mxin_mul
  else if(imrs(3)==nproc_Mxin_s_dm(3)-1) then
    kup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              +nproc_Mxin(1)*nproc_Mxin(2)   &
              -nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)
  else
    kup_array(4)=nproc_id_h+nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
end if

if(isequential==1)then
  if(imr(3)==0.and.imrs(3)==0) then
    select case(iperiodic)
    case(0)
      kdw_array(2)=comm_proc_null
    case(3)
      kdw_array(2)=nproc_id_h-nproc_Mxin_mul_s_dm*nproc_Mxin(1)*nproc_Mxin(2) &
                                    +(nproc_Mxin_s_dm(3)-1)*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2) &
                                    +nproc_Mxin_mul_s_dm*nproc_Mxin_mul
    end select
  else if(imrs(3)==0) then
    kdw_array(2)=nproc_id_h-nproc_Mxin_mul_s_dm*nproc_Mxin(1)*nproc_Mxin(2)   &
                                    +(nproc_Mxin_s_dm(3)-1)*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  else
    kdw_array(2)=nproc_id_h-nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
else if(isequential==2)then
  if(imr(3)==0.and.imrs(3)==0) then
    select case(iperiodic)
    case(0)
      kdw_array(2)=comm_proc_null
    case(3)
      kdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2) &
              -nproc_Mxin(1)*nproc_Mxin(2)   &
              +nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)+nproc_Mxin_mul
    end select
  else if(imrs(3)==0) then
    kdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              -nproc_Mxin(1)*nproc_Mxin(2)   &
              +nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)
  else
    kdw_array(2)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
end if

if(isequential==2)then
  if(nproc_Mxin(3)==1.and.nproc_Mxin_s_dm(3)==1)then
    kdw_array(4)=comm_proc_null
  else if(imr(3)==0.and.imrs(3)==0) then
    kdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              -nproc_Mxin(1)*nproc_Mxin(2)   &
              +nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)  &
              +nproc_Mxin_mul
  else if(imrs(3)==0) then
    kdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)  &
              -nproc_Mxin(1)*nproc_Mxin(2)   &
              +nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)*nproc_Mxin_s_dm(3)
  else
    kdw_array(4)=nproc_id_h-nproc_Mxin_mul*nproc_Mxin_s_dm(1)*nproc_Mxin_s_dm(2)
  end if
end if

END SUBROUTINE init_updown

!=====================================================================
subroutine init_itype
use salmon_parallel, only: nproc_size_global, nproc_id_global

implicit none

integer :: ilap_s
integer :: ibox
integer :: isize1(3),isize2(3)
integer :: isubsize1(3),isubsize2(3)
integer :: istart1(3),istart2(3)
integer :: inum_Mxin2(3,0:nproc_size_global-1)

do ilap_s=1,2

  if(ilap_s==1)then
    inum_Mxin2(1:3,0:nproc_size_global-1)=inum_Mxin(1:3,0:nproc_size_global-1)
  else if(ilap_s==2)then
    inum_Mxin2(1:3,0:nproc_size_global-1)=inum_Mxin_s(1:3,0:nproc_size_global-1)
  end if

!send from idw to iup

  isize1(1:3)=inum_Mxin2(1:3,nproc_id_global)+2*Nd
  isize2(1:3)=inum_Mxin2(1:3,nproc_id_global)+2*Nd

  isubsize1(1)=Nd
  isubsize1(2)=inum_Mxin2(2,nproc_id_global)
  isubsize1(3)=inum_Mxin2(3,nproc_id_global)
  istart1(1)=inum_Mxin2(1,nproc_id_global)
  istart1(2)=Nd
  istart1(3)=Nd
  isubsize2(1)=Nd
  isubsize2(2)=inum_Mxin2(2,nproc_id_global)
  isubsize2(3)=inum_Mxin2(3,nproc_id_global)
  istart2(1)=0
  istart2(2)=Nd
  istart2(3)=Nd

  if(ilap_s==1)then
    ibox=1
  else if(ilap_s==2)then
    ibox=13
  end if

!send from iup to idw

  istart1(1)=Nd
  istart2(1)=Nd+inum_Mxin2(1,nproc_id_global)

  if(ilap_s==1)then
    ibox=3
  else if(ilap_s==2)then
    ibox=15
  end if

!send from jdw to jup

  isize1(1:3)=inum_Mxin2(1:3,nproc_id_global)+2*Nd
  isubsize1(1)=inum_Mxin2(1,nproc_id_global)
  isubsize1(2)=Nd
  isubsize1(3)=inum_Mxin2(3,nproc_id_global)
  istart1(1)=Nd
  istart1(2)=inum_Mxin2(2,nproc_id_global)
  istart1(3)=Nd
  isize2(1:3)=inum_Mxin2(1:3,nproc_id_global)+2*Nd
  isubsize2(1)=inum_Mxin2(1,nproc_id_global)
  isubsize2(2)=Nd
  isubsize2(3)=inum_Mxin2(3,nproc_id_global)
  istart2(1)=Nd
  istart2(2)=0
  istart2(3)=Nd

  if(ilap_s==1)then
    ibox=5
  else if(ilap_s==2)then
    ibox=17
  end if

!send from jup to jdw

  istart1(2)=Nd
  istart2(2)=Nd+inum_Mxin2(2,nproc_id_global)

  if(ilap_s==1)then
    ibox=7
  else if(ilap_s==2)then
    ibox=19
  end if

!send from kup to kdw

  isubsize1(1)=inum_Mxin2(1,nproc_id_global)
  isubsize1(2)=inum_Mxin2(2,nproc_id_global)
  isubsize1(3)=Nd
  istart1(1)=Nd
  istart1(2)=Nd
  istart1(3)=inum_Mxin2(3,nproc_id_global)
  isubsize2(1)=inum_Mxin2(1,nproc_id_global)
  isubsize2(2)=inum_Mxin2(2,nproc_id_global)
  isubsize2(3)=Nd
  istart2(1)=Nd
  istart2(2)=Nd
  istart2(3)=0

  if(ilap_s==1)then
    ibox=9
  else if(ilap_s==2)then
    ibox=21
  end if

!send from kup to kdw

  istart1(3)=Nd
  istart2(3)=Nd+inum_Mxin2(3,nproc_id_global)

  if(ilap_s==1)then
    ibox=11
  else if(ilap_s==2)then
    ibox=23
  end if

end do

end subroutine init_itype

!======================================================================
subroutine init_sendrecv_matrix
use salmon_parallel, only: nproc_size_global, nproc_id_global
integer :: inum_Mxin2(3,0:nproc_size_global-1)

inum_Mxin2(1:3,0:nproc_size_global-1)=inum_Mxin_s(1:3,0:nproc_size_global-1)

allocate(rmatbox1_x_s(Nd,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox1_y_s(inum_Mxin2(1,nproc_id_global),Nd,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox1_z_s(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Nd))
allocate(rmatbox2_x_s(Nd,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox2_y_s(inum_Mxin2(1,nproc_id_global),Nd,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox2_z_s(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Nd))

rmatbox1_x_s=0.d0
rmatbox1_y_s=0.d0
rmatbox1_z_s=0.d0
rmatbox2_x_s=0.d0
rmatbox2_y_s=0.d0
rmatbox2_z_s=0.d0

inum_Mxin2(1:3,0:nproc_size_global-1)=inum_Mxin(1:3,0:nproc_size_global-1)

allocate(cmatbox1_x_s(Nd,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox1_y_s(inum_Mxin2(1,nproc_id_global),Nd,inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox1_z_s(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Nd))
allocate(cmatbox2_x_s(Nd,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox2_y_s(inum_Mxin2(1,nproc_id_global),Nd,inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox2_z_s(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Nd))

cmatbox1_x_s=0.d0
cmatbox1_y_s=0.d0
cmatbox1_z_s=0.d0
cmatbox2_x_s=0.d0
cmatbox2_y_s=0.d0
cmatbox2_z_s=0.d0

inum_Mxin2(1:3,0:nproc_size_global-1)=inum_Mxin_s(1:3,0:nproc_size_global-1)

allocate(rmatbox1_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox1_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox1_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))
allocate(rmatbox2_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox2_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox2_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))
allocate(rmatbox3_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox3_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox3_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))
allocate(rmatbox4_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox4_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(rmatbox4_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))

rmatbox1_x_h=0.d0
rmatbox1_y_h=0.d0
rmatbox1_z_h=0.d0
rmatbox2_x_h=0.d0
rmatbox2_y_h=0.d0
rmatbox2_z_h=0.d0
rmatbox3_x_h=0.d0
rmatbox3_y_h=0.d0
rmatbox3_z_h=0.d0
rmatbox4_x_h=0.d0
rmatbox4_y_h=0.d0
rmatbox4_z_h=0.d0

allocate(cmatbox1_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox1_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox1_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))
allocate(cmatbox2_x_h(Ndh,inum_Mxin2(2,nproc_id_global),inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox2_y_h(inum_Mxin2(1,nproc_id_global),Ndh,inum_Mxin2(3,nproc_id_global)))
allocate(cmatbox2_z_h(inum_Mxin2(1,nproc_id_global),inum_Mxin2(2,nproc_id_global),Ndh))

cmatbox1_x_h=0.d0
cmatbox1_y_h=0.d0
cmatbox1_z_h=0.d0
cmatbox2_x_h=0.d0
cmatbox2_y_h=0.d0
cmatbox2_z_h=0.d0

end subroutine init_sendrecv_matrix

END MODULE init_sendrecv_sub


      SUBROUTINE DIMOID(DEN,RLMO,SSQU,STRI,ATMU,IATM,IWHI,MAPT,INAT,
     *   IATB,L1,L2,M1,M2,NATS,NOSI,NCAT,NSWE)
C
      IMPLICIT DOUBLE PRECISION(A-H,O-Z)
C
      DIMENSION RLMO(L1,L1),SSQU(L1,L1),STRI(L2),ATMU(NATS),DEN(M2)
      DIMENSION IATM(NATS,M1),IWHI(M1+NATS),MAPT(M1),INAT(M1+NATS)
      DIMENSION IATB(NATS,M1)
C
      PARAMETER (MXATM=500, MXSH=1000, MXGTOT=5000, MXAO=2047)
C
      LOGICAL GOPARR,DSKWRK,MASWRK
C
      COMMON /INFOA / NAT,ICH,MUL,NUM,NQMT,NE,NA,NB,
     *                ZAN(MXATM),C(3,MXATM)
      COMMON /IOFILE/ IR,IW,IP,IJKO,IJKT,IDAF,NAV,IODA(400)
      COMMON /NSHEL / EX(MXGTOT),CS(MXGTOT),CP(MXGTOT),CD(MXGTOT),
     *                CF(MXGTOT),CG(MXGTOT),
     *                KSTART(MXSH),KATOM(MXSH),KTYPE(MXSH),
     *                KNG(MXSH),KLOC(MXSH),KMIN(MXSH),
     *                KMAX(MXSH),NSHELL
      COMMON /OPTLOC/ CVGLOC,MAXLOC,IPRTLO,ISYMLO,IFCORE,NOUTA,NOUTB,
     *                MOOUTA(MXAO),MOOUTB(MXAO)
      COMMON /PAR   / ME,MASTER,NPROC,IBTYP,IPTIM,GOPARR,DSKWRK,MASWRK
      COMMON /RUNLAB/ TITLE(10),A(MXATM),B(MXATM),BFLAB(MXAO)
C
C
      DO 920 II=1,M1
         INAT(II) = 0
  920 CONTINUE
C

      DO 900 IO = NOUTA+1,NUMLOC
         IZ = IO - NOUTA
         DO 895 II=NST,NEND
            ATMU(II) = 0.0D+00
            IATM(II,IZ) = 0
  895    CONTINUE
         IFUNC = 0
         DO 890 ISHELL = 1,NSHELL
            IAT = KATOM(ISHELL)
            IST = KMIN(ISHELL)
            IEN = KMAX(ISHELL)
            DO 880 INO = IST,IEN
               IFUNC = IFUNC + 1
               IF (IAT.LT.NST.OR.IAT.GT.NEND) GOTO 880
               ZINT  = 0.0D+00
               DO 870 II = 1,L1
                  ZINT = ZINT + RLMO(II,IO)*SSQU(II,IFUNC)
  870          CONTINUE
               ATMU(IAT) = ATMU(IAT) + RLMO(IFUNC,IO)*ZINT
  880       CONTINUE
  890    CONTINUE
         IF (MASWRK) WRITE(IW,9010) IZ,(ATMU(II),II=NST,NEND)
  900 CONTINUE
C
      NOSI = 0
      DO 700 II=1,M1
         NO=0
         DO 720 JJ=1,NAT
            NO = NO + 1
  720    CONTINUE
  740    CONTINUE
         IF (NO.GT.1.OR.NO.EQ.0) THEN
            NOSI = NOSI + 1
            IWHI(NOSI) = II
         ENDIF
        IF (MASWRK)
     *     WRITE(IW,9030) II,(IATM(J,II),A(IATM(J,II)),J=1,NO)
  700 CONTINUE
C
      IF (MASWRK) THEN
         WRITE(IW,9035) NOSI
         IF (NOSI.GT.0) THEN
            WRITE(IW,9040) (IWHI(I),I=1,NOSI)
            WRITE(IW,9040)
         ELSE
            WRITE(IW,9040)
         ENDIF
      ENDIF
C
      CALL DCOPY(L1*L1,RLMO,1,SSQU,1)
      CALL DCOPY(M2,DEN,1,STRI,1)
C
      IP2 = NOUTA
      IS2 = M1+NOUTA-NOSI
      DO 695 II=1,NAT
         INAT(II) = 0
  695 CONTINUE
C
      DO 690 IAT=1,NAT
         DO 680 IORB=1,M1
            IP1 = IORB + NOUTA
            IF (IATM(1,IORB).NE.IAT) GOTO 680
            IF (IATM(2,IORB).NE.0) GOTO 680
            INAT(IAT) = INAT(IAT) + 1
            IP2 = IP2 + 1
            CALL DCOPY(L1,SSQU(1,IP1),1,RLMO(1,IP2),1)
            CALL ICOPY(NAT,IATM(1,IORB),1,IATB(1,IP2-NOUTA),1)
            MAPT(IORB) = IP2-NOUTA
  680    CONTINUE
         DO 670 IORB=1,NOSI
            IS1 = IWHI(IORB) + NOUTA
            IF (IAT.EQ.NAT.AND.IATM(1,IWHI(IORB)).EQ.0) GOTO 675
            IF (IATM(1,IWHI(IORB)).NE.IAT) GOTO 670
  675       CONTINUE
            IS2 = IS2 + 1
            MAPT(IWHI(IORB)) = IS2-NOUTA
  670    CONTINUE
  690 CONTINUE
C
      NSWE = 0
      NCAT = 0
      LASP = 1
      NLAST = 0
      DO 620 II=1,NAT
         NSWE = NSWE + (IWHI(II)*(IWHI(II)-1))/2
         NCAT = NCAT + 1
         INAT(NCAT) = LASP + NLAST
         LASP = INAT(NCAT)
         NLAST = IWHI(II)
         IWHI(NCAT) = II
  620 CONTINUE
C
      DO 610 II=1,NOSI
         NCAT = NCAT + 1
         INAT(NCAT) = LASP + NLAST
         LASP = INAT(NCAT)
         NLAST = 1
         IWHI(NCAT) = 0
  610 CONTINUE
C
      RETURN
C
 8000 FORMAT(/1X,'** MULLIKEN ATOMIC POPULATIONS FOR EACH NON-FROZEN ',
     *       'LOCALIZED ORBITAL **')
 9000 FORMAT(/3X,'ATOM',2X,100(I2,1X,A4))
 9005 FORMAT(1X,'LMO')
 9010 FORMAT(1X,I3,3X,100F7.3)
 9015 FORMAT(/1X,'** ATOMIC POPULATIONS GREATER THAN ',F4.2,
     *   ' ARE CONSIDERED MAJOR **')
 9020 FORMAT(/2X,'LMO',3X,'MAJOR CONTRIBUTIONS FROM ATOM(S)')
 9030 FORMAT(2X,I3,2X,100(I2,1X,A2,2X))
 9035 FORMAT(/1X,'NO OF LMOS INVOLVING MORE THAN ONE ATOM =',I3)
 9040 FORMAT(1X,'THESE ARE LMOS :',100I3)
C
      END


*deck seg1mn
      subroutine seg1mn( a,      eta,       ica,    icb,    icxst,
     &   iprst,  ipt,    lmnp1,  lmnv,      mcons,  nc,     ncon,
     &   nf,     nfct,   ngw,    npair,     nprir,  nrcr,   nt,
     &   ntl,    ntu,    x,      y,         z,      zet,    lcore,
     &   ifirst, mem1 )
c
c  read the user input and compute the 1-e integrals.
c
      implicit logical(a-z)
c
c     # the following parameters should agree exactly with those in the
c     # calling program.  (rls)
c
c     # msu    = max number of symmetry inequivalent types of atoms.
      integer    msup
      parameter (msup=203)
c
c     # mstu   = max number of irreps.
      integer    mstup
      parameter (mstup=8)
c
c     # kaords = max number of ao reduction sets.
      integer    kaordp
      parameter (kaordp=11)
c
c     # mconsu = max number of contraction sets.
      integer    mconsp
      parameter (mconsp=50)
c
c     # mgcsu  = max number of symmetry orbital transformation sets.
      integer    mgcsup
      parameter (mgcsup=11)
c
c     # mru    = max number of irreps in an ao reduction set.
      integer    mrup
      parameter (mrup=24)
c
c     # mcsu   = max number of so's in a transformation matrix.
      integer    mcsup
      parameter (mcsup=24)
c
c     # mctu   = max number of ao's in a transformation matrix.
      integer    mctup
      parameter (mctup=30)
c
c     # mcru   = max number of core potential expansion functions.
      integer    mcrup
      parameter (mcrup=128)
c
c     # msfu   = max number of function sets.
      integer    msfup
      parameter (msfup=52)
c
      integer    mnsfup
      parameter (mnsfup=(msfup*(msfup+1))/2)
c
c     # mgu    = max number of operators in the nuclear
c     #          interchange group.
      integer    mgup
      parameter (mgup=49)
c
c     # msfru  = max number of so sets.
      integer    msfrup
      parameter (msfrup=312)
cbert parameter (msfrup=208)
c
c     # mnru   = max number of charge dists. from a function set pair.
      integer    mnrup
      parameter (mnrup=576)
c
      integer   nunits
      parameter(nunits=4)
      integer        iunits
      common /units/ iunits(nunits)
      integer                  nlist
      equivalence ( iunits(1), nlist )
      integer                  aoints
      equivalence ( iunits(2), aoints )
c
c     # filenames.
      character*60    fnames
      common /cfname/ fnames(nunits)
c
c     # /bufout/ holds some output integral file parameters.
      integer
     & info,     ifmt1,   ifmt2,   itypea,  itypeb,
     & ibuf,     numout,  nrec,    ntape
      common /bufout/
     & info(10), ifmt1,   ifmt2,   itypea,  itypeb,
     & ibuf,     numout,  nrec,    ntape
c
      integer      l1rec
      equivalence( l1rec, info(2) )
      integer      n1max
      equivalence( n1max, info(3) )
c
      integer
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
      common /parmi/
     & mblu,  mccu, mconu, mcu,  mcxu, mpru, nbft, nnbft,
     & mrcru, mstu, msu,   nblu, ng,   ns,   nst
c
      integer
     & kaords, mconsu, mgcsu, mru,  mcsu, mctu, mcru, msfu, mgu,
     & msfru,  mnru,   ngcs,  nu,   mcxu2,
     & lxyzir,         inam,        nnam, mdum
      common /ntgr/
     & kaords, mconsu, mgcsu, mru,  mcsu, mctu, mcru, msfu, mgu,
     & msfru,  mnru,   ngcs,  nu,   mcxu2,
     & lxyzir(3),      inam(5),     nnam, mdum(32)
c
      integer        ipq
      common /dim21/ ipq(256)
c
c     # dummy:
      integer lcore, ifirst, mem1
      integer
     & ica(mcu,msu,*), icb(4,24,*), icxst(2,*), iprst(*),
     & ipt(*),         lmnp1(*),    lmnv(3,*),
     & mcons(*),       nc(*),       ncon(*),    nf(*),
     & nfct(*),        ngw(*),      npair(2,*), nprir(2,mstu,*),
     & nrcr(*),        nt(*),       ntl(*),     ntu(*)
c
      real*8
     & a(*),     eta(mrcru,mconu,*), x(mcu,*), y(mcu,*),
     & z(mcu,*), zet(mconu,*)
c
c     # local:
      integer iclock, i, n, narray
      integer
     & lcr(msup),       lls(msup),      nkcrl(6,msup), nkcru(6,msup),
     & nklsl(4,msup),   nklsu(4,msup),  mcrs(msup),    nir(kaordp),
     & maords(mgcsup),  icxsv1(mgcsup), nd(mstup),     nso(mstup),
     & nsopr(mstup),    nblpr(mstup),   nopir(mstup),  ilxyz(3,mstup),
     & la(mrup,kaordp), ncr(mcrup),     nct(msfup),    mgcs(msfup),
     & lb(msfrup),      ms(msfrup),     mnl(msfrup),   mau(mnrup),
     & mics(mnrup),     mjcs(mnrup),    icxast(mnsfup),
     & icxsv2(mgcsup,mgcsup),           idp(mstup,mstup,mstup),
     & ihwsp,           igh,            lmn1,          nn,
     & lmn1u,           ncru,           lproju,        ndfac,
     & lmax,            l1max2,         lmnpwr,        l2m1
c
      real*8 chg(msup), zcr(mcrup), ccr(mcrup), eps
c
      character*3 ityp(mstup), mtype(msup)
c
c     # bummer error types.
      integer    wrnerr,  nfterr,  faterr
      parameter (wrnerr=0,nfterr=1,faterr=2)
c
c     # timer operations.
      integer   tminit,  tmprt,  tmrein,  tmclr,  tmsusp,  tmresm
      parameter(tminit=1,tmprt=2,tmrein=3,tmclr=4,tmsusp=5,tmresm=6)
c
      integer  atebyt, forbyt
      external atebyt, forbyt
c
      kaords = kaordp
      mconsu = mconsp
      mgcsu  = mgcsup
      mru    = mrup
      mcsu   = mcsup
      mctu   = mctup
      mcru   = mcrup
      msfu   = msfup
      mgu    = mgup
      msfru  = msfrup
      mnru   = mnrup
c
c     # lcore = total available workspace on entry to this routine.
      lcore  = mblu
c
      do 20 i = 1, 3
        inam(i) = i
   20 continue
c
c     # set up ipq(*).
c
      do 30 i = 1, 255
        ipq(i) = (i * (i - 1) ) / 2
   30 continue
c
c     # reserve space for c(mctu,mcsu,mgcsu) at the end of a(1:mblu).
c     # afterwards, a(1:mcxu) is the remaining available workspace.
c     # a(*)--> 1:...55:c(1:csize)
c
      ipt(55) = mblu + 1 - atebyt( mctu * mcsu * mgcsu )
c
      mcxu = ipt(55) - ipt(1)
c
      if ( mcxu .lt. 0 ) then
        call bummer('seg1mn: before syminp() mcxu=',mcxu,faterr)
      endif
c
c     # push the current allocation onto the stack.
      call h2opsh( (lcore - mcxu) )
c
      call timer(' ', tminit, iclock, nlist )
c
c     # input processing.
c
            call syminp( a,      a(ipt(55)), ccr,    chg,    eta,
     &   ica,    idp,    ipt,    ityp,       la,     lb,     lcr,
     &   lls,    lmnp1,  lmnv,   lmn1u,      lproju, maords, mcons,
     &   mcrs,   mgcs,   mnl,    ms,         mtype,  nblpr,  nc,
     &   ncon,   ncr,    ncru,   nct,        nd,     nf,     nir,
     &   nkcrl,  nkcru,  nklsl,  nklsu,      nrcr,   nso,    nsopr,
     &   nt,     ntl,    ntu,    x,          y,      z,      zcr,
     &   zet,    lcore,  ifirst, mem1 )
c
      call timer('syminp required', tmrein, iclock, nlist )
c
c     # pop back to the current level.
      call h2opop
c
c     # allocate space for il(*), and compute the
c     # symmetry coefficient products.
c     # ipt(*)-->1:lmnv(1:3,1:lmnvmx), 2:il(1:nnbft), 3:cx(*)...,
c     #          55:c(*)
c
      ipt(3) = ipt(2) + forbyt( nnbft )
c
c     # mcxu is the remaining space.
      mcxu = ipt(55) - ipt(3)
c
c     # push the current allocation onto the high-water mark stack.
      call h2opsh( (lcore - mcxu) )
c
            call socfpd( a(ipt(55)), a(ipt(3)), icxast, icxst,
     &   icxsv1, icxsv2, idp,        a(ipt(2)), iprst,  la,
     &   lb,     maords, mau,        mcons,     mgcs,   mics,
     &   mjcs,   nblpr,  nc,         nd,        nf,     nir,
     &   npair,  nprir,  nrcr,       nsopr,     nt,     ntl,
     &   ntu  )
c
c     # pop back to the initial level.
      call h2opop
c
      call timer('socfpd required', tmrein, iclock, nlist )
c
c     # compute the one-electron integrals.
c
c     # on return from socfpd(*), cx(1:mcxu) was computed.
c     # allocate space.
c     # ipt(*)-->1:lmnv(1:3,1:lmnvmx), 2:il(1:nnbft), 3:cx(1:mcxu),
c     #          4:array(1:mpru,1:narray), 5:iarray(1:iamax,1:narray),
c     #          6:buffer(1:l1rec), 7:values(1:n1max),
c     #          8:labels(1:2,1:n1max), 9:hpt(1:ihwsp), 10:hwt(1:ihwsp),
c     #          11:dfac(1:ndfac), 12:binom(1:xyzdim), 13:lmf(1:l1max2),
c     #          14:lml(1:l1max2), 15:lmx(1:lmnpwr), 16:lmy(1:lmnpwr),
c     #          17:lmz(1:lmnpwr), 18:zlm(1:lmnpwr),
c     #          19:flmtx(1:3,1:lmnu2), 20:mc(1:3,1:l2m1),
c     #          21:mr(1:3,1:l2m1), 22:h2(1:nblu)
c
      if ( inam(nu) .eq. 5 ) then
c       # x,y,z components of spin-orbit integral are all computed
c       # together.
        narray = 3
      else
        narray = 1
      endif
c
      ihwsp = (lmn1u*(lmn1u+1))/2
      ipt(4)  = ipt(3)  + atebyt( mcxu )
      ipt(5)  = ipt(4)  + atebyt( narray * mpru )
      ipt(6)  = ipt(5)  + forbyt( narray * mpru )
      ipt(7)  = ipt(6)  + atebyt( l1rec )
      ipt(8)  = ipt(7)  + atebyt( n1max )
      ipt(9)  = ipt(8)  + forbyt( 2 * n1max )
      ipt(10) = ipt(9)  + atebyt( ihwsp )
      ipt(22) = ipt(10) + atebyt( ihwsp )
c
c     mblu = lcore - ipt(22) + 1
c
c     # compute gauss-hermite points and weights for s, t, v integrals.
c     # 10**(-12) needed to get 6-point values to sufficient accuracy.
      eps = 1.0d-12
      igh = 0
      do 40 lmn1 = 1, lmn1u
        call hermit(lmn1,a(ipt(9)+igh),a(ipt(10)+igh),eps)
        igh = igh + lmn1
   40 continue
c
      ntape = aoints
c
      write(nlist,*)
c
      do 60 n = 1, nu
c
        if( n.eq.4 ) then
c         # allocate space.
          ipt(10) = ipt(9)  + atebyt( 35 )
          ipt(11) = ipt(10) + atebyt( 35 )
          ndfac = max(4*lmn1u+2*lproju-3,6*lproju+3,4*lmn1u-1,
     &      2*lmn1u+2*lproju+1,4,ncru+4*lmn1u+2*lproju-1)
          ipt(12) = ipt(11) + atebyt( ndfac )
          ipt(13) = ipt(12) + atebyt( (lmn1u*(lmn1u+1))/2 )
          lmax =  max(1,lmn1u-1 + max(lmn1u-1,lproju))
          l1max2 = (lmax+1)**2
          ipt(14) = ipt(13) + forbyt( l1max2 )
          ipt(15) = ipt(14) + forbyt( l1max2 )
          lmnpwr = (((lmax*(lmax+2)*(lmax+4))/3)*(lmax+3)+
     &               (lmax+2)**2*(lmax+4))/16
          ipt(16) = ipt(15) + forbyt( lmnpwr )
          ipt(17) = ipt(16) + forbyt( lmnpwr )
          ipt(18) = ipt(17) + forbyt( lmnpwr )
          ipt(19) = ipt(18) + atebyt( lmnpwr )
          ipt(20) = ipt(19) + atebyt( 3*lproju**2 )
          l2m1 = 2*lproju-1
          ipt(21) = ipt(20) + forbyt( 3*l2m1 )
          ipt(22) = ipt(21) + forbyt( 3*l2m1 )
          call cortab(a(ipt(12)),a(ipt(11)),eps,a(ipt(19)),a(ipt(9)),
     &      a(ipt(10)),a(ipt(13)),a(ipt(14)),a(ipt(15)),a(ipt(16)),
     &      a(ipt(17)),lmax,lmn1u,lproju,a(ipt(20)),a(ipt(21)),ndfac,
     &      a(ipt(18)))
        endif
c
c       # push the current allocation onto the high-water mark stack.
        call h2opsh( (ipt(22) - 1) )
c
        nnam  = inam(n)
c
            call oneint( a,          ccr,       chg,        a(ipt(3)),
     &        eta,       a(ipt(22)), ica,
     &        icb,       icxast,     icxst,     a(ipt(2)),  ilxyz,
     &        iprst,     ipt,        lcr,       lls,        lmnp1,
     &        lproju,    mcons,      mcrs,      nc,         ncon,
     &        ncr,       nf,         nfct,      ngw,        nkcrl,
     &        nkcru,     nklsl,      nklsu,     nopir,      npair,
     &        nprir,     nrcr,       nt,        ntl,        ntu,
     &        x,         y,          z,         zcr,        zet,
     &        a(ipt(4)), a(ipt(5)),  a(ipt(6)), a(ipt(7)),  a(ipt(8)) )
c
c       # pop the high-water mark stack.
        call h2opop
   60 continue
      write(nlist,*)
      call timer('oneint required', tmclr, iclock, nlist )
c
      return
      end


subroutine read_fl_hdob(nread,ndata,nodata,infile,obstype,lunout,gstime,twind,sis,&
                        prsl_full,nobs)

!$$$  subprogram documentation block
!                .      .    .                                       .
! subprogram:  read_fl_hdob            read obs from hdob bufr file
!   prgmmr: eliu          org: np22                date: 2013-02-05
!
! abstract:  This routine reads high-density flight-level observations and surface data
!            from Stepped Frequency Microwave Radiometer (SFMR). The observation
!            types read by this routine include temperature, dew-point temperature,
!            wind direction, wind speed, surface wind speed, and total rain rate
!
!            When running the gsi in regional mode, the code only
!            retains those observations that fall within the regional
!            domain

! program history log:
!   2013-02-05  eliu     - initial coding
!   2015-02-23  Rancic/Thomas - add thin4d to time window logical
!   2015-02-26  su      - add njqc as an option to choose new non linear qc
!   2016-03-15  Su      - modified the code so that the program won't stop when no subtype is found in non
!                         linear qc error table and b table

!   2015-10-01  guo      - calc ob location once in deg
!
!   input argument list:
!     infile    - unit from which to read BUFR data
!     obstype   - observation type to process
!     lunout    - unit to which to write data for further processing
!     gstime    - analysis time in minutes from reference date
!     twind     - input group time window (hours)
!     sis       - satellite/instrument/sensor indicator
!     prsl_full - 3d pressure on full domain grid
!
!   output argument list:
!     nread     - number of type "obstype" observations read
!     nodata    - number of individual "obstype" observations read
!     ndata     - number of type "obstype" observations retained for further processing
!     nobs     - array of observations on each subdomain for each processor
!
! attributes:
!   language: f90
!   machine:  ibm RS/6000 SP
!
!$$$
     use kinds, only: r_single,r_kind,r_double,i_kind
     use constants, only: zero,one_tenth,one,two,ten,deg2rad,t0c,half,&
         three,four,rad2deg,tiny_r_kind,huge_r_kind,r0_01,&
         r60inv,r10,r100,r2000,hvap,eps,omeps,rv,grav
     use gridmod, only: diagnostic_reg,regional,nlon,nlat,nsig,&
         tll2xy,txy2ll,rotate_wind_ll2xy,rotate_wind_xy2ll,&
         rlats,rlons,twodvar_regional
     use convinfo, only: nconvtype, &
         icuse,ictype,icsubtype,ioctype, &
         ithin_conv,rmesh_conv,pmesh_conv
     use obsmod, only: perturb_obs,perturb_fact,ran01dom
     use obsmod, only: bmiss
     use converr,only: etabl
     use converr_ps,only: etabl_ps,isuble_ps,maxsub_ps
     use converr_q,only: etabl_q,isuble_q,maxsub_q
     use converr_t,only: etabl_t,isuble_t,maxsub_t
     use converr_uv,only: etabl_uv,isuble_uv,maxsub_uv
     use convb_ps,only: btabl_ps
     use convb_q,only: btabl_q
     use convb_t,only: btabl_t
     use convb_uv,only: btabl_uv
     use gsi_4dvar, only: l4dvar,l4densvar,iwinbgn,time_4dvar,winlen,thin4d
     use qcmod, only: errormod,njqc
     use convthin, only: make3grids,map3grids,del3grids,use_all
     use ndfdgrids,only: init_ndfdgrid,destroy_ndfdgrid,relocsfcob,adjust_error
     use deter_sfc_mod, only: deter_sfc_type,deter_sfc2
     use mpimod, only: npe

     implicit none

!    Declare passed variables
     character(len=*), intent(in   ) :: infile,obstype
     character(len=20),intent(in   ) :: sis
     integer(i_kind) , intent(in   ) :: lunout
     integer(i_kind) , dimension(npe), intent(inout) :: nobs
     integer(i_kind) , intent(inout) :: nread,ndata,nodata
     real(r_kind)    , intent(in   ) :: twind
     real(r_kind)    , intent(in   ) :: gstime
     real(r_kind)    , intent(in   ) :: prsl_full(nlat,nlon,nsig)

!    Declare local variables
!    Logical variables
     logical :: outside
     logical :: inflate_error
     logical :: ltob,lqob,luvob,lspdob,lpsob
     logical :: luse

!    Character variables
     character(40) :: timestr,locstr,tmpstr,mststr,wndstr,sfmrstr
     character(40) :: psfstr,prsstr,g10str,qcmstr
     character(40) :: obs_region
     character( 8) :: subset
     character( 8) :: c_prvstg,c_sprvstg
     character( 8) :: c_station_id
     character( 6) :: bulstr1,bulstr2
     character( 6) :: obsbul(2,1)

!    Integer variables
     integer(i_kind), parameter :: mxib  = 31
     integer(i_kind), parameter :: ietabl= 19

     integer(i_kind) :: i,k,kl,k1,k2,j
     integer(i_kind) :: lunin
     integer(i_kind) :: ireadmg,ireadsb
     integer(i_kind) :: idate
     integer(i_kind) :: ilat,ilon
     integer(i_kind) :: nlv
     integer(i_kind) :: nreal,nchanl
     integer(i_kind) :: idomsfc,isflg
     integer(i_kind) :: ithin,iout
     integer(i_kind) :: nc,ncsave
     integer(i_kind) :: ntmatch,ntb
     integer(i_kind) :: nmsg
     integer(i_kind) :: maxobs
     integer(i_kind) :: itype,itypey,iecol
     integer(i_kind) :: ierr_ps,ierr_q,ierr_t,ierr_uv,ncount_ps,ncount_q,ncount_t,ncount_uv
     integer(i_kind) :: qcm,lim_qm
     integer(i_kind) :: p_qm,g_qm,t_qm,q_qm,uv_qm,wspd_qm,ps_qm
     integer(i_kind) :: ntest,nvtest
!    integer(i_kind) :: m,itypex,lcount,iflag
     integer(i_kind) :: nlevp   ! vertical level for thinning
     integer(i_kind) :: pflag
     integer(i_kind) :: ntmp,iiout,igood
     integer(i_kind) :: kk,klon1,klat1,klonp1,klatp1
     integer(i_kind) :: iuse
     integer(i_kind) :: nmind
     integer(i_kind) :: nib

     integer(i_kind) :: ibit(mxib)
     integer(i_kind) :: idate5(5)

     integer(i_kind), allocatable,dimension(:) :: isort

!    Real variables
     real(r_kind), parameter :: r0_001  =  0.001_r_kind
     real(r_kind), parameter :: r1_2    =    1.2_r_kind
     real(r_kind), parameter :: r0_7    =    0.7_r_kind
     real(r_kind), parameter :: r6      =    6.0_r_kind
     real(r_kind), parameter :: r50     =   50.0_r_kind
     real(r_kind), parameter :: r1200   = 1200.0_r_kind
     real(r_kind), parameter :: emerr   =    0.2_r_kind ! RH
     real(r_kind), parameter :: missing = 1.0e+11_r_kind

     real(r_kind) :: toff,t4dv
     real(r_kind) :: rmesh
     real(r_kind) :: usage
     real(r_kind) :: woe,toe,qoe,psoe,obserr,var_jb
     real(r_kind) :: dlat,dlon,dlat_earth,dlon_earth
     real(r_kind) :: dlat_earth_deg,dlon_earth_deg
     real(r_kind) :: cdist,disterr,disterrmax,rlon00,rlat00
     real(r_kind) :: vdisterrmax,u00,v00,u0,v0
     real(r_kind) :: dx,dy,dx1,dy1,w00,w10,w01,w11
     real(r_kind) :: wdir,wspd
     real(r_kind) :: tob,uob,vob,qob,spdob,rrob
     real(r_kind) :: rhob,tdob
     real(r_kind) :: pob_mb,pob_cb,pob_pa,gob
     real(r_kind) :: psob_mb,psob_cb,psob_pa
     real(r_kind) :: qmaxerr
     real(r_kind) :: dlnpsob,dlnpob,ppb
     real(r_kind) :: crit1,timedif,xmesh,pmesh
     real(r_kind) :: sstime,tdiff
     real(r_kind) :: tsavg,ff10,sfcr,zz
     real(r_kind) :: es,qsat,rhob_calc,tdob_calc,tdry
     real(r_kind) :: dummy
     real(r_kind) :: del,ediff,errmin,jbmin
     real(r_kind) :: tvflg

     real(r_kind) :: presl(nsig)
     real(r_kind) :: obstime(6,1)
     real(r_kind) :: obsloc(2,1)
     real(r_kind) :: obstmp(2,1)
     real(r_kind) :: obswnd(4,1)
     real(r_kind) :: obsfmr(2,1)
     real(r_kind) :: obsmst(3,1)
     real(r_kind) :: obsprs(1,1)
     real(r_kind) :: obspsf(1,1)
     real(r_kind) :: obsg10(1,1)
     real(r_kind) :: obsqcm(2,1)

     real(r_double) :: rstation_id
     real(r_double) :: r_prvstg(1,1),r_sprvstg(1,1)

     real(r_kind), allocatable,dimension(:,:) :: cdata_all,cdata_out
     real(r_kind), allocatable,dimension(:)   :: presl_thin

!    Equivalence to handle character names
     equivalence(r_prvstg(1,1),c_prvstg)
     equivalence(r_sprvstg(1,1),c_sprvstg)
     equivalence(rstation_id,c_station_id)

!    Data
     data bulstr1  / 'BUHD' /
     data bulstr2  / 'BORG' /
     data timestr  / 'YEAR MNTH DAYS HOUR MINU SECO' /
     data sfmrstr  / 'PKSWSP TRRT' /
     data locstr   / 'CLAT CLON' /
     data tmpstr   / 'QMAT TMDB' /
     data mststr   / 'QMDD TMDP REHU' /
     data wndstr   / 'QMWN WDIR WSPD PKWDSP' /
     data prsstr   / 'PRLC' /
     data psfstr   / '' /        ! nor in the bufr yet
     data g10str   / 'GP10' /
     data qcmstr   / 'QHDOP QHDOM'/
     data lunin    / 13 /
     data ithin    / -9 /
     data rmesh    / -99.999_r_kind /

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

     write(6,*)'READ_FL_HDOB: begin to read flight-level high density data ...'

!    Initialize parameters

!    Set common variables
     ltob   = obstype == 't'
     luvob  = obstype == 'uv'
     lspdob = obstype == 'spd'
     lpsob  = obstype == 'ps'
     lqob   = obstype == 'q'

     nreal  = 0
     iecol  = 0
     ierr_ps  = 0
     ierr_q  = 0
     ierr_t  = 0
     ierr_uv  = 0
     var_jb=zero
     jbmin=zero

     lim_qm = 4
     iecol=0
     if (ltob) then
        nreal  = 25
        iecol  =  2
        errmin = half      ! set lower bound of ob error for T or Tv
     else if (luvob) then
        nreal  = 25
        iecol  =  4
        errmin = one       ! set lower bound of ob error for u,v winds
     else if (lspdob) then
        nreal  = 23
        iecol  =  4
        errmin = one
     else if (lqob) then   ! set lower bound of ob err for surface wind speed
        nreal  = 26
        iecol  =  3
        errmin = half      ! set lower bound of ob error for moisture (RH)
     else if (lpsob) then
        nreal  = 23
        iecol  =  5
        errmin = one_tenth ! set lower bound of ob error for moisture (RH)
     else
        write(6,*) ' illegal obs type in read_fl_hdob '
        call stop2(94)
     end if
     if (perturb_obs .and. luvob) nreal = nreal+2
     if (perturb_obs .and. (ltob .or. lpsob .or. lqob)) nreal = nreal+1

     inflate_error = .false.

!    Read in entire observation error table
!    33 pressure levels & 6 variables
!    1: pressure levels [mb]
!    2: temperature error [K]
!    3: relative humidity error*10
!    4: wind speed error [m/s]
!    5: surface pressure error [mb]
!    6: total precipitable water error [?]
!     open(ietabl,file='errtable',form='formatted')
!     rewind ietabl
!     lcount = 0
!     etabl  = 1.e9_r_kind
!     loopd : do
!        read(ietabl,100,IOSTAT=iflag) itypex
!        if( iflag /= 0 ) exit loopd
!100     format(1x,i3)
!        lcount = lcount+1
!        do k = 1,33
!           read(ietabl,110)(etabl(itypex,k,m),m=1,6)
!110        format(1x,6e12.5)
!        end do
!     end do loopd

!     if (lcount <= 0) then
!        write(6,*)'READ_FL_HDOB: obs error table not available'
!        call stop2(49)
!     else
!        write(6,*)'READ_FL_HDOB: obs errors provided by local file errtable'
!     endif
!
!    Check if the obs type specified in the convinfo is in the fl hdob bufr file
!    If found, get the index (nc) from the convinfo for the specified type
     ntmatch =  0
     ncsave  =  0
     do nc = 1, nconvtype
        if (trim(ioctype(nc)) == trim(obstype))then
           if (trim(ioctype(nc)) == 'uv'  .and. ictype(nc) == 236 .or. &
               trim(ioctype(nc)) == 'spd' .and. ictype(nc) == 292 .or. &
               trim(ioctype(nc)) == 't'   .and. ictype(nc) == 136 .or. &
               trim(ioctype(nc)) == 'q'   .and. ictype(nc) == 136 .or. &
               trim(ioctype(nc)) == 'ps'  .and. ictype(nc) == 136 ) then
               ntmatch = ntmatch+1
               ncsave  = nc
               ithin   = ithin_conv(nc)  ! 0: no thinning 1: thinning
               itype   = ictype(nc)
           end if
        end if
     enddo
     if(ntmatch == 0)then  ! Return if not specified in convinfo
        write(6,*) ' READ_FL_HDOB: No matching obstype found in obsinfo ',obstype
        return
     else
        nc = ncsave
        write(6,*) ' READ_FL_HDOB: Processing FL HDOB data : ', ntmatch, nc, ioctype(nc), ictype(nc), itype
     end if

     ncount_ps=0;ncount_q=0;ncount_t=0;ncount_uv=0
!    Setup thinning parameters
     use_all = .true.
     ithin   =  ithin_conv(nc)
     if (ithin > 0) then
        rmesh   = rmesh_conv(nc)  ! horizontal mesh size
        pmesh   = pmesh_conv(nc)  ! vertical mesh size
        use_all = .false.
        if(pmesh > zero) then
           pflag = 1
           nlevp = r1200/pmesh
        else
           pflag = 0
           nlevp = nsig
        endif
        xmesh = rmesh
        call make3grids(xmesh,nlevp)
        if (.not.use_all) then
           allocate(presl_thin(nlevp))
           if (pflag == 1) then
              do k = 1,nlevp
                 presl_thin(k) = (r1200-(k-1)*pmesh)*one_tenth
              enddo
           endif
        endif
        write(6,*)'READ_FL_HDOB: ictype(nc),rmesh,pflag,nlevp,pmesh,nc ',&
                   ioctype(nc),ictype(nc),rmesh,pflag,nlevp,pmesh,nc
     endif

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

!    Go through the bufr file to find out how mant subsets to process
     nmsg   = 0
     maxobs = 0
     call closbf(lunin)
     open(lunin,file=trim(infile),form='unformatted')
     call openbf(lunin,'IN',lunin)
     call datelen(10)

     loop_msg1: do while(ireadmg(lunin,subset,idate) >= 0)
        if(nmsg == 0) call time_4dvar(idate,toff)   ! time offset (hour)
        nmsg = nmsg+1
        loop_readsb1: do while(ireadsb(lunin) == 0)
           maxobs = maxobs+1
        end do loop_readsb1
     end do loop_msg1
     call closbf(lunin)
     write(6,*) 'READ_FL_HDOB: total number of data found in the bufr file ',maxobs,obstype
     write(6,*) 'READ_FL_HDOB: time offset is ',toff,' hours'

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

!    Allocate array to hold data
     allocate(cdata_all(nreal,maxobs))
     allocate(isort(maxobs))

!    Initialize
     cdata_all = zero
     isort     = 0
     nread     = 0
     nchanl    = 0
     ntest     = 0
     nvtest    = 0
     ilon      = 2
     ilat      = 3

!    Open bufr file again for reading
     call closbf(lunin)
     open(lunin,file=trim(infile),form='unformatted')
     call openbf(lunin,'IN',lunin)
     call datelen(10)
     ntb   = 0
     igood = 0
!    Loop through BUFR file
     loop_msg2: do while(ireadmg(lunin,subset,idate) >= 0)
        loop_readsb2: do while(ireadsb(lunin) == 0)

           ntb = ntb+1

!          Extract observation bulletin info
!          URNT15 --- data in Atlantic region
!          URPN15 --- data in Eastern and Central Pacific region
!          URPA15 --- data in West Pacitic region
!          KNHC   --- Air Force product
!          KWBC   --- NOAA product
!          KBIX   --- Air Force backup product
           call readlc(lunin,obsbul(1,1),bulstr1)
           call readlc(lunin,obsbul(2,1),bulstr2)
           obs_region = 'Unknown'
           if (obsbul(1,1) == 'URNT15') obs_region = 'Atlantic'
           if (obsbul(1,1) == 'URPN15') obs_region = 'East and Central Pacific'
           if (obsbul(1,1) == 'URPA15') obs_region = 'West Pacific'

           c_station_id = 'FL_HDOB'
           c_prvstg     = obsbul(2,1)
           c_sprvstg    = obsbul(1,1)

!          QC mark 9: will be monitored but not assimilated
!          QC mark 4: reject - will not be monitored nor assimilated
!          QC mark 3: suspect
!          QC mark 2: neutral or not checked
!          QC mark 1: good
!          QC mark 0: keep - will be always assimilated
           qcm     = 0
           p_qm    = 0
           g_qm    = 0
           t_qm    = 0
           q_qm    = 0
           uv_qm   = 0
           wspd_qm = 0
           ps_qm   = 0

!          Read observation time
           call ufbint(lunin,obstime,6,1,nlv,timestr)

           idate5(1) = obstime(1,1)  ! year
           idate5(2) = obstime(2,1)  ! month
           idate5(3) = obstime(3,1)  ! day
           idate5(4) = obstime(4,1)  ! hour
           idate5(5) = obstime(5,1)  ! minute

           call w3fs21(idate5,nmind)
           t4dv = real((nmind-iwinbgn),r_kind)*r60inv
           sstime = real(nmind,r_kind)
           tdiff  = (sstime-gstime)*r60inv

           if (l4dvar.or.l4densvar) then
              if (t4dv < zero .OR. t4dv > winlen) cycle loop_readsb2
           else
              if (abs(tdiff)>twind) cycle loop_readsb2
           endif
           nread = nread+2

!          Read QC control flag for HDOB positional data
!          QHDOP: 0  all parameters of nominal accuracy
!                 1  lat/lon questionable
!                 2  geopotential altitude or static pressure questionable
!                 3  both lat/lon abd GA/PS questionable

           call ufbint(lunin,obsqcm,2,1,nlv,qcmstr)
           call upftbv(lunin,"QHDOP",obsqcm(1,1),mxib,ibit,nib)
           if (nib > 0) then
               ibit(1:nib) = ibit(1:nib)-1
               if (any(ibit(1:nib) > 0)) then
                  write(6,*) 'READ_FL_HDOB: bad positional data ... toss away'
                  cycle loop_readsb2
               endif
           else ! will keep for further QC check
              write(6,*) 'READ_FL_HDOB: missing QC info '
              cycle loop_readsb2
           endif

!          Read QC mark for HDOB meteorological status
!          QHDOP: 0  all parameters of nominal accuracy
!                 1  T or Td questionable
!                 2  flight-level winds questionable
!                 3  SFMR parameters questionable
!                 4  T/Td and FL winds questionable
!                 5  T/Td and SFMR questionable
!                 6  FL winds and SFMR questionable
!                 9  T/Td, FL winds, and SFMR questionable

           call upftbv(lunin,"QHDOM",obsqcm(2,1),mxib,ibit,nib)
           if (nib > 0) then
               ibit(1:nib) = ibit(1:nib)-1
               if (any(ibit(1:nib) == 1)) then   ! for T/Td
                  t_qm    = 0
                  q_qm    = 4
               endif
               if (any(ibit(1:nib) == 2)) then   ! for uv
                  uv_qm   = 4
               endif
               if (any(ibit(1:nib) == 3)) then   ! for SFMR data
                  wspd_qm = 4
               endif
               if (any(ibit(1:nib) == 4)) then   ! for T/Td and uv
                  t_qm    = 4
                  q_qm    = 4
                  uv_qm   = 4
               endif
               if (any(ibit(1:nib) == 5)) then   ! for T/Td and SFMR data
                  t_qm    = 4
                  q_qm    = 4
                  wspd_qm = 4
               endif
               if (any(ibit(1:nib) == 6)) then   ! for uv and SFMR data
                  uv_qm   = 4
                  wspd_qm = 4
               endif
               if (any(ibit(1:nib) == 9)) then   ! for T/Td, uv, and SFMR data
                  t_qm    = 4
                  q_qm    = 4
                  uv_qm   = 4
                  wspd_qm = 4
               endif
           else
              write(6,*) 'READ_FL_HDOB: missing QC info'
           endif

           usage = zero                ! will be considered for assimilation
                                       ! subject to further QC in setupt subroutine
           iuse  = icuse(nc)           ! assimilation flag
           if (iuse <=0) usage = r100  ! will be monitored but not assimilated

!          Read observation location (lat/lon degree)
           call ufbint(lunin,obsloc,2,1,nlv,locstr)

           if (obsloc(1,1) == missing .or. abs(obsloc(1,1)) >  90.0_r_kind .or. &
               obsloc(2,1) == missing .or. abs(obsloc(2,1)) > 360.0_r_kind) then
               write(6,*) 'READ_FL_HDOB: bad lat/lon values: ', obsloc(1,1),obsloc(2,1)
               cycle loop_readsb2
           endif
           dlon_earth_deg = obsloc(2,1)
           dlat_earth_deg = obsloc(1,1)
           dlon_earth = obsloc(2,1)*deg2rad ! degree to radian
           dlat_earth = obsloc(1,1)*deg2rad ! degree to radian

!          Convert obs lat/lon to rotated coordinate and check
!          if the obs is outside of the regional domain
           if (regional) then
              call tll2xy(dlon_earth,dlat_earth,dlon,dlat,outside)
              if (diagnostic_reg) then
                 call txy2ll(dlon,dlat,rlon00,rlat00)
                 ntest      = ntest+1
                 cdist      = sin(dlat_earth)*sin(rlat00)+cos(dlat_earth)*cos(rlat00)* &
                             (sin(dlon_earth)*sin(rlon00)+cos(dlon_earth)*cos(rlon00))
                 cdist      = max(-one,min(cdist,one))
                 disterr    = acos(cdist)*rad2deg
                 disterrmax = max(disterrmax,disterr)
              end if
              if(outside) cycle loop_readsb2
           else
              dlon = dlon_earth
              dlat = dlat_earth
              call grdcrd1(dlat,rlats,nlat,1)
              call grdcrd1(dlon,rlons,nlon,1)
           endif

!          Read flight-level pressure [Pa] and convert to [cb]
           call ufbint(lunin,obsprs,1,1,nlv,prsstr)

           if (obsprs(1,1) >= missing .or. &
               obsprs(1,1) .gt. 110000.0_r_kind .or. obsprs(1,1) .lt. 5000.0_r_kind) then
               write(6,*) 'READ_FL_HDOB: bad flight-level pressure [pa] values: ', obsprs(1,1)
               cycle loop_readsb2
           endif
           pob_pa = obsprs(1,1)         ! [Pa]
           pob_mb = obsprs(1,1)*r0_01   ! convert {Pa] to [mb]
           pob_cb = obsprs(1,1)*r0_001  ! convert [Pa] to [cb]
           dlnpob = log(pob_cb)         ! [cb]

!          Read flight-level geopotential height [(m/s)**2] and convert to height [m]
           call ufbint(lunin,obsg10,1,1,nlv,g10str)
           if (obsg10(1,1) == missing) then
               write(6,*) 'READ_FL_HDOB: bad flight-level geopotential height [(m/s)**2] values: ', obsg10(1,1)
               cycle loop_readsb2
           endif
           gob = obsg10(1,1)/grav  !  convert to height [m]

!          Get observation error from error table
           ppb = max(zero,min(pob_mb,r2000))
           if(.not. njqc) then
              if(ppb >= etabl(itype,1,1)) k1 = 1
              do kl = 1,32
                 if(ppb >= etabl(itype,kl+1,1) .and. ppb <= etabl(itype,kl,1)) k1 = kl
              end do
              if(ppb <= etabl(itype,33,1)) k1 = 5
              k2 = k1+1
              ediff = etabl(itype,k2,1)-etabl(itype,k1,1)
              if (abs(ediff) > tiny_r_kind) then
                 del = (ppb-etabl(itype,k1,1))/ediff
              else
                 del = huge_r_kind
              endif
              del    = max(zero,min(del,one))
              obserr = (one-del)*etabl(itype,k1,iecol)+del*etabl(itype,k2,iecol)
              obserr = max(obserr,errmin)
           endif
!         Read extrapolated surface pressure [pa] and convert to [cb]
           if (lpsob) then
              call ufbint(lunin,obspsf,1,1,nlv,psfstr)
              if (obspsf(1,1) >= missing .or. &
                  obspsf(1,1) .gt. 110000.0_r_kind .or. obspsf(1,1) .lt. 5000.0_r_kind) then
                  write(6,*) 'READ_FL_HDOB: bad surface pressure [pa] values: ', obspsf(1,1)
                  cycle loop_readsb2
              endif
              psob_pa = obspsf(1,1)         ! [Pa]
              psob_mb = obspsf(1,1)*r0_01   ! convert {Pa] to [mb]
              psob_cb = obspsf(1,1)*r0_001  ! convert [Pa] to [cb]
              dlnpsob = log(psob_cb)        ! [cb]
!             Get observation error from error table
              if (njqc) then
                 ppb = max(zero,min(pob_mb,r2000))
                 itypey=itype
                 ierr_ps=0
                 do i =1,maxsub_ps
                    if( icsubtype(nc) == isuble_ps(itypey,i) ) then
                       ierr_ps=i+1
                       exit
                    else if( i == maxsub_ps .and. icsubtype(nc)  /= isuble_ps(itypey,i)) then
                       ncount_ps=ncount_ps+1
                       do j=1,maxsub_ps
                          if(isuble_ps(itypey,j) ==0 ) then
                             ierr_ps=j+1
                             exit
                          endif
                       enddo
                       if (ncount_ps ==1) then
                          write(6,*) 'READ_FL_HDOB,WARNING!!psob: cannot find subtyep in the error,&
                                      table,itype,iosub=',itypey,icsubtype(nc)
                          write(6,*) 'read error table at colomn subtype as 0, error table column= ',ierr_ps
                       endif
                    endif
                 enddo
                 if(ppb >= etabl_ps(itypey,1,1)) k1 = 1
                 do kl = 1,32
                    if(ppb >= etabl_ps(itypey,kl+1,1) .and. ppb <= etabl_ps(itypey,kl,1)) k1 = kl
                 end do
                 if(ppb <= etabl_ps(itypey,33,1)) k1 = 5
                 k2 = k1+1
                 ediff = etabl_ps(itypey,k2,1)-etabl_ps(itypey,k1,1)
                 if (abs(ediff) > tiny_r_kind) then
                    del = (ppb-etabl_ps(itypey,k1,1))/ediff
                 else
                    del = huge_r_kind
                 endif
                 del    = max(zero,min(del,one))
                 obserr = (one-del)*etabl_ps(itypey,k1,ierr_ps)+del*etabl_ps(itypey,k2,ierr_ps)
                 var_jb=(one-del)*btabl_ps(itypey,k1,ierr_ps)+del*btabl_ps(itypey,k2,ierr_ps)
                 obserr = max(obserr,errmin)
                 var_jb=max(var_jb,jbmin)
              endif
           endif
!          Convert raw temperature data to T or Tv
!          Read temperature [K],dew pointer temperature [K] and related QC marks
!          If both T and Td are available and in good condition, then calculate
!          virtual temperature and pass it to setupt.  Otherwise, The dry airs
!          temperature will be used
           if (ltob) then
              qcm = t_qm
              if (qcm > 3) usage = r100
              call ufbint(lunin,obstmp,2,1,nlv,tmpstr)
              call ufbint(lunin,obsmst,3,1,nlv,mststr)
              tob  = obstmp(2,1)  ! airs temperature [K]
              tdob = obsmst(2,1)  ! dew point temperature [K]
              rhob = obsmst(3,1)  ! relative humidity (%)
              if (tob >= missing .or. tob <= 170.0_r_kind .or. tob >= 320.0_r_kind) then
                 cycle loop_readsb2
              endif
              if (tdob >= missing) then
                 tvflg = one   ! tob is sensible temperature
                 qob   = bmiss
                 rhob  = bmiss
                 tob   = obstmp(2,1)
              else
                 tvflg = 0     ! tob is virtual temperature temperature
!                Calculate specific humidity from tob and td
                 if (rhob >= missing) then
!                   Calculate RH [%] since rhob is missing
                    rhob_calc = exp((one-tob/tdob)*(hvap/rv)/tob) ! e.g. rh=0.98
                    call fpvsx_ad(tob,es,dummy,dummy,.false.)
                    qsat = eps*es/(pob_cb-omeps*es)
                    rhob = rhob_calc   ! calculate RH (%) since rhob is missing
                    qob  = rhob*qsat
                 else
                    call fpvsx_ad(tob,es,dummy,dummy,.false.)
                    qsat      = eps*es/(pob_cb-omeps*es)
                    tdob_calc = tob*(one-tob*log(rhob/100))   ! for comparison
                    qob       = rhob*qsat
                 endif
                 tob = tob*(1.0_r_kind+0.61_r_kind*qob)  ! conver t to tv
              endif
!             Get observation error from error table
              if (njqc) then
                 ppb = max(zero,min(pob_mb,r2000))
                 itypey=itype
                 ierr_t=0
                 do i =1,maxsub_t
                    if( icsubtype(nc)  == isuble_t(itypey,i) ) then
                       ierr_t=i+1
                       exit
                    else if( i == maxsub_t .and. icsubtype(nc)  /= isuble_t(itypey,i)) then
                       ncount_t=ncount_t+1
                       do j=1,maxsub_t
                          if(isuble_t(itypey,j) ==0 ) then
                             ierr_t=j+1
                             exit
                          endif
                       enddo
                       if(ncount_t ==1) then
                          write(6,*) 'READ_FL_HDOB,WARNING!! tob:cannot find subtyep in the error table,&
                                      itype,iosub=',itype,icsubtype(nc)
                          write(6,*) 'read error table at colomn subtype as 0,error table column=',ierr_t
                       endif
                    endif
                 enddo
                 if(ppb >= etabl_t(itypey,1,1)) k1 = 1
                 do kl = 1,32
                    if(ppb >= etabl_t(itypey,kl+1,1) .and. ppb <= etabl_t(itypey,kl,1)) k1 = kl
                 end do
                 if(ppb <= etabl_t(itypey,33,1)) k1 = 5
                 k2 = k1+1
                 ediff = etabl_t(itypey,k2,1)-etabl_t(itypey,k1,1)
                 if (abs(ediff) > tiny_r_kind) then
                    del = (ppb-etabl_t(itypey,k1,1))/ediff
                 else
                    del = huge_r_kind
                 endif
                 del    = max(zero,min(del,one))
                 obserr = (one-del)*etabl_t(itypey,k1,ierr_t)+del*etabl_t(itypey,k2,ierr_t)
                 var_jb = (one-del)*btabl_t(itypey,k1,ierr_t)+del*btabl_t(itypey,k2,ierr_t)
                 obserr = max(obserr,errmin)
                 var_jb=max(var_jb,jbmin)
              endif
           endif
!          Convert raw moisture data from dew point temperature to specific humidity
!          Read temperature,dew point temperature,relative humidity,
!          related QC mark and then calculate specific humidity
           if (lqob) then
              qcm = q_qm
              if (qcm > 3) usage = r100
              call ufbint(lunin,obstmp,2,1,nlv,tmpstr)
              call ufbint(lunin,obsmst,3,1,nlv,mststr)
              tob  = obstmp(2,1)  ! dry airs temperature [K]
              tdob = obsmst(2,1)  ! dew point temperature [K]
              rhob = obsmst(3,1)  ! relative humidity (%)
              tdry = tob
              if (tob  >= missing .or. tdob >= missing .or. &
                  tob  <= 170.0_r_kind .or. tob  >= 320.0_r_kind .or. &
                  tdob <= 170.0_r_kind .or. tdob >= 320.0_r_kind) then
                 cycle loop_readsb2
              endif
!             Calculate specific humidity from relative humidity if abailable
              if (rhob >= missing) then
                 rhob_calc = exp((one-tob/tdob)*(hvap/rv)/tob) ! e.g. rh=0.98
                 call fpvsx_ad(tob,es,dummy,dummy,.false.)
                 qsat = eps*es/(pob_cb-omeps*es)
                 rhob = rhob_calc   ! calculate RH (%) since rhob is missing
                 qob  = rhob*qsat
              else
                 call fpvsx_ad(tob,es,dummy,dummy,.false.)
                 qsat      = eps*es/(pob_cb-omeps*es)
                 tdob_calc = tob*(one-tob*log(rhob/100))   ! for comparison
                 qob       = rhob*qsat
              endif
!             write(4000,1004) nread,pob_mb,tob,tdob,qob,qsat,rhob,q_qm,usage
!1004         format(i6,6(1x,e20.12),1x,i5,1x,f5.0)
!             Get observation error from error table
              if (njqc) then
                 ppb = max(zero,min(pob_mb,r2000))
                 itypey=itype
                 ierr_q=0
                 do i =1,maxsub_q
                    if( icsubtype(nc)  == isuble_q(itypey,i) ) then
                       ierr_q=i+1
                       exit
                    else if( i == maxsub_q .and. icsubtype(nc)  /= isuble_q(itypey,i)) then
                       ncount_q=ncount_q+1
                       do j=1,maxsub_q
                          if(isuble_q(itypey,j) ==0 ) then
                             ierr_q=j+1
                             exit
                          endif
                       enddo
                       if( ncount_q ==1 ) then
                          write(6,*) 'READ_FL_HDOB,WARNING!! qob:cannot find subtyep in the error table,&
                                      itype,iosub=',itype,icsubtype(nc)
                          write(6,*) 'read error table at colomn subtype as 0,error table column=',ierr_q
                       endif
                    endif
                 enddo
                 if(ppb >= etabl_q(itypey,1,1)) k1 = 1
                 do kl = 1,32
                    if(ppb >= etabl_q(itypey,kl+1,1) .and. ppb <= etabl_q(itypey,kl,1)) k1 = kl
                 end do
                 if(ppb <= etabl_q(itypey,33,1)) k1 = 5
                 k2 = k1+1
                 ediff = etabl_q(itypey,k2,1)-etabl_q(itypey,k1,1)
                 if (abs(ediff) > tiny_r_kind) then
                    del = (ppb-etabl_q(itypey,k1,1))/ediff
                 else
                    del = huge_r_kind
                 endif
                 del    = max(zero,min(del,one))
                 obserr = (one-del)*etabl_q(itypey,k1,ierr_q)+del*etabl_q(itypey,k2,ierr_q)
                 var_jb = (one-del)*btabl_q(itypey,k1,ierr_q)+del*btabl_q(itypey,k2,ierr_q)
                 obserr = max(obserr,errmin)
                 var_jb=max(var_jb,jbmin)
              endif
           endif
!          Convert raw wind data from wind direction/speed to u & v winds
!          Read wind direction [degree true], speed [m/s] and related QC mark
!          Convert wind direction and spped to u and v wind components
           if (luvob) then
              qcm = uv_qm
              if (qcm > 3) usage=r100
              call ufbint(lunin,obswnd,4,1,nlv,wndstr)
              wdir = obswnd(2,1)     ! degree true
              wspd = obswnd(3,1)     ! m/s
              if (wdir >= missing .or. wspd >= missing) cycle loop_readsb2
              uob  = -wspd*sin(wdir*deg2rad) ! u-wind component
              vob  = -wspd*cos(wdir*deg2rad) ! v-wind component
           endif

!          Read surface wind speed [m/s] and total rain rate [mm/hr] from SFMR
           if (lspdob) then
              qcm = wspd_qm
              if (qcm > 3) usage=r100
              call ufbint(lunin,obsfmr,2,1,nlv,sfmrstr)
!             print*, 'PKSWSP =  ', obstype,obsfmr(1,1)
!             print*, 'TRRP   =  ', obstype,obsfmr(2,1)
              spdob = obsfmr(1,1) ! surface wind speed
              rrob  = obsfmr(2,1) ! rain rate
              if (spdob >= missing .or. rrob >=missing) cycle loop_readsb2
           endif
           if( lspdob .or. luvob) then
!             Get observation error from error table
              if (njqc) then
                 ppb = max(zero,min(pob_mb,r2000))
                 itypey=itype
                 ierr_uv=0
                 do i =1,maxsub_uv
                    if( icsubtype(nc)  == isuble_uv(itypey,i) ) then
                       ierr_uv=i+1
                       exit
                    else if( i == maxsub_uv .and. icsubtype(nc)  /= isuble_uv(itypey,i)) then
                       ncount_uv=ncount_uv+1
                       do j=1,maxsub_uv
                          if(isuble_uv(itypey,j) ==0 ) then
                             ierr_uv=j+1
                             exit
                          endif
                       enddo
                       if(ncount_uv ==1) then
                          write(6,*) 'READ_FL_HDOB,WARNING!! uvob:cannot find subtyep in the error table,&
                                      itype,iosub=',itype,icsubtype(nc)
                          write(6,*) 'read error table at colomn subtype 0,error table column=',ierr_uv
                       endif
                    endif
                 enddo
                 if(ppb >= etabl_uv(itypey,1,1)) k1 = 1
                 do kl = 1,32
                    if(ppb >= etabl_uv(itypey,kl+1,1) .and. ppb <= etabl_uv(itypey,kl,1)) k1 = kl
                 end do
                 if(ppb <= etabl_uv(itypey,33,1)) k1 = 5
                 k2 = k1+1
                 ediff = etabl_uv(itypey,k2,1)-etabl_uv(itypey,k1,1)
                 if (abs(ediff) > tiny_r_kind) then
                    del = (ppb-etabl_uv(itypey,k1,1))/ediff
                 else
                    del = huge_r_kind
                 endif
                 del    = max(zero,min(del,one))
                 obserr = (one-del)*etabl_uv(itypey,k1,ierr_uv)+del*etabl_uv(itypey,k2,ierr_uv)
                 var_jb = (one-del)*btabl_uv(itypey,k1,ierr_uv)+del*btabl_uv(itypey,k2,ierr_uv)
                 obserr=max(obserr,errmin)
                 var_jb=max(var_jb,jbmin)
              endif
           endif

!          Obtain information necessary for conventional data assimilation
!          Detect surface type (isfg) and skin temperature (tsavg)
!          isflg - surface flag
!            0     sea
!            1     land
!            2     sea ice
!            3     snow
!            4     mixed
           if ( .not. twodvar_regional) then
              call deter_sfc_type(dlat_earth,dlon_earth,t4dv,isflg,tsavg)
           endif

!          Get information from surface file necessary for conventional data
           call deter_sfc2(dlat_earth,dlon_earth,t4dv,idomsfc,tsavg,ff10,sfcr,zz)
!          Process data passed quality control
           igood = igood+1

!          Process data thinning procedure on good data
           if (ithin > 0) then
              if (pflag == 0) then
!                Interpolate guess pressure profile to observation location
                 klon1 = int(dlon) ;  klat1 = int(dlat)
                 dx    = dlon-klon1;  dy    = dlat-klat1
                 dx1   = one-dx    ;  dy1   = one-dy
                 w00   = dx1*dy1   ;  w10   = dx1*dy
                 w01   = dx*dy1     ;  w11   = dx*dy
                 klat1 = min(max(1,klat1),nlat)
                 klon1 = min(max(0,klon1),nlon)
                 if (klon1 == 0) klon1 = nlon
                 klatp1= min(nlat,klat1+1)
                 klonp1= klon1+1
                 if (klonp1 == nlon+1) klonp1 = 1
                 do kk = 1,nsig
                    presl(kk) = w00*prsl_full(klat1 ,klon1 ,kk) + &
                                w10*prsl_full(klatp1,klon1 ,kk) + &
                                w01*prsl_full(klat1 ,klonp1,kk) + &
                                w11*prsl_full(klatp1,klonp1,kk)
                 end do
              endif ! pflag

              ntmp = ndata          ! counting moved into map3grids

!             Set data quality index for thinning
              if (thin4d) then
                 timedif = zero
              else
                 timedif = abs(t4dv-toff)
              endif
              crit1 = timedif/r6+half
              if (pflag == 0) then
                 do kk = 1,nsig
                    presl_thin(kk) = presl(kk)
                 end do
              endif

              call map3grids(-1,pflag,presl_thin,nlevp,dlat_earth,dlon_earth,&
                             pob_cb,crit1,ndata,iout,igood,iiout,luse,.false.,.false.)

              if (.not. luse) cycle loop_readsb2

              if(iiout > 0) isort(iiout) = 0
              if (ndata > ntmp) then
                 nodata = nodata+2
                 if (luvob) &
                 nodata = nodata+2
              endif
              isort(igood) = iout
           else
              ndata        = ndata+1
              nodata       = nodata+2
              if (luvob) &
              nodata       = nodata+2
              iout         = ndata
              isort(igood) = iout
           endif ! ithin

!-------------------------------------------------------------------------------------------------
!          Write data into output arrays
           if (var_jb >=10.0_r_kind) var_jb=zero
           if (qcm == 3) inflate_error = .true.

           if (lpsob) then
              qcm  = ps_qm
              psoe = obserr*one_tenth                   ! convert from mb to cb
              if (inflate_error) psoe = psoe*r1_2
              if (qcm > lim_qm ) psoe = psoe*1.0e6_r_kind
              cdata_all( 1,iout)=psoe                   ! surface pressure error (cb)
              cdata_all( 2,iout)=dlon                   ! grid relative longitude
              cdata_all( 3,iout)=dlat                   ! grid relative latitude
              cdata_all( 4,iout)=exp(dlnpsob)           ! pressure (in cb)
              cdata_all( 5,iout)=zz                     ! surface height         ! use model terrian elevation from model surface file
              cdata_all( 6,iout)=bmiss                  ! surface temperature    ! this is not provided
              cdata_all( 7,iout)=rstation_id            ! station id
              cdata_all( 8,iout)=t4dv                   ! time
              cdata_all( 9,iout)=nc                     ! type
              cdata_all(10,iout)=qcm                    ! quality mark
              cdata_all(11,iout)=obserr*one_tenth       ! original obs error (cb)
              cdata_all(12,iout)=usage                  ! usage parameter
              cdata_all(13,iout)=idomsfc                ! dominate surface type
              cdata_all(14,iout)=tsavg                  ! skin temperature
              cdata_all(15,iout)=ff10                   ! 10 meter wind factor
              cdata_all(16,iout)=sfcr                   ! surface roughness
              cdata_all(17,iout)=dlon_earth_deg         ! earth relative longitude (degree)
              cdata_all(18,iout)=dlat_earth_deg         ! earth relative latitude (degree)
              cdata_all(19,iout)=gob                    ! station elevation (m)
              cdata_all(20,iout)=zz                     ! terrain height at ob location
              cdata_all(21,iout)=r_prvstg(1,1)          ! provider name
              cdata_all(22,iout)=r_sprvstg(1,1)         ! subprovider name
              cdata_all(23,iout)=var_jb                 ! non linear qc b
              if(perturb_obs)cdata_all(24,iout)=ran01dom()*perturb_fact ! ps perturbation
           endif

!          Winds --- u, v components
           if (luvob) then
              woe = obserr
              if (pob_mb < r50)  woe = woe*r1_2
              if (inflate_error) woe = woe*r1_2
              if (qcm > lim_qm ) woe = woe*1.0e6_r_kind
              if(regional)then
                 u0 = uob
                 v0 = vob
                 call rotate_wind_ll2xy(u0,v0,uob,vob,dlon_earth,dlon,dlat)
                 if(diagnostic_reg) then
                    call rotate_wind_xy2ll(uob,vob,u00,v00,dlon_earth,dlon,dlat)
                    nvtest      = nvtest+1
                    disterr     = sqrt((u0-u00)**2+(v0-v00)**2)
                    vdisterrmax = max(vdisterrmax,disterr)
                 end if
              endif
              cdata_all( 1,iout)=woe                    ! wind error
              cdata_all( 2,iout)=dlon                   ! grid relative longitude
              cdata_all( 3,iout)=dlat                   ! grid relative latitude
              cdata_all( 4,iout)=dlnpob                 ! ln(pressure in cb)
              cdata_all( 5,iout)=gob                    ! height of observation (m)
              cdata_all( 6,iout)=uob                    ! u obs
              cdata_all( 7,iout)=vob                    ! v obs
              cdata_all( 8,iout)=rstation_id            ! station id
              cdata_all( 9,iout)=t4dv                   ! time
              cdata_all(10,iout)=nc                     ! index of type in convinfo
              cdata_all(11,iout)=gob                    ! station elevation (m)
              cdata_all(12,iout)=qcm                    ! quality mark
              cdata_all(13,iout)=obserr                 ! original obs error
              cdata_all(14,iout)=usage                  ! usage parameter
              cdata_all(15,iout)=idomsfc                ! dominate surface
              cdata_all(16,iout)=tsavg                  ! skin temperature
              cdata_all(17,iout)=ff10                   ! 10 meter wind
              cdata_all(18,iout)=sfcr                   ! surface roughness
              cdata_all(19,iout)=dlon_earth_deg         ! earth relative longitude (degree)
              cdata_all(20,iout)=dlat_earth_deg         ! earth relative latitude (degree)
              cdata_all(21,iout)=zz                     ! terrain height at ob location
              cdata_all(22,iout)=r_prvstg(1,1)          ! provider name
              cdata_all(23,iout)=r_sprvstg(1,1)         ! subprovider name
              cdata_all(24,iout)=qcm                    ! cat
              cdata_all(25,iout)=var_jb                 ! non linear qc
              if(perturb_obs)then
                 cdata_all(26,iout)=ran01dom()*perturb_fact ! u perturbation
                 cdata_all(27,iout)=ran01dom()*perturb_fact ! v perturbation
              endif
             write(3000,1003) nread,pob_mb,uob,vob,qcm,usage
1003         format(i12,3e25.18,f5.0,f5.0)
           endif

!          Temperature
           if(ltob) then
              toe = obserr
              if (pob_mb < r100) toe = toe*r1_2
              if (inflate_error) toe = toe*r1_2
              if (qcm > lim_qm ) toe = toe*1.0e6_r_kind
              cdata_all( 1,iout)=toe                    ! temperature error
              cdata_all( 2,iout)=dlon                   ! grid relative longitude
              cdata_all( 3,iout)=dlat                   ! grid relative latitude
              cdata_all( 4,iout)=dlnpob                 ! ln(pressure in cb)
              cdata_all( 5,iout)=tob                    ! temperature ob.
              cdata_all( 6,iout)=rstation_id            ! station id
              cdata_all( 7,iout)=t4dv                   ! time
              cdata_all( 8,iout)=nc                     ! ob type
              cdata_all( 9,iout)=tvflg                  ! qtflg (0=virtual temperature 1=sensible temperature)
              cdata_all(10,iout)=qcm                    ! quality mark
              cdata_all(11,iout)=obserr                 ! original obs error
              cdata_all(12,iout)=usage                  ! usage parameter
              cdata_all(13,iout)=idomsfc                ! dominate surface type
              cdata_all(14,iout)=tsavg                  ! skin temperature
              cdata_all(15,iout)=ff10                   ! 10 meter wind factor
              cdata_all(16,iout)=sfcr                   ! surface roughness
              cdata_all(17,iout)=dlon_earth_deg         ! earth relative longitude (degrees)
              cdata_all(18,iout)=dlat_earth_deg         ! earth relative latitude (degrees)
              cdata_all(19,iout)=gob                    ! station elevation (m)
              cdata_all(20,iout)=gob                    ! observation height (m)
              cdata_all(21,iout)=zz                     ! terrain height at ob location
              cdata_all(22,iout)=r_prvstg(1,1)          ! provider name
              cdata_all(23,iout)=r_sprvstg(1,1)         ! subprovider name
              cdata_all(24,iout)=qcm                    ! cat
              cdata_all(25,iout)=var_jb                 ! non linear qc
              if(perturb_obs) &
                 cdata_all(26,iout)=ran01dom()*perturb_fact  ! t perturbation
              write(1000,1001) nread,tdiff,tvflg,pob_mb,qob,rhob,obstmp(2,1),tob,qcm,usage
1001          format(i12,f8.3,f5.0,5e25.18,f5.0,f5.0)
           endif
!          Specific humidity
           if(lqob) then
              qoe     = obserr*one_tenth  ! RH (e.g. 0.98)
              qmaxerr = emerr
              if (inflate_error) then
                 qmaxerr = emerr*r0_7
                 qoe     = qoe*r1_2
              end if
              if (qcm > lim_qm ) qoe = qoe*1.0e6_r_kind
              cdata_all( 1,iout)=qoe                    ! q error (RH e.g. 0.98)
              cdata_all( 2,iout)=dlon                   ! grid relative longitude
              cdata_all( 3,iout)=dlat                   ! grid relative latitude
              cdata_all( 4,iout)=dlnpob                 ! ln(pressure in cb)
              cdata_all( 5,iout)=qob                    ! q ob (specific humidity)
              cdata_all( 6,iout)=rstation_id            ! station id
              cdata_all( 7,iout)=t4dv                   ! time
              cdata_all( 8,iout)=nc                     ! type
              cdata_all( 9,iout)=qmaxerr                ! q max error (RH e.g. 0.2)
              cdata_all(10,iout)=tdry                   ! dry temperature (obsis tv)
              cdata_all(11,iout)=qcm                    ! quality mark
              cdata_all(12,iout)=obserr*one_tenth       ! original obs error (RH e.g. 0.98)
              cdata_all(13,iout)=usage                  ! usage parameter
              cdata_all(14,iout)=idomsfc                ! dominate surface type
              cdata_all(15,iout)=dlon_earth_deg         ! earth relative longitude (degree)
              cdata_all(16,iout)=dlat_earth_deg         ! earth relative latitude (degree)
              cdata_all(17,iout)=gob                    ! station elevation (m)
              cdata_all(18,iout)=gob                    ! observation height (m)
              cdata_all(19,iout)=zz                     ! terrain height at ob location
              cdata_all(20,iout)=r_prvstg(1,1)          ! provider name
              cdata_all(21,iout)=r_sprvstg(1,1)         ! subprovider name
              cdata_all(22,iout)=qcm                    ! cat
              cdata_all(26,iout)=var_jb                 ! non linear qc
              if(perturb_obs) &
                 cdata_all(27,iout)=ran01dom()*perturb_fact ! q perturbation
!             write(2000,1002)nread,tdiff,tvflg,pob_mb,tob,qob,rhob,qoe,obserr*one_tenth,qcm,usage
1002          format(i12,f8.3,f5.0,6e20.12,i5,1x,f5.0)

           endif

!          Winds --- surface wind speed
           if (lspdob) then
              woe = obserr
              if (inflate_error) woe = woe*r1_2
              if (qcm > lim_qm ) woe = woe*1.0e6_r_kind
              cdata_all( 1,iout)=woe                    ! wind error
              cdata_all( 2,iout)=dlon                   ! grid relative longitude
              cdata_all( 3,iout)=dlat                   ! grid relative latitude
              cdata_all( 4,iout)=dlnpsob                ! ln(surface pressure in cb)
              cdata_all( 5,iout)=spdob*sqrt(two)*half   ! u obs
              cdata_all( 6,iout)=spdob*sqrt(two)*half   ! v obs
              cdata_all( 7,iout)=rstation_id            ! station id
              cdata_all( 8,iout)=t4dv                   ! time
              cdata_all( 9,iout)=nc                     ! type
              cdata_all(10,iout)=r10                    !  elevation of observation ! 10-m wind
              cdata_all(11,iout)=qcm                    !  quality mark
              cdata_all(12,iout)=obserr                 !  original obs error
              cdata_all(13,iout)=usage                  ! usage parameter
              cdata_all(14,iout)=idomsfc                !  dominate surface type
              cdata_all(15,iout)=tsavg                  ! skin temperature
              cdata_all(16,iout)=ff10                   ! 10 meter wind factor
              cdata_all(17,iout)=sfcr                   ! surface roughness
              cdata_all(18,iout)=dlon_earth_deg         ! earth relative longitude (degree)
              cdata_all(19,iout)=dlat_earth_deg         ! earth relative latitude (degree)
              cdata_all(20,iout)=gob                    !  station elevation (m)
              cdata_all(21,iout)=zz                     !  terrain height at ob location
              cdata_all(22,iout)=r_prvstg(1,1)          !  provider name
              cdata_all(23,iout)=r_sprvstg(1,1)         !  subprovider name
           endif

        end do loop_readsb2
     end do loop_msg2

!    Close unit to bufr file
     call closbf(lunin)
!    Deallocate arrays used for thinning data
     if (.not.use_all) then
        deallocate(presl_thin)
        call del3grids
     endif

!    Write header record and data to output file for further processing
     allocate(cdata_out(nreal,ndata))
     do i=1,ndata
        do k=1,nreal
           cdata_out(k,i)=cdata_all(k,i)
        end do
     end do
     deallocate(cdata_all)
!     deallocate(etabl)

     call count_obs(ndata,nreal,ilat,ilon,cdata_out,nobs)
     write(lunout) obstype,sis,nreal,nchanl,ilat,ilon
     write(lunout) cdata_out
     deallocate(cdata_out)
900  continue
     if(diagnostic_reg .and. ntest>0)  write(6,*)'READ_FL_HDOB:  ',&
        'ntest,  disterrmax=', ntest,disterrmax
     if(diagnostic_reg .and. nvtest>0) write(6,*)'READ_FL_HDOB:  ',&
        'nvtest,vdisterrmax=',ntest,vdisterrmax

     if (ndata == 0) then
        call closbf(lunin)
        write(6,*)'READ_FL_HDOB: no data to process'
     endif
     write(6,*)'READ_FL_HDOB: nreal=',nreal
     write(6,*)'READ_FL_HDOB: ntb,nread,ndata,nodata=',ntb,nread,ndata,nodata

     close(lunin)

!    End of routine
     return

end subroutine read_fl_hdob