 Timestamp:
 20190701T12:44:06+02:00 (15 months ago)
 File:

 1 edited
Legend:
 Unmodified
 Added
 Removed

branches/UKMO/r6232_obs_oper_update/NEMOGCM/NEMO/OPA_SRC/OBS/obs_mpp.F90
r2513 r11202 7 7 !!  ! 200605 (K. Mogensen) Reformatted 8 8 !!  ! 200801 (K. Mogensen) add mpp_global_max 9 !! 3.6 ! 201501 (J. Waters) obs_mpp_find_obs_proc 10 !! rewritten to avoid global arrays 9 11 !! 10 12 # define mpivar mpi_double_precision … … 12 14 !! obs_mpp_bcast_integer : Broadcast an integer array from a processor to all processors 13 15 !! obs_mpp_max_integer : Find maximum on all processors of each value in an integer on all processors 14 !! obs_mpp_find_obs_proc : Find processors which should hold the observations 16 !! obs_mpp_find_obs_proc : Find processors which should hold the observations, avoiding global arrays 15 17 !! obs_mpp_sum_integers : Sum an integer array from all processors 16 18 !! obs_mpp_sum_integer : Sum an integer from all processors … … 96 98 ! 97 99 INTEGER :: ierr 98 INTEGER, DIMENSION(kno) :: ivals 99 ! 100 INCLUDE 'mpif.h' 101 !! 100 INTEGER, DIMENSION(:), ALLOCATABLE :: ivals 101 ! 102 INCLUDE 'mpif.h' 103 !! 104 105 ALLOCATE( ivals(kno) ) 102 106 103 107 ! Call the MPI library to find the maximum across processors … … 105 109 & mpi_max, mpi_comm_opa, ierr ) 106 110 kvals(:) = ivals(:) 111 112 DEALLOCATE( ivals ) 107 113 #else 108 114 ! no MPI: empty routine … … 111 117 112 118 113 SUBROUTINE obs_mpp_find_obs_proc( kobsp, kobsi, kobsj,kno )114 !! 115 !! *** ROUTINE obs_mpp_find_obs_proc ***116 !! 117 !! ** Purpose : From the array kobsp containing the results of the grid119 SUBROUTINE obs_mpp_find_obs_proc( kobsp,kno ) 120 !! 121 !! *** ROUTINE obs_mpp_find_obs_proc *** 122 !! 123 !! ** Purpose : From the array kobsp containing the results of the 118 124 !! grid search on each processor the processor return a 119 125 !! decision of which processors should hold the observation. 120 126 !! 121 !! ** Method : A temporary 2D array holding all the decisions is122 !! constructed using mpi_allgather on each processor.123 !! If more than one processor has found the observation124 !! with the observation in the inner domain gets it125 !! 126 !! ** Action : This does only work for MPI. 127 !! ** Method : Synchronize the processor number for each obs using 128 !! obs_mpp_max_integer. If an observation exists on two 129 !! processors it will be allocated to the lower numbered 130 !! processor. 131 !! 132 !! ** Action : This does only work for MPI. 127 133 !! It does not work for SHMEM. 128 134 !! … … 130 136 !! 131 137 INTEGER , INTENT(in ) :: kno 132 INTEGER, DIMENSION(kno), INTENT(in ) :: kobsi, kobsj133 138 INTEGER, DIMENSION(kno), INTENT(inout) :: kobsp 134 139 ! 135 140 #if defined key_mpp_mpi 136 141 ! 137 INTEGER :: ji 138 INTEGER :: jj 139 INTEGER :: size 140 INTEGER :: ierr 141 INTEGER :: iobsip 142 INTEGER :: iobsjp 143 INTEGER :: num_sus_obs 144 INTEGER, DIMENSION(kno) :: iobsig, iobsjg 145 INTEGER, ALLOCATABLE, DIMENSION(:,:) :: iobsp, iobsi, iobsj 146 !! 147 INCLUDE 'mpif.h' 148 !! 149 150 ! 151 ! Call the MPI library to find the maximum accross processors 152 ! 153 CALL mpi_comm_size( mpi_comm_opa, size, ierr ) 154 ! 155 ! Convert local grids points to global grid points 156 ! 142 ! 143 INTEGER :: ji, isum 144 INTEGER, DIMENSION(:), ALLOCATABLE :: iobsp 145 !! 146 !! 147 148 ALLOCATE( iobsp(kno) ) 149 150 iobsp(:)=kobsp(:) 151 152 WHERE( iobsp(:) == 1 ) 153 iobsp(:) = 9999999 154 END WHERE 155 156 iobsp(:)=1*iobsp(:) 157 158 CALL obs_mpp_max_integer( iobsp, kno ) 159 160 kobsp(:)=1*iobsp(:) 161 162 isum=0 157 163 DO ji = 1, kno 158 IF ( ( kobsi(ji) >= 1 ) .AND. ( kobsi(ji) <= jpi ) .AND. & 159 & ( kobsj(ji) >= 1 ) .AND. ( kobsj(ji) <= jpj ) ) THEN 160 iobsig(ji) = mig( kobsi(ji) ) 161 iobsjg(ji) = mjg( kobsj(ji) ) 162 ELSE 163 iobsig(ji) = 1 164 iobsjg(ji) = 1 164 IF ( kobsp(ji) == 9999999 ) THEN 165 isum=isum+1 166 kobsp(ji)=1 165 167 ENDIF 166 END DO 167 ! 168 ! Get the decisions from all processors 169 ! 170 ALLOCATE( iobsp(kno,size) ) 171 ALLOCATE( iobsi(kno,size) ) 172 ALLOCATE( iobsj(kno,size) ) 173 CALL mpi_allgather( kobsp, kno, mpi_integer, & 174 & iobsp, kno, mpi_integer, & 175 & mpi_comm_opa, ierr ) 176 CALL mpi_allgather( iobsig, kno, mpi_integer, & 177 & iobsi, kno, mpi_integer, & 178 & mpi_comm_opa, ierr ) 179 CALL mpi_allgather( iobsjg, kno, mpi_integer, & 180 & iobsj, kno, mpi_integer, & 181 & mpi_comm_opa, ierr ) 182 183 ! 184 ! Find the processor with observations from the lowest processor 185 ! number among processors holding the observation. 186 ! 187 kobsp(:) = 1 188 num_sus_obs = 0 189 DO ji = 1, kno 190 DO jj = 1, size 191 IF ( ( kobsp(ji) == 1 ) .AND. ( iobsp(ji,jj) /= 1 ) ) THEN 192 kobsp(ji) = iobsp(ji,jj) 193 iobsip = iobsi(ji,jj) 194 iobsjp = iobsj(ji,jj) 195 ENDIF 196 IF ( ( kobsp(ji) /= 1 ) .AND. ( iobsp(ji,jj) /= 1 ) ) THEN 197 IF ( ( iobsip /= iobsi(ji,jj) ) .OR. & 198 & ( iobsjp /= iobsj(ji,jj) ) ) THEN 199 IF ( ( kobsp(ji) < 1000000 ) .AND. & 200 & ( iobsp(ji,jj) < 1000000 ) ) THEN 201 num_sus_obs=num_sus_obs+1 202 ENDIF 203 ENDIF 204 IF ( mppmap(iobsip,iobsjp) /= ( kobsp(ji)+1 ) ) THEN 205 IF ( ( iobsi(ji,jj) /= 1 ) .AND. & 206 & ( iobsj(ji,jj) /= 1 ) ) THEN 207 IF ((mppmap(iobsi(ji,jj),iobsj(ji,jj)) == (iobsp(ji,jj)+1))& 208 & .OR. ( iobsp(ji,jj) < kobsp(ji) ) ) THEN 209 kobsp(ji) = iobsp(ji,jj) 210 iobsip = iobsi(ji,jj) 211 iobsjp = iobsj(ji,jj) 212 ENDIF 213 ENDIF 214 ENDIF 215 ENDIF 216 END DO 217 END DO 218 IF (lwp) WRITE(numout,*) 'Number of suspicious observations: ',num_sus_obs 219 220 DEALLOCATE( iobsj ) 221 DEALLOCATE( iobsi ) 168 ENDDO 169 170 171 IF ( isum > 0 ) THEN 172 IF (lwp) WRITE(numout,*) isum, ' observations failed the grid search.' 173 IF (lwp) WRITE(numout,*)'If ln_grid_search_lookup=.TRUE., try reducing grid_search_res' 174 ENDIF 175 222 176 DEALLOCATE( iobsp ) 177 223 178 #else 224 179 ! no MPI: empty routine 225 #endif 226 !180 #endif 181 227 182 END SUBROUTINE obs_mpp_find_obs_proc 228 183
Note: See TracChangeset
for help on using the changeset viewer.