- Timestamp:
- 2015-10-21T18:01:58+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/NERC/dev_r5589_is_oce_cpl/NEMOGCM/NEMO/OPA_SRC/DOM/iscplhsb.F90
r5802 r5820 62 62 REAL(wp):: summsk, zsum, zsum1, zarea, zsumn, zsumb 63 63 REAL(wp):: r1_tiscpl 64 REAL(wp):: zjip1_ratio , zjim1_ratio, zjjp1_ratio, zjjm1_ratio64 REAL(wp):: zjip1_ratio , zjim1_ratio , zjjp1_ratio , zjjm1_ratio 65 65 !! 66 66 REAL(wp), DIMENSION(:,: ), POINTER :: zde3t, zdtem, zdsal … … 83 83 pts_flx (:,:,:,:) = 0.0_wp 84 84 85 ! mask tsn and tsb (should be useless)85 ! mask tsn and tsb 86 86 tsb(:,:,:,jp_tem)=tsb(:,:,:,jp_tem)*ptmask_b(:,:,:); tsn(:,:,:,jp_tem)=tsn(:,:,:,jp_tem)*tmask(:,:,:); 87 87 tsb(:,:,:,jp_sal)=tsb(:,:,:,jp_sal)*ptmask_b(:,:,:); tsn(:,:,:,jp_sal)=tsn(:,:,:,jp_sal)*tmask(:,:,:); … … 98 98 IF (tmask_h(ji,jj) == 1._wp) THEN 99 99 100 ! volume differences101 zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk)102 103 ! heat diff104 zdtem(ji,jj) = tsn(ji,jj,jk,jp_tem) * fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) &100 ! volume differences 101 zde3t(ji,jj) = fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) - pe3t_b(ji,jj,jk) * ptmask_b(ji,jj,jk) 102 103 ! heat diff 104 zdtem(ji,jj) = tsn(ji,jj,jk,jp_tem) * fse3t_n(ji,jj,jk) * tmask (ji,jj,jk) & 105 105 - tsb(ji,jj,jk,jp_tem) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) 106 ! salt diff107 zdsal(ji,jj) = tsn(ji,jj,jk,jp_sal) * fse3t_n(ji,jj,jk) * tmask(ji,jj,jk) &108 - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk)106 ! salt diff 107 zdsal(ji,jj) = tsn(ji,jj,jk,jp_sal) * fse3t_n(ji,jj,jk) * tmask (ji,jj,jk) & 108 - tsb(ji,jj,jk,jp_sal) * pe3t_b (ji,jj,jk) * ptmask_b(ji,jj,jk) 109 109 110 ! shh changes 111 IF ( ptmask_b(ji,jj,jk) == 1 .OR. tmask(ji,jj,jk) == 1 ) THEN 112 zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) 113 zssh0(ji,jj) = 0._wp 114 END IF 115 116 ! volume, heat and salt differences in each cell 117 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t(ji,jj) * r1_tiscpl 118 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal(ji,jj) * r1_tiscpl 119 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem(ji,jj) * r1_tiscpl 120 121 IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN 122 ! case where we close a cell: check if the neighbour cells are wet 123 124 jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ; 125 126 zsum = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) + e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) & 127 & + e12t(jim1,jj ) * tmask(jim1,jj ,jk) + e12t(jip1,jj ) * tmask(jip1,jj ,jk) 128 129 IF ( zsum .NE. 0._wp ) THEN 130 zjip1_ratio = e12t(jip1,jj ) * tmask(jip1,jj ,jk) / zsum 131 zjim1_ratio = e12t(jim1,jj ) * tmask(jim1,jj ,jk) / zsum 132 zjjp1_ratio = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) / zsum 133 zjjm1_ratio = e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) / zsum 134 135 pvol_flx(ji ,jjp1,jk ) = pvol_flx(ji ,jjp1,jk ) + pvol_flx(ji,jj,jk ) * zjjp1_ratio 136 pvol_flx(ji ,jjm1,jk ) = pvol_flx(ji ,jjm1,jk ) + pvol_flx(ji,jj,jk ) * zjjm1_ratio 137 pvol_flx(jip1,jj ,jk ) = pvol_flx(jip1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjip1_ratio 138 pvol_flx(jim1,jj ,jk ) = pvol_flx(jim1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjim1_ratio 139 pts_flx (ji ,jjp1,jk,jp_sal) = pts_flx (ji ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio 140 pts_flx (ji ,jjm1,jk,jp_sal) = pts_flx (ji ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio 141 pts_flx (jip1,jj ,jk,jp_sal) = pts_flx (jip1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio 142 pts_flx (jim1,jj ,jk,jp_sal) = pts_flx (jim1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio 143 pts_flx (ji ,jjp1,jk,jp_tem) = pts_flx (ji ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio 144 pts_flx (ji ,jjm1,jk,jp_tem) = pts_flx (ji ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio 145 pts_flx (jip1,jj ,jk,jp_tem) = pts_flx (jip1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio 146 pts_flx (jim1,jj ,jk,jp_tem) = pts_flx (jim1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio 147 148 ! set to 0 the cell we distributed over neigbourg cells 149 pvol_flx(ji,jj,jk ) = 0._wp 150 pts_flx (ji,jj,jk,jp_sal) = 0._wp 151 pts_flx (ji,jj,jk,jp_tem) = 0._wp 152 153 ELSE IF (zsum .EQ. 0._wp ) THEN 154 ! case where we close a cell and no adjacent cell open 155 ! check if the cell beneath is wet 156 IF ( tmask(ji,jj,jk+1) .EQ. 1._wp ) THEN 157 pvol_flx(ji,jj,jk+1) = pvol_flx(ji,jj,jk+1) + pvol_flx(ji,jj,jk) 158 pts_flx (ji,jj,jk+1,jp_sal)= pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal) 159 pts_flx (ji,jj,jk+1,jp_tem)= pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem) 110 ! shh changes 111 IF ( ptmask_b(ji,jj,jk) == 1._wp .OR. tmask(ji,jj,jk) == 1._wp ) THEN 112 zde3t(ji,jj) = zde3t(ji,jj) + zssh0(ji,jj) ! zssh0 = 0 if vvl 113 zssh0(ji,jj) = 0._wp 114 END IF 115 116 ! volume, heat and salt differences in each cell 117 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk) + zde3t(ji,jj) * r1_tiscpl 118 pts_flx (ji,jj,jk,jp_sal)= pts_flx (ji,jj,jk,jp_sal) + zdsal(ji,jj) * r1_tiscpl 119 pts_flx (ji,jj,jk,jp_tem)= pts_flx (ji,jj,jk,jp_tem) + zdtem(ji,jj) * r1_tiscpl 120 121 IF ( tmask(ji,jj,jk) == 0._wp .AND. ptmask_b(ji,jj,jk) == 1._wp ) THEN 122 ! case where we close a cell: check if the neighbour cells are wet 123 124 jip1=ji+1 ; jim1=ji-1 ; jjp1=jj+1 ; jjm1=jj-1 ; 125 126 zsum = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) + e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) & 127 & + e12t(jim1,jj ) * tmask(jim1,jj ,jk) + e12t(jip1,jj ) * tmask(jip1,jj ,jk) 128 129 IF ( zsum .NE. 0._wp ) THEN 130 zjip1_ratio = e12t(jip1,jj ) * tmask(jip1,jj ,jk) / zsum 131 zjim1_ratio = e12t(jim1,jj ) * tmask(jim1,jj ,jk) / zsum 132 zjjp1_ratio = e12t(ji ,jjp1) * tmask(ji ,jjp1,jk) / zsum 133 zjjm1_ratio = e12t(ji ,jjm1) * tmask(ji ,jjm1,jk) / zsum 134 135 pvol_flx(ji ,jjp1,jk ) = pvol_flx(ji ,jjp1,jk ) + pvol_flx(ji,jj,jk ) * zjjp1_ratio 136 pvol_flx(ji ,jjm1,jk ) = pvol_flx(ji ,jjm1,jk ) + pvol_flx(ji,jj,jk ) * zjjm1_ratio 137 pvol_flx(jip1,jj ,jk ) = pvol_flx(jip1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjip1_ratio 138 pvol_flx(jim1,jj ,jk ) = pvol_flx(jim1,jj ,jk ) + pvol_flx(ji,jj,jk ) * zjim1_ratio 139 pts_flx (ji ,jjp1,jk,jp_sal) = pts_flx (ji ,jjp1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjp1_ratio 140 pts_flx (ji ,jjm1,jk,jp_sal) = pts_flx (ji ,jjm1,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjjm1_ratio 141 pts_flx (jip1,jj ,jk,jp_sal) = pts_flx (jip1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjip1_ratio 142 pts_flx (jim1,jj ,jk,jp_sal) = pts_flx (jim1,jj ,jk,jp_sal) + pts_flx (ji,jj,jk,jp_sal) * zjim1_ratio 143 pts_flx (ji ,jjp1,jk,jp_tem) = pts_flx (ji ,jjp1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjp1_ratio 144 pts_flx (ji ,jjm1,jk,jp_tem) = pts_flx (ji ,jjm1,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjjm1_ratio 145 pts_flx (jip1,jj ,jk,jp_tem) = pts_flx (jip1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjip1_ratio 146 pts_flx (jim1,jj ,jk,jp_tem) = pts_flx (jim1,jj ,jk,jp_tem) + pts_flx (ji,jj,jk,jp_tem) * zjim1_ratio 160 147 161 148 ! set to 0 the cell we distributed over neigbourg cells … … 163 150 pts_flx (ji,jj,jk,jp_sal) = 0._wp 164 151 pts_flx (ji,jj,jk,jp_tem) = 0._wp 165 ELSE 166 ! case no adjacent cell on the horizontal and on the vertical 167 PRINT *, 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal' 168 PRINT *, ' ',mig(ji),' ',mjg(jj),' ',jk 169 PRINT *, ' ',ji,' ',jj,' ',jk,' ',narea 170 PRINT *, ' we are now looking for the closest wet cell on the horizontal ' 171 ! We deal with this points later. 152 153 ELSE IF (zsum .EQ. 0._wp ) THEN 154 ! case where we close a cell and no adjacent cell open 155 ! check if the cell beneath is wet 156 IF ( tmask(ji,jj,jk+1) .EQ. 1._wp ) THEN 157 pvol_flx(ji,jj,jk+1) = pvol_flx(ji,jj,jk+1) + pvol_flx(ji,jj,jk) 158 pts_flx (ji,jj,jk+1,jp_sal)= pts_flx (ji,jj,jk+1,jp_sal) + pts_flx (ji,jj,jk,jp_sal) 159 pts_flx (ji,jj,jk+1,jp_tem)= pts_flx (ji,jj,jk+1,jp_tem) + pts_flx (ji,jj,jk,jp_tem) 160 161 ! set to 0 the cell we distributed over neigbourg cells 162 pvol_flx(ji,jj,jk ) = 0._wp 163 pts_flx (ji,jj,jk,jp_sal) = 0._wp 164 pts_flx (ji,jj,jk,jp_tem) = 0._wp 165 ELSE 166 ! case no adjacent cell on the horizontal and on the vertical 167 WRITE(numout,*) 'W A R N I N G iscpl: no adjacent cell on the vertical and horizontal' 168 WRITE(numout,*) ' ',mig(ji),' ',mjg(jj),' ',jk 169 WRITE(numout,*) ' ',ji,' ',jj,' ',jk,' ',narea 170 WRITE(numout,*) ' we are now looking for the closest wet cell on the horizontal ' 171 ! We deal with these points later. 172 END IF 172 173 END IF 173 174 END IF 174 175 END IF 175 END IF176 176 END DO 177 177 END DO … … 181 181 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 182 182 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 183 184 zsum = glob_sum_full(pvol_flx(:,:,:) ) * rn_fiscpl * rn_rdt185 IF (lwp) PRINT *, 'total volume correction 21 = ',zsum186 zsum = glob_sum_full(pts_flx(:,:,:,jp_tem)) * rn_fiscpl * rn_rdt187 IF (lwp) PRINT *, 'total heat correction 21 = ',zsum188 zsum = glob_sum_full(pts_flx(:,:,:,jp_sal)) * rn_fiscpl * rn_rdt189 IF (lwp) PRINT *, 'total salt correction 21 = ',zsum190 183 191 184 ! if no neighbour wet cell in case of 2close a cell", need to find the nearest wet point … … 198 191 DO ji = 2,jpi-1 199 192 DO jj = 2,jpj-1 200 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 201 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 & 202 & .AND. tmask_h(ji,jj) == 1._wp ) THEN 193 IF ( ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1) == 0._wp .AND. tmask_h(ji,jj) == 1._wp & 194 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN 203 195 vnpts(narea) = vnpts(narea) + 1 204 196 END IF … … 216 208 ALLOCATE(ixpts(npts), iypts(npts), izpts(npts), zcorr_vol(npts), zcorr_sal(npts), zcorr_tem(npts), zlon(npts), zlat(npts)) 217 209 ixpts(:) = -9999 ; iypts(:) = -9999 ; izpts(:) = -9999 ; zlon(:) = -1.0e20 ; zlat(:) = -1.0e20 218 zcorr_vol(:) = 0.0_wp219 zcorr_sal(:) = 0.0_wp220 zcorr_tem(:) = 0.0_wp210 zcorr_vol(:) = -1.0e20 211 zcorr_sal(:) = -1.0e20 212 zcorr_tem(:) = -1.0e20 221 213 222 214 ! fill new variable … … 225 217 DO ji = 2,jpi-1 226 218 DO jj = 2,jpj-1 227 IF ( ptmask_b(ji,jj,jk) == 1 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) == 0 & 228 & .AND. SUM(tmask(ji,jj-1:jj+1,jk)) == 0 .AND. tmask(ji,jj,jk+1) == 0 & 229 & .AND. tmask_h(ji,jj) == 1 ) THEN 219 IF ( ptmask_b(ji,jj,jk) == 1._wp .AND. tmask(ji,jj,jk+1) == 0._wp .AND. tmask_h(ji,jj) == 1._wp & 220 .AND. SUM(tmask(ji-1:ji+1,jj,jk)) + SUM(tmask(ji,jj-1:jj+1,jk)) == 0._wp) THEN 230 221 jpts = jpts + 1 ! positioning in the vnpts vector for the area narea 231 PRINT *, 'corrected point ', narea, ji, jj, jk, jpts232 222 ixpts(jpts) = ji ; iypts(jpts) = jj ; izpts(jpts) = jk 233 223 zlon (jpts) = glamt(ji,jj) ; zlat (jpts) = gphit(ji,jj) … … 235 225 zcorr_sal(jpts) = pts_flx (ji,jj,jk,jp_sal) 236 226 zcorr_tem(jpts) = pts_flx (ji,jj,jk,jp_tem) 227 237 228 ! set flx to 0 (safer) 238 229 pvol_flx(ji,jj,jk ) = 0.0_wp 239 230 pts_flx (ji,jj,jk,jp_sal) = 0.0_wp 240 231 pts_flx (ji,jj,jk,jp_tem) = 0.0_wp 241 PRINT *, zcorr_vol(jpts)*rn_fiscpl*rn_rdt, zcorr_sal(jpts)*rn_fiscpl*rn_rdt, zcorr_tem(jpts)*rn_fiscpl*rn_rdt242 232 END IF 243 233 END DO … … 246 236 247 237 ! build array of total problematic point on each cpu (share to each cpu) 238 ! point coordinates 248 239 CALL mpp_max(zlat ,npts) 249 240 CALL mpp_max(zlon ,npts) 250 241 CALL mpp_max(izpts,npts) 251 242 243 ! correction values 244 CALL mpp_max(zcorr_vol,npts) 245 CALL mpp_max(zcorr_sal,npts) 246 CALL mpp_max(zcorr_tem,npts) 247 252 248 ! put correction term in the closest cell 253 PRINT *, 'corrected point1 ', narea, zlon, zlat, izpts254 249 DO jpts = 1,npts 255 250 CALL dom_ngb(zlon(jpts), zlat(jpts), ixpts(jpts), iypts(jpts),'T', izpts(jpts)) 256 PRINT *, 'corrected point2 ', narea, jpts, ixpts(jpts), iypts(jpts), izpts(jpts)257 251 DO jj = mj0(iypts(jpts)),mj1(iypts(jpts)) 258 252 DO ji = mi0(ixpts(jpts)),mi1(ixpts(jpts)) 259 253 jk = izpts(jpts) 260 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk ) + zcorr_vol(jpts) 261 pts_flx (ji,jj,jk,jp_sal) = pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts) 262 pts_flx (ji,jj,jk,jp_tem) = pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts) 263 END DO 264 END DO 265 END DO 254 255 IF (tmask_h(ji,jj) == 1._wp) THEN 256 ! correct the vol_flx in the closest cell 257 pvol_flx(ji,jj,jk) = pvol_flx(ji,jj,jk ) + zcorr_vol(jpts) 258 pts_flx (ji,jj,jk,jp_sal) = pts_flx (ji,jj,jk,jp_sal) + zcorr_sal(jpts) 259 pts_flx (ji,jj,jk,jp_tem) = pts_flx (ji,jj,jk,jp_tem) + zcorr_tem(jpts) 260 261 ! set correction to 0 262 zcorr_vol(jpts) = 0.0_wp 263 zcorr_sal(jpts) = 0.0_wp 264 zcorr_tem(jpts) = 0.0_wp 265 END IF 266 END DO 267 END DO 268 END DO 269 266 270 ! deallocate variables 267 271 DEALLOCATE(vnpts) … … 273 277 pts_flx (:,:,:,jp_tem) = pts_flx (:,:,:,jp_tem) * tmask(:,:,:) 274 278 275 CALL lbc_sum(pvol_flx(:,:,: ),'T',1.) 276 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1.) 277 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1.) 278 279 ! CHECK vol !!!!!!!!! warning tmask_i wrong if deals with before value, so glob_sum wrong for before value!!!! 280 zsum = glob_sum_full( pvol_flx(:,:,:) ) 281 IF (lwp) PRINT *, 'CHECK vol = ',zsum 282 ! CHECK salt 283 zsum = glob_sum( pts_flx(:,:,:,jp_sal) ) 284 IF (lwp) PRINT *, 'CHECK salt = ',zsum 285 ! CHECK heat 286 zsum = glob_sum( pts_flx(:,:,:,jp_tem) ) 287 IF (lwp) PRINT *, 'CHECK heat = ',zsum 288 !! 279 ! compute sum over the halo and set it to 0. 280 CALL lbc_sum(pvol_flx(:,:,: ),'T',1._wp) 281 CALL lbc_sum(pts_flx (:,:,:,jp_sal),'T',1._wp) 282 CALL lbc_sum(pts_flx (:,:,:,jp_tem),'T',1._wp) 283 284 ! deallocate variables 289 285 CALL wrk_dealloc(jpi,jpj,jpk, ztmp3d ) 290 286 CALL wrk_dealloc(jpi,jpj, zde3t )
Note: See TracChangeset
for help on using the changeset viewer.
