module fock_module

  use xc_hybrid_module, only: iflag_hybrid, alpha_hf &
                             ,FKMB_0,FKMB_1,FKBZ_0,FKBZ_1,FOCK_0,FOCK_1 &
                             ,occ_factor,gamma_hf
  use array_bound_module, only: ML_0,ML_1,MB,MB_0,MB_1,MBZ,MBZ_0,MBZ_1 &
                               ,MSP_0,MSP_1
  use wf_module, only: unk, occ, hunk
  use fock_fft_module, only: Fock_FFT_Double, Fock_FFT_DoubleComplex
  use parallel_module
  use watch_module
  use rsdft_mpi_module
  use hartree_mol_module, only: timer_reset_hartree_mol, timer_result_hartree_mol

  implicit none

  private
  public :: op_fock
  public :: UpdateWF_fock

  integer :: SYStype=0
  logical :: init_done = .false.

  interface op_fock
    module procedure d_op_fock, z_op_fock
  end interface

  real(8),allocatable :: occ_hf(:,:,:)
  real(8),allocatable :: d_unk_hf(:,:,:,:)
  complex(8),allocatable :: z_unk_hf(:,:,:,:)

contains

  subroutine init_fock
    use var_sys_parameter, only: use_real8_wf
    use io_ctrl_parameters, only: wf_available
    use io_read_wf_simple_module, only: read_wf_simple
    implicit none
    integer :: ng0,ng1,ng,ns0,ns1
    call get_range_parallel( ng0, ng1, 'g' ); ng=ng1-ng0+1
    call get_range_parallel( ns0, ns1, 's' )
    allocate( occ_hf(FKMB_0:FKMB_1,FKBZ_0:FKBZ_1,ns0:ns1) )
    occ_hf=0.0d0
    if ( use_real8_wf() ) then
      allocate( d_unk_hf(ng,FKMB_0:FKMB_1,FKBZ_0:FKBZ_1,ns0:ns1) )
      d_unk_hf=0.0d0
      if ( wf_available() ) call read_wf_simple( d_wf_out=d_unk_hf, occ_out=occ_hf )
    else
      allocate( z_unk_hf(ng,FKMB_0:FKMB_1,FKBZ_0:FKBZ_1,ns0:ns1) )
      z_unk_hf=(0.0d0,0.0d0)
      if ( wf_available() ) call read_wf_simple( z_wf_out=z_unk_hf, occ_out=occ_hf )
    end if
    init_done = .true.
  end subroutine init_fock

  subroutine d_op_fock( tpsi, hpsi, n,k,s )
    implicit none
    real(8),intent(in) :: tpsi(:,n:)
    real(8),intent(inout) :: hpsi(:,n:)
    integer,intent(in) :: n,k,s
    integer :: ib,ib1,ib2

    if ( iflag_hybrid == 0 ) return
    if ( .not.init_done ) call init_fock

    ib1 = n
    ib2 = ib1 + size(tpsi,2) - 1

    if ( iflag_hybrid == 2 ) then

      do ib = ib1, ib2
        hpsi(:,ib) = hpsi(:,ib) + hunk(:,ib,k,s)
      end do

    else if ( iflag_hybrid > 0 ) then

      do ib = ib1, ib2
        call Fock_Double( tpsi(:,ib), hpsi(:,ib), n,k,s )
      end do

    end if
  end subroutine d_op_fock

  subroutine z_op_fock( tpsi, hpsi, n,k,s )
    implicit none
    complex(8),intent(in) :: tpsi(:,n:)
    complex(8),intent(inout) :: hpsi(:,n:)
    integer,intent(in) :: n,k,s
    integer :: ib,ib1,ib2

    if ( iflag_hybrid == 0 ) return
    if ( .not.init_done ) call init_fock

    ib1 = n
    ib2 = ib1 + size(tpsi,2) - 1

    if ( iflag_hybrid == 2 ) then

      do ib = ib1, ib2
        hpsi(:,ib) = hpsi(:,ib) + hunk(:,ib,k,s)
      end do

    else if ( iflag_hybrid > 0 ) then

      do ib = ib1, ib2
        call Fock_DoubleComplex( tpsi(:,ib), hpsi(:,ib), n,k,s )
      end do

    end if
  end subroutine z_op_fock

  subroutine Fock_Double( psi, tpsi, n,k,s )
    implicit none
    real(8),intent(in) :: psi(:)
    real(8),intent(inout) :: tpsi(:)
    integer,intent(in) :: n,k,s
    complex(8),allocatable :: trho(:),tvht(:)
    real(8) :: c1,c2
    integer :: m1,m2,i,ng

    ng = size( psi, 1 )

    allocate( trho(ng) ); trho=(0.0d0,0.0d0)
    allocate( tvht(ng) ); tvht=(0.0d0,0.0d0)

    do m1 = FKMB_0, FKMB_1, 2

      m2 = min( m1+1, FKMB_1 )

      if ( abs(occ_hf(m1,k,s)) < 1.d-10 ) cycle

      if ( m1 < m2 ) then
        do i = 1, ng
          trho(i) = dcmplx( d_unk_hf(i,m1,k,s), d_unk_hf(i,m2,k,s) )*psi(i)
        end do
      else if ( m1 == m2 ) then
        do i = 1, ng
          trho(i) = d_unk_hf(i,m1,k,s)*psi(i)
        end do
      end if

      call Fock_FFT_Double( trho, tvht )

      c1 = alpha_hf*(2.0d0*occ_factor)*occ_hf(m1,k,s)
      c2 = alpha_hf*(2.0d0*occ_factor)*occ_hf(m2,k,s)

      if ( m1 < m2 ) then
        do i = 1, ng
          tpsi(i) = tpsi(i) - c1*real( tvht(i) )*d_unk_hf(i,m1,k,s) &
                            - c2*aimag( tvht(i) )*d_unk_hf(i,m2,k,s)
        end do
      else if ( m1 == m2 ) then
        do i = 1, ng
          tpsi(i) = tpsi(i) - c1*real( tvht(i) )*d_unk_hf(i,m1,k,s)
        end do
      end if

    end do ! m1

    deallocate( tvht, trho )

    return
  end subroutine Fock_Double

  subroutine Fock_DoubleComplex( psi, tpsi, n,k,s )
    use rsdft_mpi_module, only: rsdft_allreduce_sum
    implicit none
    complex(8),intent(in) :: psi(:)
    complex(8),intent(inout) :: tpsi(:)
    integer,intent(in) :: n,k,s
    complex(8),allocatable :: trho(:),tvht(:),tphi(:)
    complex(8),parameter :: zero=(0.0d0,0.0d0)
    real(8) :: c
    integer :: m,q,t,ng

    ng = size( psi )

    allocate( trho(ng) ); trho=zero
    allocate( tvht(ng) ); tvht=zero
    allocate( tphi(ng) ); tphi=zero

! ---

    if ( gamma_hf == 0 ) then

      do t = FOCK_0, FOCK_1

        if ( t == 1 ) then

          do q = FKBZ_0, FKBZ_1
          do m = FKMB_0, FKMB_1

            if ( abs(occ_hf(m,q,s)) < 1.d-10 ) cycle

            trho(:) = conjg( z_unk_hf(:,m,q,s) )*psi(:)

            call Fock_FFT_DoubleComplex( trho, tvht, k,q,t )

            c = occ_factor*occ_hf(m,q,s)*alpha_hf

            tphi(:) = tphi(:) - c*tvht(:)*z_unk_hf(:,m,q,s)

          end do ! m
          end do ! q

        else ! [ t /= 1 ]

          do q = FKBZ_0, FKBZ_1
          do m = FKMB_0, FKMB_1

            if ( abs(occ_hf(m,q,s)) < 1.d-10 ) cycle

            trho(:) = z_unk_hf(:,m,q,s)*psi(:)

            call Fock_FFT_DoubleComplex( trho, tvht, k,q,t )

            c = occ_factor*occ_hf(m,q,s)*alpha_hf

            tphi(:) = tphi(:) - c*tvht(:)*conjg( z_unk_hf(:,m,q,s) )

          end do ! m
          end do ! q

        end if ! [ t ]

      end do ! t

    else ! [ gamma_hf /= 0 ]

      q = k

      do m = FKMB_0, FKMB_1

        if ( abs(occ_hf(m,q,s)) < 1.d-10 ) cycle

        trho(:) = conjg( z_unk_hf(:,m,q,s) )*psi(:)

        call Fock_FFT_DoubleComplex( trho, tvht, k,q,1 )

        c = alpha_hf*(2.0d0*occ_factor)*occ_hf(m,q,s)

        tphi(:) = tphi(:) - c*tvht(:)*z_unk_hf(:,m,q,s)

      end do ! m

    end if ! [ gamma_hf ]

    call rsdft_allreduce_sum( tphi, comm_fkmb )
    tpsi(:) = tpsi(:) + tphi(:)

    deallocate( tphi )
    deallocate( tvht )
    deallocate( trho )

    return
  end subroutine Fock_DoubleComplex

  subroutine UpdateWF_Fock( SYStype_in )
    implicit none
    integer,optional,intent(in) :: SYStype_in
    integer :: s,k,n,m,i_occ,i_orb,ierr
    type(time) :: tt
    logical :: disp_on

    if ( present(SYStype_in) ) SYStype = SYStype_in

    call write_border( 0, " UpdateWF_Fock(start)" )
    call start_timer( 'UpdateWF_Fock', tt )

    if ( .not.init_done ) call init_fock

    if ( allocated(d_unk_hf) ) then
      d_unk_hf(:,:,:,:) = 0.0d0
      occ_hf(:,:,:) = 0.0d0
      do s = MSP_0, MSP_1
      do k = MBZ_0, MBZ_1
      do n = MB_0 , MB_1
        d_unk_hf(:,n,k,s) = unk(:,n,k,s)
        occ_hf(n,k,s) = occ(n,k,s)
      end do !n
      end do !k
      end do !s
    else if ( allocated(z_unk_hf) ) then
      z_unk_hf(:,:,:,:) = (0.0d0,0.0d0)
      occ_hf(:,:,:) = 0.0d0
      do s = MSP_0, MSP_1
      do k = MBZ_0, MBZ_1
      do n = MB_0 , MB_1
        z_unk_hf(:,n,k,s) = unk(:,n,k,s)
        occ_hf(n,k,s) = occ(n,k,s)
      end do !n
      end do !k
      end do !s
    end if

    call write_border( 1, " UpdateWF_Fock(allreduce1)" )

    if ( allocated(d_unk_hf) ) then
      do s = MSP_0, MSP_1
      do k = MBZ_0, MBZ_1
        call rsdft_allreduce_sum( d_unk_hf(:,:,k,s), comm_band )
      end do ! k
      end do ! s
    else if ( allocated(z_unk_hf) ) then
      do s = MSP_0, MSP_1
      do k = MBZ_0, MBZ_1
        call rsdft_allreduce_sum( z_unk_hf(:,:,k,s), comm_band )
      end do ! k
      end do ! s
    end if

    call write_border( 1, " UpdateWF_Fock(allreduce2)" )

    if ( allocated(d_unk_hf) ) then
      do s = MSP_0, MSP_1
        call rsdft_allreduce_sum( d_unk_hf(:,:,:,s), comm_bzsm )
      end do ! s
    else if ( allocated(z_unk_hf) ) then
      do s = MSP_0, MSP_1
        call rsdft_allreduce_sum( z_unk_hf(:,:,:,s), comm_bzsm )
      end do ! s
    end if

    call write_border( 1, " UpdateWF_Fock(allreduce3)" )

    do s = MSP_0, MSP_1
    do k = MBZ_0, MBZ_1
      call rsdft_allreduce_sum( occ_hf(:,k,s), comm_band )
    end do ! k
    end do ! s

    call write_border( 1, " UpdateWF_Fock(allreduce4)" )

    do s = MSP_0, MSP_1
      call rsdft_allreduce_sum( occ_hf(:,:,s), comm_bzsm )
    end do ! s

    call end_timer( 'UpdateWF_Fock_allreduce' )

    hunk(:,:,:,:) = (0.0d0,0.0d0)
    ! ct_fock_fft(:)=0.0d0
    ! et_fock_fft(:)=0.0d0

    if ( allocated(d_unk_hf) ) then
      do s = MSP_0, MSP_1
        call Fock_4_Double( s )
      end do
    else if ( allocated(z_unk_hf) ) then
      do s = MSP_0, MSP_1
        if ( gamma_hf == 1 ) then
          call Fock_4( s )
        else
          call Fock_5( s )
        end if
      end do !s
    else
      call stop_program('Work-array for Hybdir-DFT (?_unk_hf) is not allocated')
    end if

    call end_timer( 'UpdateWF_fock_whole' )

    iflag_hybrid = 2

    ! call check_disp_switch( disp_on, 0 )
    ! if ( disp_on ) then
    !   write(*,'(1x,"iflag_hybrid=",i2)') iflag_hybrid
    !   write(*,*) "time(fock_fft1)=",ct_fock_fft(1),et_fock_fft(1)
    !   write(*,*) "time(fock_fft2)=",ct_fock_fft(2),et_fock_fft(2)
    !   write(*,*) "time(fock_fft3)=",ct_fock_fft(3),et_fock_fft(3)
    !   write(*,*) "time(fock_fft4)=",ct_fock_fft(4),et_fock_fft(4)
    !   write(*,*) "time(fock_fft5)=",ct_fock_fft(5),et_fock_fft(5)
    !   write(*,*) "time(fock_fft6)=",ct_fock_fft(6),et_fock_fft(6)
    !   write(*,*) "time(fock_fft7)=",ct_fock_fft(7),et_fock_fft(7)
    !   write(*,*) "time(fock_fft8)=",ct_fock_fft(8),et_fock_fft(8)
    ! end if

    call write_border( 0, " UpdateWF_fock(end)" )

  end subroutine UpdateWF_Fock

  subroutine Fock_4( s )
    implicit none
    integer,intent(in) :: s
    complex(8),allocatable :: trho(:),tvht(:)
    real(8) :: c
    integer :: m,n,i,j,k,nwork,iwork,ierr,nwork_0,nwork_1,ng
    integer,allocatable :: mapwork(:,:)

    call write_border( 1, " Fock_4(start)" )

    k = 1

! ---

    nwork=0
    i=0
    do n=1,MB
    do m=1,n
      if ( abs(occ(n,k,s))<1.d-10 .and. abs(occ(m,k,s))<1.d-10 ) cycle
      i=i+1
      j=mod(i-1,np_band)
      if ( j == myrank_b ) nwork=nwork+1
    end do
    end do

    allocate( mapwork(2,nwork) ); mapwork=0

    nwork=0
    i=0
    do n=1,MB
    do m=1,n
      if ( abs(occ(n,k,s))<1.d-10 .and. abs(occ(m,k,s))<1.d-10 ) cycle
      i=i+1
      j=mod(i-1,np_band)
      if ( j == myrank_b ) then
        nwork=nwork+1
        mapwork(1,nwork)=m
        mapwork(2,nwork)=n
      end if
    end do
    end do

    ir_fkmb(:)=0
    id_fkmb(:)=0
    do i=1,nwork
      j=mod(i-1,np_fkmb)
      ir_fkmb(j)=ir_fkmb(j)+1
    end do
    do j=0,np_fkmb-1
      id_fkmb(j)=sum(ir_fkmb(0:j))-ir_fkmb(j)
    end do

    nwork_0 = id_fkmb(myrank_f) + 1
    nwork_1 = id_fkmb(myrank_f) + ir_fkmb(myrank_f)

! ---

    ng = size( z_unk_hf, 1 )

    allocate( trho(ng) ); trho=(0.0d0,0.0d0)
    allocate( tvht(ng) ); tvht=(0.0d0,0.0d0)

! ---

    do iwork = nwork_0, nwork_1

      m = mapwork(1,iwork)
      n = mapwork(2,iwork)

      trho(:) = conjg( z_unk_hf(:,m,k,s) )*z_unk_hf(:,n,k,s)

      call Fock_FFT_DoubleComplex( trho, tvht, k,k,1 )

      if ( abs(occ(m,k,s)) >= 1.d-10 ) then
        c = alpha_hf*(2.0d0*occ_factor)*occ(m,k,s)
        hunk(:,n,k,s) = hunk(:,n,k,s) - c*tvht(:)*z_unk_hf(:,m,k,s)
      end if

      if ( m == n ) cycle

      if ( abs(occ(n,k,s)) >= 1.d-10 ) then
        c = alpha_hf*(2.0d0*occ_factor)*occ(n,k,s)
        hunk(:,m,k,s) = hunk(:,m,k,s) - c*conjg( tvht(:) )*z_unk_hf(:,n,k,s)
      end if

    end do !iwork

    deallocate( tvht )
    deallocate( trho )

    deallocate( mapwork )

! ---

    call rsdft_allreduce_sum( hunk(:,:,k,s), comm_band )
    call rsdft_allreduce_sum( hunk(:,:,k,s), comm_fkmb )

    call write_border( 1, " Fock_4(end)" )

    return
  end subroutine Fock_4

  subroutine Fock_4_Double( s )
    implicit none
    integer,intent(in) :: s
    complex(8),allocatable :: trho(:),tvht(:)
    real(8),parameter :: tol=1.d-10
    real(8) :: c
    integer :: m1,n1,m2,n2,m,n,i,j,k,nwork,iwork1,iwork2,ierr
    integer :: nwork_0,nwork_1,ng
    integer,allocatable :: mapwork(:,:)

    call write_border( 1, " Fock_4_Double(start)" )

    k = 1

! ---

    nwork=0
    i=0
    do n=1,MB
    do m=1,n
      if ( abs(occ(n,k,s)) < tol .and. abs(occ(m,k,s)) < tol ) cycle
      i=i+1
      j=mod(i-1,np_band)
      if ( j == myrank_b ) nwork=nwork+1
    end do
    end do

    allocate( mapwork(2,nwork) ); mapwork=0

    nwork=0
    i=0
    do n=1,MB
    do m=1,n
      if ( abs(occ(n,k,s)) < tol .and. abs(occ(m,k,s)) < tol ) cycle
      i=i+1
      j=mod(i-1,np_band)
      if ( j == myrank_b ) then
        nwork=nwork+1
        mapwork(1,nwork)=m
        mapwork(2,nwork)=n
      end if
    end do
    end do

    ir_fkmb(:)=0
    id_fkmb(:)=0
    do i=1,nwork
      j=mod(i-1,np_fkmb)
      ir_fkmb(j)=ir_fkmb(j)+1
    end do
    do j=0,np_fkmb-1
      id_fkmb(j)=sum(ir_fkmb(0:j))-ir_fkmb(j)
    end do

    nwork_0 = id_fkmb(myrank_f) + 1
    nwork_1 = id_fkmb(myrank_f) + ir_fkmb(myrank_f)

! ---

    ng = size( d_unk_hf, 1 )

    allocate( trho(ng) ); trho=(0.0d0,0.0d0)
    allocate( tvht(ng) ); tvht=(0.0d0,0.0d0)

! ---

    do iwork1 = nwork_0, nwork_1, 2

      iwork2 = min( iwork1+1, nwork_1 )

      m1 = mapwork(1,iwork1)
      n1 = mapwork(2,iwork1)
      m2 = mapwork(1,iwork2)
      n2 = mapwork(2,iwork2)

      if ( iwork1 < iwork2 ) then
        trho(:) = dcmplx( d_unk_hf(:,m1,k,s)*d_unk_hf(:,n1,k,s), &
                          d_unk_hf(:,m2,k,s)*d_unk_hf(:,n2,k,s) )
      else
        trho(:) = d_unk_hf(:,m1,k,s)*d_unk_hf(:,n1,k,s)
      end if

      call Fock_FFT_Double( trho, tvht )

      if ( abs(occ(m1,k,s)) >= tol ) then
        c = alpha_hf*(2.0d0*occ_factor)*occ(m1,k,s)
        hunk(:,n1,k,s) = hunk(:,n1,k,s) - c*real( tvht(:) )*d_unk_hf(:,m1,k,s)
      end if

      if ( m1 /= n1 .and. abs(occ(n1,k,s)) >= tol ) then
        c = alpha_hf*(2.0d0*occ_factor)*occ(n1,k,s)
        hunk(:,m1,k,s) = hunk(:,m1,k,s) - c*real( tvht(:) )*d_unk_hf(:,n1,k,s)
      end if

      if ( iwork1 < iwork2 ) then

        if ( abs(occ(m2,k,s)) >= tol ) then
          c = alpha_hf*(2.0d0*occ_factor)*occ(m2,k,s)
          hunk(:,n2,k,s) = hunk(:,n2,k,s) - c*aimag( tvht(:) )*d_unk_hf(:,m2,k,s)
        end if

        if ( m2 /= n2 .and. abs(occ(n2,k,s)) >= tol ) then
          c = alpha_hf*(2.0d0*occ_factor)*occ(n2,k,s)
          hunk(:,m2,k,s) = hunk(:,m2,k,s) - c*aimag( tvht(:) )*d_unk_hf(:,n2,k,s)
        end if

      end if

    end do ! iwork

    deallocate( tvht )
    deallocate( trho )

    deallocate( mapwork )

! ---

    call rsdft_allreduce_sum( hunk(:,:,k,s), comm_band )
    call rsdft_allreduce_sum( hunk(:,:,k,s), comm_fkmb )

    call write_border( 1, " Fock_4_Double(end)" )

    return
  end subroutine Fock_4_Double

  subroutine Fock_5( s )
    implicit none
    integer,intent(in) :: s
    complex(8),allocatable :: trho(:),tvht(:)
    real(8) :: c,ctt(0:3),ett(0:3)
    integer :: m,n,q,k,i,j,a,b,nwork,iwork,ierr,nwork_0,nwork_1
    integer :: ng
    integer,allocatable :: mapnk(:,:),mapwork(:,:)

    call write_border( 1, " Fock_5(start)" )

    call watch(ctt(0),ett(0))

! ---

    allocate( mapnk(2,MB*MBZ) ); mapnk=0

    i=0
    do k=1,MBZ
    do n=1,MB
      i=i+1
      mapnk(1,i)=n
      mapnk(2,i)=k
    end do
    end do

! ---

    nwork=0
    a=0
    do j=1,MB*MBZ
    do i=1,j
      m=mapnk(1,i)
      q=mapnk(2,i)
      n=mapnk(1,j)
      k=mapnk(2,j)
      if ( abs(occ_hf(n,k,s))<1.d-10 .and. abs(occ_hf(m,q,s))<1.d-10 ) cycle
      a=a+1
      b=mod(a-1,np_band*np_bzsm)
      if ( b == myrank_k+myrank_b*np_bzsm ) nwork=nwork+1
    end do
    end do

!    if ( disp_switch_parallel ) then
!       write(*,*) "total # of me    =",a
!       write(*,*) "# of me of rank0 =",nwork
!    end if

    allocate( mapwork(2,nwork) ); mapwork=0

    nwork=0
    a=0
    do j=1,MB*MBZ
    do i=1,j
      m=mapnk(1,i)
      q=mapnk(2,i)
      n=mapnk(1,j)
      k=mapnk(2,j)
      if ( abs(occ_hf(n,k,s))<1.d-10 .and. abs(occ_hf(m,q,s))<1.d-10 ) cycle
      a=a+1
      b=mod(a-1,np_band*np_bzsm)
      if ( b == myrank_k+myrank_b*np_bzsm ) then
        nwork=nwork+1
        mapwork(1,nwork)=i
        mapwork(2,nwork)=j
      end if
    end do ! i
    end do ! j

    ir_fkmb(:)=0
    id_fkmb(:)=0
    do i=1,nwork
      j=mod(i-1,np_fkmb)
      ir_fkmb(j)=ir_fkmb(j)+1
    end do
    do j=0,np_fkmb-1
      id_fkmb(j)=sum(ir_fkmb(0:j))-ir_fkmb(j)
    end do

    nwork_0 = id_fkmb(myrank_f) + 1
    nwork_1 = id_fkmb(myrank_f) + ir_fkmb(myrank_f)

! ---

    ng = size( z_unk_hf, 1 )

    allocate( trho(ng) ); trho=(0.0d0,0.0d0)
    allocate( tvht(ng) ); tvht=(0.0d0,0.0d0)

    call watch(ctt(1),ett(1))

! ---

    do iwork = nwork_0, nwork_1

      a = mapwork(1,iwork)
      b = mapwork(2,iwork)
      m = mapnk(1,a)
      q = mapnk(2,a)
      n = mapnk(1,b)
      k = mapnk(2,b)

! - normal part -

      trho(:) = conjg( z_unk_hf(:,m,q,s) )*z_unk_hf(:,n,k,s)

      call Fock_FFT_DoubleComplex( trho, tvht, k,q,1 )

      if ( abs(occ_hf(m,q,s)) >= 1.d-10 ) then
        c = alpha_hf*occ_factor*occ_hf(m,q,s)
        hunk(:,n,k,s) = hunk(:,n,k,s) - c*tvht(:)*z_unk_hf(:,m,q,s)
      end if

      if ( a /= b .and. abs(occ_hf(n,k,s)) >= 1.d-10 ) then
        c = alpha_hf*occ_factor*occ_hf(n,k,s)
        hunk(:,m,q,s) = hunk(:,m,q,s) - c*conjg( tvht(:) )*z_unk_hf(:,n,k,s)
      end if

! - time-reversal part -

      trho(:) = z_unk_hf(:,m,q,s)*z_unk_hf(:,n,k,s)

      call Fock_FFT_DoubleComplex( trho, tvht, k,q,2 )

      if ( abs(occ_hf(m,q,s)) >= 1.d-10 ) then
        c = alpha_hf*occ_factor*occ_hf(m,q,s)
        hunk(:,n,k,s) = hunk(:,n,k,s) - c*tvht(:)*conjg( z_unk_hf(:,m,q,s) )
      end if

      if ( a /= b .and. abs(occ_hf(n,k,s)) >= 1.d-10 ) then
        c = alpha_hf*occ_factor*occ_hf(n,k,s)
        hunk(:,m,q,s) = hunk(:,m,q,s) - c*tvht(:)*conjg( z_unk_hf(:,n,k,s) )
      end if

    end do ! iwork

    call watch(ctt(2),ett(2))

! ---

    call write_border( 1, " Fock_5(allreduce1)" )

    m=size( hunk,1 )*size( hunk,2 )
    do k=1,MBZ
      call rsdft_allreduce_sum( hunk(:,:,k,s), comm_band )
    end do

    call write_border( 1, " Fock_5(allreduce2)" )

    m=size( hunk,1 )*size( hunk,2 )*size( hunk,3 )
    call rsdft_allreduce_sum( hunk(:,:,:,s), comm_bzsm )

    call write_border( 1, " Fock_5(allreduce3)" )

    m=size( hunk,1 )*size( hunk,2 )*size( hunk,3 )
    call rsdft_allreduce_sum( hunk(:,:,:,s), comm_fkmb )

    call watch(ctt(3),ett(3))

    ! ct_focK_fft(6) = ctt(1) - ctt(0)
    ! et_focK_fft(6) = ett(1) - ett(0)
    ! ct_focK_fft(7) = ctt(2) - ctt(1)
    ! et_focK_fft(7) = ett(2) - ett(1)
    ! ct_focK_fft(8) = ctt(3) - ctt(2)
    ! et_focK_fft(8) = ett(3) - ett(2)

! ---

    deallocate( tvht )
    deallocate( trho )

    deallocate( mapwork )
    deallocate( mapnk )

! ---

    call write_border( 1, " Fock_5(end)" )

    return
  end subroutine Fock_5

end module fock_module


text:
      LOGICAL FUNCTION DCHFL (PROMPT, MAXVAL, TRUANS, PERM)

C  DCHFL gets an integer response from the operator, to be used as
C  an index into PERM, and, if the result is incorrect, issues fail
C  and returns TRUE.  If correct, it returns FALSE, but does not
C  issue pass.

C  Input parameters:
C    PROMPT      : prompt to be sent to operator.
C    MAXVAL      : highest valid response.
C    TRUANS      : expected value from operator.
C    PERM        : permutation of 1-MAXVAL, used to randomize prompt.

      INTEGER     TRUANS, MAXVAL, PERM(*), ANS

      CHARACTER   PROMPT*(*)

      CALL DCHOIC (PROMPT, 0,MAXVAL, ANS)
      IF (ANS .EQ. 0) THEN
         DCHFL = .TRUE.
         CALL OPFAIL
      ELSE
         IF (PERM(ANS) .EQ. TRUANS) THEN
            DCHFL = .FALSE.
         ELSE
            DCHFL = .TRUE.
            CALL FAIL
         ENDIF
      ENDIF

      END

ext: f


text:
*     program testanstee
*     character recipe*1
*   1 continue
*     print *,'give iel ion wavelength elower & eionization'
*     read(*,*) iel,ion,xlb,elo,eion
*     call anstee(iel,ion,xlb,elo,eion,sigma,velexp,levlo,levup,recipe)
*     write(*,*) 'iel ion xlb elo eion sigma velexp levlo levup recipe'
*     write(*,*) iel,ion,xlb,elo,eion,sigma,velexp,levlo,levup,recipe
*     goto 1
*     end
      subroutine anstee(iel,ion,xlb,elo,eion,sigma,velexp,levlo,levup,
     &                                                          recipe)
* Get Hydrogen damping data for s-p, p-s, p-d, d-p, d-f and f-d transitions in neutral species
* and for a large number of ionized lines
* ref Anstee S.D., O'Mara B.J. 1995, MNRAS 276, 859-866         'A'
* Barklem P.S., O'Mara B.J. 1997, MNRAS 290, 102-106            'B'
* Barklem P.S., O'Mara B.J., Ross J.E. 1998, MNRAS 296, 1057    'C'
* Barklem P.S., O'Mara B.J. 1998, MNRAS 300, 863                'S'
* Barklem 1997, 1999, private comm (approx. for some lines)     'S'
* Barklem P.S., Piskunov N., O'Mara B.J. 2000, A&AS 142, 467    'S'
* Barklem P.S. 2003, private communication (IR lines)           'S'
* Barklem, Aspelund-Johansson 2005, Fe II, astro-ph/0502098     'S'
* Barklem 2008, private communication Cr II as for Fe II above  'S'
*
* table1 and table2 gives sigma(s,p) and velexp(s,p)
* table3 and table4 gives sigma(p,d) and velexp(p,d)
* table5 and table6 gives sigma(d,f) and velexp(d,f)
*
* input:
* iel    = atomic number
* ion    = species (neutral=1)
* xlb    = wavelength in Aangstroem
* elo    = excitation energy of the lower level in eV
* eion   = ionisation energy in eV
* levlo  = state designation of the lower level, s p d f g etc
* levup  = state designation of the upper level, s p d f g etc
* output:
* sigma  = collision crossection in atomic units at 10^4 m/s
* velexp = velocity exponent "alpha"
* recipe = A if Anstee & O'Mara (s-p), B if Barklem & O'Mara (p-d) or 1998,
*          C if Barklem, O'Mara & Ross (d-f), S Barklem & O'Mara (ions),
*          Barklem, private comm. or Barklem & Aspelund-Johansson 2005.
*          Else U (Unsoeld)
*
* Updates 2008-02-27 /B. Edvardsson:
* Added 13165 Cr II lines from Paul + 226 long-wavelength Fe II lines
* Much improved identification of 'special' Fe II and Cr II lines by
*      use of also the excitation energy/8067.
* Homogenized different values of the H I ionization energy to 13.595 eV
*
      implicit none
      integer nspecial,nfe2,ncr2
      parameter (nspecial=5024)
      parameter (nfe2=24188)
      parameter (ncr2=13165)
      real table1(10:50,10:50),table2(10:50,10:50)
      real table3(10:50,10:50),table4(10:50,10:50)
      real table5(10:50,10:50),table6(10:50,10:50)
      real elo,eup,eion,xlb,nstars,nstarp,nstard,nstarf,sigma,velexp
      real xlbs(nspecial),sigmas(nspecial),alphas(nspecial)
      real xlbfe2(nfe2),sigmafe2(nfe2),alphafe2(nfe2)
      real xlbcr2(ncr2),sigmacr2(ncr2),alphacr2(ncr2)
      real elos(nspecial),elofe2(nfe2),elocr2(ncr2)
      integer i,j,iel,ion,ielfe2,ionfe2,ielcr2,ioncr2
      integer nsp,iels(nspecial),ions(nspecial),nfe,ncr
      character levlo*1,levup*1,string*132,check*1,recipe*1
      logical first
*
      data first / .true. /
*
      recipe='U'
      nstars=0.0
      nstarp=0.0
      nstard=0.0
      nstarf=0.0
      sigma=0.0
      velexp=0.0
*     eup=12398.426/xlb+elo (not consistent with eqwidth.f)
      eup=12399.8/xlb+elo
      if(eup.ge.eion) then
        print *,'subr. anstee: Upper excit. energy .ge. ioniz. energy;'
        print *,'el,ion,wavelength,chi,I=',iel,ion,xlb,eup,eion
        return
      endif
      if(ion.gt.2.or.ion.lt.1) then
        return
* no such data, use Unsoeld if anything
      endif
*
*
      if(first) then
*
* Read s-p and p-s data from Anstee.dat for sigma and velexp
*
        open(612,
     &  file='DATA/Anstee-1802-2014.dat',
     &           status='old',form='formatted')
*
* First read data from table 1, not commentary lines
* Horizontally: p-states 1.3 - 3.0, step 0.1  (18 values)
* Vertically:   s-states 1.0 - 3.0, step 0.1  (21 values)
*
    1   continue
        read(612,1000) string
 1000   format(a132)
        read(string,1010) check
 1010   format(a1)
        if (check.ne.'*') then
          read(string,*) (table1(j,10),j=13,30)
          do i=11,30
            read(612,*) (table1(j,i),j=13,30)
          enddo
        else
          goto 1
        endif
*
* Read data from table 2, not commentary lines
*
    2   continue
        read(612,1000) string
        read(string,1010) check
        if (check.ne.'*') then
          read(string,*) (table2(j,10),j=13,30)
          do i=11,30
            read(612,*) (table2(j,i),j=13,30)
          enddo
        else
          goto 2
        endif
*
* Then read data from table 3, not commentary lines
* Horizontally: d-states 2.3 - 4.0, step 0.1  (18 values)
* Vertically:   p-states 1.3 - 3.0, step 0.1  (18 values)
*
    3   continue
        read(612,1000) string
        read(string,1010) check
        if (check.ne.'*') then
          read(string,*) (table3(j,13),j=23,40)
          do i=14,30
            read(612,*) (table3(j,i),j=23,40)
          enddo
        else
          goto 3
        endif
*
* Read data from table 4, not commentary lines
*
    4   continue
        read(612,1000) string
        read(string,1010) check
        if (check.ne.'*') then
          read(string,*) (table4(j,13),j=23,40)
          do i=14,30
            read(612,*) (table4(j,i),j=23,40)
          enddo
        else
          goto 4
        endif
*
* Then read data from table 5, not commentary lines
* Horizontally: f-states 3.3 - 5.0, step 0.1  (18 values)
* Vertically:   d-states 2.3 - 4.0, step 0.1  (18 values)
*
    5   continue
        read(612,1000) string
        read(string,1010) check
        if (check.ne.'*') then
          read(string,*) (table5(j,23),j=33,50)
          do i=24,40
            read(612,*) (table5(j,i),j=33,50)
          enddo
        else
          goto 5
        endif
*
* Read data from table 6, not commentary lines
*
    6   continue
        read(612,1000) string
        read(string,1010) check
        if (check.ne.'*') then
          read(string,*) (table6(j,23),j=33,50)
          do i=24,40
            read(612,*) (table6(j,i),j=33,50)
          enddo
        else
          goto 6
        endif
*
* read data for special lines and store
*
        do i=1,14
          read(612,*)
        enddo
        do i=1,nspecial
          read(612,1020) iels(i),ions(i),xlbs(i),elos(i),
     &                  sigmas(i),alphas(i)
 1020     format(i2,3x,i2,f10.3,f11.3,59x,f8.2,f8.3)
          nsp=i
        enddo
        if(nsp.ne.nspecial) then
          print *,'nsp .ne. nspecial:',nsp,nspecial
          stop 'Why do nsp and nspecial differ?'
        endif
* Now read and store the large number of Fe II lines:
        do i=1,5
          read(612,*)
        enddo
        do i=1,nfe2
          read(612,1030) ielfe2,ionfe2,xlbfe2(i),elofe2(i),
     &                  sigmafe2(i),alphafe2(i)
 1030     format(i2,3x,i2,f10.3,f11.3,59x,f8.2,f8.3)
          nfe=i
        enddo
        if(nfe.ne.nfe2) then
          print *,'nfe .ne. nfe2:',nfe,nfe2
          stop 'Why do nfe and nfe2 differ?'
        endif
* Finally read and store the large number of Cr II lines:
        do i=1,6
          read(612,*)
        enddo
        do i=1,ncr2
          read(612,1030) ielcr2,ioncr2,xlbcr2(i),elocr2(i),
     &                  sigmacr2(i),alphacr2(i)
          ncr=i
        enddo
        if(ncr.ne.ncr2) then
          print *,'ncr .ne. ncr2:',ncr,ncr2
          stop 'Why do ncr and ncr2 differ?'
        endif
*
        close(612)
        first=.false.
      endif
*
      if(ion.eq.1) then
*
        if ((levlo.eq.'s'.or.levlo.eq.'S').and.
     &        (levup.eq.'p'.or.levup.eq.'P')) then
          nstars=1./(sqrt((eion-elo)/13.595))
          nstarp=1./(sqrt((eion-eup)/13.595))
          if ((nstarp.ge.1.3.and.nstarp.le.3.0).and.
     &         (nstars.ge.1.0.and.nstars.le.3.0))then
            call interpolation(table1,table2,nstars,nstarp,
     &                                          sigma,velexp)
            recipe='A'
          endif
        else if ((levlo.eq.'p'.or.levlo.eq.'P').and.
     &             (levup.eq.'s'.or.levup.eq.'S')) then
          nstarp=1./(sqrt((eion-elo)/13.595))
          nstars=1./(sqrt((eion-eup)/13.595))
          if ((nstarp.ge.1.3.and.nstarp.le.3.0).and.
     &          (nstars.ge.1.0.and.nstars.le.3.0)) then
            call interpolation(table1,table2,nstars,nstarp,
     &                                         sigma,velexp)
            recipe='A'
          endif
*
        else if ((levlo.eq.'p'.or.levlo.eq.'P').and.
     &             (levup.eq.'d'.or.levup.eq.'D')) then
          nstarp=1./(sqrt((eion-elo)/13.595))
          nstard=1./(sqrt((eion-eup)/13.595))
          if ((nstarp.ge.1.3.and.nstarp.le.3.0).and.
     &          (nstard.ge.2.3.and.nstard.le.4.0)) then
            call interpolation(table3,table4,nstarp,nstard,
     &                                         sigma,velexp)
            recipe='B'
          endif
        else if ((levlo.eq.'d'.or.levlo.eq.'D').and.
     &             (levup.eq.'p'.or.levup.eq.'P')) then
          nstard=1./(sqrt((eion-elo)/13.595))
          nstarp=1./(sqrt((eion-eup)/13.595))
          if ((nstarp.ge.1.3.and.nstarp.le.3.0).and.
     &          (nstard.ge.2.3.and.nstard.le.4.0)) then
            call interpolation(table3,table4,nstarp,nstard,
     &                                         sigma,velexp)
            recipe='B'
          endif
*
        else if ((levlo.eq.'d'.or.levlo.eq.'D').and.
     &             (levup.eq.'f'.or.levup.eq.'F')) then
          nstard=1./(sqrt((eion-elo)/13.595))
          nstarf=1./(sqrt((eion-eup)/13.595))
          if ((nstard.ge.2.3.and.nstard.le.4.0).and.
     &          (nstarf.ge.3.3.and.nstarf.le.5.0)) then
            call interpolation(table5,table6,nstard,nstarf,
     &                                         sigma,velexp)
            recipe='C'
          endif
        else if ((levlo.eq.'f'.or.levlo.eq.'F').and.
     &             (levup.eq.'d'.or.levup.eq.'D')) then
          nstarf=1./(sqrt((eion-elo)/13.595))
          nstard=1./(sqrt((eion-eup)/13.595))
          if ((nstard.ge.2.3.and.nstard.le.4.0).and.
     &          (nstarf.ge.3.3.and.nstarf.le.5.0)) then
            call interpolation(table5,table6,nstard,nstarf,
     &                                         sigma,velexp)
            recipe='C'
          endif
        endif
*
      endif
*
* Check also whether the line has been individually treated:
* Then this data is preferred.
*
      if(iel.eq.24 .and. ion.eq.2) then
* Cr II
        do i=1,ncr
          if(iel.eq.ielcr2 .and. ion.eq.ioncr2) then
            if(abs(xlb-xlbcr2(i)).le.0.05) then
* wavelengths within 0.05 Aangstroem
              if(abs(elo-elocr2(i)/8067.).lt.0.02) then
* energies within 0.02 eV
                recipe='S'
                velexp=alphacr2(i)
                sigma= sigmacr2(i)
                print *,'Special Cr 2 Barklem priv.',iel,ion,xlb
                goto 8
              endif
            endif
          else
            stop 'This was supposedly a Cr II line!'
          endif
        enddo
    8   continue
      else if(iel.eq.26 .and. ion.eq.2) then
* Fe II
        do i=1,nfe
          if(iel.eq.ielfe2 .and. ion.eq.ionfe2) then
            if(abs(xlb-xlbfe2(i)).le.0.05) then
              if(abs(elo-elofe2(i)/8067.).lt.0.02) then
                recipe='S'
                velexp=alphafe2(i)
                sigma= sigmafe2(i)
                print *,'Special Fe 2 Barklem & A-J',iel,ion,xlb
                goto 9
              endif
            endif
          else
            stop 'This was supposedly an Fe II line!'
          endif
        enddo
    9   continue
      else
* all other 'special' lines
        do i=1,nsp
          if(iel.eq.iels(i) .and. ion.eq.ions(i)) then
            if(abs(xlb-xlbs(i)).le.0.05) then
              if(abs(elo-elos(i)/8067.).lt.0.02) then
                recipe='S'
                velexp=alphas(i)
                sigma= sigmas(i)
                print *,'Special line P. Barklem',iel,ion,xlb
                goto 10
              endif
            endif
          endif
        enddo
   10   continue
      endif
*
      if(ion.eq.1 .and. recipe.eq.'U') then
* the last resort
        if((levlo.eq.'d'.or.levlo.eq.'D').and.
     &         (levup.eq.'p'.or.levup.eq.'P')) then
          nstard=1./(sqrt((eion-elo)/13.595))
          if(nstard.lt.2.0) then
* The upper p-state will dominate, use that one alone
* since there is (as yet) no data for the lower level:
* ref: Paul Barklem, email 1997
            nstarp=1./(sqrt((eion-eup)/13.595))
            if(nstarp.ge.2.6.and.nstarp.le.2.7) then
              sigma=762.+960.0*(nstarp-2.6)
              velexp=0.270-0.04*(nstarp-2.6)
              recipe='S'
              print *,'Special line, only upper p level',iel,ion,xlb
            else if(nstarp.gt.2.7.and.nstarp.le.2.8) then
              sigma=858.+1110.*(nstarp-2.7)
              velexp=0.266+0.02*(nstarp-2.7)
              recipe='S'
              print *,'Special line, only upper p level',iel,ion,xlb
            else if(nstarp.gt.2.8.and.nstarp.le.2.9) then
              sigma=969.+610.0*(nstarp-2.8)
              velexp=0.268-0.10*(nstarp-2.8)
              recipe='S'
              print *,'Special line, only upper p level',iel,ion,xlb
            else if(nstarp.gt.2.9.and.nstarp.le.3.0) then
              sigma=1030.+440.*(nstarp-2.9)
              velexp=0.258-0.04*(nstarp-2.9)
              recipe='S'
              print *,'Special line, only upper p level',iel,ion,xlb
            endif
          endif
        endif
      endif
*
      if(recipe.ne.'A' .and. recipe.ne.'B' .and. recipe.ne.'C'
     &    .and. recipe.ne.'S') then
*
* OK, we have to stick to Unsolds recipe
*
        recipe='U'
      endif
*
      return
      end
*
************************************************************************
*
      subroutine interpolation(tablea,tableb,nstar1,nstar2,sigma,velexp)
* interpolate in broadening data tables to get cross section and
* velocity exponent for s-p, p-s, p-d, d-p, d-f or f-d transitions
*
      implicit none
      real tablea(10:50,10:50),tableb(10:50,10:50),sigma,velexp
      real nstar1,nstar2,fract1,fract2,a,b,c,d,x,y
      integer i1,i2
*
      i2=int(10.*nstar2)
      i1=int(10.*nstar1)
      fract2=(10.*nstar2-float(i2))
      fract1=(10.*nstar1-float(i1))
* interpolate in cross section table, first in the 2 direction
      a=tablea(i2,i1)
      b=tablea(i2+1,i1)
      c=tablea(i2,i1+1)
      d=tablea(i2+1,i1+1)
      x=a*(1.-fract2)+b*fract2
      y=c*(1.-fract2)+d*fract2
* interpolate in the 1 direction
      sigma=x*(1.-fract1)+y*fract1
* interpolate in velocity exponent table, first in the 2 direction
      a=tableb(i2,i1)
      b=tableb(i2+1,i1)
      c=tableb(i2,i1+1)
      d=tableb(i2+1,i1+1)
      x=a*(1.-fract2)+b*fract2
      y=c*(1.-fract2)+d*fract2
* interpolate in the 1 direction
      velexp=x*(1.-fract1)+y*fract1
*
      return
      end
*
************************************************************************
*

max_stars_repo_name: dnidever/apogee

max_issues_repo_name: dnidever/apogee

max_forks_repo_name: dnidever/apogee


MODULE getincom
!-
!$Id: getincom.f90 2281 2010-10-15 14:21:13Z smasson $
!-
! This software is governed by the CeCILL license
! See IOIPSL/IOIPSL_License_CeCILL.txt
!---------------------------------------------------------------------
USE errioipsl, ONLY : ipslerr
USE stringop, &
 &   ONLY : nocomma,cmpblank,strlowercase
!-
IMPLICIT NONE
!-
PRIVATE
PUBLIC :: getin_name, getin, getin_dump
!-
!!--------------------------------------------------------------------
!! The "getin_name" routine allows the user to change the name
!! of the definition file in which the data will be read.
!! ("run.def" by default)
!!
!!  SUBROUTINE getin_name (file_name)
!!
!! OPTIONAL INPUT argument
!!
!! (C) file_name :  the name of the file
!!                  in which the data will be read
!!--------------------------------------------------------------------
!-
!-
INTERFACE getin
!!--------------------------------------------------------------------
!! The "getin" routines get a variable.
!! We first check if we find it in the database
!! and if not we get it from the definition file.
!!
!! SUBROUTINE getin (target,ret_val)
!!
!! INPUT
!!
!! (C) target : Name of the variable
!!
!! OUTPUT
!!
!! (I/R/C/L) ret_val : scalar, vector or matrix that will contain
!!                     that will contain the (standard)
!!                     integer/real/character/logical values
!!--------------------------------------------------------------------
  MODULE PROCEDURE getinrs, getinr1d, getinr2d, &
 &                 getinis, getini1d, getini2d, &
 &                 getincs, getinc1d, getinc2d, &
 &                 getinls, getinl1d, getinl2d
END INTERFACE
!-
!!--------------------------------------------------------------------
!! The "getin_dump" routine will dump the content of the database
!! into a file which has the same format as the definition file.
!! The idea is that the user can see which parameters were used
!! and re-use the file for another run.
!!
!!  SUBROUTINE getin_dump (fileprefix)
!!
!! OPTIONAL INPUT argument
!!
!! (C) fileprefix : allows the user to change the name of the file
!!                  in which the data will be archived
!!--------------------------------------------------------------------
!-
  INTEGER,PARAMETER :: max_files=100
  CHARACTER(LEN=100),DIMENSION(max_files),SAVE :: filelist
  INTEGER,SAVE      :: nbfiles
!-
  INTEGER,SAVE :: allread=0
  CHARACTER(LEN=100),SAVE :: def_file = 'run.def'
!-
  INTEGER,PARAMETER :: i_txtslab=1000,l_n=30
  INTEGER,SAVE :: nb_lines,i_txtsize=0
  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: fichier
  CHARACTER(LEN=l_n),SAVE,ALLOCATABLE,DIMENSION(:) :: targetlist
  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: fromfile,compline
!-
  INTEGER,PARAMETER :: n_d_fmt=5,max_msgs=15
  CHARACTER(LEN=6),SAVE :: c_i_fmt = '(I5.5)'
!-
! The data base of parameters
!-
  INTEGER,PARAMETER :: memslabs=200
  INTEGER,PARAMETER :: compress_lim=20
!-
  INTEGER,SAVE :: nb_keys=0
  INTEGER,SAVE :: keymemsize=0
!-
! keystr definition
! name of a key
!-
! keystatus definition
! keystatus = 1 : Value comes from the file defined by 'def_file'
! keystatus = 2 : Default value is used
! keystatus = 3 : Some vector elements were taken from default
!-
! keytype definition
! keytype = 1 : Integer
! keytype = 2 : Real
! keytype = 3 : Character
! keytype = 4 : Logical
!-
  INTEGER,PARAMETER :: k_i=1, k_r=2, k_c=3, k_l=4
!-
! Allow compression for keys (only for integer and real)
! keycompress < 0 : not compressed
! keycompress > 0 : number of repeat of the value
!-
TYPE :: t_key
  CHARACTER(LEN=l_n) :: keystr
  INTEGER :: keystatus, keytype, keycompress, &
 &           keyfromfile, keymemstart, keymemlen
END TYPE t_key
!-
  TYPE(t_key),SAVE,ALLOCATABLE,DIMENSION(:) :: key_tab
!-
  INTEGER,SAVE,ALLOCATABLE,DIMENSION(:) :: i_mem
  INTEGER,SAVE :: i_memsize=0, i_mempos=0
  REAL,SAVE,ALLOCATABLE,DIMENSION(:) :: r_mem
  INTEGER,SAVE :: r_memsize=0, r_mempos=0
  CHARACTER(LEN=100),SAVE,ALLOCATABLE,DIMENSION(:) :: c_mem
  INTEGER,SAVE :: c_memsize=0, c_mempos=0
  LOGICAL,SAVE,ALLOCATABLE,DIMENSION(:) :: l_mem
  INTEGER,SAVE :: l_memsize=0, l_mempos=0
!-
CONTAINS
!-
!=== DEFINITION FILE NAME INTERFACE
!-
SUBROUTINE getin_name (cname)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: cname
!---------------------------------------------------------------------
  IF (allread == 0) THEN
    def_file = ADJUSTL(cname)
  ELSE
    CALL ipslerr (3,'getin_name', &
 &   'The name of the database file (any_name.def)', &
 &   'must be changed *before* any attempt','to read the database.')
  ENDIF
!------------------------
END SUBROUTINE getin_name
!-
!=== INTEGER INTERFACE
!-
SUBROUTINE getinis (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  INTEGER :: ret_val
!-
  INTEGER,DIMENSION(1) :: tmp_ret_val
  INTEGER :: pos,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  tmp_ret_val(1) = ret_val
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,1,i_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,1,target,i_val=tmp_ret_val)
  ENDIF
  ret_val = tmp_ret_val(1)
!---------------------
END SUBROUTINE getinis
!===
SUBROUTINE getini1d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  INTEGER,DIMENSION(:) :: ret_val
!-
  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
  ENDIF
  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
!----------------------
END SUBROUTINE getini1d
!===
SUBROUTINE getini2d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  INTEGER,DIMENSION(:,:) :: ret_val
!-
  INTEGER,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
  INTEGER :: jl,jj,ji
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  size_1 = SIZE(ret_val,1)
  size_2 = SIZE(ret_val,2)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      tmp_ret_val(jl) = ret_val(ji,jj)
    ENDDO
  ENDDO
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,i_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,i_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,i_val=tmp_ret_val)
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      ret_val(ji,jj) = tmp_ret_val(jl)
    ENDDO
  ENDDO
!----------------------
END SUBROUTINE getini2d
!-
!=== REAL INTERFACE
!-
SUBROUTINE getinrs (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  REAL :: ret_val
!-
  REAL,DIMENSION(1) :: tmp_ret_val
  INTEGER :: pos,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  tmp_ret_val(1) = ret_val
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,1,r_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,1,target,r_val=tmp_ret_val)
  ENDIF
  ret_val = tmp_ret_val(1)
!---------------------
END SUBROUTINE getinrs
!===
SUBROUTINE getinr1d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  REAL,DIMENSION(:) :: ret_val
!-
  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
  ENDIF
  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
!----------------------
END SUBROUTINE getinr1d
!===
SUBROUTINE getinr2d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  REAL,DIMENSION(:,:) :: ret_val
!-
  REAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
  INTEGER :: jl,jj,ji
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  size_1 = SIZE(ret_val,1)
  size_2 = SIZE(ret_val,2)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      tmp_ret_val(jl) = ret_val(ji,jj)
    ENDDO
  ENDDO
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,r_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,r_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,r_val=tmp_ret_val)
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      ret_val(ji,jj) = tmp_ret_val(jl)
    ENDDO
  ENDDO
!----------------------
END SUBROUTINE getinr2d
!-
!=== CHARACTER INTERFACE
!-
SUBROUTINE getincs (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  CHARACTER(LEN=*) :: ret_val
!-
  CHARACTER(LEN=100),DIMENSION(1) :: tmp_ret_val
  INTEGER :: pos,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  tmp_ret_val(1) = ret_val
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,1,c_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,1,target,c_val=tmp_ret_val)
  ENDIF
  ret_val = tmp_ret_val(1)
!---------------------
END SUBROUTINE getincs
!===
SUBROUTINE getinc1d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  CHARACTER(LEN=*),DIMENSION(:) :: ret_val
!-
  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
  ENDIF
  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
!----------------------
END SUBROUTINE getinc1d
!===
SUBROUTINE getinc2d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  CHARACTER(LEN=*),DIMENSION(:,:) :: ret_val
!-
  CHARACTER(LEN=100),DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
  INTEGER :: jl,jj,ji
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  size_1 = SIZE(ret_val,1)
  size_2 = SIZE(ret_val,2)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      tmp_ret_val(jl) = ret_val(ji,jj)
    ENDDO
  ENDDO
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,c_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,c_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,c_val=tmp_ret_val)
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      ret_val(ji,jj) = tmp_ret_val(jl)
    ENDDO
  ENDDO
!----------------------
END SUBROUTINE getinc2d
!-
!=== LOGICAL INTERFACE
!-
SUBROUTINE getinls (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  LOGICAL :: ret_val
!-
  LOGICAL,DIMENSION(1) :: tmp_ret_val
  INTEGER :: pos,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  tmp_ret_val(1) = ret_val
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,1,l_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,1,target,l_val=tmp_ret_val)
  ENDIF
  ret_val = tmp_ret_val(1)
!---------------------
END SUBROUTINE getinls
!===
SUBROUTINE getinl1d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  LOGICAL,DIMENSION(:) :: ret_val
!-
  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,status=0,fileorig
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
  tmp_ret_val(1:size_of_in) = ret_val(1:size_of_in)
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
  ENDIF
  ret_val(1:size_of_in) = tmp_ret_val(1:size_of_in)
!----------------------
END SUBROUTINE getinl1d
!===
SUBROUTINE getinl2d (target,ret_val)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  LOGICAL,DIMENSION(:,:) :: ret_val
!-
  LOGICAL,DIMENSION(:),ALLOCATABLE,SAVE :: tmp_ret_val
  INTEGER,SAVE :: tmp_ret_size = 0
  INTEGER :: pos,size_of_in,size_1,size_2,status=0,fileorig
  INTEGER :: jl,jj,ji
!---------------------------------------------------------------------
!-
! Do we have this target in our database ?
!-
  CALL get_findkey (1,target,pos)
!-
  size_of_in = SIZE(ret_val)
  size_1 = SIZE(ret_val,1)
  size_2 = SIZE(ret_val,2)
  IF (.NOT.ALLOCATED(tmp_ret_val)) THEN
    ALLOCATE (tmp_ret_val(size_of_in))
  ELSE IF (size_of_in > tmp_ret_size) THEN
    DEALLOCATE (tmp_ret_val)
    ALLOCATE (tmp_ret_val(size_of_in))
    tmp_ret_size = size_of_in
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      tmp_ret_val(jl) = ret_val(ji,jj)
    ENDDO
  ENDDO
!-
  IF (pos < 0) THEN
!-- Get the information out of the file
    CALL get_fil (target,status,fileorig,l_val=tmp_ret_val)
!-- Put the data into the database
    CALL get_wdb &
 &   (target,status,fileorig,size_of_in,l_val=tmp_ret_val)
  ELSE
!-- Get the value out of the database
    CALL get_rdb (pos,size_of_in,target,l_val=tmp_ret_val)
  ENDIF
!-
  jl=0
  DO jj=1,size_2
    DO ji=1,size_1
      jl=jl+1
      ret_val(ji,jj) = tmp_ret_val(jl)
    ENDDO
  ENDDO
!----------------------
END SUBROUTINE getinl2d
!-
!=== Generic file/database INTERFACE
!-
SUBROUTINE get_fil (target,status,fileorig,i_val,r_val,c_val,l_val)
!---------------------------------------------------------------------
!- Subroutine that will extract from the file the values
!- attributed to the keyword target
!-
!- (C) target    : target for which we will look in the file
!- (I) status    : tells us from where we obtained the data
!- (I) fileorig  : index of the file from which the key comes
!- (I) i_val(:)  : INTEGER(nb_to_ret)   values
!- (R) r_val(:)  : REAL(nb_to_ret)      values
!- (L) l_val(:)  : LOGICAL(nb_to_ret)   values
!- (C) c_val(:)  : CHARACTER(nb_to_ret) values
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  INTEGER,INTENT(OUT) :: status,fileorig
  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
  REAL,DIMENSION(:),OPTIONAL             :: r_val
  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
!-
  INTEGER :: k_typ,nb_to_ret,it,pos,len_str,status_cnt,io_err
  CHARACTER(LEN=n_d_fmt)  :: cnt
  CHARACTER(LEN=80) :: str_READ,str_READ_lower
  CHARACTER(LEN=9)  :: c_vtyp
  LOGICAL,DIMENSION(:),ALLOCATABLE :: found
  LOGICAL :: def_beha,compressed
  CHARACTER(LEN=10) :: c_fmt
  INTEGER :: i_cmpval
  REAL    :: r_cmpval
  INTEGER :: ipos_tr,ipos_fl
!---------------------------------------------------------------------
!-
! Get the type of the argument
  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
  SELECT CASE (k_typ)
  CASE(k_i)
    nb_to_ret = SIZE(i_val)
  CASE(k_r)
    nb_to_ret = SIZE(r_val)
  CASE(k_c)
    nb_to_ret = SIZE(c_val)
  CASE(k_l)
    nb_to_ret = SIZE(l_val)
  CASE DEFAULT
    CALL ipslerr (3,'get_fil', &
 &   'Internal error','Unknown type of data',' ')
  END SELECT
!-
! Read the file(s)
  CALL getin_read
!-
! Allocate and initialize the memory we need
  ALLOCATE(found(nb_to_ret))
  found(:) = .FALSE.
!-
! See what we find in the files read
  DO it=1,nb_to_ret
!---
!-- First try the target as it is
    CALL get_findkey (2,target,pos)
!---
!-- Another try
!---
    IF (pos < 0) THEN
      WRITE(UNIT=cnt,FMT=c_i_fmt) it
      CALL get_findkey (2,TRIM(target)//'__'//cnt,pos)
    ENDIF
!---
!-- We dont know from which file the target could come.
!-- Thus by default we attribute it to the first file :
    fileorig = 1
!---
    IF (pos > 0) THEN
!-----
      found(it) = .TRUE.
      fileorig = fromfile(pos)
!-----
!---- DECODE
!-----
      str_READ = ADJUSTL(fichier(pos))
      str_READ_lower = str_READ
      CALL strlowercase (str_READ_lower)
!-----
      IF (    (TRIM(str_READ_lower) == 'def')     &
 &        .OR.(TRIM(str_READ_lower) == 'default') ) THEN
        def_beha = .TRUE.
      ELSE
        def_beha = .FALSE.
        len_str = LEN_TRIM(str_READ)
        io_err = 0
        SELECT CASE (k_typ)
        CASE(k_i)
          WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') len_str
          READ (UNIT=str_READ(1:len_str), &
 &              FMT=c_fmt,IOSTAT=io_err) i_val(it)
        CASE(k_r)
          READ (UNIT=str_READ(1:len_str), &
 &              FMT=*,IOSTAT=io_err) r_val(it)
        CASE(k_c)
          c_val(it) = str_READ(1:len_str)
        CASE(k_l)
          ipos_tr = -1
          ipos_fl = -1
          ipos_tr = MAX(INDEX(str_READ_lower,'tru'), &
 &                      INDEX(str_READ_lower,'y'))
          ipos_fl = MAX(INDEX(str_READ_lower,'fal'), &
 &                      INDEX(str_READ_lower,'n'))
          IF (ipos_tr > 0) THEN
            l_val(it) = .TRUE.
          ELSE IF (ipos_fl > 0) THEN
            l_val(it) = .FALSE.
          ELSE
            io_err = 100
          ENDIF
        END SELECT
        IF (io_err /= 0) THEN
          CALL ipslerr (3,'get_fil', &
 &         'Target '//TRIM(target), &
 &         'is not of '//TRIM(c_vtyp)//' type',' ')
        ENDIF
      ENDIF
!-----
      IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
!-------
!------ Is this the value of a compressed field ?
        compressed = (compline(pos) > 0)
        IF (compressed) THEN
          IF (compline(pos) /= nb_to_ret) THEN
            CALL ipslerr (2,'get_fil', &
 &           'For key '//TRIM(target)//' we have a compressed field', &
 &           'which does not have the right size.', &
 &           'We will try to fix that.')
          ENDIF
          IF      (k_typ == k_i) THEN
            i_cmpval = i_val(it)
          ELSE IF (k_typ == k_r) THEN
            r_cmpval = r_val(it)
          ENDIF
        ENDIF
      ENDIF
    ELSE
      found(it) = .FALSE.
      def_beha = .FALSE.
      compressed = .FALSE.
    ENDIF
  ENDDO
!-
  IF ( (k_typ == k_i).OR.(k_typ == k_r) ) THEN
!---
!-- If this is a compressed field then we will uncompress it
    IF (compressed) THEN
      DO it=1,nb_to_ret
        IF (.NOT.found(it)) THEN
          IF      (k_typ == k_i) THEN
            i_val(it) = i_cmpval
          ELSE IF (k_typ == k_r) THEN
          ENDIF
          found(it) = .TRUE.
        ENDIF
      ENDDO
    ENDIF
  ENDIF
!-
! Now we set the status for what we found
  IF (def_beha) THEN
    status = 2
    WRITE(*,*) 'USING DEFAULT BEHAVIOUR FOR ',TRIM(target)
  ELSE
    status_cnt = 0
    DO it=1,nb_to_ret
      IF (.NOT.found(it)) THEN
        status_cnt = status_cnt+1
        IF      (status_cnt <= max_msgs) THEN
          WRITE (UNIT=*,FMT='(" USING DEFAULTS : ",A)', &
 &               ADVANCE='NO') TRIM(target)
          IF (nb_to_ret > 1) THEN
            WRITE (UNIT=*,FMT='("__")',ADVANCE='NO')
            WRITE (UNIT=*,FMT=c_i_fmt,ADVANCE='NO') it
          ENDIF
          SELECT CASE (k_typ)
          CASE(k_i)
            WRITE (UNIT=*,FMT=*) "=",i_val(it)
          CASE(k_r)
            WRITE (UNIT=*,FMT=*) "=",r_val(it)
          CASE(k_c)
            WRITE (UNIT=*,FMT=*) "=",c_val(it)
          CASE(k_l)
            WRITE (UNIT=*,FMT=*) "=",l_val(it)
          END SELECT
        ELSE IF (status_cnt == max_msgs+1) THEN
          WRITE (UNIT=*,FMT='(" USING DEFAULTS ... ",A)')
        ENDIF
      ENDIF
    ENDDO
!---
    IF (status_cnt == 0) THEN
      status = 1
    ELSE IF (status_cnt == nb_to_ret) THEN
      status = 2
    ELSE
      status = 3
    ENDIF
  ENDIF
! Deallocate the memory
  DEALLOCATE(found)
!---------------------
END SUBROUTINE get_fil
!===
SUBROUTINE get_rdb (pos,size_of_in,target,i_val,r_val,c_val,l_val)
!---------------------------------------------------------------------
!- Read the required variable in the database
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER :: pos,size_of_in
  CHARACTER(LEN=*) :: target
  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
  REAL,DIMENSION(:),OPTIONAL             :: r_val
  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
!-
  INTEGER :: k_typ,k_beg,k_end
  CHARACTER(LEN=9) :: c_vtyp
!---------------------------------------------------------------------
!-
! Get the type of the argument
  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
    CALL ipslerr (3,'get_rdb', &
 &   'Internal error','Unknown type of data',' ')
  ENDIF
!-
  IF (key_tab(pos)%keytype /= k_typ) THEN
    CALL ipslerr (3,'get_rdb', &
 &   'Wrong data type for keyword '//TRIM(target), &
 &   '(NOT '//TRIM(c_vtyp)//')',' ')
  ENDIF
!-
  IF (key_tab(pos)%keycompress > 0) THEN
    IF (    (key_tab(pos)%keycompress /= size_of_in) &
 &      .OR.(key_tab(pos)%keymemlen /= 1) ) THEN
      CALL ipslerr (3,'get_rdb', &
 &     'Wrong compression length','for keyword '//TRIM(target),' ')
    ELSE
      SELECT CASE (k_typ)
      CASE(k_i)
        i_val(1:size_of_in) = i_mem(key_tab(pos)%keymemstart)
      CASE(k_r)
        r_val(1:size_of_in) = r_mem(key_tab(pos)%keymemstart)
      END SELECT
    ENDIF
  ELSE
    IF (key_tab(pos)%keymemlen /= size_of_in) THEN
      CALL ipslerr (3,'get_rdb', &
 &     'Wrong array length','for keyword '//TRIM(target),' ')
    ELSE
      k_beg = key_tab(pos)%keymemstart
      k_end = k_beg+key_tab(pos)%keymemlen-1
      SELECT CASE (k_typ)
      CASE(k_i)
        i_val(1:size_of_in) = i_mem(k_beg:k_end)
      CASE(k_r)
        r_val(1:size_of_in) = r_mem(k_beg:k_end)
      CASE(k_c)
        c_val(1:size_of_in) = c_mem(k_beg:k_end)
      CASE(k_l)
        l_val(1:size_of_in) = l_mem(k_beg:k_end)
      END SELECT
    ENDIF
  ENDIF
!---------------------
END SUBROUTINE get_rdb
!===
SUBROUTINE get_wdb &
 &  (target,status,fileorig,size_of_in, &
 &   i_val,r_val,c_val,l_val)
!---------------------------------------------------------------------
!- Write data into the data base
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=*) :: target
  INTEGER :: status,fileorig,size_of_in
  INTEGER,DIMENSION(:),OPTIONAL          :: i_val
  REAL,DIMENSION(:),OPTIONAL             :: r_val
  LOGICAL,DIMENSION(:),OPTIONAL          :: l_val
  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_val
!-
  INTEGER :: k_typ
  CHARACTER(LEN=9) :: c_vtyp
  INTEGER :: k_mempos,k_memsize,k_beg,k_end
  LOGICAL :: l_cmp
!---------------------------------------------------------------------
!-
! Get the type of the argument
  CALL get_qtyp (k_typ,c_vtyp,i_val,r_val,c_val,l_val)
  IF (     (k_typ /= k_i).AND.(k_typ /= k_r) &
 &    .AND.(k_typ /= k_c).AND.(k_typ /= k_l) )THEN
    CALL ipslerr (3,'get_wdb', &
 &   'Internal error','Unknown type of data',' ')
  ENDIF
!-
! First check if we have sufficiant space for the new key
  IF (nb_keys+1 > keymemsize) THEN
    CALL getin_allockeys ()
  ENDIF
!-
  SELECT CASE (k_typ)
  CASE(k_i)
    k_mempos = i_mempos; k_memsize = i_memsize;
    l_cmp = (MINVAL(i_val) == MAXVAL(i_val)) &
 &         .AND.(size_of_in > compress_lim)
  CASE(k_r)
    k_mempos = r_mempos; k_memsize = r_memsize;
    l_cmp = (MINVAL(r_val) == MAXVAL(r_val)) &
 &         .AND.(size_of_in > compress_lim)
  CASE(k_c)
    k_mempos = c_mempos; k_memsize = c_memsize;
    l_cmp = .FALSE.
  CASE(k_l)
    k_mempos = l_mempos; k_memsize = l_memsize;
    l_cmp = .FALSE.
  END SELECT
!-
! Fill out the items of the data base
  nb_keys = nb_keys+1
  key_tab(nb_keys)%keystr = target(1:MIN(LEN_TRIM(target),l_n))
  key_tab(nb_keys)%keystatus = status
  key_tab(nb_keys)%keytype = k_typ
  key_tab(nb_keys)%keyfromfile = fileorig
  key_tab(nb_keys)%keymemstart = k_mempos+1
  IF (l_cmp) THEN
    key_tab(nb_keys)%keycompress = size_of_in
    key_tab(nb_keys)%keymemlen = 1
  ELSE
    key_tab(nb_keys)%keycompress = -1
    key_tab(nb_keys)%keymemlen = size_of_in
  ENDIF
!-
! Before writing the actual size lets see if we have the space
  IF (key_tab(nb_keys)%keymemstart+key_tab(nb_keys)%keymemlen &
 &    > k_memsize) THEN
    CALL getin_allocmem (k_typ,key_tab(nb_keys)%keymemlen)
  ENDIF
!-
  k_beg = key_tab(nb_keys)%keymemstart
  k_end = k_beg+key_tab(nb_keys)%keymemlen-1
  SELECT CASE (k_typ)
  CASE(k_i)
    i_mem(k_beg:k_end) = i_val(1:key_tab(nb_keys)%keymemlen)
    i_mempos = k_end
  CASE(k_r)
    r_mem(k_beg:k_end) = r_val(1:key_tab(nb_keys)%keymemlen)
    r_mempos = k_end
  CASE(k_c)
    c_mem(k_beg:k_end) = c_val(1:key_tab(nb_keys)%keymemlen)
    c_mempos = k_end
  CASE(k_l)
    l_mem(k_beg:k_end) = l_val(1:key_tab(nb_keys)%keymemlen)
    l_mempos = k_end
  END SELECT
!---------------------
END SUBROUTINE get_wdb
!-
!===
!-
SUBROUTINE getin_read
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,SAVE :: current
!---------------------------------------------------------------------
  IF (allread == 0) THEN
!-- Allocate a first set of memory.
    CALL getin_alloctxt ()
    CALL getin_allockeys ()
    CALL getin_allocmem (k_i,0)
    CALL getin_allocmem (k_r,0)
    CALL getin_allocmem (k_c,0)
    CALL getin_allocmem (k_l,0)
!-- Start with reading the files
    nbfiles = 1
    filelist(1) = TRIM(def_file)
    current = 1
!--
    DO WHILE (current <= nbfiles)
      CALL getin_readdef (current)
      current = current+1
    ENDDO
    allread = 1
    CALL getin_checkcohe ()
  ENDIF
!------------------------
END SUBROUTINE getin_read
!-
!===
!-
  SUBROUTINE getin_readdef(current)
!---------------------------------------------------------------------
!- This subroutine will read the files and only keep the
!- the relevant information. The information is kept as it
!- found in the file. The data will be analysed later.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER :: current
!-
  CHARACTER(LEN=100) :: READ_str,NEW_str,last_key,key_str
  CHARACTER(LEN=n_d_fmt) :: cnt
  CHARACTER(LEN=10) :: c_fmt
  INTEGER :: nb_lastkey
!-
  INTEGER :: eof,ptn,len_str,i,it,iund,io_err
  LOGICAL :: check = .FALSE.
!---------------------------------------------------------------------
  eof = 0
  ptn = 1
  nb_lastkey = 0
!-
  IF (check) THEN
    WRITE(*,*) 'getin_readdef : Open file ',TRIM(filelist(current))
  ENDIF
!-
  OPEN (UNIT=22,FILE=filelist(current),STATUS="OLD",IOSTAT=io_err)
  IF (io_err /= 0) THEN
    CALL ipslerr (2,'getin_readdef', &
 &  'Could not open file '//TRIM(filelist(current)),' ',' ')
    RETURN
  ENDIF
!-
  DO WHILE (eof /= 1)
!---
    CALL getin_skipafew (22,READ_str,eof,nb_lastkey)
    len_str = LEN_TRIM(READ_str)
    ptn = INDEX(READ_str,'=')
!---
    IF (ptn > 0) THEN
!---- Get the target
      key_str = TRIM(ADJUSTL(READ_str(1:ptn-1)))
!---- Make sure that a vector keyword has the right length
      iund = INDEX(key_str,'__')
      IF (iund > 0) THEN
        WRITE (UNIT=c_fmt,FMT='("(I",I3.3,")")') &
 &        LEN_TRIM(key_str)-iund-1
        READ(UNIT=key_str(iund+2:LEN_TRIM(key_str)), &
 &           FMT=c_fmt,IOSTAT=io_err) it
        IF ( (io_err == 0).AND.(it > 0) ) THEN
          WRITE(UNIT=cnt,FMT=c_i_fmt) it
          key_str = key_str(1:iund+1)//cnt
        ELSE
          CALL ipslerr (3,'getin_readdef', &
 &         'A very strange key has just been found :', &
 &         TRIM(key_str),' ')
        ENDIF
      ENDIF
!---- Prepare the content
      NEW_str = TRIM(ADJUSTL(READ_str(ptn+1:len_str)))
      CALL nocomma (NEW_str)
      CALL cmpblank (NEW_str)
      NEW_str  = TRIM(ADJUSTL(NEW_str))
      IF (check) THEN
        WRITE(*,*) &
 &        '--> getin_readdef : ',TRIM(key_str),' :: ',TRIM(NEW_str)
      ENDIF
!---- Decypher the content of NEW_str
!-
!---- This has to be a new key word, thus :
      nb_lastkey = 0
!----
      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
!----
    ELSE IF (len_str > 0) THEN
!---- Prepare the key if we have an old one to which
!---- we will add the line just read
      IF (nb_lastkey > 0) THEN
        iund =  INDEX(last_key,'__')
        IF (iund > 0) THEN
!-------- We only continue a keyword, thus it is easy
          key_str = last_key(1:iund-1)
        ELSE
          IF (nb_lastkey /= 1) THEN
            CALL ipslerr (3,'getin_readdef', &
 &           'We can not have a scalar keyword', &
 &           'and a vector content',' ')
          ENDIF
!-------- The last keyword needs to be transformed into a vector.
          WRITE(UNIT=cnt,FMT=c_i_fmt) 1
          targetlist(nb_lines) = &
 &         last_key(1:MIN(LEN_TRIM(last_key),l_n-n_d_fmt-2))//'__'//cnt
          key_str = last_key(1:LEN_TRIM(last_key))
        ENDIF
      ENDIF
!---- Prepare the content
      NEW_str = TRIM(ADJUSTL(READ_str(1:len_str)))
      CALL getin_decrypt (current,key_str,NEW_str,last_key,nb_lastkey)
    ELSE
!---- If we have an empty line then the keyword finishes
      nb_lastkey = 0
      IF (check) THEN
        WRITE(*,*) 'getin_readdef : Have found an emtpy line '
      ENDIF
    ENDIF
  ENDDO
!-
  CLOSE(UNIT=22)
!-
  IF (check) THEN
    OPEN (UNIT=22,file=TRIM(def_file)//'.test')
    DO i=1,nb_lines
      WRITE(UNIT=22,FMT=*) targetlist(i)," : ",fichier(i)
    ENDDO
    CLOSE(UNIT=22)
  ENDIF
!---------------------------
END SUBROUTINE getin_readdef
!-
!===
!-
SUBROUTINE getin_decrypt(current,key_str,NEW_str,last_key,nb_lastkey)
!---------------------------------------------------------------------
!- This subroutine is going to decypher the line.
!- It essentialy checks how many items are included and
!- it they can be attached to a key.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
! ARGUMENTS
!-
  INTEGER :: current,nb_lastkey
  CHARACTER(LEN=*) :: key_str,NEW_str,last_key
!-
! LOCAL
!-
  INTEGER :: len_str,blk,nbve,starpos
  CHARACTER(LEN=100) :: tmp_str,new_key,mult
  CHARACTER(LEN=n_d_fmt) :: cnt
  CHARACTER(LEN=10) :: c_fmt
!---------------------------------------------------------------------
  len_str = LEN_TRIM(NEW_str)
  blk = INDEX(NEW_str(1:len_str),' ')
  tmp_str = NEW_str(1:len_str)
!-
! If the key is a new file then we take it up. Else
! we save the line and go on.
!-
  IF (INDEX(key_str,'INCLUDEDEF') > 0) THEN
    DO WHILE (blk > 0)
      IF (nbfiles+1 > max_files) THEN
        CALL ipslerr (3,'getin_decrypt', &
 &       'Too many files to include',' ',' ')
      ENDIF
!-----
      nbfiles = nbfiles+1
      filelist(nbfiles) = tmp_str(1:blk)
!-----
      tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
      blk = INDEX(tmp_str(1:LEN_TRIM(tmp_str)),' ')
    ENDDO
!---
    IF (nbfiles+1 > max_files) THEN
      CALL ipslerr (3,'getin_decrypt', &
 &     'Too many files to include',' ',' ')
    ENDIF
!---
    nbfiles =  nbfiles+1
    filelist(nbfiles) = TRIM(ADJUSTL(tmp_str))
!---
    last_key = 'INCLUDEDEF'
    nb_lastkey = 1
  ELSE
!-
!-- We are working on a new line of input
!-
    IF (nb_lines+1 > i_txtsize) THEN
      CALL getin_alloctxt ()
    ENDIF
    nb_lines = nb_lines+1
!-
!-- First we solve the issue of conpressed information. Once
!-- this is done all line can be handled in the same way.
!-
    starpos = INDEX(NEW_str(1:len_str),'*')
    IF ( (starpos > 0).AND.(tmp_str(1:1) /= '"') &
 &                    .AND.(tmp_str(1:1) /= "'") ) THEN
!-----
      IF (INDEX(key_str(1:LEN_TRIM(key_str)),'__') > 0) THEN
        CALL ipslerr (3,'getin_decrypt', &
 &       'We can not have a compressed field of values', &
 &       'in a vector notation (TARGET__n).', &
 &       'The key at fault : '//TRIM(key_str))
      ENDIF
!-
!---- Read the multiplied
!-
      mult = TRIM(ADJUSTL(NEW_str(1:starpos-1)))
!---- Construct the new string and its parameters
      NEW_str = TRIM(ADJUSTL(NEW_str(starpos+1:len_str)))
      len_str = LEN_TRIM(NEW_str)
      blk = INDEX(NEW_str(1:len_str),' ')
      IF (blk > 1) THEN
        CALL ipslerr (2,'getin_decrypt', &
 &       'This is a strange behavior','you could report',' ')
      ENDIF
      WRITE (UNIT=c_fmt,FMT='("(I",I5.5,")")') LEN_TRIM(mult)
      READ(UNIT=mult,FMT=c_fmt) compline(nb_lines)
!---
    ELSE
      compline(nb_lines) = -1
    ENDIF
!-
!-- If there is no space wthin the line then the target is a scalar
!-- or the element of a properly written vector.
!-- (ie of the type TARGET__00001)
!-
    IF (    (blk <= 1) &
 &      .OR.(tmp_str(1:1) == '"') &
 &      .OR.(tmp_str(1:1) == "'") ) THEN
!-
      IF (nb_lastkey == 0) THEN
!------ Save info of current keyword as a scalar
!------ if it is not a continuation
        targetlist(nb_lines) = key_str(1:MIN(LEN_TRIM(key_str),l_n))
        last_key = key_str(1:MIN(LEN_TRIM(key_str),l_n))
        nb_lastkey = 1
      ELSE
!------ We are continuing a vector so the keyword needs
!------ to get the underscores
        WRITE(UNIT=cnt,FMT=c_i_fmt) nb_lastkey+1
        targetlist(nb_lines) = &
 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
        last_key = &
 &        key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
        nb_lastkey = nb_lastkey+1
      ENDIF
!-----
      fichier(nb_lines) = NEW_str(1:len_str)
      fromfile(nb_lines) = current
    ELSE
!-
!---- If there are blanks whithin the line then we are dealing
!---- with a vector and we need to split it in many entries
!---- with the TARGET__n notation.
!----
!---- Test if the targer is not already a vector target !
!-
      IF (INDEX(TRIM(key_str),'__') > 0) THEN
        CALL ipslerr (3,'getin_decrypt', &
 &       'We have found a mixed vector notation (TARGET__n).', &
 &       'The key at fault : '//TRIM(key_str),' ')
      ENDIF
!-
      nbve = nb_lastkey
      nbve = nbve+1
      WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
!-
      DO WHILE (blk > 0)
!-
!------ Save the content of target__nbve
!-
        fichier(nb_lines) = tmp_str(1:blk)
        new_key = &
 &       key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
        targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
        fromfile(nb_lines) = current
!-
        tmp_str = TRIM(ADJUSTL(tmp_str(blk+1:LEN_TRIM(tmp_str))))
        blk = INDEX(TRIM(tmp_str),' ')
!-
        IF (nb_lines+1 > i_txtsize) THEN
          CALL getin_alloctxt ()
        ENDIF
        nb_lines = nb_lines+1
        nbve = nbve+1
        WRITE(UNIT=cnt,FMT=c_i_fmt) nbve
!-
      ENDDO
!-
!---- Save the content of the last target
!-
      fichier(nb_lines) = tmp_str(1:LEN_TRIM(tmp_str))
      new_key = &
 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
      targetlist(nb_lines) = new_key(1:MIN(LEN_TRIM(new_key),l_n))
      fromfile(nb_lines) = current
!-
      last_key = &
 &      key_str(1:MIN(LEN_TRIM(key_str),l_n-n_d_fmt-2))//'__'//cnt
      nb_lastkey = nbve
!-
    ENDIF
!-
  ENDIF
!---------------------------
END SUBROUTINE getin_decrypt
!-
!===
!-
SUBROUTINE getin_checkcohe ()
!---------------------------------------------------------------------
!- This subroutine checks for redundancies.
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER :: line,n_k,k
!---------------------------------------------------------------------
  DO line=1,nb_lines-1
!-
    n_k = 0
    DO k=line+1,nb_lines
      IF (TRIM(targetlist(line)) == TRIM(targetlist(k))) THEN
        n_k = k
        EXIT
      ENDIF
    ENDDO
!---
!-- IF we have found it we have a problem to solve.
!---
    IF (n_k > 0) THEN
      WRITE(*,*) 'COUNT : ',n_k
      WRITE(*,*) &
 &  'getin_checkcohe : Found a problem on key ',TRIM(targetlist(line))
      WRITE(*,*) &
 &  'getin_checkcohe : The following values were encoutered :'
      WRITE(*,*) &
 &  '                ',TRIM(targetlist(line)),' == ',fichier(line)
      WRITE(*,*) &
 &  '                ',TRIM(targetlist(k)),' == ',fichier(k)
      WRITE(*,*) &
 &  'getin_checkcohe : We will keep only the last value'
      targetlist(line) = ' '
    ENDIF
  ENDDO
!-----------------------------
END SUBROUTINE getin_checkcohe
!-
!===
!-
SUBROUTINE getin_skipafew (unit,out_string,eof,nb_lastkey)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER :: unit,eof,nb_lastkey
  CHARACTER(LEN=100) :: dummy
  CHARACTER(LEN=100) :: out_string
  CHARACTER(LEN=1) :: first
!---------------------------------------------------------------------
  first="#"
  eof = 0
  out_string = "    "
!-
  DO WHILE (first == "#")
    READ (UNIT=unit,FMT='(A)',ERR=9998,END=7778) dummy
    dummy = TRIM(ADJUSTL(dummy))
    first=dummy(1:1)
    IF (first == "#") THEN
      nb_lastkey = 0
    ENDIF
  ENDDO
  out_string=dummy
!-
  RETURN
!-
9998 CONTINUE
  CALL ipslerr (3,'getin_skipafew','Error while reading file',' ',' ')
!-
7778 CONTINUE
  eof = 1
!----------------------------
END SUBROUTINE getin_skipafew
!-
!===
!-
SUBROUTINE getin_allockeys ()
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  TYPE(t_key),ALLOCATABLE,DIMENSION(:) :: tmp_key_tab
!-
  INTEGER :: ier
  CHARACTER(LEN=20) :: c_tmp
!---------------------------------------------------------------------
  IF (keymemsize == 0) THEN
!---
!-- Nothing exists in memory arrays and it is easy to do.
!---
    WRITE (UNIT=c_tmp,FMT=*) memslabs
    ALLOCATE(key_tab(memslabs),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_allockeys', &
 &     'Can not allocate key_tab', &
 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
    ENDIF
    nb_keys = 0
    keymemsize = memslabs
    key_tab(:)%keycompress = -1
!---
  ELSE
!---
!-- There is something already in the memory,
!-- we need to transfer and reallocate.
!---
    WRITE (UNIT=c_tmp,FMT=*) keymemsize
    ALLOCATE(tmp_key_tab(keymemsize),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_allockeys', &
 &     'Can not allocate tmp_key_tab', &
 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
    ENDIF
    WRITE (UNIT=c_tmp,FMT=*) keymemsize+memslabs
    tmp_key_tab(1:keymemsize) = key_tab(1:keymemsize)
    DEALLOCATE(key_tab)
    ALLOCATE(key_tab(keymemsize+memslabs),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_allockeys', &
 &     'Can not allocate key_tab', &
 &     'to size '//TRIM(ADJUSTL(c_tmp)),' ')
    ENDIF
    key_tab(:)%keycompress = -1
    key_tab(1:keymemsize) = tmp_key_tab(1:keymemsize)
    DEALLOCATE(tmp_key_tab)
    keymemsize = keymemsize+memslabs
  ENDIF
!-----------------------------
END SUBROUTINE getin_allockeys
!-
!===
!-
SUBROUTINE getin_allocmem (type,len_wanted)
!---------------------------------------------------------------------
!- Allocate the memory of the data base for all 4 types of memory
!- INTEGER / REAL / CHARACTER / LOGICAL
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER :: type,len_wanted
!-
  INTEGER,ALLOCATABLE :: tmp_int(:)
  REAL,ALLOCATABLE :: tmp_real(:)
  CHARACTER(LEN=100),ALLOCATABLE :: tmp_char(:)
  LOGICAL,ALLOCATABLE :: tmp_logic(:)
  INTEGER :: ier
  CHARACTER(LEN=20) :: c_tmp
!---------------------------------------------------------------------
  SELECT CASE (type)
  CASE(k_i)
    IF (i_memsize == 0) THEN
      ALLOCATE(i_mem(memslabs),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) memslabs
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate db-memory', &
 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      i_memsize=memslabs
    ELSE
      ALLOCATE(tmp_int(i_memsize),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) i_memsize
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate tmp_int', &
 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      tmp_int(1:i_memsize) = i_mem(1:i_memsize)
      DEALLOCATE(i_mem)
      ALLOCATE(i_mem(i_memsize+MAX(memslabs,len_wanted)),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) i_memsize+MAX(memslabs,len_wanted)
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to re-allocate db-memory', &
 &       'i_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      i_mem(1:i_memsize) = tmp_int(1:i_memsize)
      i_memsize = i_memsize+MAX(memslabs,len_wanted)
      DEALLOCATE(tmp_int)
    ENDIF
  CASE(k_r)
    IF (r_memsize == 0) THEN
      ALLOCATE(r_mem(memslabs),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) memslabs
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate db-memory', &
 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      r_memsize =  memslabs
    ELSE
      ALLOCATE(tmp_real(r_memsize),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) r_memsize
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate tmp_real', &
 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      tmp_real(1:r_memsize) = r_mem(1:r_memsize)
      DEALLOCATE(r_mem)
      ALLOCATE(r_mem(r_memsize+MAX(memslabs,len_wanted)),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) r_memsize+MAX(memslabs,len_wanted)
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to re-allocate db-memory', &
 &       'r_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      r_mem(1:r_memsize) = tmp_real(1:r_memsize)
      r_memsize = r_memsize+MAX(memslabs,len_wanted)
      DEALLOCATE(tmp_real)
    ENDIF
  CASE(k_c)
    IF (c_memsize == 0) THEN
      ALLOCATE(c_mem(memslabs),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) memslabs
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate db-memory', &
 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      c_memsize = memslabs
    ELSE
      ALLOCATE(tmp_char(c_memsize),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) c_memsize
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate tmp_char', &
 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      tmp_char(1:c_memsize) = c_mem(1:c_memsize)
      DEALLOCATE(c_mem)
      ALLOCATE(c_mem(c_memsize+MAX(memslabs,len_wanted)),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) c_memsize+MAX(memslabs,len_wanted)
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to re-allocate db-memory', &
 &       'c_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      c_mem(1:c_memsize) = tmp_char(1:c_memsize)
      c_memsize = c_memsize+MAX(memslabs,len_wanted)
      DEALLOCATE(tmp_char)
    ENDIF
  CASE(k_l)
    IF (l_memsize == 0) THEN
      ALLOCATE(l_mem(memslabs),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) memslabs
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate db-memory', &
 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      l_memsize = memslabs
    ELSE
      ALLOCATE(tmp_logic(l_memsize),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) l_memsize
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to allocate tmp_logic', &
 &       'to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      tmp_logic(1:l_memsize) = l_mem(1:l_memsize)
      DEALLOCATE(l_mem)
      ALLOCATE(l_mem(l_memsize+MAX(memslabs,len_wanted)),stat=ier)
      IF (ier /= 0) THEN
        WRITE (UNIT=c_tmp,FMT=*) l_memsize+MAX(memslabs,len_wanted)
        CALL ipslerr (3,'getin_allocmem', &
 &       'Unable to re-allocate db-memory', &
 &       'l_mem to size '//TRIM(ADJUSTL(c_tmp)),' ')
      ENDIF
      l_mem(1:l_memsize) = tmp_logic(1:l_memsize)
      l_memsize = l_memsize+MAX(memslabs,len_wanted)
      DEALLOCATE(tmp_logic)
    ENDIF
  CASE DEFAULT
    CALL ipslerr (3,'getin_allocmem','Unknown type of data',' ',' ')
  END SELECT
!----------------------------
END SUBROUTINE getin_allocmem
!-
!===
!-
SUBROUTINE getin_alloctxt ()
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(LEN=100),ALLOCATABLE :: tmp_fic(:)
  CHARACTER(LEN=l_n),ALLOCATABLE :: tmp_tgl(:)
  INTEGER,ALLOCATABLE :: tmp_int(:)
!-
  INTEGER :: ier
  CHARACTER(LEN=20) :: c_tmp1,c_tmp2
!---------------------------------------------------------------------
  IF (i_txtsize == 0) THEN
!---
!-- Nothing exists in memory arrays and it is easy to do.
!---
    WRITE (UNIT=c_tmp1,FMT=*) i_txtslab
    ALLOCATE(fichier(i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate fichier', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
!---
    ALLOCATE(targetlist(i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate targetlist', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
!---
    ALLOCATE(fromfile(i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate fromfile', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
!---
    ALLOCATE(compline(i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate compline', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
!---
    nb_lines = 0
    i_txtsize = i_txtslab
  ELSE
!---
!-- There is something already in the memory,
!-- we need to transfer and reallocate.
!---
    WRITE (UNIT=c_tmp1,FMT=*) i_txtsize
    WRITE (UNIT=c_tmp2,FMT=*) i_txtsize+i_txtslab
    ALLOCATE(tmp_fic(i_txtsize),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate tmp_fic', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
    tmp_fic(1:i_txtsize) = fichier(1:i_txtsize)
    DEALLOCATE(fichier)
    ALLOCATE(fichier(i_txtsize+i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate fichier', &
 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
    ENDIF
    fichier(1:i_txtsize) = tmp_fic(1:i_txtsize)
    DEALLOCATE(tmp_fic)
!---
    ALLOCATE(tmp_tgl(i_txtsize),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate tmp_tgl', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
    tmp_tgl(1:i_txtsize) = targetlist(1:i_txtsize)
    DEALLOCATE(targetlist)
    ALLOCATE(targetlist(i_txtsize+i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate targetlist', &
 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
    ENDIF
    targetlist(1:i_txtsize) = tmp_tgl(1:i_txtsize)
    DEALLOCATE(tmp_tgl)
!---
    ALLOCATE(tmp_int(i_txtsize),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate tmp_int', &
 &     'to size '//TRIM(ADJUSTL(c_tmp1)),' ')
    ENDIF
    tmp_int(1:i_txtsize) = fromfile(1:i_txtsize)
    DEALLOCATE(fromfile)
    ALLOCATE(fromfile(i_txtsize+i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate fromfile', &
 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
    ENDIF
    fromfile(1:i_txtsize) = tmp_int(1:i_txtsize)
!---
    tmp_int(1:i_txtsize) = compline(1:i_txtsize)
    DEALLOCATE(compline)
    ALLOCATE(compline(i_txtsize+i_txtslab),stat=ier)
    IF (ier /= 0) THEN
      CALL ipslerr (3,'getin_alloctxt', &
 &     'Can not allocate compline', &
 &     'to size '//TRIM(ADJUSTL(c_tmp2)),' ')
    ENDIF
    compline(1:i_txtsize) = tmp_int(1:i_txtsize)
    DEALLOCATE(tmp_int)
!---
    i_txtsize = i_txtsize+i_txtslab
  ENDIF
!----------------------------
END SUBROUTINE getin_alloctxt
!-
!===
!-
SUBROUTINE getin_dump (fileprefix)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  CHARACTER(*),OPTIONAL :: fileprefix
!-
  CHARACTER(LEN=80) :: usedfileprefix
  INTEGER :: ikey,if,iff,iv
  CHARACTER(LEN=20) :: c_tmp
  CHARACTER(LEN=100) :: tmp_str,used_filename
  LOGICAL :: check = .FALSE.
!---------------------------------------------------------------------
  IF (PRESENT(fileprefix)) THEN
    usedfileprefix = fileprefix(1:MIN(LEN_TRIM(fileprefix),80))
  ELSE
    usedfileprefix = "used"
  ENDIF
!-
  DO if=1,nbfiles
!---
    used_filename = TRIM(usedfileprefix)//'_'//TRIM(filelist(if))
    IF (check) THEN
      WRITE(*,*) &
 &      'GETIN_DUMP : opens file : ',TRIM(used_filename),' if = ',if
      WRITE(*,*) 'GETIN_DUMP : NUMBER OF KEYS : ',nb_keys
    ENDIF
    OPEN (UNIT=22,FILE=used_filename)
!---
!-- If this is the first file we need to add the list
!-- of file which belong to it
    IF ( (if == 1).AND.(nbfiles > 1) ) THEN
      WRITE(22,*) '# '
      WRITE(22,*) '# This file is linked to the following files :'
      WRITE(22,*) '# '
      DO iff=2,nbfiles
        WRITE(22,*) 'INCLUDEDEF = ',TRIM(filelist(iff))
      ENDDO
      WRITE(22,*) '# '
    ENDIF
!---
    DO ikey=1,nb_keys
!-----
!---- Is this key from this file ?
      IF (key_tab(ikey)%keyfromfile == if) THEN
!-------
!------ Write some comments
        WRITE(22,*) '#'
        SELECT CASE (key_tab(ikey)%keystatus)
        CASE(1)
          WRITE(22,*) '# Values of ', &
 &          TRIM(key_tab(ikey)%keystr),' comes from ',TRIM(def_file)
        CASE(2)
          WRITE(22,*) '# Values of ', &
 &          TRIM(key_tab(ikey)%keystr),' are all defaults.'
        CASE(3)
          WRITE(22,*) '# Values of ', &
 &          TRIM(key_tab(ikey)%keystr), &
 &          ' are a mix of ',TRIM(def_file),' and defaults.'
        CASE DEFAULT
          WRITE(22,*) '# Dont know from where the value of ', &
 &          TRIM(key_tab(ikey)%keystr),' comes.'
        END SELECT
        WRITE(22,*) '#'
!-------
!------ Write the values
        SELECT CASE (key_tab(ikey)%keytype)
        CASE(k_i)
          IF (key_tab(ikey)%keymemlen == 1) THEN
            IF (key_tab(ikey)%keycompress < 0) THEN
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              ' = ',i_mem(key_tab(ikey)%keymemstart)
            ELSE
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              ' = ',key_tab(ikey)%keycompress, &
 &              ' * ',i_mem(key_tab(ikey)%keymemstart)
            ENDIF
          ELSE
            DO iv=0,key_tab(ikey)%keymemlen-1
              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              '__',TRIM(ADJUSTL(c_tmp)), &
 &              ' = ',i_mem(key_tab(ikey)%keymemstart+iv)
            ENDDO
          ENDIF
        CASE(k_r)
          IF (key_tab(ikey)%keymemlen == 1) THEN
            IF (key_tab(ikey)%keycompress < 0) THEN
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              ' = ',r_mem(key_tab(ikey)%keymemstart)
            ELSE
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              ' = ',key_tab(ikey)%keycompress, &
                   & ' * ',r_mem(key_tab(ikey)%keymemstart)
            ENDIF
          ELSE
            DO iv=0,key_tab(ikey)%keymemlen-1
              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr),'__',TRIM(ADJUSTL(c_tmp)), &
 &              ' = ',r_mem(key_tab(ikey)%keymemstart+iv)
            ENDDO
          ENDIF
        CASE(k_c)
          IF (key_tab(ikey)%keymemlen == 1) THEN
            tmp_str = c_mem(key_tab(ikey)%keymemstart)
            WRITE(22,*) TRIM(key_tab(ikey)%keystr), &
 &              ' = ',TRIM(tmp_str)
          ELSE
            DO iv=0,key_tab(ikey)%keymemlen-1
              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
              tmp_str = c_mem(key_tab(ikey)%keymemstart+iv)
              WRITE(22,*) &
 &              TRIM(key_tab(ikey)%keystr), &
 &              '__',TRIM(ADJUSTL(c_tmp)), &
 &              ' = ',TRIM(tmp_str)
            ENDDO
          ENDIF
        CASE(k_l)
          IF (key_tab(ikey)%keymemlen == 1) THEN
            IF (l_mem(key_tab(ikey)%keymemstart)) THEN
              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = TRUE '
            ELSE
              WRITE(22,*) TRIM(key_tab(ikey)%keystr),' = FALSE '
            ENDIF
          ELSE
            DO iv=0,key_tab(ikey)%keymemlen-1
              WRITE(UNIT=c_tmp,FMT=c_i_fmt) iv+1
              IF (l_mem(key_tab(ikey)%keymemstart+iv)) THEN
                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
 &                          TRIM(ADJUSTL(c_tmp)),' = TRUE '
              ELSE
                WRITE(22,*) TRIM(key_tab(ikey)%keystr),'__', &
 &                          TRIM(ADJUSTL(c_tmp)),' = FALSE '
              ENDIF
            ENDDO
          ENDIF
        CASE DEFAULT
          CALL ipslerr (3,'getin_dump', &
 &         'Unknown type for variable '//TRIM(key_tab(ikey)%keystr), &
 &         ' ',' ')
        END SELECT
      ENDIF
    ENDDO
!-
    CLOSE(UNIT=22)
!-
  ENDDO
!------------------------
END SUBROUTINE getin_dump
!===
SUBROUTINE get_qtyp (k_typ,c_vtyp,i_v,r_v,c_v,l_v)
!---------------------------------------------------------------------
!- Returns the type of the argument (mutually exclusive)
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(OUT) :: k_typ
  CHARACTER(LEN=*),INTENT(OUT) :: c_vtyp
  INTEGER,DIMENSION(:),OPTIONAL          :: i_v
  REAL,DIMENSION(:),OPTIONAL             :: r_v
  LOGICAL,DIMENSION(:),OPTIONAL          :: l_v
  CHARACTER(LEN=*),DIMENSION(:),OPTIONAL :: c_v
!---------------------------------------------------------------------
  k_typ = 0
  IF (COUNT((/PRESENT(i_v),PRESENT(r_v),PRESENT(c_v),PRESENT(l_v)/)) &
 &    /= 1) THEN
    CALL ipslerr (3,'get_qtyp', &
 &   'Invalid number of optional arguments','(/= 1)',' ')
  ENDIF
!-
  IF     (PRESENT(i_v)) THEN
    k_typ = k_i
    c_vtyp = 'INTEGER'
  ELSEIF (PRESENT(r_v)) THEN
    k_typ = k_r
    c_vtyp = 'REAL'
  ELSEIF (PRESENT(c_v)) THEN
    k_typ = k_c
    c_vtyp = 'CHARACTER'
  ELSEIF (PRESENT(l_v)) THEN
    k_typ = k_l
    c_vtyp = 'LOGICAL'
  ENDIF
!----------------------
END SUBROUTINE get_qtyp
!===
SUBROUTINE get_findkey (i_tab,c_key,pos)
!---------------------------------------------------------------------
!- This subroutine looks for a key in a table
!---------------------------------------------------------------------
!- INPUT
!-   i_tab  : 1 -> search in key_tab(1:nb_keys)%keystr
!-            2 -> search in targetlist(1:nb_lines)
!-   c_key  : Name of the key we are looking for
!- OUTPUT
!-   pos    : -1 if key not found, else value in the table
!---------------------------------------------------------------------
  IMPLICIT NONE
!-
  INTEGER,INTENT(in) :: i_tab
  CHARACTER(LEN=*),INTENT(in) :: c_key
  INTEGER,INTENT(out) :: pos
!-
  INTEGER :: ikey_max,ikey
  CHARACTER(LEN=l_n) :: c_q_key
!---------------------------------------------------------------------
  pos = -1
  IF     (i_tab == 1) THEN
    ikey_max = nb_keys
  ELSEIF (i_tab == 2) THEN
    ikey_max = nb_lines
  ELSE
    ikey_max = 0
  ENDIF
  IF ( ikey_max > 0 ) THEN
    DO ikey=1,ikey_max
      IF (i_tab == 1) THEN
        c_q_key = key_tab(ikey)%keystr
      ELSE
        c_q_key = targetlist(ikey)
      ENDIF
      IF (TRIM(c_q_key) == TRIM(c_key)) THEN
        pos = ikey
        EXIT
      ENDIF
    ENDDO
  ENDIF
!-------------------------
END SUBROUTINE get_findkey
!===
!------------------
END MODULE getincom