module ptc_export_xml_module
use madx_ptc_module ! to access the layout 'MY_RING'
implicit none

private
public	:: ptc_export_xml ! external interface 


contains

  subroutine ptc_export_xml(filenameIA)
    implicit none
    integer filenameIA(*)
    character(48) filename   
    !integer I,MF,DI,nt
    integer i,mf
    type(LAYOUT), TARGET :: L
    type(FIBRE), pointer :: P
    !character*255 line
    !REAL(DP) D(3),ANG(3),PREC,DS
    !LOGICAL(LP) ENERGY_PATCH
	integer xml_level
	
	xml_level = 0
    
	filename = charconv(filenameIA)
	
	write(6,*) 'Fortran: export XML document "', trim(filename),'"representing PTC machine'	



	L = MY_RING ! my ring is global variable from madx_ptc_module	
		
!    P=>L%START
!    i=1
!    nt=0
!    do while(i<=l%n)

!       call count_PATCH_sixtrack(di,p)
!       i=i+1+DI
!       nt=nt+1
!    ENDDO

!nt=0

!    PREC=1.D-10
     call kanalnummer(mf)
     open(unit=mf,file=filename)

     write (MF,'(a)') '<?xml version="1.0" encoding="UTF-8"?>' ! format to avoid first blank character
     write (MF,*) '<!-- File generated by Fortran code linked against the PTC library -->'
     write (MF,*) '<ptc-machine xsi:noNamespaceSchemaLocation="PtcMachine.xsd"' ! ...
     write (MF,*) 'xmlns:xsi="http://www.w3.org/2001/XMLSchema-instance">' !... continued

    P=>L%START
    i=1
    do while(i<=l%n) ! for each fibre
       
       CALL print_FIBRE_SIXTRACK(P,mf,xml_level+1)
       p=>p%next
       i=i+1    !+DI
    ENDDO
    
    call print_XML_beam(L,mf,xml_level+1)

    write (MF,*) '</ptc-machine>'
    close(MF)    
  END subroutine ptc_export_xml

  subroutine print_FIBRE_SIXTRACK(fibre_ptr,file_handle,xml_level)
    implicit none
    integer file_handle
    integer xml_level
    type(FIBRE), pointer :: fibre_ptr
    character propagation*32
    select case(fibre_ptr%dir)
    case(1)
    	propagation = 'forward'
    case(-1)
    	propagation = 'backward'
    case default
    	propagation = 'undefined'
    end select
    
    write(file_handle,*) '<fibre propagation-direction="',trim(propagation),'">'
    call print_XML_patches(file_handle,fibre_ptr,xml_level+1)
    call print_XML_misalignments(file_handle,fibre_ptr,xml_level+1)
    call print_XML_element(fibre_ptr%mag,file_handle,xml_level+1)
     write(file_handle,*) '</fibre>'
  END subroutine print_FIBRE_SIXTRACK
  
  subroutine print_XML_patches(mf,f,xml_level)
  	implicit none
	type(FIBRE), pointer :: f	
	integer mf,i
	integer xml_level
	character padding*10
	real(dp) xi,yi,zi,xo,yo,zo
	real(dp) rxi,ryi,rzi,rxo,ryo,rzo
	padding = ''
	do i=1,10
		padding = padding//' '
	end do
	! input patch
	xi = f%patch%a_d(1)
	yi = f%patch%a_d(2)
	zi = f%patch%a_d(3)
	rxi = f%patch%a_ang(1)
	ryi = f%patch%a_ang(2)
	rzi = f%patch%a_ang(3)		
	! output patch
	xo = f%patch%b_d(1)
	yo = f%patch%b_d(2)
	zo = f%patch%b_d(3)
	rxo = f%patch%b_ang(1)
	ryo = f%patch%b_ang(2)
	rzo = f%patch%b_ang(3)		
	write(mf,*) padding(1:xml_level), '<patches>'
	write(mf,*) padding(1:xml_level+1), '<input>'
	write(mf,*) padding(1:xml_level+2), '<translations x="',xi,'"',' y="',yi,'"',' z="',zi,'"/>'
	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxi,'"',' ry="',ryi,'"',' rz="',rzi,'"/>'
	write(mf,*) padding(1:xml_level+1), '</input>'
	write(mf,*) padding(1:xml_level+1), '<output>'
	write(mf,*) padding(1:xml_level+2), '<translations x="',xo,'"',' y="',yo,'"',' z="',zo,'"/>'
	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxo,'"',' ry="',ryo,'"',' rz="',rzo,'"/>'
	write(mf,*) padding(1:xml_level+1), '</output>'	
	write(mf,*) padding(1:xml_level), '</patches>'
  end subroutine print_XML_patches
  
  subroutine print_XML_misalignments(mf,f,xml_level)
  	implicit none
	integer mf
	integer xml_level,i
	type(FIBRE), pointer ::f
	character padding*10
	real(dp) xi,yi,zi,xo,yo,zo
	real(dp) rxi,ryi,rzi,rxo,ryo,rzo
	
	padding = ''
	do i=1,10
		padding = padding//' '
	end do 
	! input misalignment
	xi = f%chart%d_in(1)
	yi = f%chart%d_in(2)
	zi = f%chart%d_in(3)
	rxi = f%chart%ang_in(1)
	ryi = f%chart%ang_in(2)
	rzi = f%chart%ang_in(3)
	! output misalignment
	xo = f%chart%d_out(1)
	yo = f%chart%d_out(2)
	zo = f%chart%d_out(3)
	rxo = f%chart%ang_out(1)
	ryo = f%chart%ang_out(2)
	rzo = f%chart%ang_out(3)		
	write(mf,*) padding(1:xml_level), '<misalignments>'
	write(mf,*) padding(1:xml_level+1), '<input>'
	write(mf,*) padding(1:xml_level+2), '<translations x="',xi,'"',' y="',yi,'"',' z="',zi,'"/>'
	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxi,'"',' ry="',ryi,'"',' rz="',rzi,'"/>'
	write(mf,*) padding(1:xml_level+1), '</input>'
	write(mf,*) padding(1:xml_level+1), '<output>'
	write(mf,*) padding(1:xml_level+2), '<translations x="',xo,'"',' y="',yo,'"',' z="',zo,'"/>'
	write(mf,*) padding(1:xml_level+2), '<rotations rx="',rxo,'"',' ry="',ryo,'"',' rz="',rzo,'"/>'
	write(mf,*) padding(1:xml_level+1), '</output>'		
	write(mf,*) padding(1:xml_level), '</misalignments>'
  end subroutine print_XML_misalignments
  
  
  subroutine print_XML_element(m,mf,xml_level)
  	implicit none
	integer mf
	integer xml_level,i
!	type(FIBRE), pointer :: P
	type(element), pointer :: m
	real(dp) length ! for a drift or a magnet
	real(dp) voltage, phase, frequency ! for an RF cavity
	real(dp) ks ! try this for a solenoid
	real(dp) a1,b1 ! for a crab cavity
	character el_name*48 ! the name of the element
	character padding*10
	el_name = ''
	padding = ''
	do i=1,10
		padding = padding//' '
	end do
	do i=1,len(trim(M%VORNAME))
		el_name(i:i)=lowercase(M%VORNAME(i:i))
	end do
	! hardcode design-tilt as 0.0 for the time-being
	write (MF,*) padding(1:xml_level), '<element name="',trim(el_name),'" design-tilt="0.0"><!-- instance of ',TRIM(M%NAME),'-->'
	write(MF,*) padding(1:xml_level+1), '<kind>'
	! trim to remove trailing blanks
	select case (M%KIND)
		case (30) ! this is a marker
			write(MF,*) padding(1:xml_level+2), '<marker/>'
		case (31) ! this is a drift
			length = M%L
			write(MF,*) padding(1:xml_level+2), '<drift length="',length,'"/>'
		case (32) ! this is a drift-kick-drift??
			!write(MF,*) padding(1:xml_level+2), '<UNIDENTIFIED/><!-- drift-kick-drift -->'
			! should ensure this is a quadrupole (do we end-up here for sextupole as well?
			length = M%L
			write(MF,*) padding(1:xml_level+2), '<magnet length="',length,'">'
			! Does it account for any kind of magnet - at least this is what we
			! agreed on in the Schema
			if (ASSOCIATED(M%an)) then
       			do i=1,m%p%NMUL
          			! write(mf,*) m%bn(i),m%an(i), " BN AN ",I
          			write(mf,*) padding(1:xml_level+3), '<an index="',i,'" value="',m%an(i),'"/>'
          			write(mf,*) padding(1:xml_level+3), '<bn index="',i,'" value="',m%bn(i),'"/>'
       			enddo
    			endif
			write(MF,*) padding(1:xml_level+2), '</magnet>'
		case (33) ! this is a multiple block
			! As far as I know let's identify it as a MAD multipole composed of a series
			! of zero length thin lenses
			! for the time being omit, MAD's LRAD fictitious length (synchrotron radiation)
			! and TILT
			write(MF,*) padding(1:xml_level+2), '<thin-lens-series>'
			if (ASSOCIATED(M%an)) then
			do i=1,m%p%NMUL
				write(MF,*) padding(1:xml_level+3), '<an index="',i,'" value="',m%bn(i),'"/><!-- skew component-->'
				write(MF,*) padding(1:xml_level+3), '<bn index="',i,'" value="',m%an(i),'"/><!-- normal component-->'				
			enddo	
			endif
			write(MF,*) padding(1:xml_level+2), '</thin-lens-series>'			
		case (34) ! this is a cavity
			length = M%L
			voltage = M%VOLT ! for an ordinary RF cavity (i.e. not a crab)
			frequency = M%FREQ
			phase = M%PHAS + M%C4%PHASE0 + M%C4%PH(1)
			write(MF,*) padding(1:xml_level), '<RF-cavity length="',length, &
			'"  voltage="',voltage,'" frequency="',frequency,'" phase="',phase,'">'
				! following should be conditionnal to the cavity being
				! a crab cavity
				a1 = M%AN(1)
				b1 = M%BN(1)
				write(MF,*) padding(1:xml_level+3), '<a1 value="',a1,'"/>'
				write(MF,*) padding(1:xml_level+3), '<b1 value="',b1,'"/>'
			write(MF,*) padding(1:xml_level+2), '</RF-cavity>'
		case (35) ! found-out that this is a solenoid
			length = M%L
			ks = 0 ! as I don't know yet where to pick it up
			write(MF,*) padding(1:xml_level), '<solenoid length="',length,'" ks="',ks,'"/>'
		case (41) ! found-out that this is monitor
			length = M%L
			write(MF,*) padding(1:xml_level), '<monitor length="',length,'"/>'
			! monitor actual has a type, but let's forget it for the time-being
		case (42) ! found-out this is an H-monitor
			length = M%L
			write(MF,*) padding(1:xml_level), '<H-monitor length="',length,'"/>'
		case (43) ! found-out this is a V-monitor
			length = M%L
			write(MF,*) padding(1:xml_level), '<V-monitor length="',length,'"/>'
		case (44) ! found-out this is an instrument
			write(MF,*) padding(1:xml_level), '<instrument/>'
		case (48) ! found-out this is a R-collimator
			length = M%L
			write(MF,*) padding(1:xml_level), '<R-collimator length="',length,'"/>'
		! and what about an E-collimator ???
		case (51) ! to be confirmed that this is indeed a  cavity...
			!voltage = M%VOLT;
			length = M%L
			write(MF,*) padding(1:xml_level), '<TW-cavity length="',length,'"/>'
		case default
			write(MF,*) padding(1:xml_level), '<device code="',M%KIND,'"--/><!--unknown-->'
	end select
	write (MF,*) padding(1:xml_level+1), '</kind>'
	write (MF,*) padding(1:xml_level), '</element>'
  end subroutine print_XML_element
  
  
  subroutine print_XML_beam(L,file_handle, xml_level)
  	integer file_handle,xml_level
	integer i
	real(dp) charge,mass,beta0,p0c
	type(LAYOUT), TARGET :: L
	character padding*10;
	padding = ''
	do i=1,10
		padding = padding//' '
	end do
	charge = L%START%charge
	mass = L%START%mass
	beta0 = L%START%beta0
	p0c = L%START%MAG%P%p0c
	write(file_handle,*) padding(1:xml_level), '<beam charge="',charge,'" mass="',mass,'" beta0="',beta0,'" p0c="',p0c,'"/>'	
  end subroutine print_XML_beam
  
  subroutine print_element_SIXTRACK(P,m,mf)
    implicit none
    integer mf,I
    type(FIBRE), pointer :: P
    type(element), pointer :: m
    character*255 line

    WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ELEMENT $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
    if(m%vorname(1:1)==' ') then
       WRITE(MF,*) M%KIND,M%NAME, ' NOVORNAME'
    ELSE
       WRITE(MF,*) M%KIND,M%NAME,' ',M%VORNAME
    ENDIF
    WRITE(MF,*) M%L
    IF(ASSOCIATED(M%FREQ)) THEN
       WRITE(MF,*) " CAVITY INFORMATION "
!HALF*EL%P%DIR*EL%P%CHARGE*EL%volt*c_1d_3*SIN(twopi*EL%freq*x(6)/CLIGHT+EL%PHAS+EL%phase0)/EL%P%P0C

       WRITE(LINE,*) c_1d_3*M%VOLT, twopi*M%FREQ/CLIGHT,M%PHAS+M%C4%phase0
       WRITE(MF,'(A255)') LINE
    ELSEIF(ASSOCIATED(M%VOLT)) THEN
       WRITE(MF,*) " ELECTRIC SEPTUM INFORMATION "
       WRITE(MF,*) M%VOLT,M%PHAS, "VOLT, PHAS(rotation angle) "
    ELSE
       WRITE(MF,*) " NO ELECTRIC ELEMENT INFORMATION "
    ENDIF
    IF(ASSOCIATED(M%B_SOL)) THEN
       WRITE(MF,*)  M%B_SOL, " B_SOL"
    ELSE
       WRITE(MF,*) zero
    ENDIF
    CALL print_magnet_chart_SIXTRACK(P,m%P,mf)
    IF(ASSOCIATED(M%an)) THEN
       do i=1,m%p%NMUL
          write(mf,*) m%bn(i),m%an(i), " BN AN ",I
       enddo
    endif
!    call print_specific_element(m,mf)
    WRITE(MF,*) "$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$   END   $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$"
  end subroutine print_element_SIXTRACK

  subroutine print_magnet_chart_SIXTRACK(P,m,mf)
    implicit none
    type(FIBRE), pointer :: P
    type(magnet_chart), pointer :: m
    integer mf
    character*200 line

    WRITE(MF,*) "MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART MAGNET CHART "
    WRITE(MF,*) M%METHOD,M%NST,M%NMUL, " METHOD NST NMUL"
    WRITE(line,*) M%B0,M%EDGE, m%tiltd, " B0, EDGES, TILT"
    WRITE(MF,'(A200)') LINE
    WRITE(LINE,*) P%BETA0,P%GAMMA0I, P%GAMBET, " BETA0 GAMMA0I GAMBET "
    WRITE(MF,'(A200)') LINE

    write(mf,'(a68)') "END MAGNET CHART END MAGNET CHART END MAGNET CHART END MAGNET CHART "

	if(M%METHOD/=2.and.p%mag%l>zero) then
	  write(6,*) " error method must be 2 ",P%mag%name
	  stop
	endif
	if(M%exact) then
	  write(6,*) " No exact magnet permitted ",P%mag%name
	  stop
	endif
  end subroutine print_magnet_chart_SIXTRACK

  subroutine print_PATCH_MIS_SIXTRACK(m,mf)
    implicit none
    type(FIBRE), pointer :: m
    integer mf
    character*200 line

    write(mf,'(a30)')  " PATCHING AND MISALIGNMENTS "
    write(mf,'(a30)')  "  Reversed discontinuous patches "
    WRITE(MF,*) M%PATCH%A_X1,M%PATCH%A_X2,M%PATCH%B_X1,M%PATCH%B_X2
    write(mf,'(a30)')  "  Time patches "
    WRITE(MF,*) M%PATCH%A_T, M%PATCH%B_T
    write(mf,'(a30)')  "  Frontal geometric patches "
    WRITE(LINE,*) M%PATCH%A_ANG,M%PATCH%A_D
    WRITE(MF,'(a200)') LINE
    write(mf,'(a30)')  "  Exit geometric patches "
    WRITE(LINE,*) M%PATCH%B_ANG,M%PATCH%B_D
    WRITE(MF,'(a200)') LINE
    write(mf,'(a30)')  "  Entrance misalignments "
    WRITE(LINE,*) M%CHART%ANG_IN,M%CHART%D_IN
    WRITE(MF,'(a200)') LINE
    write(mf,'(a30)')  "  Exit misalignments "
    WRITE(LINE,*) M%CHART%ANG_OUT,M%CHART%D_OUT
    WRITE(MF,'(a200)') LINE

    write(mf,'(a14)') " END GEOMETRY "
  end subroutine print_PATCH_MIS_SIXTRACK
  
  character function lowercase(C)
  	implicit none
  	character C
	integer asciiDiff
      	asciiDiff = iachar('a') - iachar('A')
        if (LGE(C,'A') .AND. LLE(C,'Z')) then
       		lowercase = achar(iachar(C) + asciiDiff)
	else
		lowercase = C
	endif
  end function

  ! following copied from util.F
  
        character * 48 function charconv(tint)
!----------------------------------------------------------------------*
! purpose:                                                             *
!   converts integer array to string (based on ascii)                  *
! input:                                                               *
!   tint  (int array)  1 = length, rest = string                       *
!----------------------------------------------------------------------*
      implicit none
      integer tint(*)
      integer i, j, m, n
      parameter (m = 128)
      character *(m) letter
      data letter /                                                     &
     &'                                !"#$%&''()*+,-./0123456789:;<=>?@&
     &ABCDEFGHIJKLMNOPQRSTUVWXYZ[ ]^_`abcdefghijklmnopqrstuvwxyz{|}~'/
      charconv = ' '
      n = tint(1)
      do i = 1, n
        j = tint(i+1)
        if (j .lt. m)  charconv(i:i) = letter(j:j)
      enddo
      end function
  
  
end module ptc_export_xml_module