program grid_project
  use gildas_def
  use image_def
  use gkernel_interfaces
  use gbl_format
  !---------------------------------------------------------------------
  ! GDF	Stand alone program
  !	Resample an input CLASS grid to a different projection system
  ! Subroutines
  !	(IMAGE),(SIC)
  !---------------------------------------------------------------------
  ! Global
  character(len=*), parameter :: pname = 'GRID_PROJECT'
  ! Local
  real(8), parameter :: pi=3.141592653589793d0
  !
  character(len=80) :: namex,namey,center_1,center_2
  logical :: error
  integer :: nkey,sys_code,ier
  integer, parameter :: mvoc=8
  character(len=16) :: vocab(mvoc),key,system,proj
  type(gildas) :: x,y
  !
  integer :: n
  real(8) :: center(2),angle,aproj(3),bproj(3)
  real(8), allocatable :: xwork(:), ywork(:)
  !
  data vocab/'NONE','GNOMONIC','ORTHOGRAPHIC','AZIMUTHAL',   &
     &    'STEREOGRAPHIC','LAMBERT','AITOFF','RADIO'/
  !
  call gildas_open
  call gildas_char('Y_NAME$',namey)
  call gildas_char('X_NAME$',namex)
  call gildas_char('PROJECTION$',proj)
  call gildas_char('SYSTEM$',system)
  call gildas_char('CENTER_1$',center_1)
  call gildas_char('CENTER_2$',center_2)
  call gildas_dble('ANGLE$',angle,1)
  call gildas_close
  !
   ! Input file
  call gildas_null(y)
  y%loca%read = .false.
  y%gil%form = fmt_r4
  y%gil%ndim = 2 ! This is a table in fact
  call gdf_read_gildas(y,namey,'.tab',error,data=.true.)
  if (error) then
    call gagout('F-'//pname//',  Cannot read input file')
    goto 100
  endif
  !
  call gildas_null(x)
  call gdf_copy_header(y,x,error)
  !
  ! Now define output
  call sic_parsef(namex,x%file,' ','.tab')
  if (proj.ne.'UNCHANGED') then
    call sic_upper(proj)
    n = len_trim(proj)
    if (n.ne.0) then
      call sic_ambigs('PROJECTION',proj,key,nkey,vocab,mvoc,error)
      if (error) then
        write(6,1000)  'F-'//pname//',  Invalid projection system'
        goto 100
      endif
      x%gil%ptyp = nkey-1
    endif
  endif
  !
  ! Coordinate system
  call get_conv_code(y%char%syst,system,sys_code,error)
  if (error)  goto 100
  if (sys_code.ne.0) then
    x%char%syst = system
    write(6,1000)  'E-'//pname//',  System change not yet supported'
    goto 100
  endif
  !
  if (x%char%syst.eq.'EQUATORIAL' .or. x%char%syst.eq.'ICRS') then
    call sic_decode(center_1,center(1),24,error)
  else
    call sic_decode(center_1,center(1),360,error)
  endif
  if (error) goto 101
  call sic_decode(center_2,center(2),360,error)
  if (error) goto 101
  x%gil%a0 = center(1)
  x%gil%d0 = center(2)
  if (x%gil%ptyp.eq.p_radio .and. angle.ne.0.0) then
    write(6,1000)  'F-'//pname//',  Angle ignored in Radio projection'
    goto 100
  elseif (x%gil%ptyp.eq.p_aitoff .and. angle.ne.0.0) then
    write(6,1000)  'F-'//pname//',  Angle ignored in Aitoff projection'
    goto 100
  endif
  x%gil%pang = angle*pi/180.0d0
  !
  ! Create output image
  call gdf_create_image(x,error)
  if (error) then
    write(6,1000) 'F-'//pname//',  Cannot create X file'
    write(6,1000) x%file
    goto 100
  endif
  !
  ! Get some work space for X,Y
  allocate (xwork(x%gil%dim(2)),ywork(x%gil%dim(2)), &
    & x%r2d(x%gil%dim(1), x%gil%dim(2)), stat=ier)
  if (ier.ne.0) goto 100
  !
  x%r2d = y%r2d
  aproj = [y%gil%a0,y%gil%d0,y%gil%pang]
  bproj = [x%gil%a0,x%gil%d0,x%gil%pang]
  call regrid (y%r2d,y%gil%dim(1),y%gil%dim(2),   &
     &    y%gil%ptyp,aproj,x%r2d,x%gil%ptyp,bproj,   &
     &    sys_code,xwork,ywork,1,2)
  call gdf_write_data(x,x%r2d,error)
  !
  call gagout('S-'//pname//',  Successful completion')
  call sysexi(1)
  !
101 call gagout('F-'//pname//',  Bad syntax in center coordinates')
100 call sysexi (fatale)
  !
1000 format(a,a)
end program grid_project
!
subroutine get_conv_code(oldsys,newsys,code,error)
  use gkernel_interfaces
  !---------------------------------------------------------------------
  !
  !---------------------------------------------------------------------
  character(len=*), intent(in)    :: oldsys
  character(len=*), intent(inout) :: newsys
  integer(kind=4),  intent(out)   :: code
  logical,          intent(inout) :: error
  ! Local
  character(len=*), parameter :: pname='GRID_PROJECT'
  !
  call sic_upper(newsys)
  !
  ! Unchanged
  if (newsys.eq.'UNCHANGED') then
    code = 0
    newsys = oldsys
    return
  endif
  !
  ! Same system
  if (oldsys.eq.newsys) then
    code = 0
    return
  endif
  !
  ! Supported conversions
  if (newsys.eq.'GALACTIC' .and. oldsys.eq.'EQUATORIAL') then
    code = 1
    return
  elseif (newsys.eq.'EQUATORIAL' .and. oldsys.eq.'GALACTIC') then
    code = -1
    return
  endif
  !
  ! Unsupported conversions
  code = 0
  write(6,'(6A)') 'F-',pname,',  Cannot convert from ',oldsys,' to ',newsys
  error = .true.
  !
end subroutine get_conv_code
!
subroutine regrid(a,mc,mv,atype,aproj,   &
     &    b,btype,bproj,code,xb,yb,ix,iy)
  use gkernel_interfaces
  use gkernel_types
  !---------------------------------------------------------------------
  ! GREG	Stand alone subroutine
  !	Regrid an input map in a given projection to
  !	an output map in another projection
  ! Arguments
  !	A	R*4(*)	Input GRID of dimensions MC MV
  !	MC,MV   I	Size of A
  !	ATYPE	I	Type of projection
  !	APROJ	R*8(3)	Projection constants
  !			PROJ(1) = A0,	PROJ(2)=D0,	PROJ(3)=Angle
  !	B	R*4(*)	Output map of dimensions MC MV
  !	BTYPE	I
  !	BPROJ	R*8(3)
  !	CODE	I	Galactic to Equatorial (-1)
  !			or Equatorial to Galactic (1)
  !	XB,YB	R*8	Work arrays of dimension MV
  !       IX,IY   I       Pointer to columns of X and Y
  !---------------------------------------------------------------------
  integer(kind=index_length) :: mc                     !
  integer(kind=index_length) :: mv                     !
  real*4 :: a(mc,mv)                !
  integer :: atype                  !
  real*8 :: aproj(3)                !
  real*4 :: b(mc,mv)                !
  integer :: btype                  !
  real*8 :: bproj(3)                !
  integer :: code                   !
  real*8 :: xb(mc)                  !
  real*8 :: yb(mc)                  !
  integer :: ix                     !
  integer :: iy                     !
  ! Local
  integer :: i,ier
  type(projection_t) :: proj
  logical :: error
  real(kind=8), allocatable :: axb(:),ayb(:)
  !
  ! Setup Input projection
  error = .false.
  call gwcs_projec(aproj(1),aproj(2),aproj(3),atype,proj,error)
  allocate(axb(mv),ayb(mv),stat=ier)
  !
  ! Convert Output projection to Absolute coordinates
  do i=1,mv
    xb(i) = a(ix,i)
    yb(i) = a(iy,i)
  enddo
  call rel_to_abs(proj,xb,yb,axb,ayb,mv)
  !      do i=1,10
  !         type *,i,xb(i),yb(I)
  !      ENDDO
  !
  ! Change coordinate system - not coded...
  if (code.eq.-1) then
    ! call gal_equ (xb,yb,xb,yb,mv,error)
  elseif (code.eq.1) then
    ! call equ_gal (xb,yb,xb,yb,mv,error)
  endif
  !
  ! Setup Output projection
  call gwcs_projec(bproj(1),bproj(2),bproj(3),btype,proj,error)
  !
  ! Convert Absolute coordinates to input projection
  call abs_to_rel(proj,axb,ayb,xb,yb,mv)
  !      do i=1,10
  !         type *,i,xb(i),yb(I)
  !      ENDDO
  do i=1,mv
    b(ix,i) = xb(i)
    b(iy,i) = yb(i)
  enddo
end subroutine regrid
