source: palm/trunk/SOURCE/data_output_dvrp.f90 @ 203

 MODULE dvrp_color

    USE dvrp_variables

    IMPLICIT NONE

 CONTAINS

    SUBROUTINE color_dvrp( value, color )

       REAL, INTENT(IN)  ::  value
       REAL, INTENT(OUT) ::  color(4)

       REAL              ::  scale

       scale = ( value - slicer_range_limits_dvrp(1,islice_dvrp) ) / &
               ( slicer_range_limits_dvrp(2,islice_dvrp) -           &
                 slicer_range_limits_dvrp(1,islice_dvrp) )

       scale = MODULO( 180.0 + 180.0 * scale, 360.0 )

       color = (/ scale, 0.5, 1.0, 0.0 /)

    END SUBROUTINE color_dvrp

 END MODULE dvrp_color


 RECURSIVE SUBROUTINE data_output_dvrp

!------------------------------------------------------------------------------!
! Actual revisions:
! -----------------
! 
! TEST: different colours for isosurfaces
! TEST: write statements
!
! Former revisions:
! -----------------
! $Id: data_output_dvrp.f90 139 2007-11-29 09:37:41Z raasch $
!
! 130 2007-11-13 14:08:40Z letzel
! allow two instead of one digit to specify isosurface and slicer variables
! for unknown variables (CASE DEFAULT) call new subroutine 
! user_data_output_dvrp
!
! 82 2007-04-16 15:40:52Z raasch
! Preprocessor strings for different linux clusters changed to "lc",
! routine local_flush is used for buffer flushing
!
! 75 2007-03-22 09:54:05Z raasch
! Particles-package is now part of the default code,
! moisture renamed humidity
!
! RCS Log replace by Id keyword, revision history cleaned up
!
! Revision 1.13  2006/02/23 10:25:12  raasch
! Former routine plot_dvrp renamed data_output_dvrp,
! Only a fraction of the particles may have a tail,
! pl.. replaced by do.., %size renamed %dvrp_psize
!
! Revision 1.1  2000/04/27 06:27:17  raasch
! Initial revision
!
!
! Description:
! ------------
! Plot of isosurface, particles and slicers with dvrp-software
!------------------------------------------------------------------------------!
#if defined( __dvrp_graphics )

    USE arrays_3d
    USE cloud_parameters
    USE cpulog
    USE DVRP
    USE dvrp_color
    USE dvrp_variables
    USE grid_variables
    USE indices
    USE interfaces
    USE particle_attributes
    USE pegrid
    USE control_parameters

    IMPLICIT NONE

    CHARACTER (LEN=2) ::  section_chr
    CHARACTER (LEN=6) ::  output_variable
    INTEGER ::  i, j, k, l, m, n, nn, section_mode, tv, vn
    INTEGER, DIMENSION(:), ALLOCATABLE ::  p_c, p_t
    REAL    ::  center(3), distance, slicer_position, surface_value
    REAL, DIMENSION(:),     ALLOCATABLE ::  psize, p_x, p_y, p_z
    REAL, DIMENSION(:,:,:), ALLOCATABLE ::  local_pf


    WRITE ( 9, * ) '*** myid=', myid, ' Anfang data_output_dvrp'
    CALL local_flush( 9 )
    CALL cpu_log( log_point(27), 'data_output_dvrp', 'start' )

!
!-- Loop over all output modes choosed
    m           = 1
    tv          = 0  ! threshold counter
    islice_dvrp = 0  ! slice plane counter
    DO WHILE ( mode_dvrp(m) /= ' ' )
!
!--    Update of the steering variables
       IF ( .NOT. lock_steering_update )  THEN
!
!--       Set lock to avoid recursive calls of DVRP_STEERING_UPDATE
          lock_steering_update = .TRUE.
!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: vor steering_update'
!   CALL local_flush( 9 )
          CALL DVRP_STEERING_UPDATE( m-1, data_output_dvrp )
!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: nach steering_update'
!   CALL local_flush( 9 )
          lock_steering_update = .FALSE.
       ENDIF

!
!--    Determine the variable which shall be plotted (in case of slicers or
!--    isosurfaces)
       IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN
          READ ( mode_dvrp(m), '(10X,I2)' )  vn
          output_variable = do3d(0,vn)
          tv = tv + 1
       ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN
          READ ( mode_dvrp(m), '(6X,I2)' )  vn
          output_variable = do2d(0,vn)
          l = MAX( 2, LEN_TRIM( do2d(0,vn) ) )
          section_chr = do2d(0,vn)(l-1:l)
          SELECT CASE ( section_chr )
             CASE ( 'xy' )
                section_mode = 2
                slicer_position = zu(MIN( slicer_position_dvrp(m), nz_do3d ))
             CASE ( 'xz' )
                section_mode = 1
                slicer_position = slicer_position_dvrp(m) * dy
             CASE ( 'yz' )
                section_mode = 0
                slicer_position = slicer_position_dvrp(m) * dx
          END SELECT
       ENDIF

!
!--    Select the plot mode (in case of isosurface or slicer only if user has
!--    defined a variable which shall be plotted; otherwise do nothing)
       IF ( mode_dvrp(m)(1:9) == 'particles'  .AND.  particle_advection  .AND. &
            simulated_time >= particle_advection_start )  THEN

!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: anfang particles'
!   CALL local_flush( 9 )
!
!--       DVRP-Calls for plotting particles:
          CALL cpu_log( log_point_s(28), 'dvrp_particles', 'start' )

!
!--       Definition of characteristics of particle material
!          CALL DVRP_MATERIAL_RGB( m-1, 1, 0.1, 0.7, 0.1, 0.0 )
          CALL DVRP_MATERIAL_RGB( m-1, 1, 0.0, 0.0, 0.0, 0.0 )

!
!--       Move particle coordinates to one-dimensional arrays
          IF ( .NOT. use_particle_tails )  THEN
!
!--          All particles are output
             ALLOCATE( psize(number_of_particles), p_t(number_of_particles), &
                       p_c(number_of_particles), p_x(number_of_particles),   &
                       p_y(number_of_particles), p_z(number_of_particles) )
             psize = 0.0;  p_t = 0;  p_c = 0.0;  p_x = 0.0;  p_y = 0.0
             p_z   = 0.0;
             psize = particles(1:number_of_particles)%dvrp_psize
             p_x   = particles(1:number_of_particles)%x * superelevation_x
             p_y   = particles(1:number_of_particles)%y * superelevation_y
             p_z   = particles(1:number_of_particles)%z * superelevation
             p_c   = particles(1:number_of_particles)%color
          ELSE
!
!--          Particles have a tail
!            WRITE (9,*) '--- before ALLOCATE  simtime=',simulated_time,' #of_tails=', number_of_tails, &
!                          ' max#of_tp=', maximum_number_of_tailpoints
!   CALL local_flush( 9 )
             ALLOCATE( psize(number_of_tails), p_t(number_of_tails),      &
                       p_c(number_of_tails*maximum_number_of_tailpoints), &
                       p_x(number_of_tails*maximum_number_of_tailpoints), &
                       p_y(number_of_tails*maximum_number_of_tailpoints), &
                       p_z(number_of_tails*maximum_number_of_tailpoints) )
!            WRITE (9,*) '--- after ALLOCATE'
!   CALL local_flush( 9 )
             psize = 0.0;  p_t = 0;  p_c = 0.0;  p_x = 0.0;  p_y = 0.0
             p_z   = 0.0;
             i = 0
             k = 0
             DO  n = 1, number_of_particles
                nn = particles(n)%tail_id
                IF ( nn /= 0 )  THEN
                   k = k + 1
!                  IF ( simulated_time > 1338.0 )  THEN
!                     WRITE (9,*) '--- particle ',n,' tail_id=',nn,' #of_tp=',particles(n)%tailpoints
!   CALL local_flush( 9 )
!                  ENDIF
                   DO  j = 1, particles(n)%tailpoints
                      i = i + 1
                      p_x(i) = particle_tail_coordinates(j,1,nn) * &
                                                                superelevation_x
                      p_y(i) = particle_tail_coordinates(j,2,nn) * &
                                                                superelevation_y
                      p_z(i) = particle_tail_coordinates(j,3,nn) * &
                                                                superelevation
                      p_c(i) = particle_tail_coordinates(j,4,nn)
!                     IF ( simulated_time > 1338.0 )  THEN
!                        WRITE (9,*) '--- tp= ',i,' x=',p_x(i),' y=',p_y(i), &
!                                                ' z=',p_z(i),' c=',p_c(i)
!   CALL local_flush( 9 )
!                     ENDIF
                   ENDDO
                   psize(k) = particles(n)%dvrp_psize
                   p_t(k)   = particles(n)%tailpoints - 1
!                  IF ( simulated_time > 1338.0 )  THEN
!                     WRITE (9,*) '--- t= ',k,' psize=',psize(k),' p_t=',p_t(k)
!   CALL local_flush( 9 )
!                  ENDIF
                ENDIF                
             ENDDO
!            WRITE (9,*) '--- after locally storing the particle attributes'
!   CALL local_flush( 9 )
          ENDIF

!
!--       Compute and plot particles in dvr-format
          IF ( uniform_particles  .AND.  .NOT. use_particle_tails )  THEN
!
!--          All particles have the same color. Use simple routine to set
!--          the particle attributes (produces less output data)
             CALL DVRP_PARTICLES( m-1, p_x, p_y, p_z, psize )
          ELSE
!
!--          Set color definitions
             CALL user_dvrp_coltab( 'particles', 'none' )

             CALL DVRP_COLORTABLE_HLS( m-1, 0, interval_values_dvrp,     &
                                       interval_h_dvrp, interval_l_dvrp, &
                                       interval_s_dvrp, interval_a_dvrp )

             IF ( .NOT. use_particle_tails )  THEN
                CALL DVRP_PARTICLES( m-1, number_of_particles, p_x, p_y, p_z, &
                                     3, psize, p_c, p_t )
             ELSE
!               WRITE (9,*) '--- before DVRP_PARTICLES'
!   CALL local_flush( 9 )
                CALL DVRP_PARTICLES( m-1, number_of_tails, p_x, p_y, p_z, 15, &
                                     psize, p_c, p_t )
!               WRITE (9,*) '--- after DVRP_PARTICLES'
!               WRITE (9,*) 'm-1 = ',m-1
!               WRITE (9,*) 'number_of_tails=', number_of_tails
!               WRITE (9,*) 'p_x =', p_x
!               WRITE (9,*) 'p_y =', p_y
!               WRITE (9,*) 'p_z =', p_z
!               WRITE (9,*) 'psize =', psize
!               WRITE (9,*) 'p_c =', p_c
!               WRITE (9,*) 'p_t =', p_t

!   CALL local_flush( 9 )
             ENDIF
          ENDIF

          CALL DVRP_VISUALIZE( m-1, 3, dvrp_filecount )
!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: ende particles'
!   CALL local_flush( 9 )

          DEALLOCATE( psize, p_c, p_t, p_x, p_y, p_z )

          CALL cpu_log( log_point_s(28), 'dvrp_particles', 'stop' )


       ELSEIF ( ( mode_dvrp(m)(1:10) == 'isosurface'  .OR.   &
                  mode_dvrp(m)(1:6)  == 'slicer'           ) &
                  .AND.  output_variable /= ' ' )  THEN

!
!--       Create an intermediate array, properly dimensioned for plot-output 
          ALLOCATE( local_pf(nxl:nxr+1,nys:nyn+1,nzb:nz_do3d) )

!
!--       Move original array to intermediate array
          SELECT CASE ( output_variable )

             CASE ( 'u', 'u_xy', 'u_xz', 'u_yz' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      DO  k = nzb, nz_do3d
                         local_pf(i,j,k) = u(k,j,i)
                      ENDDO
                   ENDDO
                ENDDO
!
!--             Replace mirrored values at lower surface by real surface values
                IF ( output_variable == 'u_xz'  .OR. &
                     output_variable == 'u_yz' )  THEN
                   IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0
                ENDIF


             CASE ( 'v', 'v_xy', 'v_xz', 'v_yz' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      DO  k = nzb, nz_do3d
                         local_pf(i,j,k) = v(k,j,i)
                      ENDDO
                   ENDDO
                ENDDO
!
!--             Replace mirrored values at lower surface by real surface values
                IF ( output_variable == 'v_xz'  .OR. &
                     output_variable == 'v_yz' )  THEN
                   IF ( ibc_uv_b == 0 )  local_pf(:,:,nzb) = 0.0
                ENDIF

             CASE ( 'w', 'w_xy', 'w_xz', 'w_yz' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      DO  k = nzb, nz_do3d
                         local_pf(i,j,k) = w(k,j,i)
                      ENDDO
                   ENDDO
                ENDDO
! Averaging for Langmuir circulation
!                DO  k = nzb, nz_do3d
!                   DO  j = nys+1, nyn
!                      DO  i = nxl, nxr+1
!                         local_pf(i,j,k) = 0.25 * local_pf(i,j-1,k) + &
!                                           0.50 * local_pf(i,j,k)   + &
!                                           0.25 * local_pf(i,j+1,k)
!                      ENDDO
!                   ENDDO
!                ENDDO

             CASE ( 'p', 'p_xy', 'p_xz', 'p_yz' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      DO  k = nzb, nz_do3d
                         local_pf(i,j,k) = p(k,j,i)
                      ENDDO
                   ENDDO
                ENDDO

             CASE ( 'pt', 'pt_xy', 'pt_xz', 'pt_yz' )
                IF ( .NOT. cloud_physics ) THEN
                   DO  i = nxl, nxr+1
                      DO  j = nys, nyn+1
                         DO  k = nzb, nz_do3d
                            local_pf(i,j,k) = pt(k,j,i)
                         ENDDO
                      ENDDO
                   ENDDO
                ELSE
                   DO  i = nxl, nxr+1
                      DO  j = nys, nyn+1
                         DO  k = nzb, nz_do3d
                            local_pf(i,j,k) = pt(k,j,i) + l_d_cp * pt_d_t(k) * &
                                                          ql(k,j,i)
                         ENDDO
                      ENDDO
                   ENDDO
                ENDIF

             CASE ( 'q', 'q_xy', 'q_xz', 'q_yz' )
                IF ( humidity  .OR.  passive_scalar )  THEN
                   DO  i = nxl, nxr+1
                      DO  j = nys, nyn+1
                         DO  k = nzb, nz_do3d
                            local_pf(i,j,k) = q(k,j,i)
                         ENDDO
                      ENDDO
                   ENDDO            
                ELSE
                   IF ( myid == 0 )  THEN
                      PRINT*, '+++ data_output_dvrp: if humidity/passive_scalar = ', & 
                              'FALSE output of ', output_variable,            &
                              'is not provided' 
                   ENDIF
                ENDIF
             
             CASE ( 'ql', 'ql_xy', 'ql_xz', 'ql_yz' )
                IF ( cloud_physics  .OR.  cloud_droplets )  THEN
                   DO  i = nxl, nxr+1
                      DO  j = nys, nyn+1
                         DO  k = nzb, nz_do3d
                            local_pf(i,j,k) = ql(k,j,i)
                         ENDDO
                      ENDDO
                   ENDDO
                ELSE
                   IF ( myid == 0 ) THEN
                      PRINT*, '+++ data_output_dvrp: if cloud_physics = FALSE ', & 
                              'output of ', output_variable, 'is not provided' 
                   ENDIF
                ENDIF

             CASE ( 'u*_xy' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      local_pf(i,j,nzb+1) = us(j,i)
                   ENDDO
                ENDDO
                slicer_position = zu(nzb+1)

             CASE ( 't*_xy' )
                DO  i = nxl, nxr+1
                   DO  j = nys, nyn+1
                      local_pf(i,j,nzb+1) = ts(j,i)
                   ENDDO
                ENDDO
                slicer_position = zu(nzb+1)


             CASE DEFAULT
!
!--             The DEFAULT case is reached either if output_variable contains
!--             unsupported variable or if the user has coded a special case in
!--             the user interface. There, the subroutine user_data_output_dvrp 
!--             checks which of these two conditions applies.
                CALL user_data_output_dvrp( output_variable, local_pf )


          END SELECT


          IF ( mode_dvrp(m)(1:10) == 'isosurface' )  THEN

!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: anfang isosurface'
!   CALL local_flush( 9 )
!
!--          DVRP-Calls for plotting isosurfaces:
             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'start' )

!
!--          Definition of characteristics of isosurface material
!--          Preliminary settings for w!
             IF ( output_variable == 'w' )  THEN
                IF ( tv == 1 )  THEN
                   CALL DVRP_MATERIAL_RGB( m-1, 1, 0.8, 0.1, 0.1, 0.0 )
                ELSE
                   CALL DVRP_MATERIAL_RGB( m-1, 1, 0.1, 0.1, 0.8, 0.0 )
                ENDIF
             ELSE
                CALL DVRP_MATERIAL_RGB( m-1, 1, 0.9, 0.9, 0.9, 0.0 )
             ENDIF

!
!--          Compute and plot isosurface in dvr-format
             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp, &
                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
             CALL DVRP_THRESHOLD( m-1, threshold(tv) )
             CALL DVRP_VISUALIZE( m-1, 1, dvrp_filecount )
!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: ende isosurface'
!   CALL local_flush( 9 )

             CALL cpu_log( log_point_s(26), 'dvrp_isosurface', 'stop' )

          ELSEIF ( mode_dvrp(m)(1:6) == 'slicer' )  THEN

!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: anfang slicer'
!   CALL local_flush( 9 )
!
!--          DVRP-Calls for plotting slicers:
             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'start' )

!
!--          Material and color definitions
             CALL DVRP_MATERIAL_RGB( m-1, 1, 0.0, 0.0, 0.0, 0.0 )

             islice_dvrp = islice_dvrp + 1
!             CALL DVRP_COLORFUNCTION( m-1, DVRP_CM_HLS, 25,                    &
!                                      slicer_range_limits_dvrp(:,islice_dvrp), &
!                                      color_dvrp )

             CALL user_dvrp_coltab( 'slicer', output_variable )

             CALL DVRP_COLORTABLE_HLS( m-1, 1, interval_values_dvrp,     &
                                       interval_h_dvrp, interval_l_dvrp, &
                                       interval_s_dvrp, interval_a_dvrp )

!
!--          Compute and plot slicer in dvr-format
             CALL DVRP_DATA( m-1, local_pf, 1, nx_dvrp, ny_dvrp, nz_dvrp, &
                             cyclic_dvrp, cyclic_dvrp, cyclic_dvrp )
!             CALL DVRP_SLICER( m-1, section_mode, slicer_position )
             CALL DVRP_SLICER( m-1, 2, 1.0 )
             WRITE (9,*) 'nx_dvrp=', nx_dvrp
             WRITE (9,*) 'ny_dvrp=', ny_dvrp
             WRITE (9,*) 'nz_dvrp=', nz_dvrp
             WRITE (9,*) 'section_mode=', section_mode
             WRITE (9,*) 'slicer_position=', slicer_position
             CALL local_flush( 9 )

             CALL DVRP_VISUALIZE( m-1, 2, dvrp_filecount )

             CALL cpu_log( log_point_s(27), 'dvrp_slicer', 'stop' )

!   WRITE ( 9, * ) '*** myid=', myid, ' data_output_dvrp: ende slicer'
!   CALL local_flush( 9 )
          ENDIF

          DEALLOCATE( local_pf )

       ENDIF

       m = m + 1

    ENDDO

    dvrp_filecount = dvrp_filecount + 1

    CALL cpu_log( log_point(27), 'data_output_dvrp', 'stop' )
!   WRITE ( 9, * ) '*** myid=', myid, ' Ende data_output_dvrp'
!   CALL local_flush( 9 )

#endif
 END SUBROUTINE data_output_dvrp