program csc

*     convert single crystal data
*     ^       ^      ^
*
*     converts any data format read by FIT to inputfile for
*     TVtueb (E2, HMI Berlin)
*
*     > myfit -o csc csc.f
*
*     Nov.03 L.Keller
*     Dec.03 M.Zolliker (merged DMC + HRPT Version, 1 pass)

      implicit none

! max. number of files, max. number of points
      integer mf,mp
      parameter (mf=2000,mp=1600)

      real int1(mp),tth(mp)
      real tem(mf),omega(mf),mon(mf),tth0(mf)
      real lambda,dtth,lasttth,lastint
      real reverse,omegasign
      integer i,j,f,l,n,np,flag,nfiles,linstr
      integer intall(mp,mf), int2(mp)
      character*32 sample,owner,date,title,instr
      character*1024 list

      call fit_init

      call dat_ask_filelist(list,' ')

      flag=0

      call fit_dat_next(list,flag)

      call fit_get_real('lambda',lambda)      
      call fit_get_str('owner',l,owner)
      call fit_get_str('sample',l,sample)
      call fit_get_str('title',l,title)
      call fit_get_str('date',l,date)

      call fit_get_str('instrument',linstr,instr)
      if (instr .eq. 'DMC') then
        omegasign=-1  ! Vorzeichenwechsel von A3
        dtth=0.2
        reverse=-1 ! for historical reasons, revert output
        np=400
      elseif (instr .eq. 'HRPT') then
        omegasign=1
        dtth=0.1
        reverse=-1
        np=1600
      else
        write(*,*) 'unknown instrument: ',instr
        stop
      endif

      write(*,*)
      write(*,*)'processing ...'
      write(*,*)

      do f=1,mf

        call fit_get_real('a3',omega(f))
        call fit_get_real('temp',tem(f))
        call fit_get_real('smon',mon(f))

        call fit_get_array('X',tth,mp,n)
        call fit_get_array('Y',int1,mp,n)

        j=0
        lasttth=tth(1)
        lastint=int1(1)
        do i=1,n
          do while ((tth(i)-lasttth)/dtth .gt. 1.5) ! step is higher than 1.5 times step
            j=j+1
            intall(j,f)=nint((lastint+int1(i))*0.5)
            lasttth=lasttth+dtth
          enddo
          j=j+1
          lastint=int1(i)
          intall(j,f)=nint(lastint)
          lasttth=tth(i)
        enddo
!       check if step and number of points is correct
        if (nint((tth(n)-tth(1))/dtth) .ne. np-1 .or. j .ne. np) then
          print *,'step ',dtth,' np ',j
          print *,'theta-range', tth(1), tth(n)
          print *,'mismatch'
          stop
        endif 
        tth0(f)=tth(1)

!        print '(''+'',i5)',f
        print '(a1,i5,a1,$)','+',f,13

        call fit_dat_silent
        call fit_dat_next(list,flag)

        if (flag.eq.0) then
          nfiles=f
          goto 100
        endif

      enddo
      write(*,*)'too many files - fatal error'
      stop
  100 continue
      write(*,*)
      nfiles=f

      open(1,file='csc.asc',status='unknown')
      print *,'create csc.asc'

      write(1,'(a14)')'SYS$SYSDEVICE:'
      write(1,*)
      write(1,'(a6,a64)')'NUMOR ',list    
      write(1,*)
      write(1,'(3a)')'EXPTYPE ',instr(1:linstr),',SINQ'
      write(1,*)
      write(1,'(a3,x,a32)')'USN',owner
      write(1,*)
      write(1,'(a3,x,F6.4)')'WAV',lambda
      write(1,*)
      write(1,'(a,i6,a)') 'WIND W1=     1,',np,
     & ' W2=     0,     0 W3=     0,  W4=     0,     0'
      write(1,*)
      write(1,'(a9)')'PASS TTHS'
      write(1,*)
      write(1,'(a9)')'PRO T_SAM'
      write(1,*)
      write(1,'(a8,i12)')'MM1 MON=',nint(mon(1))
      write(1,*)
      write(1,'(a,e12.5,a,e12.5,a,e12.5)')
     & 'RELA TTHS=',1.0*np,',',1.0*np,',',reverse*dtth
      write(1,*)
      write(1,'(a3,x,a32)')'SAM',sample
      write(1,*)
      write(1,'(a5,x,a32)')'TITLE',title
      write(1,*)
      write(1,'(a10,i6,x,a4)')'SETV STEP=',nfiles,'OMGS'
      write(1,*)
      write(1,'(a12,e12.5)')'READ T_MEAN=',tem(1)
      write(1,*)
      write(1,'(a4,x,a32)')'DATE',date
      write(1,*)
      write(1,'(a3,x,a32)')'COM',title
      write(1,*)
      write(1,*)
       
     	
      do f=1,nfiles

        if (reverse .lt. 0) then
          j=np
          do i=1,np
            int2(j)=intall(i,f)
            tth(j)=tth0(f)+dtth*(i-1)
            j=j-1
          enddo
        else
          do i=1,np
            int2(i)=intall(i,f)
            tth(i)=tth0(f)+dtth*(i-1)
          enddo
        endif

        write(1,'(a9)')'SETVALUES'
        write(1,'(a4,F12.4)')'OMGS',omegasign*omega(f)
	write(1,*)
	write(1,*)
        write(1,'(a14)')'PROTOCOLVALUES'
        write(1,'(a5,F12.4)')'T_SAM',tem(f)
	write(1,*)
	write(1,*)
        write(1,'(a13)')'MASTER1VALUES'
        write(1,'(a3)')'MM1'
	write(1,'(a3,i12)')'MON',nint(mon(f))
        write(1,'(a3)')'SL1'
        write(1,'(a4,F12.4)')'TTHS',tth0(f)
        write(1,'(a4)')'LDET'
        write(1,'(a2)')'W1'

        do i=1,np,10
          write(1,'(x,i4,a1,F7.2,10I12)')i,'/',tth(i),
     &      (int2(j),j=i,min(np,i+9))
	enddo

        write(1,'(a18,a27,a15)')'PEAK','BACKGROUND','INTEGRAL'
	write(1,'(F12.4,4i12)')0.0,0,0,0,1
        write(1,'(a16)')'TIM1           1'
	write(1,*)
	write(1,*)
        write(1,'(a14)')'PROTOCOLVALUES'
        write(1,'(a5,F12.4)')'T_SAM',tem(f)
	write(1,*)
	write(1,*)

      enddo
  200 continue

      write(1,'(a14)')'DATE 01-JAN-01'
      write(1,*)
      write(1,'(a13)')'TIME 01:01:01'
      write(1,*)

      close(1)

      end