!-------------------------------------------------------------------------------
!> module ATMOSPHERE / Physics Radiation
!!
!! @par Description
!!          Atmospheric radiation transfer process wrapper
!!
!! @author Team SCALE
!!
!! @par History
!! @li      2013-12-06 (S.Nishizawa)   [new]
!!
!<
!-------------------------------------------------------------------------------
module mod_atmos_phy_rd_driver
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  use scale_tracer
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: ATMOS_PHY_RD_driver_setup
  public :: ATMOS_PHY_RD_driver

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  real(RP), private, allocatable :: RHOT_t(:,:,:)

  integer, private :: ktop
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine ATMOS_PHY_RD_driver_setup( RD_TYPE )
    use scale_process, only: &
       PRC_MPIstop
    use scale_atmos_phy_rd, only: &
       ATMOS_PHY_RD_setup
    implicit none

    character(len=H_SHORT), intent(in) :: RD_TYPE
    !---------------------------------------------------------------------------

    if( IO_L ) write(IO_FID_LOG,*)
    if( IO_L ) write(IO_FID_LOG,*) '+++ Module[Physics-RD]/Categ[ATMOS]'

    allocate( RHOT_t(KA,IA,JA) )

    call ATMOS_PHY_RD_setup( RD_TYPE )

    call ATMOS_PHY_RD_driver( .true., .false. )

    return
  end subroutine ATMOS_PHY_RD_driver_setup

  !-----------------------------------------------------------------------------
  !> Radiation main
  subroutine ATMOS_PHY_RD_driver( update_flag, history_flag )
    use scale_grid_real, only: &
       REAL_CZ,  &
       REAL_FZ,  &
       REAL_LON, &
       REAL_LAT
    use scale_landuse, only: &
       LANDUSE_frac_ocean
    use scale_time, only: &
       dt_RD => TIME_DTSEC_ATMOS_PHY_RD, &
       TIME_NOWDATE
    use scale_history, only: &
       HIST_in
    use scale_atmos_thermodyn, only: &
       THERMODYN_qd        => ATMOS_THERMODYN_qd,       &
       THERMODYN_cv        => ATMOS_THERMODYN_cv,       &
       THERMODYN_rhoe      => ATMOS_THERMODYN_rhoe,     &
       THERMODYN_rhot      => ATMOS_THERMODYN_rhot,     &
       THERMODYN_temp_pres => ATMOS_THERMODYN_temp_pres
    use scale_atmos_solarins, only: &
       SOLARINS_insolation => ATMOS_SOLARINS_insolation
    use scale_atmos_phy_rd, only: &
       ATMOS_PHY_RD
    use scale_atmos_phy_rd_common, only: &
       RD_heating => ATMOS_PHY_RD_heating, &
       I_SW, &
       I_LW, &
       I_dn, &
       I_up
    use mod_atmos_vars, only: &
       ATMOS_vars_fillhalo, &
       ATMOS_vars_total, &
       DENS, &
       RHOT, &
       QTRC, &
       RHOT_tp
    use mod_atmos_vars_sf, only: &
       ATMOS_vars_sf_fillhalo, &
       SWD,                    &
       LWD
    use mod_cpl_vars, only: &
       sw_AtmLnd => CPL_sw_AtmLnd, &
       sw_AtmOcn => CPL_sw_AtmOcn, &
       SkinT,                      &
       ALBW,                       &
       ALBG
    implicit none

    logical, intent(in) :: update_flag
    logical, intent(in), optional :: history_flag

    real(RP) :: RHOE    (KA,IA,JA)
    real(RP) :: RHOE_t  (KA,IA,JA,2)
    real(RP) :: RHOT_tmp(KA,IA,JA)
    real(RP) :: TEMP_t  (KA,IA,JA)
    real(RP) :: QDRY    (KA,IA,JA)
    real(RP) :: CVtot   (KA,IA,JA)
    real(RP) :: TEMP    (KA,IA,JA)
    real(RP) :: PRES    (KA,IA,JA)

    real(RP) :: flux_rad(KA,IA,JA,2,2)
    real(RP) :: flux_net(KA,IA,JA,2)
    real(RP) :: flux_up (KA,IA,JA,2)
    real(RP) :: flux_dn (KA,IA,JA,2)

    real(RP) :: flux_rad_top(IA,JA,2)
    real(RP) :: flux_rad_sfc(IA,JA,2)

    real(RP) :: solins  (IA,JA)
    real(RP) :: cosSZA  (IA,JA)
    real(RP) :: temp_sfc(IA,JA)
    real(RP) :: albedo_land(IA,JA,2)

    integer :: k, i, j
    !---------------------------------------------------------------------------

    if ( update_flag ) then

       if ( sw_AtmLnd .or. sw_AtmOcn ) then ! tentative
          temp_sfc   (:,:) = SkinT(:,:)
       else
          call THERMODYN_temp_pres( TEMP(:,:,:),  & ! [OUT]
                                    PRES(:,:,:),  & ! [OUT]
                                    DENS(:,:,:),  & ! [IN]
                                    RHOT(:,:,:),  & ! [IN]
                                    QTRC(:,:,:,:) ) ! [IN]

          temp_sfc(:,:) = TEMP(KS,:,:)
       endif

       if ( sw_AtmLnd ) then ! tentative
          albedo_land(:,:,I_SW) = ALBG(:,:,1)
          albedo_land(:,:,I_LW) = ALBG(:,:,2)
       elseif ( sw_AtmOcn ) then ! tentative
          albedo_land(:,:,I_SW) = ALBW(:,:,1)
          albedo_land(:,:,I_LW) = ALBW(:,:,2)
       else
          albedo_land(:,:,:) = 0.5_RP
       endif

       call SOLARINS_insolation( solins  (:,:),  & ! [OUT]
                                 cosSZA  (:,:),  & ! [OUT]
                                 REAL_LON(:,:),  & ! [IN]
                                 REAL_LAT(:,:),  & ! [IN]
                                 TIME_NOWDATE(:) ) ! [IN]

       call ATMOS_PHY_RD( DENS, RHOT, QTRC,      & ! [IN]
                          REAL_CZ, REAL_FZ,      & ! [IN]
                          LANDUSE_frac_ocean,    & ! [IN]
                          temp_sfc, albedo_land, & ! [IN]
                          solins, cosSZA,        & ! [IN]
                          flux_rad,              & ! [OUT]
                          flux_rad_top           ) ! [OUT]

       call THERMODYN_rhoe( RHOE(:,:,:),  & ! [OUT]
                            RHOT(:,:,:),  & ! [IN]
                            QTRC(:,:,:,:) ) ! [IN]

       ! apply radiative flux convergence -> heating rate
       call RD_heating( flux_rad(:,:,:,:,:),  & ! [IN]
                        REAL_FZ (:,:,:),      & ! [IN]
                        dt_RD,                & ! [IN]
                        RHOE_t  (:,:,:,:),    & ! [OUT]
                        RHOE    (:,:,:)       ) ! [INOUT]

       ! update rhot
       call THERMODYN_rhot( RHOT_tmp(:,:,:),& ! [OUT]
                            RHOE(:,:,:),    & ! [IN]
                            QTRC(:,:,:,:)   ) ! [IN]

       do j = JS, JE
       do i = IS, IE
       do k = KS, KE
          RHOT_t(k,i,j) = ( RHOT_tmp(k,i,j)-RHOT(k,i,j) ) / dt_RD
       enddo
       enddo
       enddo

       if ( sw_AtmLnd .or. sw_AtmOcn ) then
          do j = JS, JE
          do i = IS, IE
             LWD(i,j) = flux_rad(KS-1,i,j,I_LW,I_dn)
             SWD(i,j) = flux_rad(KS-1,i,j,I_SW,I_dn)
          enddo
          enddo
       endif

       if ( present(history_flag) ) then
       if ( history_flag ) then

          call HIST_in( solins(:,:), 'SOLINS', 'solar insolation',        'W/m2', dt_RD )
          call HIST_in( cosSZA(:,:), 'COSZ',   'cos(solar zenith angle)', '0-1',  dt_RD )

          do j = JS, JE
          do i = IS, IE
          do k = KS, KE
             flux_net(k,i,j,I_LW) = 0.5_RP * ( ( flux_rad(k-1,i,j,I_LW,I_up) - flux_rad(k-1,i,j,I_LW,I_dn) ) &
                                             + ( flux_rad(k  ,i,j,I_LW,I_up) - flux_rad(k  ,i,j,I_LW,I_dn) ) )
             flux_net(k,i,j,I_SW) = 0.5_RP * ( ( flux_rad(k-1,i,j,I_SW,I_up) - flux_rad(k-1,i,j,I_SW,I_dn) ) &
                                             + ( flux_rad(k  ,i,j,I_SW,I_up) - flux_rad(k  ,i,j,I_SW,I_dn) ) )

             flux_up (k,i,j,I_LW) = 0.5_RP * ( flux_rad(k-1,i,j,I_LW,I_up) + flux_rad(k,i,j,I_LW,I_up) )
             flux_up (k,i,j,I_SW) = 0.5_RP * ( flux_rad(k-1,i,j,I_SW,I_up) + flux_rad(k,i,j,I_SW,I_up) )
             flux_dn (k,i,j,I_LW) = 0.5_RP * ( flux_rad(k-1,i,j,I_LW,I_dn) + flux_rad(k,i,j,I_LW,I_dn) )
             flux_dn (k,i,j,I_SW) = 0.5_RP * ( flux_rad(k-1,i,j,I_SW,I_dn) + flux_rad(k,i,j,I_SW,I_dn) )
          enddo
          enddo
          enddo
          call HIST_in( flux_net(:,:,:,I_LW), 'RADFLUX_LW',  'net radiation flux(LW)', 'W/m2', dt_RD )
          call HIST_in( flux_net(:,:,:,I_SW), 'RADFLUX_SW',  'net radiation flux(SW)', 'W/m2', dt_RD )
          call HIST_in( flux_up (:,:,:,I_LW), 'RADFLUX_LWUP', 'up radiation flux(LW)', 'W/m2', dt_RD )
          call HIST_in( flux_up (:,:,:,I_SW), 'RADFLUX_SWUP', 'up radiation flux(SW)', 'W/m2', dt_RD )
          call HIST_in( flux_dn (:,:,:,I_LW), 'RADFLUX_LWDN', 'dn radiation flux(LW)', 'W/m2', dt_RD )
          call HIST_in( flux_dn (:,:,:,I_SW), 'RADFLUX_SWDN', 'dn radiation flux(SW)', 'W/m2', dt_RD )

          call HIST_in( flux_rad_top(:,:,I_LW), 'OLR', 'TOA     longwave  radiation', 'W/m2', dt_RD )
          call HIST_in( flux_rad_top(:,:,I_SW), 'OSR', 'TOA     shortwave radiation', 'W/m2', dt_RD )
          do j = JS, JE
          do i = IS, IE
             flux_rad_sfc(i,j,I_LW) = flux_rad(KS-1,i,j,I_LW,I_up)-flux_rad(KS-1,i,j,I_LW,I_dn)
             flux_rad_sfc(i,j,I_SW) = flux_rad(KS-1,i,j,I_SW,I_up)-flux_rad(KS-1,i,j,I_SW,I_dn)
          enddo
          enddo
          call HIST_in( flux_rad_sfc(:,:,I_LW), 'SLR', 'Surface longwave  radiation', 'W/m2', dt_RD )
          call HIST_in( flux_rad_sfc(:,:,I_SW), 'SSR', 'Surface shortwave radiation', 'W/m2', dt_RD )

          call THERMODYN_qd( QDRY(:,:,:),  & ! [OUT]
                             QTRC(:,:,:,:) ) ! [IN]

          call THERMODYN_cv( CVtot(:,:,:),   & ! [OUT]
                             QTRC (:,:,:,:), & ! [IN]
                             QDRY (:,:,:)    ) ! [IN]

          TEMP_t(:,:,:) = RHOE_t(:,:,:,I_LW) / CVtot(:,:,:) * 86400.0_RP
          call HIST_in( TEMP_t, 'TEMP_t_rd_LW', 'tendency of temp in rd(LW)', 'K/day', dt_RD )
          TEMP_t(:,:,:) = RHOE_t(:,:,:,I_SW) / CVtot(:,:,:) * 86400.0_RP
          call HIST_in( TEMP_t, 'TEMP_t_rd_SW', 'tendency of temp in rd(SW)', 'K/day', dt_RD )
          TEMP_t(:,:,:) = ( RHOE_t(:,:,:,I_LW) + RHOE_t(:,:,:,I_SW) ) / CVtot(:,:,:) * 86400.0_RP
          call HIST_in( TEMP_t, 'TEMP_t_rd', 'tendency of temp in rd', 'K/day', dt_RD )
       endif
       endif
    endif

    do j = JS, JE
    do i = IS, IE
    do k = KS, KE
       RHOT_tp(k,i,j) = RHOT_tp(k,i,j) + RHOT_t(k,i,j)
    enddo
    enddo
    enddo

    return
  end subroutine ATMOS_PHY_RD_driver

end module mod_atmos_phy_rd_driver


C
      SUBROUTINE ERT_INIT(ARCHIE,NERT)

C
      IMPLICIT NONE

      INTEGER NERT

      REAL*8 ARCHIE(4)

      OPEN(18,FILE='input/archie',status='old')

      READ(18,*) ARCHIE(1)
      READ(18,*) ARCHIE(2)
      READ(18,*) ARCHIE(3)
      READ(18,*) ARCHIE(4)
      READ(18,*) NERT
      CLOSE(18)
      return
      end
c       INCLUDE 'CATHY.H'
c      INTEGER AUGMX,AUGMY,AUGMZ
c      INTEGER NCOL,NROW,NSTR,NCOL3D,NSTR3D,I,J,NODO
c      INTEGER NROW3D,K,EL
c      INTEGER TRIANG2D(4,2*(NCOL+2*AUGMX)*(NROW+2*AUGMY))
cC attenzione!
c      INTEGER NNOD2D,NTRI2D,N12D,NZONE2D,NERT
c      INTEGER N3D,NT3D,N13D,NZONE3D,UNO
c      PARAMETER (NNOD2D=(NCOL+2*AUGMX+1)*(NROW+2*AUGMY+1))
c      PARAMETER (N3D=NNOD2D*(NSTR+AUGMZ+1))
c      PARAMETER (NT3D= 3*(NSTR+AUGMZ)*(NCOL+2*AUGMX)*(NROW+2*AUGMY))
c      INTEGER TETRA(5,NT3D)
c
c
c      REAL*8 ARCHIE(4),ZRATIO(NSTR),BASE
c      REAL*8 ZRATIO3D(NSTR+AUGMZ)
c      REAL*8 DELTA_X,LENGTH_X,LENGTH_Z,A,ALT
c      REAL*8 DELTA_Y
c      REAL*8 X3D(N3D),Y3D(N3D),Z3D(N3D)
c      REAL*8 DEPTH3D(NNOD2D)
c      REAL*8 XC3(NT3D),YC3(NT3D),ZC3(NT3D)
c      REAL*8 RMAX
c      DATA    RMAX/1.7D+100/

C
c the grid for sat3d_ert has 8 rows and 9 columns more than
C the surface grid of the DEM in CatHy. (valid for rectangular grids)
C
c      NROW3D=NROW+2*AUGMY+1
c      NCOL3D=NCOL+2*AUGMX+1
cc      NSTR3D=NSTR+AUGMZ
cC
cc at first create the 2d mesh using gridgen2d, then use gen3d for the
cc creation of the 3 dim grid.
c      OPEN(18,FILE='input_ert/grid',status='unknown')
c      DO I=1,NCOL3D*NROW3D
c         X2D(I)=0.0d0
c         Y2D(I)=0.0d0
c      END DO
c
c      CALL ERT_MESH2D(LENGTH_X,LENGTH_Y,NCOL3D-1,NROW3D-1,TRIANG2D)
c      NROW3D=NROW+8+1
c      NCOL3D=NCOL+8+1
c      LENGTH_Y= 1.0d0
c      LENGTH_X= 1.0d0
c      NNOD2D=NROW3D*NCOL3D
c      NTRI2D=2*(NROW3D-1)*(NCOL3D-1)
cc      CALL ERT_COOR2D(LENGTH_X,LENGTH_Y,NCOL3D-1,NROW3D-1,
cc     1          X2D,Y2D,NNOD2D,NT2D)
cc
cc the grid is red as there is only one zone. Later in the program for
cC ert measurements assimilation to each element will be assigned
cc a different zone.
cc
cC
c      LENGTH_X= DELTA_X*NCOL+2*(2**AUGMX-1)*DELTA_X
c      LENGTH_Y= DELTA_Y*NROW+2*(2**AUGMY-1)*DELTA_Y
c      LENGTH_Z= BASE+ZRATIO(NSTR)*BASE*AUGMZ
c      DO I=1,NSTR3D
c         IF (I.LE.NSTR) THEN
c            ZRATIO3D(I)=ZRATIO(I)*BASE/LENGTH_Z
c         ELSE
c             ZRATIO3D(I)=ZRATIO3D(NSTR)
c         END IF
c      END DO
c      WRITE(*,*) LENGTH_X,LENGTH_Y,LENGTH_Z,'LENGTH_X,LENGTH_Y,LENGTH_Z'
c      WRITE(*,*) (ZRATIO3D(I),I=1,NSTR3D),'ZRATIO3D'
c      LX=0.0d0
c      DO I=1,NCOL3D
c         LY= LENGTH_Y
c         DO J=1,NROW3D
c            NODO= (I-1)*NROW3D+J
c            X3D(NODO)=LX
c            Y3D(NODO)=LY
c            IF (J.LE. AUGMY) THEN
c               LY=LY-2**(AUGMY-J)*DELTA_Y
c            ELSE IF((J.GT.AUGMY).AND.(J.LE.NROW3D-AUGMY) THEN
c               LY=LY-DELTA_Y
c            ELSE
c               LY=LY-2**(J-NROW3D+AUGMY-1)*DELTA_Y
c            END IF
c         END DO
c         IF (I.LE. AUGMX) THEN
c            LX=LX+2**(AUGMX-I)*DELTA_X
c         ELSE IF((I.GT.AUGMX).AND.(I.LE.NCOL3D-AUGMX) THEN
c            LX=LX+DELTA_X
c         ELSE
c            LX=LX-2**(I-NCOL3D+AUGMX-1)*DELTA_X
c         END IF
c      END DO
c      WRITE(*,*) LX,LY,'LX,LZ'
c      DO I=1,NNOD2D
c          DEPTH3D(I)=0.0d0
c      END DO
c      CALL RIORD(NTRI2D,TRIANG2D,3)
c      CALL GEN3D(N3D,NT3D,NNOD2D,NSTR3D,NTRI2D,0,0,
c     1           TRIANG2D,TETRA3D,RMAX,LENGTH_Z,DEPTH3D,ZRATIO3D,
c     2      X3D,Y3D,Z3D,XC3D,YC3D,ZC3D)
c      NZONE3D=1
c      N13D=30
c      UNO=1
c      WRITE(18,*)  N3D,NT3D
c      WRITE(18,*)  NSTR3D,NZONE3D,N13D
c      Do I =1,NSTR3D
c         DO K=1,3*(NCOL2D-1)*(NROW2D-1)
c            EL=(I-1)*3 *(NCOL2D-1)*(NROW2D-1)+K
c            WRITE(18,*) EL,(TETRA(J,EL),J=1,4),I,UNO
c         END DO
c      END DO
c      Do I=1,N3D
c         WRITE(18,*) I, X3D(I),Y3D(I),Z3D(I)
c      END Do
c      CLOSE(18)

c      return
c      end


subroutine smc()

  use advance_module
  use chemistry_module
  use derivative_stencil_module
  use initialize_module
  use layout_module
  use multifab_module
  use omp_module
  use probin_module
  use runtime_init_module
  use smcdata_module
  use threadbox_module
  use time_module
  use variables_module

  implicit none

  integer :: init_step, istep, ioproc

  real(dp_t) :: dt, courno
  real(dp_t)  , pointer     :: dx(:)

  real(dp_t) :: wt1, wt2, wt_advance, wt_fb, wt_c2p, wt_c, wt_t, wt_hd
  type(layout)   :: la
  type(multifab) :: U

  call runtime_init()

  call stencil_init()

  call chemistry_init()

  call init_variables()

  call initialize_from_scratch(la,dt,courno,dx,U)

  call build_smcdata(la)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! print processor and grid info
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  if (parallel_IOProcessor()) then
     print *, ' '
     print *, 'number of MPI processes = ', parallel_nprocs()
     print *, 'number of threads       = ', omp_get_max_threads()
     print *, ' '
     print *, 'number of boxes         = ', nboxes(la)
     print *, ' '
  end if

  init_step = 1

  if ( parallel_IOProcessor()) then
     print*,""
     print*,"BEGIN MAIN EVOLUTION LOOP"
     print*,""
  end if

  wt1 = parallel_wtime()

  if ( (max_step >= init_step) .and. (time < stop_time .or. stop_time < 0.d0) ) then

     do istep = init_step, max_step

        if (parallel_IOProcessor()) then
           print*,'Advancing time step',istep,'time = ',time
        end if

        call advance(U,dt,courno,dx,istep)

        time = time + dt

        if ( parallel_IOProcessor() ) then
           print *, 'End of step', istep,'time = ', time
           print*, ""
        end if

        if (parallel_IOProcessor() .and. verbose .ge. 2) then
           call flush(6)
        end if

        ! have we reached the stop time?
        if (stop_time >= 0.d0) then
           if (time >= stop_time) then
              goto 999
           end if
        end if

     end do

999  continue

  end if

  wt2 = parallel_wtime()

  call destroy_smcdata()
  call destroy_threadbox()

  call destroy(U)

  call destroy(la)

  call chemistry_close()

  call runtime_close()

  deallocate(dx)

  ioproc = parallel_IOProcessorNode()
  call parallel_reduce(wt_advance, wt2-wt1        , MPI_MAX, proc=ioproc)
  call parallel_reduce(wt_fb     , wt_fillboundary, MPI_MAX, proc=ioproc)
  call parallel_reduce(wt_c2p    , wt_ctoprim     , MPI_MAX, proc=ioproc)
  call parallel_reduce(wt_c      , wt_chemterm    , MPI_MAX, proc=ioproc)
  call parallel_reduce(wt_t      , wt_transprop   , MPI_MAX, proc=ioproc)
  call parallel_reduce(wt_hd     , wt_hypdiff     , MPI_MAX, proc=ioproc)

  if (parallel_IOProcessor()) then
     print*, ' '
     print*, 'SMC Advance Time = ', wt_advance
     print*, '  fill boundary Time = ', wt_fb
     print*, '  ctoprim       Time = ', wt_c2p
     print*, '  chemterm      Time = ', wt_c
     print*, '  transprop     Time = ', wt_t
     print*, '  hyper & diff  Time = ', wt_hd
     print*, ' '
  end if

end subroutine smc


! Now the part where we add the incomplete Shed Segment, Gamma=0 at the "TE"
! The interest of adding those segments is that they will be convected.
! The index of those segments are stored in IBufferNewSegShed, these segments are attributed an updated value later, so that there are not incomplete anymore.

! TODO: the code below is quite redundant with Part_Emit... Maybe with a little if t=0 they could be combined..

! The imap are convenient index that allows the method to be dealt with the same way
if ( isequal(EmissionMethod,'ConvectTEAfterSolving_WithPanlP')) then
! The future points 1 and 2 of the "Buffer vortex rings" are actually points 4 and 3 of the TE panel
imap1=4
imap2=3
else if ( isequal(EmissionMethod,'CreateTEBeforeSolving')) then
! The future points 1 and 2 of the "Buffer vortex rings" are points 4 and 3 of the NW panel..
imap1=4
imap2=3
else if ( isequal(EmissionMethod,'CreateTEBeforeSolvingAndReplacePanel')) then
! The future points 1 and 2 of the "Buffer vortex rings" are points 1 and 2 of the NW panel..
imap1=1
imap2=2
end if

!m2f: IR.IBufferNewSegShed =zeros(1,Data1.nTotSideEmit) ! Index of Shed Sgmt created along the TE, part of the buffer ring
real*8, allocatable, dimension(1,Data1.nTotSideEmit) :: TODO ! m2f:check >!
if (allocated(TODO)) deallocate(TODO) !m2f: check if wanted
allocate(TODO(1,Data1.nTotSideEmit))
TODO = 0.0D
TODO =TODO ! Index of Shed Sgmt created along the TE, part of the buffer ring

!m2f: IR.IBufferNewSegTrailed=zeros(1,Data1.nTotSideEmit+1) ! Index of Trailed Sgmt created along the TE, part of the buffer ring
real*8, allocatable, dimension(1,Data1.nTotSideEmit+1) :: TODO ! m2f:check >!
if (allocated(TODO)) deallocate(TODO) !m2f: check if wanted
allocate(TODO(1,Data1.nTotSideEmit+1))
TODO = 0.0D
TODO =TODO ! Index of Trailed Sgmt created along the TE, part of the buffer ring

! IppForTEconv=zeros(1,Data1.nTotSideEmit); ! IcpForTEconv=zeros(1,Data1.nTotSideEmit); ! cpt_PP_te=0; ! cpt_CP_te=0; cpt_SegShed=0 ! counter of TE segments
ispanCum=0 ! increased index in "x" direction, almost compatible with former lattice. Before for instance X(the coordinates of the segmetns points) would have dimensions nx*nz, can be removed in the future
iNW=0 ! accumulation over "NW elements", either a NW panels or a NW incomplete segment from last time step.
! keyboard
do iw=1,size(IR.Wings)
do ipatch=1,size(IR.Wings(iw).Patches) ! loop on Patches
! TODO leading edge and TE emission
if ( IR.Wings(iw).Patches(ipatch).bEmit ) then ! Ok will emit
bThick=IR.Wings(iw).Patches(ipatch).bThick
do is=1,IR.Wings(iw).Patches(ipatch).nSpan !loop on span for TE panels

! ----------------------- PANEL index ip and Panel Points iPs ----------------------------------------
if ( isequal(EmissionMethod,'ConvectTEAfterSolving_WithPanlP')) then
! In this case the panel used is the last panel of the stripe
ip=IR.Wings(iw).Patches(ipatch).FirstPanel+is*(IR.Wings(iw).Patches(ipatch).nChord)-1 ! last panel next to TE (top one if Thick)
else if ( isequal(EmissionMethod,'CreateTEBeforeSolving') .or. isequal(EmissionMethod,'CreateTEBeforeSolvingAndReplacePanel')) then
! we use a NW panel
iNW=iNW+1
ip=IR.IpanelsNW(iNW)
end if
iPs=IR.Panl(ip,cpanCoord) ! the four points indexes of either the last panel or the NW panel

! ------------------------ DETERMINATION OF GAMMA ----------------------------------------
Gamma21=0

! ------------------------ POINTS DEFINITIONS - ADDING Point 2 (and point 1 at beginning of stripe) of Buffer Ring----------
if (is==1) then
ispanCum=ispanCum+1
! Point 1 of the "buffer vortex ring"
! If ReplaceByRing : P1=P1_NW_panel (remeber this NW panel is replace by rings at this stage, the convection has not occured)
! If CreateBefore : P1=P4_NW_panel ( the convection should have occured on the segShedBufferOld)
! If ConvectTE : P1=P4_last_wing_panel (the convection should have occured)
P1=IR.PanlP(iPs(imap1),1:3)
call fAddSegmentPoints( IR,P1,1,ispanCum,timeManager.itime , IR,isp1) !1 for convection
end if
ispanCum=ispanCum+1

! Point 2 of the "buffer vortex ring": see comments for point 1 above
P2=IR.PanlP(iPs(imap2),1:3)
call fAddSegmentPoints( IR,P2,1,ispanCum,timeManager.itime , IR,isp2) !1 for convection

! -------------------------- CREATING SEGMENTS of the Buffer Ring ----------------------------------------
! Adding the incomplete shed segment, NewSegShed (future segment 34 with intensity Gamma (will be GammaOld then))
! If ReplaceByRing : then this segment is at the TE
! Otherwise : it's the ShedVorticityConcentrationPoint on the TE trajectory
call fAddSegment( IR, isp2,isp1,Gamma21,timeManager.itime , IR,iNewSegShed)
cpt_SegShed=cpt_SegShed+1 ! counter of Shed segments
IR.IBufferNewSegShed(cpt_SegShed)=iNewSegShed

! PanlP as Control points
! cpt_PP_te=cpt_PP_te+1;
! IppForTEconv(cpt_PP_te)=iPs(4);

! This is required for CreateTEAfter and for ConvectTEBefore

! Propagation for next stripe
P1=P2
isp1=isp2
end do ! end loop on span/stripe
! cpt_PP_te=cpt_PP_te+1;
! IppForTEconv(cpt_PP_te)=iPs(3);
end if !if emit
end do ! loop on patches
end do

! Unused / old...
! IR.IppForTEconv=IppForTEconv(1:cpt_PP_te);
! IR.IcpForTEconv=IcpForTEconv(1:cpt_CP_te);
! IR.IppFutureNW =IppForTEconv


      subroutine nodein (id,y,z,roller,reftem,numnp,ityp2d)
!!!!c     implicit double precision (a-h,o-z)                                    dp
!!!!c
!!!!c     read and print nodal point data
!!!!c
      use CN_Objects_manager
      common/bk03/numdc,imassn,idampn,irller,penstf
      common/bk06/nprnt,mprint,itmpop,numelt,jprint,idump,locstr
      common/bk14/lfna(15),lfnt(6)
      common/bk23/itemp,itherm,irtin
      common/bk29/numfrq,clengt
      dimension y(*),z(*),id(2,*),roller(*),reftem(*)
      character*80 txts,mssg
!!!!!      common/WMLthermal/thermalflag,thermalconstraint(40000),
!!!!!     >    Tinit(40000),Rqold(40000)

!      common/WMLthermalperiod/period(40000)

      integer period    !!!!thermalflag, thermalconstraint,
      data nold,ymin,ymax,zmin,zmax/0,1.e20,-1.e20,1.e20,-1.e20/
      real xcoord,ycoord,BC_Mech_flag
      real BC_thermal_t,BC_diffusion_c
      integer BC_thermal_flag,BC_diffusion_flag

       write(7777,*) '-- nodein.f'
      nprnt =0
      irller=0
      bcd=0.
      kn0=0
      do 10 i=1,numnp
      id(1,i)=0
   10 id(2,i)=0
!!!!      id(1:2,1:numnp)=0
!ck----for orion input by m.k.
!c      write(29,115) numnp,numelt,numnp,numelt
!ck----end
!c
   20 kn=kn0
      call gttxsg (txts,lcount)
      read(txts,*,err=75) n,y(n),z(n),BC_Mech_flag,BC_thermal_flag
     1      ,BC_thermal_t,BC_diffusion_flag,BC_diffusion_c   !, Tfl(n),period(n)
!!!!      thermalconstraint(n)=BC_thermal_flag
!!!!      Tinit(n)=BC_thermal_t

!----------call the CN manager to set BC for both thermal and diffusion ismail2016-02-17
      Call CNSetBCdata(n,BC_thermal_t,BC_diffusion_c,BC_thermal_flag
     >                  , BC_diffusion_flag)

      !Thermal modification, WML 82210
!!!!      if (thermalflag.eq.0) then
!!!!      read(unit=txts,fmt=90,err=75) n,bcc,y(n),z(n)!,kn0,tref
!!!!!      y(n) = y(n)*1.
!!!!!	  z(n) = z(n)*1.
!!!!	  elseif (thermalflag > 0) then
!!!!      read(unit=txts,fmt=91,err=75) n,bcc,y(n),z(n),thermalconstraint(n)
!!!!     1      ,Tinit(n,1)   !, Tfl(n),period(n)
!!!!      endif

      if(irtin.eq.1) reftem(n)=tref
      roller(n)=BC_Mech_flag
!c
!c     check boundary condition code on axis of symmetry
!c
      if (ityp2d.ne.0) go to 30
      if (y(n).ne.0.0) go to 30
      if (BC_Mech_flag.eq.0.0) BC_Mech_flag=1.0
      if (BC_Mech_flag.eq.2.0) BC_Mech_flag=3.0
   30 if (ymin.gt.y(n)) ymin=y(n)
      if (ymax.lt.y(n)) ymax=y(n)
      if (zmin.gt.z(n)) zmin=z(n)
      if (zmax.lt.z(n)) zmax=z(n)
      if (nprnt.gt.0) go to 40
      nprnt=50
      call header
      write(lfnt(2),80)
   40 nprnt=nprnt-1
      write(lfnt(2),100) n,BC_Mech_flag,y(n),z(n),BC_thermal_flag,
     > BC_thermal_t,BC_diffusion_flag,BC_diffusion_c
      if (BC_Mech_flag.ge.0.0) iflag=0
      if (BC_Mech_flag.lt.0.0) iflag=1
      if (BC_Mech_flag.ne.bcd) iflag=1
      if (BC_Mech_flag.lt.0.0) BC_Mech_flag=-BC_Mech_flag

      if (BC_Mech_flag.eq.1.0) id(1,n)=1
      if (BC_Mech_flag.eq.2.0) id(2,n)=1
      if (BC_Mech_flag.eq.3.0) id(1,n)=1
      if (BC_Mech_flag.eq.3.0) id(2,n)=1

      if (kn.eq.0) kn=1
      if (nold.eq.0) go to 60
      num=(n-nold)/kn
      numn=num-1
      if (numn.lt.1) go to 60
      xnum=num
      dy=(y(n)-y(nold))/xnum
      dz=(z(n)-z(nold))/xnum
      if(irtin.eq.1) dt=(reftem(n)-reftem(nold))/xnum
      k=nold
      do 50 j=1,numn
      kk=k
      k=k+kn
      y(k)=y(kk)+dy
      z(k)=z(kk)+dz
      if(irtin.eq.1) reftem(k)=reftem(kk)+dt
      roller(k)=roller(kk)
      if (iflag.eq.1) go to 50
      id(1,k)=id(1,kk)
      id(2,k)=id(2,kk)
   50 continue
c
   60 nold=n
      bcd=BC_Mech_flag
      if (n.ne.numnp) go to 20
c
!!!!!!    ----------------------------testing
!!!!        write(*,*)id(1,1:25)
!!!!        write(*,*)id(2,1:25)
      do 70 i=1,numnp
      absrol=abs(roller(i))
      if(absrol.eq.1..or.absrol.eq.2..or.absrol.eq.3.) roller(i)=0.
      if(roller(i).ne.0.) irller=1
   70 continue
c
      clengt=sqrt((zmax-zmin)**2+(ymax-ymin)**2)
      penstf=10000.*clengt*penstf/sqrt(float(numelt))
c
      return
c
   75 nold=nold+1
      write (unit=mssg,fmt=110) nold
      call termin (txts,mssg,lcount,1)
c
   80 format(///' n o d a l   p o i n t   d a t a '/
     > /' node',5x,' b.c.',10x,'y',10x,'z',10x,'BC',
     > 5x,'Tini',5x,'BC',5x,'Cini')
   90 format(i5,f5.1,2e13.5,i5,e13.5)
   91 format(i5,f5.1,2e13.5,i5,2e13.5,i5)
  100 format(i5,5x,f5.0,5x,e12.4,8x,e12.4,6x,i4,
     > 5x,e12.4,5x,i4,5x,e12.4)
  110 format(' error reading nodal cards, probably for node #',i6)
  115 format(i5,2x,i5,2x,i5,2x,i5)
      end


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to improve the camera pointing by fitting to the star
C background.
C
      SUBROUTINE STARFIT(IMG,PIC,HPIC,NL,NS,FOV)
      IMPLICIT REAL*8 (A-H,O-Z)
      BYTE PIC(NS,NL)
      INTEGER*2 HPIC(NS,NL)

      COMMON/CSTAR/NSTARS,STARS(3,2000),SPTS(2,2000),LOMAG,HIMAG
      COMMON/CSTAR1/ISAO,SAOFILE
      COMMON/CSTAR2/STARNAME,STARTYPE
      REAL*4 STARS,SPTS
      INTEGER*4 HIMAG,LOMAG,HIMAG1
      CHARACTER*72 SAOFILE
      CHARACTER*13 STARNAME(2000)
      CHARACTER*3 STARTYPE(2000)

      COMMON/GSCCMN/ GSCPFX
      CHARACTER*199 GSCPFX

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      COMMON/CPICX/T0,T
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      INTEGER*4 SHIST(13)
      LOGICAL PARMTST,XVIPTST
C
C set ISAO to -2 if we are to use GSC catalog instead of SAO catalog
      call xvparm('GSCPFX',gscpfx,icnt,idef,' ')
      if (icnt.eq.1 .and. gscpfx(1:1).ne. ' ') then
        isao = -2
      else
        CALL XVPARM('SAO',saofile,icnt,idef,' ') !Get SAO catalog file spec
        if (icnt.eq.0) then
          call xvmessage(' Missing SAO parameter....',' ')
          call xvmessage(' See help on SAO parameter.',' ')
          call xvmessage(' NAV task cancelled',' ')
	  call abend
        endif
      endif

      MODEL=5
      CALL GETNAV		!Install planet geometry
      IF (ISAO.EQ.-1) THEN
         CALL XVUNIT(ISAO,'S',1,IND,'U_NAME',SAOFILE,' ')
         CALL XVSIGNAL(ISAO,IND,.TRUE.)
      ENDIF
      CALL T1950(IDATE,ITIME,RSC,t)
      CALL GETSTARS(ISAO,CM,FOV,T,stars,spts,nstars,
     &     starname,startype,*20)
      CALL STARHIST(STARS,SPTS,NSTARS,NL,NS,shist,lomag,himag)
      CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,0)
C
   20 CALL XVINTRACT('STARFIT','STARFIT ')
      IF (XVIPTST('HELP')) CALL XVINTRACT('STARFIT',' ')
      IF (XVIPTST('EXIT')) RETURN

      CALL ISETCOLOR

      IF (XVIPTST('SSTARS')) THEN
          IF (NSTARS.GT.0)
     &		 CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,0)
          GOTO 20
      ENDIF

      IF (PARMTST('HIMAG',HIMAG,I)) THEN
          IF (NSTARS.GT.0)
     &		 CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,1)
          GOTO 20
      ENDIF

      IF (XVIPTST('MSTARS')) THEN
          CALL MOVESTAR(PIC,HPIC,NL,NS,*20)
          CALL STARHIST(STARS,SPTS,NSTARS,NL,NS,shist,lomag,himag1)
          IF (NSTARS.GT.0)
     &		 CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,1)
          GOTO 20
      ENDIF

      IF (XVIPTST('TIEPOINT')) THEN
          CALL TIESTAR(*20)
c         CALL GETSTARS(ISAO,CM,OAL,OAS,ZSCALE,FOV,T,
c    &		stars,spts,nstars,starname,startype,*20)
c  above call has 3 arguments not in the (current) function!
c  remove these to avoid warnings during build ... (lwk / oct09)
          CALL GETSTARS(ISAO,CM,FOV,T,
     &		stars,spts,nstars,starname,startype,*20)
          CALL STARHIST(STARS,SPTS,NSTARS,NL,NS,shist,lomag,himag1)
          IF (NSTARS.GT.0)
     &		 CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,1)
          GOTO 20
      ENDIF

      IF (XVIPTST('EDIT')) THEN
          CALL EDITNAV(IMG,PIC,HPIC,NL,NS)
          CALL UPDATESTAR  !VRH 7/4/89 update stars - new routine
          CALL STARHIST(STARS,SPTS,NSTARS,NL,NS,shist,lomag,himag1)
          GOTO 20
      ENDIF

      IF (XVIPTST('PARAMS')) THEN
         CALL RPARAM
         GOTO 20
      ENDIF

      CALL DISPLAY(PIC,HPIC,NL,NS,IND)
      IF (IND.NE.0) GOTO 20
      CALL SDISPLAY(PIC,HPIC,NL,NS,IND) !VRH 6/28/89 new calling list
      IF (IND.NE.0) GOTO 20
      GOTO 20
C
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Read SAO catalog and returns stars within field-of-view of camera
C
C Inputs:  CM=C-matrix
C	   OAL,OAS=Line-sample of optical-axis intercept point
C          ZSCALE=FL*PICSCALE
C          FOV=camera field-of-view (radians)
C	   T=days since EME50
C
C Outputs: STARS(3,N)=(RA,DEC,MAGNITUDE)
C	   SPTS(2,N)=(RLINE,RSAMP)
C	   NSTARS = number of stars returned
C
C SAO catalog format:  In the file, the data
C is grouped into 18 segments of 10 degrees each
C and is ordered in RA within each segment.
C Each star has a data record of 36 bytes.
C RA (radians), RAMu (pm in sec time/year)
C DEC (radians), DECMu (pm in sec arc/year)
C Visual Magnitude,  13-byte Name and 3-byte Spectral type
C The first 4 records of the output catalog are 18 sets
C of pointers to the records for the start and end of
C each segment.  Record count starts at 0.
C The real values (RA, RAMu, DEC, DECMu and Mag) are in IEEE
C The pointer integers are in network byte order INTFMT=HIGH

      SUBROUTINE GETSTARS(ISAO,CM,FOV,T,stars,spts,nstars,
     &                    starname,startype,*)
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*4 STARS(3,2000),SPTS(2,2000)
      CHARACTER*13 STARNAME(2000)
      CHARACTER*3 STARTYPE(2000)
      REAL*8 CM(3,3)

      COMMON/CP/IBUG,NLW,NSW,NSEARCH,IFIT

      COMMON/CONST/PI,DTR,RTD
      REAL*8 LODEC,LORA,JTIME
      CHARACTER*80 MSG

      COMMON/GSCCMN/ GSCPFX
      CHARACTER*199 GSCPFX

      common /starinfo/ stardata, starnm, startp
      real*4 stardata(5)
      character*13 starnm
      character*3 startp

      integer*4 conv_buf(12)
      integer*4 ptr(2,18),pointers(36)
      real*4 DATA(5)

      logical from
      doubleprecision oara, oadec, oakappa, oauv(3), oarov, kappa0
      integer maxstars / 2000 /
      save

CBTC if the VICAR unit number of the SAO Catalog file is -2, then use the
CBTC STScI Guide Star Catalog
      if ( isao .eq. -2) then

CBTC - get optic axis, convert to GSC reference frame & unit vector
CBTC - set the Radius-Of-View to be the input FOV - so we will get stars
CBTC     within a circle of diameter twice the FOV around the optic axis
        CALL COMPCM(CM,oara,oadec,oakappa)
CBTC
CBTC - convert oara, oadec to GSC reference frame
        from = .false.
        call fromorto_star( oara, oadec, from)
        call radrec( 1d0, oara, oadec, oauv)
        oarov = FOV
CBTC
CBTC - load stars within oarov of optic axis into the stars() array

        call xvmessage( 'GSC search disabled in this version', ' ')
        nstars = 0
CBTCGSCDISABLED x        call seagsc( oara, oadec, oauv, oarov, gscpfx
CBTCGSCDISABLED x     &             , maxstars, stars, nstars)

CBTC
CBTC - convert stars' ra & dec back to local reference frame
        IF (NSTARS.GT.0) then
          from = .true.
          do i1=1,nstars
            ra = stars(1,i1)
            dec = stars(2,i1)
            call fromorto_star( ra, dec, from)
            stars(1,i1) = ra
            stars(2,i1) = dec
          enddo
          CALL UPDATESTAR
          return
        endif
        CALL XVMESSAGE('***No stars found in GSC within field-of-view'
     .                ,' ')
        RETURN1
      endif
CBTC
  110 FORMAT('STAR=',I4,2F8.3,F5.2,2F10.5,' New=',2F8.5)

      JTIME = T/365.25D0		!Years since 1-1-1950
      WRITE(MSG,*)'Years of plate since 1/1/1950 is:',JTIME
      CALL XVMESSAGE(MSG,' ')
C     ....Get right-ascension & declination of optical-axis intercept
      CALL COMPCM(CM,ra0,dec0,kappa0)
CBTC
CBTC convert optic axis to SAO reference frame
      from = .false.
      call fromorto_star( ra0, dec0, from)
      from = .true.
CBTC
C     ....Determine ra,dec limits of a box twice the camera's
C     ....field-of-view
      TFOV = 2.*FOV
      HIDEC = DEC0 + TFOV/2.
      LODEC = HIDEC - TFOV
      HIDEC = MIN(PI/2.,HIDEC)
      LODEC = MAX(-PI/2.,LODEC)
      HIRA = RA0 + TFOV/2./DCOS(DEC0)  !VRH 8/16/89 correct for smaller
      LORA = HIRA - TFOV/DCOS(DEC0)    !VRH 8/16/89 RA circles at poles
      IF (LORA .LT. 0.) LORA = LORA + 2.*PI
      IF (HIRA .GT. 2.*PI) HIRA = HIRA - 2.*PI
      IF (DEC0.GT.(PI/2.-TFOV).OR.DEC0.LT.(TFOV-PI/2.)) THEN  !VRH 8/16/89
          LORA = 0.      ! If within FOV of pole, whole RA range is in FOV
          HIRA = 2.*PI
      ENDIF
CBTC      WRITE(MSG,*)'RA FOV limits:',lora,hira
      WRITE(MSG,*)'RA FOV limits(EME50):',lora/dtr,hira/dtr
      CALL XVMESSAGE(MSG,' ')
      IF (LORA .GT. HIRA)
     &   CALL XVMESSAGE('FOV contains 0 RA, limits reversed',' ')
CBTC      WRITE(MSG,*)'Dec FOV limits:',lodec,hidec
      WRITE(MSG,*)'Dec FOV limits(EME50):',lodec/dtr,hidec/dtr
      CALL XVMESSAGE(MSG,' ')

C     ....Determine the blocks of declination which span the plate fov.
      IBTOP = INT((90.-HIDEC*RTD)/10.) + 1
      IBBOT = INT((90.-LODEC*RTD)/10.) + 1
      WRITE(MSG,*)'Star Catalog blocks used from',ibtop,' to',ibbot
      CALL XVMESSAGE(MSG,' ')

C     ....Open SAO catalogue compressed by IDL procedure CONVERT_SAO.PRO
      CALL XVOPEN(ISAO,IND,'COND','NOLABELS NOBLOCK',
     &		'I_FORMAT','FULL','CONVERT','OFF','U_NS',9,
     &          'OPEN_ACT','SA','IO_ACT','SA',' ')
      NSTARS = 0

c read pointers: star catalog data is BigEndian (HIGH) and IEEE
c integer elements (pointers)
      CALL XVREAD(ISAO,pointers,IND,'LINE',1,' ')  !Read pointers from header
      CALL XVREAD(ISAO,pointers(10),IND,'LINE',2,' ')
      CALL XVREAD(ISAO,pointers(19),IND,'LINE',3,' ')
      CALL XVREAD(ISAO,pointers(28),IND,'LINE',4,' ')
      call xvtrans_in(conv_buf,'FULL','FULL','HIGH','IEEE', status)
      call xvtrans(conv_buf, pointers, ptr, 36)

C     ....Now get all the stars in the area
      DO 50 I1=IBTOP,IBBOT	   !Loop through blocks
      WRITE(MSG,*)'RECORD RANGE=',PTR(1,I1),PTR(2,I1)
      CALL XVMESSAGE(MSG,' ')

      IF(PTR(1,I1).EQ.0) GOTO 50 ! In case no data VRH 6/22/89

c Narrow down RA range
      JPTR1 = PTR(1,I1)
      JPTR2 = PTR(2,I1)
      NSTEP = (JPTR2-JPTR1)/36
      IF (LORA.LT.HIRA.AND.NSTEP.GT.10) THEN
        DO 30 I2=PTR(1,I1),PTR(2,I1),NSTEP
        CALL XVREAD(ISAO,stardata,IND,'LINE',I2+1,' ')  !Read star data
        call xvtrans_in(conv_buf,'REAL','REAL','HIGH','IEEE', status)
        call xvtrans(conv_buf, stardata, data, 5)
        IF (DATA(1).LT.LORA) JPTR1 = I2
        IF (DATA(1).GT.HIRA.AND.JPTR2.EQ.PTR(2,I1)) JPTR2 = I2
30      CONTINUE
      ENDIF

      WRITE(MSG,*)'Record inside block RANGE=',JPTR1,JPTR2
      CALL XVMESSAGE(MSG,' ')

      DO 40 I2=JPTR1,JPTR2 !Loop through valid records in block I1
      CALL XVREAD(ISAO,stardata,IND,'LINE',I2+1,' ')  !Read star data from file
      call xvtrans_in(conv_buf,'REAL','REAL','HIGH','IEEE', status)
      call xvtrans(conv_buf, stardata, data, 5)

      IF (LORA.GT.HIRA) THEN
         IF (DATA(1).LT.LORA.AND.DATA(1).GT.HIRA) GOTO 40
      ELSE
         IF (DATA(1).GT.HIRA) GOTO 50    !Determine if star
         IF (DATA(1).LT.LORA) GOTO 40    !is within fov...
      ENDIF
      IF (DATA(3).GT.HIDEC) GOTO 40
      IF (DATA(3).LT.LODEC) GOTO 40
C     ....Apply proper motion to star
      RA = DATA(1)+(DATA(2)*JTIME/240.D0)*DTR
      DEC = DATA(3)+(DATA(4)*JTIME/3600.D0)*DTR

CBTC  ....Convert to ISYSTEM
      call fromorto_star( ra, dec, from)
CBTC
      IF (NSTARS.GE.2000) THEN
         CALL XVMESSAGE('***More than 2000 stars within field-of-view',
     .      ' ')
         CALL XVMESSAGE('***Remaining stars ignored',' ')
         GOTO 100
      ENDIF
      NSTARS = NSTARS + 1
      STARS(1,NSTARS) = RA
      STARS(2,NSTARS) = DEC
      STARS(3,NSTARS) = DATA(5)	!Visual magnitude
      ICHAR = INDEX(STARNM,CHAR(0))
      IF (ICHAR .GT. 0) THEN
         STARNAME(NSTARS) = STARNM(1:ICHAR-1)
      ELSE IF (ICHAR.EQ.1) THEN
         STARNAME(NSTARS) = ' '
      ELSE
         STARNAME(NSTARS) = STARNM
      ENDIF
      ICHAR = INDEX(STARTP,CHAR(0))
      IF (ICHAR .GT. 0) THEN
         STARTYPE(NSTARS) = STARTP(1:ICHAR-1)
      ELSE IF (ICHAR.EQ.1) THEN
         STARTYPE(NSTARS) = ' '
      ELSE
         STARTYPE(NSTARS) = STARTP
      ENDIF
      IF (IBUG.EQ.1) THEN
         WRITE(MSG,110) NSTARS,DATA(1),DATA(3),DATA(5),
     &     DATA(2),DATA(4),RA,DEC
         CALL XVMESSAGE(MSG,' ')
      ENDIF
   40 CONTINUE
   50 CONTINUE

  100 CALL XVCLOSE(ISAO,IND,' ')
      CALL UPDATESTAR  !VRH 7/4/89 update stars - new routine
      IF (NSTARS.GT.0) RETURN
      CALL XVMESSAGE('***No stars found in catalog within field-of-view'
     .      ,' ')
      RETURN1
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
      SUBROUTINE STARHIST(STARS,SPTS,NSTARS,NL,NS,shist,lomag,himag)
      REAL*4 STARS(3,2000),SPTS(2,2000)
      INTEGER*4 SHIST(13),LOMAG,HIMAG
      CHARACTER*80 MSG

      RNL = NL		!Float the image size for efficiency
      RNS = NS
      CALL ZIA(SHIST,13)

      DO 5 I=1,NSTARS
      RLINE = SPTS(1,I)
      IF (RLINE.LT.1.OR.RLINE.GT.RNL) GOTO 5
      RSAMP = SPTS(2,I)
      IF (RSAMP.LT.1.OR.RSAMP.GT.RNS) GOTO 5
      IMAG = STARS(3,I)
      IF (IMAG.LT.0) IMAG=0
      IF (IMAG.GT.12) IMAG=12
      SHIST(IMAG+1) = SHIST(IMAG+1)+1
    5 CONTINUE

      HIMAG = 1
      LOMAG = 2000

      IF (SHIST(1).GT.0) THEN
         WRITE(MSG,*) 'There are ',SHIST(1),
     &	' stars at or below magnitude 0'
         CALL XVMESSAGE(MSG,' ')
      ENDIF

      DO 10 I=1,11
      IF (SHIST(I+1).EQ.0) GOTO 10
      WRITE(MSG,*) 'There are ',SHIST(I+1),' stars at magnitude',I
      CALL XVMESSAGE(MSG,' ')
      HIMAG = I + 1
      IF (LOMAG.EQ.2000) LOMAG=I
   10 CONTINUE

      IF (LOMAG.EQ.2000) LOMAG=I

      IF (SHIST(13).GT.0) THEN
         WRITE(MSG,*) 'There are ',SHIST(13),
     &	' stars at or above magnitude 12'
         CALL XVMESSAGE(MSG,' ')
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to manually register the star background and update OM matrix.
C
      SUBROUTINE MOVESTAR(PIC,HPIC,NL,NS,*)
      IMPLICIT REAL*8 (A-H,O-Z)
      BYTE PIC(NS,NL)
      INTEGER*2 HPIC(NS,NL)

      COMMON/CSTAR/NSTARS,STARS(3,2000),SPTS(2,2000),LOMAG,HIMAG
      REAL*4 STARS,SPTS
      INTEGER*4 HIMAG,LOMAG

      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      REAL*4 CPTS(2,100),APTS(2,100),rl4,rs4
      INTEGER*2 IPTS(100)
      LOGICAL XVIPTST
      CHARACTER*80 MSG
  110 FORMAT('DL=',F8.3,' DS=',F8.3,' DT=',F8.4,' RMS=',F8.3,' pixels')

      CALL STARPTS(PIC,HPIC,NL,NS,STARS,SPTS,NSTARS,LOMAG,HIMAG,
     &		cpts,apts,ipts,npts)
      IF (NPTS.EQ.0) RETURN

c      do i=1,npts
c	write(*,'(a,i3,a,f6.1,X,f6.1,a,f6.1,x,f6.1)') ' star ',
c    &   i,': c-',cpts(1,i),cpts(2,i),' a-',apts(1,i),apts(2,i)
c      end do

    5 CALL XVINTRACT('CHISQ',
     &   ' Specify type of fit (Enter ''CHI2, ''CHI3 or ''EXIT)')
      IF (XVIPTST('EXIT')) RETURN1
      IF (XVIPTST('CHI2')) THEN
          IFIT = 2
          DT = 0.D0
      ELSE
          IF (XVIPTST('CHI3')) THEN
               IFIT = 3
          ELSE
               GOTO 5
          ENDIF
      ENDIF

      IF (ITYPE.EQ.7) THEN
         XOAL = OAL_IS
         XOAS = OAS_IS
      ELSE
         XOAL = OAL
         XOAS = OAS
      ENDIF

      CALL GETANGLES2(CM,theta_n,theta_a,theta_b)
      LOOP_COUNT = 0
      IMODE = 0

      IF(theta_a.LT.10.*DTR) THEN !VRH 7/26/89 automatic direct CM correction
         CALL XVMESSAGE(
     .      'NOTE: ThetaA (Optic axis to celes pole) <10 deg',' ')
         CALL XVMESSAGE(
     .      'Making pointing correction directly to C-Matrix',' ')
c12345678901234567890123456789012345678901234567890123456789012345678907234567890
      ENDIF

   10 IF (IFIT.EQ.2) THEN
           CALL FIT2(APTS,CPTS,NPTS,dl,ds)
      ELSE
           CALL FIT3(APTS,CPTS,NPTS,XOAL,XOAS,dl,ds,dt,*999)
           THETA_N = THETA_N + DT
      ENDIF

      IF (ITYPE.EQ.7) THEN 	!Scale displacements to object-space
         DL = DL*CTOS
         DS = DS*CTOS
      ENDIF

      IF (theta_a.LT.10.*DTR) THEN  !VRH 7/26/89 corrections directly to CM
         SCALE = DSQRT(ZSCALE**2+DL**2+DS**2)
         CALL ROTATE1(CM,-DL/SCALE,1)
         CALL ROTATE1(CM,DS/SCALE,2)
         IF(IFIT.EQ.3) CALL ROTATE1(CM,DT,3)
         CALL GETANGLES2(CM,theta_n,theta_a,theta_b)
      ELSE ! Regular way
         CALL MOVE1(DL,DS,theta_n,theta_a,theta_b,ZSCALE)
         CALL OMMATRIX(THETA_N,THETA_A,THETA_B,cm)	!Update CM-matrix
      ENDIF
      RMS = 0.D0

      DO I=1,NPTS
         J = IPTS(I)
         RAS = STARS(1,J)
         DEC = STARS(2,J)
         CALL STARINV(RAS,DEC,rline,rsamp,CM,OAL,OAS,ZSCALE)
         IF (ITYPE.EQ.7) then
	   CALL CONVISOS(PROJECT,ICAM,rl4,rs4,sngl(RLINE),sngl(RSAMP),
     &		0,CONV,NPH,NPV,ind)
	   rline=rl4
	   rsamp=rs4
	 endif
         CPTS(1,I) = RLINE
         CPTS(2,I) = RSAMP
         RMS = RMS + (APTS(1,I)-RLINE)**2 + (APTS(2,I)-RSAMP)**2
      ENDDO

      RMS = DSQRT(RMS/NPTS)
      WRITE(MSG,110) DL,DS,DT*RTD,RMS
      CALL XVMESSAGE(MSG,' ')

      IF (IMODE.EQ.1) GOTO 20
      DIFF = DSQRT(DL**2 + DS**2)
      IF (DIFF.LT.0.01.AND.DABS(DT).LT.0.0001D0)
     &     IMODE=1			!Set up for last iteration
      LOOP_COUNT = LOOP_COUNT + 1
      IF (LOOP_COUNT.GE.15) THEN
           CALL XVMESSAGE('***Star fit converges slowly',' ')
           IMODE = 1			!Set up for last iteration
      ENDIF
      GOTO 10
C
   20 CALL GETANGLES(CM,ME(1,3),PSC,ANGLN,ANGLA,ANGLB)
      CALL UPDATENAV
      CALL UPDATESTAR
      RETURN

  999 RETURN1
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to acquire star tiepoints by matching the computed star background
C to the imaged stars via the cursor.
C Outputs: CPTS,APTS=(line,samp) coordinates for matching computed stars
C             and star images, respectively.
C          IPTS=pointer to SPTS array for each tiepoint.
C	   NPTS=number of tiepoints acquired.
C
      SUBROUTINE STARPTS(PIC,HPIC,NL,NS,STARS,SPTS,NSTARS,LOMAG,HIMAG,
     &      cpts,apts,ipts,npts)
      INTEGER HIMAG

      COMMON/CRES/RES(2,202),BLEM(4,1000),NBLEMS
      REAL*4 RES,BLEM

      COMMON/CPIC/IPROJ,ICAM,FRAME_ID,PLANET_ID
      COMMON/CPIC/TARGET_ID,IDATE,ITIME
      INTEGER*4 IPROJ,ICAM,FRAME_ID,PLANET_ID,TARGET_ID

      BYTE PIC(NS,NL)
      INTEGER*2 HPIC(NS,NL)
      REAL*4 STARS(3,2000),SPTS(2,2000),CPTS(2,100),APTS(2,100)
      INTEGER*2 IPTS(100)
      LOGICAL XVIPTST
      REAL*8 RL8,RS8

      NPTS = 0
      CALL XVMESSAGE('Begin manual registration of star background...',
     1 ' ')

    5 CALL XVMESSAGE('To select a star, move cursor to a graphics star',
     1 ' ')
      CALL XVMESSAGE('and hit RETURN.  You will then be asked to match',
     1 ' ')
      CALL XVMESSAGE('the selected star to its image via the cursor',
     1 ' ')
      CALL XVMESSAGE(
     &  'Repeat to acquire more points or type EXIT when done',' ')
      CALL XVMESSAGE('You may delete a point by typing D',' ')
      CALL XVMESSAGE(
     &  'You may adjust the display by using H,CZOOM,STRETCH, or ASTR',
     1 ' ')

   10 CALL XVINTRACT('TRACECRV','READY')
      IF (XVIPTST('HELP')) GOTO 5
      IF (XVIPTST('EXIT')) RETURN
      IF (XVIPTST('D')) THEN
         IF (NPTS.EQ.0) GOTO 10
         CALL FINDPT(CPTS,NPTS,1,imin)	!Find closest star to cursor
C               Delete it
         CALL DRAWDOT(APTS(1,IMIN),APTS(2,IMIN),0)
         NPTS = NPTS - 1
         DO I=IMIN,NPTS
             IPTS(I) = IPTS(I+1)
             CPTS(1,I) = CPTS(1,I+1)
             CPTS(2,I) = CPTS(2,I+1)
             APTS(1,I) = APTS(1,I+1)
             APTS(2,I) = APTS(2,I+1)
         ENDDO
         GOTO 10
      ENDIF

      CALL DISPLAY(PIC,HPIC,NL,NS,IND)
      IF (IND.EQ.1) THEN
          IF (NSTARS.GT.0)
     &	     CALL DRAWSTARS(STARS,SPTS,NSTARS,LOMAG,HIMAG,0)
          IF (NPTS.GT.0) CALL DRAWCURVE(APTS,NPTS,0)
      ENDIF
      IF (IND.GT.0) GOTO 10
C     ....Here to acquire a new star
      CALL FINDSTAR(STARS,SPTS,NSTARS,HIMAG,imin) !Find closest star to cursor
      CALL XVINTRACT('READY','Cursor star image and hit RETURN')
      IF (XVIPTST('EXIT')) GOTO 10
      CALL CURSOR(RL8,RS8)		!Read cursor position
      RLINE = RL8
      RSAMP = RS8
      PRINT 1000,CHAR(7)
 1000 FORMAT(1X,A1)

      IF (IPROJ.EQ.4) THEN
         CALL VGRCLEAR(ind,3,RES,BLEM,NBLEMS,3.,RLINE,RSAMP)
         IF (IND.EQ.0) GOTO 10
      ENDIF

      CALL DRAWDOT(SPTS(1,IMIN),SPTS(2,IMIN),255)
      CALL DRAWDOT(RLINE,RSAMP,255)	!Draw a dot there
      NPTS = NPTS + 1			!Record the star
      IPTS(NPTS) = IMIN
      CPTS(1,NPTS) = SPTS(1,IMIN)
      CPTS(2,NPTS) = SPTS(2,IMIN)
      APTS(1,NPTS) = RLINE
      APTS(2,NPTS) = RSAMP
      IF (NPTS.LT.100) GOTO 10
      CALL XVMESSAGE('Maximum number of points acquired',' ')
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Update the star map with current navigation info (VRH)
C
      SUBROUTINE UPDATESTAR
      IMPLICIT REAL*8 (A-H,O-Z)

      COMMON/CSTAR/NSTARS,STARS(3,2000),SPTS(2,2000),LOMAG,HIMAG
      REAL*4 STARS,SPTS
      INTEGER*4 HIMAG,LOMAG

      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL
      real*4 rl4,rs4

      DO I=1,NSTARS		!Recompute star background
         RAS = STARS(1,I)
         DEC = STARS(2,I)
         CALL STARINV(RAS,DEC,rline,rsamp,CM,OAL,OAS,ZSCALE)
         IF (ITYPE.EQ.7) then
	   CALL CONVISOS(PROJECT,ICAM,rl4,rs4,sngl(RLINE),sngl(RSAMP),
     &		0,CONV,NPH,NPV,ind)
	   rline=rl4
	   rsamp=rs4
	 endif
         SPTS(1,I) = RLINE
         SPTS(2,I) = RSAMP
      ENDDO
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Find star in starmap that is closest to cursor.
C Output: IMIN = index of closest star.
C
      SUBROUTINE FINDSTAR(STARS,SPTS,NSTARS,HIMAG,imin)
      REAL*4 STARS(3,NSTARS),SPTS(2,NSTARS)
      INTEGER HIMAG
      REAL*8 RL8,RS8

      CALL CURSOR(RL8,RS8)		!Read cursor position
      RLINE = RL8
      RSAMP = RS8
      PRINT 1000,CHAR(7)		!Make bell go "ding"
 1000 FORMAT(1X,A1)
      RMIN = 1.D+20

C     ....Find closest point to cursor position
      DO 10 I=1,NSTARS
      IF (STARS(3,I).GT.FLOAT(HIMAG)) GOTO 10
      R = (SPTS(1,I)-RLINE)**2 + (SPTS(2,I)-RSAMP)**2
      IF (R.LT.RMIN) THEN
          RMIN = R
          IMIN = I
      ENDIF
   10 CONTINUE

      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to check cursor position and issue warning message if it
C is within radius R of a Voyager reseau mark or blemish.
C This routine is a modification of CLEANVGR.
C
C MODE=1 ...check for reseau marks
C     =2 ...check for camera blemishes
C     =3 ...check for both
C
C Return indicator (IND) =1 for normal return, =0 if cursor position
C is rejected.
C
      SUBROUTINE VGRCLEAR(ind,MODE,RES,BLEM,NBLEM,R,RLINE,RSAMP)
      REAL*4 RES(2,202),BLEM(4,1000)
      INTEGER*2 ROW_TYPE(24)/1,2,1,2,3,2,4,2,4,2,4,2,4,2,
     &    4,2,4,2,4,2,1,2,1,1/
      INTEGER*2 IROW(24)/1,13,24,36,47,51,62,66,77,81,92,
     &    96,107,111,122,126,137,141,152,156,167,179,190,190/
      INTEGER*2 ICOL(12,4)/0,1,2,3,4,5,6,7,8,9,10,11,
     &                     0,1,2,3,4,5,6,7,8,9,10,10,
     &                     0,1,1,1,1,155,155,155,155,2,2,3,
     &                     0,1,1,1,1,1,2,2,2,2,2,3/
      REAL*4 OFFSETS(4),LOFFSET,LEFTSAMP
      INTEGER*4 RTYPE
      LOGICAL XVIPTST
      CHARACTER*80 MSG  ! VRH 5/25/95 added variable previously undeclared
C
      IND = 1
      R2 = R**2			!Square of pixel radius
      IF (RES(1,195).LT.900.0) THEN  !If image-space, then
         RNL = 800.0		!number of lines=800
         RNS = 800.0		!number of samps=800
      ELSE			!else, object-space.
         RNL = 1000.0
         RNS = 1000.0
      ENDIF
      IF (RSAMP.LT.1.0 .OR. RSAMP.GT.RNS) RETURN
      IF (RLINE.LT.1.0 .OR. RLINE.GT.RNL) RETURN

      IF (MODE.EQ.2) GOTO 50
C     ....First, see if point is near a reseau mark
      DL = (RES(1,172)-RES(1,29))/18	!Pixel spacing between rows
      DS = (RES(2,105)-RES(2,97))/8	!Pixel spacing between columns
      TL1 = 0.5*(RES(1,6)+RES(1,18))	!Boundary btwn first two rows
      TL2 = 0.5*(RES(1,18)+RES(1,29))	!Boundary btwn second and third rows
      BL2 = 0.5*(RES(1,173)+RES(1,184))	!Boundary btwn rows 21 and 22
      BL1 = 0.5*(RES(1,184)+RES(1,196))	!Boundary btwn last two rows
      LOFFSET = 3.0*DL - 0.5*(RES(1,29)+RES(1,41))	!Line offset
      OFFSETS(1) = 6.0*DS - 0.5*(RES(2,29)+RES(2,30))	!Samp offset row type 1
      OFFSETS(2) = 5.0*DS - 0.5*(RES(2,100)+RES(2,101))	!Samp offset row type 2
      OFFSETS(3) = 6.0*DS - 0.5*(RES(2,48)+RES(2,49))	!Samp offset row type 3
      OFFSETS(4) = 6.0*DS - 0.5*(RES(2,93)+RES(2,94))	!Samp offset row type 4
C     ....Boundary btwn first two marks on rows 2 and 22
      LEFTSAMP = 0.5*(RES(2,13)+RES(2,14))
C     ....Boundary btwn last two marks on rows 2 and 22
      RIGTSAMP = 0.5*(RES(2,22)+RES(2,23))
C
      IL = (RLINE+LOFFSET)/DL
      IF (RLINE.LT.TL2) THEN
         IF (RSAMP.LT.LEFTSAMP) THEN
            D = (RES(1,1)-RLINE)**2 + (RES(2,1)-RSAMP)**2
            IF (D.LT.R2) GOTO 990
            D = (RES(1,13)-RLINE)**2 + (RES(2,13)-RSAMP)**2
            IF (D.LT.R2) GOTO 990
         ELSE
            IF (RSAMP.GT.RIGTSAMP) THEN
               D = (RES(1,12)-RLINE)**2 + (RES(2,12)-RSAMP)**2
               IF (D.LT.R2) GOTO 990
               D = (RES(1,23)-RLINE)**2 + (RES(2,23)-RSAMP)**2
               IF (D.LT.R2) GOTO 990
            ENDIF
         ENDIF
         IF (RLINE.LT.TL1) THEN
            IL = 0
         ELSE
            IL = 1
         ENDIF
      ENDIF
C
      IF (RLINE.GT.BL2) THEN
         IF (RSAMP.LT.LEFTSAMP) THEN
            D = (RES(1,190)-RLINE)**2 + (RES(2,190)-RSAMP)**2
            IF (D.LT.R2) GOTO 990
            D = (RES(1,179)-RLINE)**2 + (RES(2,179)-RSAMP)**2
            IF (D.LT.R2) GOTO 990
         ELSE
            IF (RSAMP.GT.RIGTSAMP) THEN
               D = (RES(1,201)-RLINE)**2 + (RES(2,201)-RSAMP)**2
               IF (D.LT.R2) GOTO 990
               D = (RES(1,189)-RLINE)**2 + (RES(2,189)-RSAMP)**2
               IF (D.LT.R2) GOTO 990
            ENDIF
         ENDIF
         IF (RLINE.GT.BL1) THEN
            IL = 22
         ELSE
            IL = 21
         ENDIF
      ENDIF
C
      RTYPE = ROW_TYPE(IL+1)
      OFFSET = OFFSETS(RTYPE)
      IS = (RSAMP+OFFSET)/DS
      IRES = IROW(IL+1) + ICOL(IS+1,RTYPE)
      D = (RES(1,IRES)-RLINE)**2 + (RES(2,IRES)-RSAMP)**2
      IF (D.LT.R2) GOTO 990

   50 IF (MODE.EQ.1) RETURN	!Cursor position accepted
C     ....Now check for camera blemishes
      DO I=1,NBLEM
         D = (BLEM(2,I)-RLINE)**2 + (BLEM(3,I)-RSAMP)**2
         IF (D.LT.R2) GOTO 992
      ENDDO
      RETURN			!Cursor position accepted

  990 D = SQRT(D)
      WRITE(MSG,1000) D
 1000 FORMAT('***Warning: Cursor position is within',F4.1,
     &' pixels from a reseau mark')
      GOTO 993
  992 D = SQRT(D)
      WRITE(MSG,1002) D
 1002 FORMAT('***Warning: Cursor position is within',F4.1,
     &' pixels from a camera blemish')
  993 CALL XVMESSAGE(MSG,' ')

  995 CALL XVINTRACT('QUERRY',
     &	' Do you wish to accept the point? (Enter Y or N)')
      IF (XVIPTST('Y')) RETURN  !Cursor position accepted
      IF (.NOT.XVIPTST('N')) GOTO 995
      IND = 0			!Cursor position rejected
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Routine to derive an estimate for the C-matrix via tiepoint data
C (line,samp,ra,dec) for two stars.
C The C and OM matrices are updated.
C
C This routine is a modification of subroutine ESTIMATE,
C written by Vance Hammerle, 1987.
C
      SUBROUTINE TIESTAR(*)
      IMPLICIT REAL*8 (A-H,O-Z)
      COMMON/DISTOR/CONV(2216),OAL_IS,OAS_IS,CTOS,PROJECT
      COMMON/DISTORI/ITYPE,NPH,NPV
      REAL*4 CONV
      CHARACTER*5 PROJECT

      COMMON/CMAP/MODEL,IGEO,MRING,NRINGS
      COMMON/CMAP/ALPHAp,DELTAp,THETA,ZETAZ,PHIp
      COMMON/CMAP/FL,OAL,OAS,PSCALE,ZSCALE
      COMMON/CMAP/ROT,RA,RB,RC,RLORA,RMIN,RMAX,ASDSUN
      COMMON/CMAP/CM(3,3),PSC(3),PSUN(3),PSAT(3),RSC,RSUN
      COMMON/CMAP/ME(3,3),OM(3,3),ANGLN,ANGLA,ANGLB
      COMMON/CMAP/PSC3(3),SCLAT,SCLON
      COMMON/CMAP/PSUN3(3),SUNLAT,SUNLON
      COMMON/CMAP/SMAA,ECC,INCL,OMEGAZ,PIZERO,dOMEGA_dt,dw_dt
      REAL*8 ME,INCL

      COMMON/CONST/PI,DTR,RTD

      REAL*8 L1,L2
      real*4 ll1,ll2,ss1,ss2
      REAL*4 PAR(2)
      LOGICAL rPARMTST,XVIPTST,LST

      HPI = PI/2.D0

      CALL XVMESSAGE('Begin TIEPOINTS mode...',' ')
      CALL XVMESSAGE('Select two stars with the cursor and',' ')
      CALL XVMESSAGE('supply their right-ascension and declination',' ')
      CALL XVMESSAGE('in response to the following prompts:',' ')

      CALL XVINTRACT('READY','Cursor first star and hit RETURN')
      IF (XVIPTST('EXIT')) GOTO 990
      CALL CURSOR(L1,S1)	!Read coordinates of first point
      ll1 = l1
      ss1 = s1
      CALL DRAWDOT(lL1,sS1,255)	!Draw a dot there
      CALL XVINTRACT('ANGLE','Enter right-ascension (hr,min,sec)')
      LST=rPARMTST('ANG',PAR,I)
      CALL HMSTORAD(PAR,a1)
      CALL XVINTRACT('ANGLE','Enter declination (deg,min,sec)')
      LST=rPARMTST('ANG',PAR,I)
      CALL DMSTORAD(PAR,d1)

      CALL XVINTRACT('READY','Cursor second star and hit RETURN')
      IF (XVIPTST('EXIT')) GOTO 990
      CALL CURSOR(L2,S2)	!Read coordinates of first point
      ll2 = l2
      ss2 = s2
      CALL DRAWDOT(L2,S2,255)	!Draw a dot there
      CALL XVINTRACT('ANGLE','Enter right-ascension (hr,min,sec)')
      LST=rPARMTST('ANG',PAR,I)
      CALL HMSTORAD(PAR,a2)
      CALL XVINTRACT('ANGLE','Enter declination (deg,min,sec)')
      LST=rPARMTST('ANG',PAR,I)
      CALL DMSTORAD(PAR,d2)
C
      IF (ITYPE.EQ.7) THEN	!If image-space, convert to object-space
        CALL CONVISOS(PROJECT,ICAM,sngl(L1),sngl(S1),ll1,ss1,1,CONV,
     &	 NPH,NPV,ind)
        CALL CONVISOS(PROJECT,ICAM,sngl(L2),sngl(S2),ll2,ss2,1,CONV,
     &	 NPH,NPV,ind)
	l1=ll1
	l2=ll2
	s1=ss1
	s2=ss2
      ENDIF

      if (a1.eq.a2) then
	PHI_12 = hpi
      else
	PHI_12 = DATAN2(D2-D1,A1-A2)
      endif
      if (a1.eq.a2) then
	THETA_12 = hpi
      else
	THETA_12 = DATAN2(L1-L2,S2-S1)
      endif
      R_12 = DSQRT((L2-L1)*(L2-L1) + (S2-S1)*(S2-S1))
C
      if (a1.eq.a2) then
	THETA_OA = hpi
      else
	THETA_OA = DATAN2(L1-OAL,OAS-S1)
      endif
      PHI_OA = THETA_OA - THETA_12 + PHI_12 - HPI
      R_OA = DSQRT((L1-OAL)*(L1-OAL) + (S1-OAS)*(S1-OAS))
C
      ALPHA_OA = A1 + (A1-A2)*(R_OA/R_12)*(DSIN(PHI_OA)/DCOS(PHI_12))
      DEC_OA = D1 + (D2-D1)*(R_OA/R_12)*(DCOS(PHI_OA)/DSIN(PHI_12))
C
      THETA_N = 3.D0*HPI - THETA_12 + PHI_12
      THETA_N = MOD(THETA_N,4.D0*HPI)
      THETA_A = HPI - DEC_OA
      THETA_B = 2.D0*HPI - ALPHA_OA
      CALL OMMATRIX(THETA_N,THETA_A,THETA_B,cm)		!Update CM-matrix
      CALL GETANGLES(CM,ME(1,3),PSC,angln,angla,anglb)
      CALL UPDATENAV
      RETURN
C
  990 CALL XVMESSAGE('TIEPOINTS mode cancelled',' ')
      RETURN1
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert hrs,min,sec to radians.
C
      SUBROUTINE HMSTORAD(T,rad)
      REAL*4 T(3)       !Input hr,min,sec
      COMMON/CONST/PI,DTR,RTD
      REAL*8 PI,DTR,RTD
C     ....rad = 15(h+(m+s/60)/60)*pi/180
      rad = 15.D0*(T(1)+(T(2)+T(3)/60.D0)/60.D0)*DTR
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert deg,min,sec to radians.
C
      SUBROUTINE DMSTORAD(A,rad)
      REAL*4 A(3)	!Input degrees,min,sec
      COMMON/CONST/PI,DTR,RTD
      REAL*8 PI,DTR,RTD
C     ....rad = (deg + min/60 + sec/3600)*pi/180
      D = (A(2)+A(3)/60.D0)/60.D0
      IF (A(1).LT.0.0) D = -D
      rad = (A(1) + D)*DTR
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert right-ascension from radians to hrs,min,sec.
C
      SUBROUTINE RADTOHMS(RAD,ih,im,rs)
      real*8 rad,rs

      COMMON/CONST/PI,DTR,RTD
      REAL*8 PI,DTR,RTD

      DEG = RAD*RTD		!Convert from radians to degrees
      DEG = AMOD(DEG+360.,360.)	!Make sure it's positive
      rs = 240.0*DEG		!Convert degrees to secs-time
      ih = rs/3600.0
      rs = rs - 3600.0*ih
      im = rs/60.0
      rs = rs - 60.0*im
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert declination from radians to deg,min,secs.
C
      SUBROUTINE RADTODMS(RAD,id,im,rs)
      real*8 rad,rs

      COMMON/CONST/PI,DTR,RTD
      REAL*8 PI,DTR,RTD

      DEG = RAD*RTD		!Convert from radians to degrees
      id = DEG
      rs = 3600.0*(DEG-id)	!Convert fractional degrees to secs-arc
      IF (DEG.LT.0.0) rs=-rs	!Minutes and seconds are always positive
      im = rs/60.0
      rs = rs - 60.0*im
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert (ra,dec) from NAV reference system (isystem) from-or-to
C reference system of the catalog.
C
      subroutine fromorto_star(ra, dec, from)
      implicit doubleprecision (a-h,o-z)
      logical from

      COMMON/CSTAR1/ISAO,SAOFILE
      CHARACTER*72 SAOFILE

      if ( isao .eq. -2) then	!Using STScI Guide Star Catalog
         call fromortogsc( ra, dec, from)
      else			!Otherwise, using SAO or equivalent
         call fromortosao( ra, dec, from)
      endif
      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert star (RA,DEC) between B1950 (=SAO Catalog Ref. Frame)
C and NAV local reference frame (ISYSTEM in SEDR common block)
C
      subroutine fromortosao(ra, dec,from)
      implicit doubleprecision (a-h,o-z)
      logical from
      doubleprecision mtx(3,3), v3(3), range
      integer b1950, toref
      character*80 msg

      COMMON/SEDR/SEDR(200),LBUF(100),ISYSTEM
      REAL*4 SEDR
      INTEGER LBUF
      INTEGER ISYSTEM	!1=b2000, 2=b1950

      integer oldsys
      data oldsys / -1 /
      save

      if (isystem .eq. 2) return

      if (oldsys .eq. isystem) goto 50	!skip if already done
      oldsys = isystem
      call irfnum( 'B1950', b1950)	!get SPICE index of B1950 ref frame

C       ...get SPICE index of ISYSTEM reference frame
      if (isystem .eq. 2) then
         toref = b1950
      elseif (isystem .eq. 1) then
         call irfnum( 'J2000', toref)
         call xvmessage( 'FROMORTOSAO:  J2000 chosen', ' ')
      else		!unknown ISYSTEM, use B1950, issue warning
         toref = b1950
         write(msg,'(1x,a,i3.3,a)')
     &                 'FROMORTOSAO:  bad ISYSTEM (', isystem
     &               , '; using B1950; contact programmer'
         call xvmessage( msg, ' ')
      endif
      call irfrot(b1950,toref,mtx)	!Get rotation matrix

   50 if (b1950 .eq. toref) return	!Skip if b1950=isystem
      call radrec(1d0,ra,dec,v3)	!Convert ra, dec to vector
      if (from) then
         call mxv(mtx,v3,v3)		!Convert from b1950 to isystem
      else
         call mtxv(mtx,v3,v3)		!Convert from isystem to b1950
      endif
      call recrad(v3,range,ra,dec)	!Convert vector to ra, dec
      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Convert star (RA,DEC) between J2000 (i.e. reference frame of GSC)
C and NAV local reference frame (ISYSTEM in SEDR common block)
C
      subroutine fromortogsc(ra, dec, from)
      implicit doubleprecision (a-h,o-z)
      logical from
      doubleprecision mtx(3,3), v3(3), range
      integer j2000, toref
      character*80 msg

      COMMON/SEDR/SEDR(200),LBUF(100),ISYSTEM
      REAL*4 SEDR
      INTEGER LBUF
      INTEGER ISYSTEM	!1=b2000, 2=b1950

      integer oldsys
      data oldsys / -1 /
      save

      if (isystem .eq. 1) return	!Skip if isystem already b2000

      if ( oldsys .eq. isystem) goto 50	!Skip if matrix already computed
      oldsys = isystem
      call irfnum( 'J2000', j2000)	!get SPICE index of J2000
C     ...get SPICE index of ISYSTEM reference frame
      if ( isystem .eq. 1) then
         toref = j2000
      elseif ( isystem .eq. 2) then
         call irfnum( 'B1950', toref)
         call xvmessage( 'FROMORTOGSC:  B1950 chosen', ' ')
      else			!unknown ISYSTEM, use J2000, issue warning
         toref = J2000
         write(msg,'(1x,a,i3.3,a)')
     &                 'FROMORTOBGSC:  bad ISYSTEM (', isystem
     &               , '; using J2000; contact programmer'
         call xvmessage( msg, ' ')
      endif
      call irfrot(j2000, toref, mtx)	!get rotation matrix

   50 if ( j2000 .eq. toref) return	!skip if isystem=j2000
      call radrec( 1d0,ra,dec,v3)	!convert ra, dec to vector
      if (from) then
         call mxv(mtx,v3,v3)		!isystem to j2000
      else
         call mtxv(mtx,v3,v3)		!j2000 to isystem
      endif
      call recrad(v3,range,ra,dec)	!convert vector to ra, dec
      return
      end


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

!> Implementation of the dimer projection method for extended tight binding methods.
module frag
   use mctc_env, only : error_type, fatal_error, get_argument, wp
   use mctc_io, only : structure_type, new, write_structure
   use mctc_io_math, only : matinv_3x3
   use mctc_io_convert, only : autoev
   use frag_bondorder, only : get_wiberg_bondorder
   use frag_fragment, only : get_wiberg_fragment, unfold_fragment
   use frag_output, only : format_list, to_string
   use frag_rad, only : guess_bonds
   use frag_xtb, only : get_calculator
   use tblite_basis_type, only : get_cutoff, basis_type
   use tblite_blas, only : dot, gemv, gemm
   use tblite_context_type, only : context_type
   use tblite_cutoff, only : get_lattice_points
   use tblite_integral_overlap, only : get_overlap
   use tblite_output_format, only : format_string
   use tblite_wavefunction_type, only : wavefunction_type, new_wavefunction, &
      & get_density_matrix
   use tblite_xtb_calculator, only : xtb_calculator
   use tblite_xtb_singlepoint, only : xtb_singlepoint
   implicit none
   private

   public :: get_jab, jab_input

   !> Configuration data for calculation
   type :: jab_input
      !> Name of the requested tight binding method
      character(len=:), allocatable :: method
      !> List of fragments, generated if not given here
      integer, allocatable :: fragment(:)
      !> Threshold for generating fragments from bond orders
      real(wp) :: thr = 0.1_wp
      !> Calculation accuracy
      real(wp) :: accuracy = 1.0_wp
      !> Output verbosity
      integer :: verbosity = 2
      !> Electronic temperature in Kelvin
      real(wp) :: etemp = 300.0_wp
   end type jab_input

   !> Conversion factor from temperature to energy (Boltzmann's constant in atomic units)
   real(wp), parameter :: ktoau = 3.166808578545117e-06_wp

contains

!> Entry point for calculation of dipole projection related properties
subroutine get_jab(input, mol, error)
   !> Input data for the calculation
   type(jab_input), intent(in) :: input
   !> Molecular structure data
   type(structure_type), intent(inout) :: mol
   !> Error handling
   type(error_type), allocatable, intent(out) :: error

   integer :: spin, charge, stat, unit, ifr, nfrag, nao
   logical :: exist
   real(wp) :: energy, cutoff, jab, sab, jeff, invlat(3, 3)
   real(wp), allocatable :: gradient(:, :), sigma(:, :)
   type(context_type) :: ctx
   type(xtb_calculator) :: calc, fcalc
   type(structure_type), allocatable :: mfrag(:)
   type(wavefunction_type) :: wfn
   type(wavefunction_type), allocatable :: wfx(:)
   real(wp), allocatable :: overlap(:, :), trans(:, :), wbo(:, :), abc(:, :)
   real(wp), allocatable :: orbital(:, :), scmat(:, :), fdim(:, :), scratch(:), efrag(:)
   integer, allocatable :: fragment(:)

   call get_calculator(calc, mol, input%method, error)
   if (allocated(error)) return

   call new_wavefunction(wfn, mol%nat, calc%bas%nsh, calc%bas%nao, &
      & input%etemp * ktoau)

   call xtb_singlepoint(ctx, mol, calc, wfn, input%accuracy, energy, &
      & verbosity=input%verbosity-1)
   if (ctx%failed()) then
      call ctx%get_error(error)
      return
   end if

   allocate(overlap(calc%bas%nao, calc%bas%nao))
   cutoff = get_cutoff(calc%bas)
   call get_lattice_points(mol%periodic, mol%lattice, cutoff, trans)
   call get_overlap(mol, trans, cutoff, calc%bas, overlap)

   if (allocated(input%fragment)) then
      fragment = input%fragment
   else
      allocate(wbo(mol%nat, mol%nat))
      call get_wiberg_bondorder(calc%bas, overlap, wfn%density, wbo)

      allocate(fragment(mol%nat))
      call get_wiberg_fragment(fragment, wbo, input%thr)
   end if

   nfrag = maxval(fragment)
   select case(nfrag)
   case(:1)
      !call fatal_error(error, "Found no fragments in the input structure")
      !return
   case(2:)
      call ctx%message("Found "//to_string(nfrag)//" fragments:")
      do ifr = 1, nfrag
         call ctx%message("Fragment "//to_string(ifr)//":  "//format_list(fragment == ifr))
      end do
      call ctx%message("")
   end select

   call guess_bonds(mol, wbo)

   call get_wiberg_fragment(fragment, wbo, input%thr)

   nfrag = maxval(fragment)
   select case(nfrag)
   case(:1)
      !call fatal_error(error, "Found no fragments in the input structure")
      !return
   case(2:)
      call ctx%message("Found "//to_string(nfrag)//" fragments:")
      do ifr = 1, nfrag
         call ctx%message("Fragment "//to_string(ifr)//":  "//format_list(fragment == ifr))
      end do
      call ctx%message("")
   end select

   if (any(mol%periodic)) then
      invlat = matinv_3x3(mol%lattice)
      abc = matmul(invlat, mol%xyz)
      call unfold_fragment(abc, wbo, input%thr)
      mol%xyz(:, :) = matmul(mol%lattice, abc)
   end if

   allocate(mfrag(nfrag))
   call get_structure_fragment(mfrag(1), mol, fragment == 1)
   call write_structure(mfrag(1), "final.xyz", error)

end subroutine get_jab

!> Unpack coefficients from a fragment orbital space in the full orbital space
subroutine unpack_coeff(full_bas, frag_bas, full, frag, mask)
   !> Basis set information for full system
   type(basis_type), intent(in) :: full_bas
   !> Basis set information for fragment
   type(basis_type), intent(in) :: frag_bas
   !> Quantity in full orbital space
   real(wp), intent(out) :: full(:)
   !> Quantity in fragment orbital space
   real(wp), intent(in) :: frag(:)
   !> Atom resolved mask for this fragment
   logical, intent(in) :: mask(:)

   integer :: iat, jat, ish, ii, jj, iao, jao, nao

   jat = 0
   do iat = 1, size(mask)
      if (mask(iat)) then
         jat = jat + 1
         ii = full_bas%ish_at(iat)
         jj = frag_bas%ish_at(jat)
         do ish = 1, full_bas%nsh_at(iat)
            iao = full_bas%iao_sh(ii+ish)
            jao = frag_bas%iao_sh(jj+ish)
            nao = full_bas%nao_sh(ii+ish)
            full(iao+1:iao+nao) = frag(jao+1:jao+nao)
         end do
      else
         ii = full_bas%ish_at(iat)
         do ish = 1, full_bas%nsh_at(iat)
            iao = full_bas%iao_sh(ii+ish)
            nao = full_bas%nao_sh(ii+ish)
            full(iao+1:iao+nao) = 0.0_wp
         end do
      end if
   end do
end subroutine unpack_coeff

!> Extract a the fragment structure from the full structure
!>
!> Todo: This routine can currently only create neutral fragments,
!>       charge and spin information is not partition or transferred to fragments
subroutine get_structure_fragment(frag, mol, mask)
   !> Molecular structure data of the fragment
   type(structure_type), intent(out) :: frag
   !> Molecular structure data of the full system
   type(structure_type), intent(in) :: mol
   !> Atom resolved mask for this fragment
   logical, intent(in) :: mask(:)

   integer :: nat
   integer, allocatable :: num(:)
   real(wp), allocatable :: xyz(:, :)

   nat = count(mask)
   num = pack(mol%num(mol%id), mask)
   xyz = reshape(pack(mol%xyz, spread(mask, 1, 3)), [3, nat])
   call new(frag, num, xyz)
end subroutine get_structure_fragment

end module frag


      SUBROUTINE ML5_0_MP_COMPUTE_LOOP_COEFS(PS,ANSDP)
C
C     Generated by MadGraph5_aMC@NLO v. %(version)s, %(date)s
C     By the MadGraph5_aMC@NLO Development Team
C     Visit launchpad.net/madgraph5 and amcatnlo.web.cern.ch
C
C     Returns amplitude squared summed/avg over colors
C     and helicities for the point in phase space P(0:3,NEXTERNAL)
C     and external lines W(0:6,NEXTERNAL)
C
C     Process: g g > w- t b~ QED=1 QCD=2 [ virt = QCD ]
C
      IMPLICIT NONE
C
C     CONSTANTS
C
      CHARACTER*64 PARAMFILENAME
      PARAMETER ( PARAMFILENAME='MadLoopParams.dat')
      INTEGER NBORNAMPS
      PARAMETER (NBORNAMPS=8)
      INTEGER    NLOOPS, NLOOPGROUPS, NCTAMPS
      PARAMETER (NLOOPS=144, NLOOPGROUPS=77, NCTAMPS=252)
      INTEGER    NLOOPAMPS
      PARAMETER (NLOOPAMPS=396)
      INTEGER    NCOLORROWS
      PARAMETER (NCOLORROWS=NLOOPAMPS)
      INTEGER    NEXTERNAL
      PARAMETER (NEXTERNAL=5)
      INTEGER    NWAVEFUNCS,NLOOPWAVEFUNCS
      PARAMETER (NWAVEFUNCS=28,NLOOPWAVEFUNCS=267)
      INTEGER MAXLWFSIZE
      PARAMETER (MAXLWFSIZE=4)
      INTEGER LOOPMAXCOEFS, VERTEXMAXCOEFS
      PARAMETER (LOOPMAXCOEFS=70, VERTEXMAXCOEFS=5)
      INTEGER    NCOMB
      PARAMETER (NCOMB=48)
      REAL*16    ZERO
      PARAMETER (ZERO=0E0_16)
      COMPLEX*32 IMAG1
      PARAMETER (IMAG1=(0E0_16,1E0_16))
C     These are constants related to the split orders
      INTEGER    NSO, NSQUAREDSO, NAMPSO
      PARAMETER (NSO=0, NSQUAREDSO=0, NAMPSO=0)

C
C     ARGUMENTS
C
      REAL*16 PS(0:3,NEXTERNAL)
      REAL*8 ANSDP(3,0:NSQUAREDSO)
C
C     LOCAL VARIABLES
C
      LOGICAL DPW_COPIED
      INTEGER I,J,K,H,HEL_MULT,ITEMP
      REAL*16 TEMP2
      INTEGER NHEL(NEXTERNAL), IC(NEXTERNAL)
      REAL*16 P(0:3,NEXTERNAL)
      DATA IC/NEXTERNAL*1/
      REAL*16 ANS(3,0:NSQUAREDSO)
      COMPLEX*32 COEFS(MAXLWFSIZE,0:VERTEXMAXCOEFS-1,MAXLWFSIZE)
      COMPLEX*32 CFTOT
C
C     FUNCTIONS
C
      INTEGER ML5_0_ML5SOINDEX_FOR_BORN_AMP
      INTEGER ML5_0_ML5SOINDEX_FOR_LOOP_AMP
      INTEGER ML5_0_ML5SQSOINDEX
C
C     GLOBAL VARIABLES
C
      INCLUDE 'mp_coupl_same_name.inc'

      LOGICAL CHECKPHASE, HELDOUBLECHECKED
      COMMON/ML5_0_INIT/CHECKPHASE, HELDOUBLECHECKED

      INTEGER HELOFFSET
      INTEGER GOODHEL(NCOMB)
      LOGICAL GOODAMP(NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_FILTERS/GOODAMP,GOODHEL,HELOFFSET

      INTEGER HELPICKED
      COMMON/ML5_0_HELCHOICE/HELPICKED

      INTEGER USERHEL
      COMMON/ML5_0_USERCHOICE/USERHEL

      INTEGER SQSO_TARGET
      COMMON/ML5_0_SOCHOICE/SQSO_TARGET

      LOGICAL UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE,CT_REQ_SO_DONE
     $ ,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_SO_DONE
     $ ,CTCALL_REQ_SO_DONE,FILTER_SO
      COMMON/ML5_0_SO_REQS/UVCT_REQ_SO_DONE,MP_UVCT_REQ_SO_DONE
     $ ,CT_REQ_SO_DONE,MP_CT_REQ_SO_DONE,LOOP_REQ_SO_DONE,MP_LOOP_REQ_S
     $ O_DONE,CTCALL_REQ_SO_DONE,FILTER_SO

      COMPLEX*32 AMP(NBORNAMPS)
      COMMON/ML5_0_MP_AMPS/AMP
      COMPLEX*16 DP_AMP(NBORNAMPS)
      COMMON/ML5_0_AMPS/DP_AMP
      COMPLEX*32 W(20,NWAVEFUNCS)
      COMMON/ML5_0_MP_W/W

      COMPLEX*16 DPW(20,NWAVEFUNCS)
      COMMON/ML5_0_W/DPW

      COMPLEX*32 WL(MAXLWFSIZE,0:LOOPMAXCOEFS-1,MAXLWFSIZE,0:NLOOPWAVEF
     $ UNCS)
      COMPLEX*32 PL(0:3,0:NLOOPWAVEFUNCS)
      COMMON/ML5_0_MP_WL/WL,PL

      COMPLEX*32 LOOPCOEFS(0:LOOPMAXCOEFS-1,NSQUAREDSO,NLOOPGROUPS)
      COMMON/ML5_0_MP_LCOEFS/LOOPCOEFS

      COMPLEX*32 AMPL(3,NCTAMPS)
      COMMON/ML5_0_MP_AMPL/AMPL

      INTEGER CF_D(NCOLORROWS,NBORNAMPS)
      INTEGER CF_N(NCOLORROWS,NBORNAMPS)
      COMMON/ML5_0_CF/CF_D,CF_N

      INTEGER HELC(NEXTERNAL,NCOMB)
      COMMON/ML5_0_HELCONFIGS/HELC

      LOGICAL MP_DONE_ONCE
      COMMON/ML5_0_MP_DONE_ONCE/MP_DONE_ONCE

C     ----------
C     BEGIN CODE
C     ----------

C     To be on the safe side, we always update the MP params here.
C     It can be redundant as this routine can be called a couple of
C      times for the same PS point during the stability checks.
C     But it is really not time consuming and I would rather be safe.
      CALL MP_UPDATE_AS_PARAM()

      MP_DONE_ONCE = .TRUE.

C     AS A SAFETY MEASURE WE FIRST COPY HERE THE PS POINT
      DO I=1,NEXTERNAL
        DO J=0,3
          P(J,I)=PS(J,I)
        ENDDO
      ENDDO

      DO I=0,3
        PL(I,0)=(ZERO,ZERO)
      ENDDO
      DO I=1,MAXLWFSIZE
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,MAXLWFSIZE
            IF(I.EQ.K.AND.J.EQ.0) THEN
              WL(I,J,K,0)=(1.0E0_16,ZERO)
            ELSE
              WL(I,J,K,0)=(ZERO,ZERO)
            ENDIF
          ENDDO
        ENDDO
      ENDDO

      DO K=1, 3
        DO I=1,NCTAMPS
          AMPL(K,I)=(ZERO,ZERO)
        ENDDO
      ENDDO

      DO I=1, NBORNAMPS
        DP_AMP(I) = (0.0D0,0.0D0)
        AMP(I) = (ZERO, ZERO)
      ENDDO

      DO I=1,NLOOPGROUPS
        DO J=0,LOOPMAXCOEFS-1
          DO K=1,NSQUAREDSO
            LOOPCOEFS(J,K,I)=(ZERO,ZERO)
          ENDDO
        ENDDO
      ENDDO

      DO K=1,3
        DO J=0,NSQUAREDSO
          ANSDP(K,J)=0.0D0
          ANS(K,J)=ZERO
        ENDDO
      ENDDO

      DPW_COPIED = .FALSE.
      DO H=1,NCOMB
        IF ((HELPICKED.EQ.H).OR.((HELPICKED.EQ.-1).AND.(CHECKPHASE.OR.(
     $   .NOT.HELDOUBLECHECKED).OR.(GOODHEL(H).GT.-HELOFFSET.AND.GOODHE
     $   L(H).NE.0)))) THEN
          DO I=1,NEXTERNAL
            NHEL(I)=HELC(I,H)
          ENDDO

          MP_UVCT_REQ_SO_DONE=.FALSE.
          MP_CT_REQ_SO_DONE=.FALSE.
          MP_LOOP_REQ_SO_DONE=.FALSE.

          IF (.NOT.CHECKPHASE.AND.HELDOUBLECHECKED.AND.HELPICKED.EQ.
     $     -1) THEN
            HEL_MULT=GOODHEL(H)
          ELSE
            HEL_MULT=1
          ENDIF

          CALL ML5_0_MP_HELAS_CALLS_AMPB_1(P,NHEL,H,IC)
 2000     CONTINUE
          MP_CT_REQ_SO_DONE=.TRUE.

          CALL ML5_0_MP_HELAS_CALLS_UVCT_1(P,NHEL,H,IC)
 3000     CONTINUE
          MP_UVCT_REQ_SO_DONE=.TRUE.

          DO I=1,NCTAMPS
            DO J=1,NBORNAMPS
              CFTOT=CMPLX(CF_N(I,J)/REAL(ABS(CF_D(I,J)),KIND=16)
     $         ,0.0E0_16,KIND=16)
              IF(CF_D(I,J).LT.0) CFTOT=CFTOT*IMAG1
              ITEMP = ML5_0_ML5SQSOINDEX(ML5_0_ML5SOINDEX_FOR_LOOP_AMP(
     $         I),ML5_0_ML5SOINDEX_FOR_BORN_AMP(J))
              IF (.NOT.FILTER_SO.OR.SQSO_TARGET.EQ.ITEMP) THEN
                DO K=1,3
                  TEMP2 = HEL_MULT*2.0E0_16*REAL(CFTOT*AMPL(K,I)
     $             *CONJG(AMP(J)),KIND=16)
                  ANS(K,ITEMP)=ANS(K,ITEMP)+TEMP2
                  ANS(K,0)=ANS(K,0)+TEMP2
                ENDDO
              ENDIF
            ENDDO
          ENDDO

          CALL ML5_0_MP_COEF_CONSTRUCTION_1(P,NHEL,H,IC)
 4000     CONTINUE
          MP_LOOP_REQ_SO_DONE=.TRUE.

C         Copy the qp wfs to the dp ones as they are used to setup the
C          CT calls.
C         This needs to be done once since only the momenta of these
C          WF matters.
          IF(.NOT.DPW_COPIED) THEN
            DO I=1,NWAVEFUNCS
              DO J=1,MAXLWFSIZE+4
                DPW(J,I)=DBLE(W(J,I))
              ENDDO
            ENDDO
            DPW_COPIED=.TRUE.
          ENDIF

        ENDIF
      ENDDO

      DO I=1,3
        DO J=0,NSQUAREDSO
          ANSDP(I,J)=ANS(I,J)
        ENDDO
      ENDDO

C     Grouping of loop diagrams now done directly when creating the
C      LOOPCOEFS.

      END