program evolvopick use spitpgm use points3d use fraktals !----------------------------------------------------- implicit none double precision, dimension(4) :: KA, KB, KI integer :: tick, nbsteps double precision :: dptick type(t_point3d), dimension(:), allocatable :: points integer :: nbpoints integer :: fd, errcode character (len=200) :: command KA(1) = -1.42 ; KA(2) = 1.62 KA(3) = 1.08 ; KA(4) = -2.43 KB(1) = 1.51 ; KB(2) = -1.89 KB(3) = 1.69 ; KB(4) = 0.79 nbsteps = 1800 nbpoints = 70000 allocate(points(nbpoints), stat=errcode) if (0 .NE. errcode) then STOP " : EVOLVOPICK, NO ENOUGH MEMORY" endif do tick = 0, nbsteps-1 dptick = DBLE(tick) / DBLE(nbsteps) ! print *, tick, " ", dptick call interp4dp(KA, KB, KI, dptick) ! print *, KI(1), KI(2), KI(3), KI(4) write(0, '(1X, I8, 3X, 4F11.6)') tick, KI ! mmmm, not optimal open (newunit=fd, file='WS/k-pick.txt', & status='unknown', position='append', & action='write', iostat=errcode) if (0 .NE. errcode) then STOP ' : FUBAR ON OUTPUT FILE' endif write(fd, '(I5, 4X, 4F8.4)') tick, KI close(fd) ! call compute_pickover(points, KI) call write_points3d(points, 27, 69900, 'WS/pick.dat') write(command, '(A, I6)') './tracepick.sh ', tick call execute_command_line (command, exitstat=errcode) if (0 .NE. errcode) then STOP ' : ERR RUN TRACE COMMAND !' endif enddo !----------------------------------------------------- contains subroutine interp4dp (ina, inb, out, dpk) double precision, dimension(4), intent(in) :: ina, inb double precision, dimension(4), intent(out) :: out double precision, intent(in) :: dpk integer :: foo do foo=1, 4 out(foo) = (ina(foo) * (1.0-dpk)) + (inb(foo) * (dpk)) enddo end subroutine end program evolvopick