gatherv_write_3d_array.F90 6.4 KB
Newer Older
Femi Kadri's avatar
Femi Kadri committed
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166
SUBROUTINE gatherv_write_3d_array(local_array,local_x_min_boundary,local_x_max_boundary,local_y_min_boundary,local_y_max_boundary,&
& local_z_min_boundary,local_z_max_boundary,ROOT,My_MPI_Process_ID,Number_Of_Processes,&
& global_x_min_boundary,global_x_max_boundary,global_y_min_boundary,global_y_max_boundary,global_z_min_boundary,&
& global_z_max_boundary,local_send_count,cartesian_communicator,all_processes_local_bounds,&
& global_receive_count,filename_number_of_letters,filename)


USE debug_module
USE precision_detector

IMPLICIT NONE
	!-----------INTENT(IN)------------------------------------------
	INTEGER,INTENT(IN) :: local_x_min_boundary,local_x_max_boundary,local_y_min_boundary,local_y_max_boundary
	INTEGER,INTENT(IN) :: local_z_min_boundary,local_z_max_boundary,ROOT,My_MPI_Process_ID,Number_Of_Processes
	INTEGER,INTENT(IN) :: local_send_count,global_x_min_boundary,global_x_max_boundary,global_y_min_boundary
	INTEGER,INTENT(IN) :: global_receive_count,filename_number_of_letters
	INTEGER,INTENT(IN) :: global_y_max_boundary,global_z_min_boundary,global_z_max_boundary,cartesian_communicator
	INTEGER,INTENT(IN),DIMENSION(6 * Number_Of_Processes) :: all_processes_local_bounds
	INTEGER,DIMENSION(0:Number_Of_Processes-1) :: root_receive_displays,root_receive_counts
	REAL,INTENT(IN),DIMENSION(local_x_min_boundary:local_x_max_boundary,local_y_min_boundary:local_y_max_boundary,&
	& local_z_min_boundary:local_z_max_boundary) :: local_array
	CHARACTER(LEN = filename_number_of_letters) filename
	!-----------INTENT(OUT)------------------------------------------
	REAL,ALLOCATABLE :: global_array(:,:,:)
	
	!-----------NO INTENT------------------------------------------
	INTEGER :: counter,I,J,K,Process_Number,mpi_error_code
	INTEGER :: my_mpi_real_data_type
	

	
	REAL,ALLOCATABLE :: local_send_buffer(:),global_array_receive_buffer(:)


INCLUDE "mpif.h"

my_mpi_real_data_type = get_my_mpi_real_data_type ()  !FUNNEL OUT THE RESULT OF PRECISION TESTING (this automatically sets the MPI REAL DATA PRECISION TYPE)

ALLOCATE ( local_send_buffer(local_send_count),global_array_receive_buffer(global_receive_count), &
&  global_array(global_x_min_boundary:global_x_max_boundary,global_y_min_boundary:global_y_max_boundary,&
	& global_z_min_boundary:global_z_max_boundary) )

	!============================ START COMMUNICATING local_array TO ROOT ============================

	!GATHER LOCAL local_array ARRAYS INTO A 1-D local_send_buffer, MPI_GATHER FROM ALL PROCESSES THE BUFFERS
	!INTO A 1-D global_array ARRAY, AND WRITE FROM global_array ARRAY INTO global_array ARRAY IN ORDER TO WRITE THE RESUME FILES

	counter = 0

	!WRITE (0,*) My_MPI_Process_ID,"about to write local_send_buffer"

			
			DO K = local_z_min_boundary, local_z_max_boundary
		
				DO J = local_y_min_boundary, local_y_max_boundary
		
					DO I = local_x_min_boundary, local_x_max_boundary

						counter = counter + 1
						local_send_buffer(counter) = local_array(I,J,K)
						
					
					END DO !!K
		
				END DO !!J
	
			END DO !!I

!			WRITE(9,*) local_array

!	WRITE (0,*) My_MPI_Process_ID,"finished writing local_send_buffer"
	
!	write(9,*) 'local_x_boundary',local_x_min_boundary, local_x_max_boundary
!	write(9,*) 'local_y_boundary',local_y_min_boundary, local_y_max_boundary
!	write(9,*) 'local_z_boundary',local_z_min_boundary, local_z_max_boundary

	IF (My_MPI_Process_ID.EQ.ROOT) THEN !IF My_MPI_Process_ID = ROOT THEN DEFINE root_receive_counts AND root_receive_displays
		
!		WRITE (0,*) My_MPI_Process_ID,"ROOT IS PREPARING TO GATHERV"
		
		DO Process_Number = 0, Number_Of_Processes - 1
		
			root_receive_counts(Process_Number) = ( all_processes_local_bounds(2 + Process_Number * 6) - all_processes_local_bounds(1 + Process_Number * 6) + 1 ) * &
			& ( all_processes_local_bounds(4 + Process_Number * 6) - all_processes_local_bounds(3 + Process_Number * 6) + 1 ) * &
			& ( all_processes_local_bounds(6 + Process_Number * 6) - all_processes_local_bounds(5 + Process_Number * 6) + 1 )
				
				IF (Process_Number.EQ.0) THEN
					
					root_receive_displays(Process_Number) = 0
					
					ELSE
					
					root_receive_displays(Process_Number) = root_receive_displays(Process_Number - 1) + root_receive_counts(Process_Number - 1)
				
				ENDIF !! Process_Number.EQ.0 OR ELSE

		END DO !! 	Process_Number =1, Number_Of_Processes	


	END IF !!My_MPI_Process_ID.EQ.ROOT

	!~~~~~~~~~~~~~~~~~~ START MPI COMMUNICATION~~~~~~~~~~~~~~~~~~~~
	!HERE IS THE ACTUAL MPI COMMUNICATION WHERE THE local_send_buffer ARE GATHERED ON ROOT
	!INTO global_array_receive_buffer
	WRITE (0,*) My_MPI_Process_ID,"about to MPI_Gatherv"
		CALL MPI_Gatherv(local_send_buffer,local_send_count,my_mpi_real_data_type,global_array_receive_buffer,root_receive_counts, &
		& root_receive_displays,my_mpi_real_data_type,ROOT,cartesian_communicator,mpi_error_code)
	WRITE (0,*) My_MPI_Process_ID,"finished MPI_Gatherv"
	!~~~~~~~~~~~~~~~~~~~END MPI COMMUNICATION~~~~~~~~~~~~~~~~~~~~~~~

	IF (My_MPI_Process_ID.EQ.ROOT) THEN 
		
		
		counter = 0  !THIS JUST KEEPS TRACK OF THE global_array_receive_buffer INDEX

		DO Process_Number = 0, Number_Of_Processes - 1  !UNPACK THE global_array_receive_buffer INTO global_array
		
				DO K = all_processes_local_bounds(5 + Process_Number * 6), all_processes_local_bounds(6 + Process_Number * 6)
	
					DO J = all_processes_local_bounds(3 + Process_Number * 6), all_processes_local_bounds(4 + Process_Number * 6)
		
						DO I = all_processes_local_bounds(1 + Process_Number * 6), all_processes_local_bounds(2 + Process_Number * 6)
					
							counter = counter + 1
										
							global_array(I,J,K) = global_array_receive_buffer(counter)

						END DO !!I
		
					END DO !!J
	
				END DO !!K

		END DO !! 	Process_Number 

	

	!============================ END COMMUNICATING local_array TO ROOT ============================
!	write(9,*) 'x',global_x_min_boundary, global_x_max_boundary
!	write(9,*) 'y',global_y_min_boundary, global_y_max_boundary
!	write(9,*) 'z',global_z_min_boundary, global_z_max_boundary

	OPEN (68, FILE = 'results/'//filename//'.txt', STATUS = 'unknown', form='formatted')
	
	DO K = global_z_min_boundary, global_z_max_boundary
	
		DO J = global_y_min_boundary, global_y_max_boundary
		
			DO I = global_x_min_boundary, global_x_max_boundary
							
				WRITE(68,*) I, J, K, global_array( I, J, K )
			
			END DO !!I
		
		END DO !!J
	
	END DO !!K

	CLOSE(68)

END IF !!My_MPI_Process_ID.EQ.ROOT

DEALLOCATE ( local_send_buffer,global_array_receive_buffer,global_array )

RETURN
END SUBROUTINE gatherv_write_3d_array