Changeset 7222 for branches/2015/dev_r5003_MERCATOR6_CRS
- Timestamp:
- 2016-11-14T15:34:11+01:00 (8 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO
- Files:
-
- 3 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdom.F90
r7217 r7222 179 179 CALL crs_lbc_lnk( p_gphi_crs, cd_type, 1.0 ) 180 180 CALL crs_lbc_lnk( p_glam_crs, cd_type, 1.0 ) 181 182 !cbr??? ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd183 ! SELECT CASE ( cd_type )184 ! CASE ( 'T', 'V' )185 ! DO ji = 2, nlei_crs186 ! ijis = mis_crs(ji) + mxbinctr187 ! p_gphi_crs(ji,1) = p_gphi(ijis,1)188 ! p_glam_crs(ji,1) = p_glam(ijis,1)189 ! ENDDO190 ! CASE ( 'U', 'F' )191 ! DO ji = 2, nlei_crs192 ! ijis = mis_crs(ji)193 ! p_gphi_crs(ji,1) = p_gphi(ijis,1)194 ! p_glam_crs(ji,1) = p_glam(ijis,1)195 ! ENDDO196 ! END SELECT197 181 ! 198 182 END SUBROUTINE crs_dom_coordinates … … 245 229 SELECT CASE ( cd_type ) 246 230 CASE ( 'T' ) 247 !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijjs+1 ) )248 !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs:ijje ) )249 231 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1) 250 232 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1) 251 233 CASE ( 'U' ) 252 !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijjs+1 ) )253 !p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs:ijje ) )254 234 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijjs+1 ) 255 235 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 ) 256 236 257 237 CASE ( 'V' ) 258 !p_e1_crs(ji,jj) = SUM( p_e1(ijis:ijie ,ijje ) )259 !p_e2_crs(ji,jj) = SUM( p_e2(ijis+1 ,ijjs+1:ijje+1) )260 238 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje ) 261 239 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijis+1,ijjs+1 ) 262 240 CASE ( 'F' ) 263 !p_e1_crs(ji,jj) = SUM( p_e1(ijis+1:ijie+1 ,ijje ) )264 !p_e2_crs(ji,jj) = SUM( p_e2(ijie ,ijjs+1:ijje+1) )265 241 p_e1_crs(ji,jj) = REAL(nn_factx,wp)*p_e1(ijis+1,ijje ) 266 242 p_e2_crs(ji,jj) = REAL(nn_facty,wp)*p_e2(ijie ,ijjs+1 ) … … 270 246 271 247 272 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 ) !cbr , pval=1.0 )273 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 ) !cbr , pval=1.0 )248 CALL crs_lbc_lnk( p_e1_crs, cd_type, 1.0 ) 249 CALL crs_lbc_lnk( p_e2_crs, cd_type, 1.0 ) 274 250 275 251 END SUBROUTINE crs_dom_hgr … … 1119 1095 !! 3) Define the processor domain indice for a croasening grid 1120 1096 !!---------------------------------------------------------------- 1121 !! 1122 !! local variables 1123 1124 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 1125 INTEGER :: ierr ! allocation error status 1097 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 1098 INTEGER :: ierr ! allocation error status 1126 1099 INTEGER :: iproci,iprocj,iproc,iprocno,iprocso,iimppt_crs 1127 1100 INTEGER :: ii_start,ii_end,ij_start,ij_end 1101 !!---------------------------------------------------------------- 1128 1102 1129 1103 1130 ! 1.a. Define global domain indices : take into account the interior domain only ( removes i/j=1 , i/j=jpiglo/jpjglo ) then add 2/3 grid points 1104 !============================================================================================== 1105 ! Define global and local domain sizes 1106 !============================================================================================== 1131 1107 jpiglo_crs = INT( (jpiglo - 2) / nn_factx ) + 2 1132 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj1133 ! jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 31134 1108 jpjglo_crs = INT( (jpjglo - MOD(jpjglo, nn_facty)) / nn_facty ) + 2 1135 1109 jpiglo_crsm1 = jpiglo_crs - 1 … … 1138 1112 jpi_crs = ( jpiglo_crs - 2 * jpreci + (jpni-1) ) / jpni + 2 * jpreci 1139 1113 jpj_crs = ( jpjglo_crsm1 - 2 * jprecj + (jpnj-1) ) / jpnj + 2 * jprecj 1140 !cbr? IF( njmpp==1 )THEN1141 ! jpj_crs=jpj_crs+11142 ! ENDIF1143 1144 1114 1145 1115 jpi_crsm1 = jpi_crs - 1 1146 1116 jpj_crsm1 = jpj_crs - 1 1117 1147 1118 nperio_crs = jperio 1148 1119 npolj_crs = npolj … … 1150 1121 ierr = crs_dom_alloc() ! allocate most coarse grid arrays 1151 1122 1152 ! 2.a Define processor domain 1123 !============================================================================================== 1124 ! Define processor domain indices 1125 !============================================================================================== 1153 1126 IF( .NOT. lk_mpp ) THEN 1127 1154 1128 nimpp_crs = 1 1155 1129 njmpp_crs = 1 … … 1160 1134 nlei_crs = jpi_crs 1161 1135 nlej_crs = jpj_crs 1136 1162 1137 ELSE 1163 ! Initialisation of most local variables - 1138 1164 1139 nimpp_crs = 1 1165 1140 njmpp_crs = 1 … … 1171 1146 nlej_crs = jpj_crs 1172 1147 1173 !============================================================================================== 1174 ! mpp_ini2 1175 !============================================================================================== 1176 DO ji = 1 , jpni 1177 DO jj = 1 ,jpnj 1178 IF( nfipproc(ji,jj) == narea-1 )THEN 1179 iproci=ji 1180 iprocj=jj 1181 ENDIF 1182 ENDDO 1183 ENDDO 1184 1185 !WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea 1186 !WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj 1187 !WRITE(narea+8000-1,*)"nowe noea",nowe,noea 1188 !WRITE(narea+8000-1,*)"noso nono",noso,nono 1189 !WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj 1190 !WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo 1191 !WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj 1192 !WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj 1193 !WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp 1194 !WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci 1195 !WRITE(narea+8000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1 1196 !WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj 1197 !WRITE(narea+8000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1 1198 !WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs 1199 !WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs 1200 !WRITE(narea+8000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij 1201 !WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj) 1202 !========================================================================== 1203 ! dim along I 1204 !========================================================================== 1205 SELECT CASE ( nperio ) 1206 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 1207 1208 DO ji=1,jpiglo_crs 1209 ijis=nn_factx*(ji-1)-2 1210 ijie=nn_factx*(ji-1) 1211 mis2_crs(ji)=ijis 1212 mie2_crs(ji)=ijie 1213 ENDDO 1214 1215 ji=1 1216 DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 ) 1217 ji=ji+1 1218 IF( ji==jpiglo_crs )EXIT 1219 END DO 1220 ijis=ji 1221 1222 !mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 1223 !ijis =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur 1224 !ii_start =indice local de mjs2_crs(jj) 1225 ii_start = mis2_crs(ijis)-nimpp+1 1226 nimpp_crs = ijis-1 1227 1228 nldi_crs = 2 1229 IF( nowe == -1 )THEN 1148 !============================================================================================== 1149 ! mpp_ini2 1150 !============================================================================================== 1151 1152 !order of local domain in i and j directions 1153 DO ji = 1 , jpni 1154 DO jj = 1 ,jpnj 1155 IF( nfipproc(ji,jj) == narea-1 )THEN 1156 iproci=ji 1157 iprocj=jj 1158 ENDIF 1159 ENDDO 1160 ENDDO 1161 1162 !WRITE(narea+8000-1,*)"nfipproc(ji,jj),narea :",nfipproc(iproci,iprocj),narea 1163 !WRITE(narea+8000-1,*)"proc i,j ",iproci,iprocj 1164 !WRITE(narea+8000-1,*)"nowe noea",nowe,noea 1165 !WRITE(narea+8000-1,*)"noso nono",noso,nono 1166 !WRITE(narea+8000-1,*)"nbondi nbondj ",nbondi,nbondj 1167 !WRITE(narea+8000-1,*)"jpiglo jpjglo ",jpiglo,jpjglo 1168 !WRITE(narea+8000-1,*)"jpi jpj ",jpi,jpj 1169 !WRITE(narea+8000-1,*)"nbondi nbondj",nbondi,nbondj 1170 !WRITE(narea+8000-1,*)"nimpp njmpp ",nimpp,njmpp 1171 !WRITE(narea+8000-1,*)"loc jpi nldi,nlei,nlci ",jpi, nldi ,nlei ,nlci 1172 !WRITE(narea+8000-1,*)"glo jpi nldi,nlei ",jpi, nldi+nimpp-1,nlei+nimpp-1 1173 !WRITE(narea+8000-1,*)"loc jpj nldj,nlej,nlcj ",jpj, nldj ,nlej ,nlcj 1174 !WRITE(narea+8000-1,*)"glo jpj nldj,nlej ",jpj, nldj+njmpp-1,nlej+njmpp-1 1175 !WRITE(narea+8000-1,*)"jpiglo_crs jpjglo_crs ",jpiglo_crs,jpjglo_crs 1176 !WRITE(narea+8000-1,*)"jpi_crs jpj_crs ",jpi_crs,jpj_crs 1177 !WRITE(narea+8000-1,*)"jpni jpnj jpnij ",jpni,jpnj,jpnij 1178 !WRITE(narea+8000-1,*)"glamt gphit ",glamt(1,1),gphit(jpi,jpj),glamt(jpi,jpj),gphit(jpi,jpj) 1179 1180 !========================================================================== 1181 ! coarsened domain: dimensions along I 1182 !========================================================================== 1183 1184 SELECT CASE ( nperio ) 1185 1186 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 1187 1188 DO ji=1,jpiglo_crs 1189 ijis=nn_factx*(ji-1)-2 1190 ijie=nn_factx*(ji-1) 1191 mis2_crs(ji)=ijis 1192 mie2_crs(ji)=ijie 1193 ENDDO 1194 1195 ji=1 1196 DO WHILE( mis2_crs(ji) - nimpp + 1 .LT. 1 ) 1197 ji=ji+1 1198 IF( ji==jpiglo_crs )EXIT 1199 END DO 1200 ijis=ji 1201 1202 !mjs2_crs(ijis)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 1203 !ijis =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur 1204 !ii_start =indice local de mjs2_crs(jj) 1205 ii_start = mis2_crs(ijis)-nimpp+1 1206 nimpp_crs = ijis-1 1207 1208 nldi_crs = 2 1209 IF( nowe == -1 )THEN 1230 1210 1231 1211 mie2_crs(ijis-1) = mis2_crs(ijis)-1 … … 1237 1217 mis2_crs(ijis-1) = -1 1238 1218 CASE(2) 1239 !CBR? nldi_crs=11240 1219 nldi_crs=2 1241 1220 mis2_crs(ijis-1) = mie2_crs(ijis-1) 1242 1221 CASE(3) 1243 !CBR? nldi_crs=11244 1222 nldi_crs=2 1245 1223 mis2_crs(ijis-1) = mie2_crs(ijis-1) -1 … … 1248 1226 END SELECT 1249 1227 1250 ENDIF1251 1252 IF( nimpp==1 )nimpp_crs=11253 1254 !----------------------------------------1255 ji=jpiglo_crs1256 DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi )1257 ji=ji-11258 IF( ji==1 )EXIT1259 END DO1260 ijie=ji1261 nlei_crs=ijie-nimpp_crs+11262 nlci_crs=nlei_crs+jpreci1263 1264 !----------------------------------------1265 DO ji = 1, jpi_crs1266 mig_crs(ji) = ji + nimpp_crs - 11267 ENDDO1268 DO ji = 1, jpiglo_crs1269 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) )1270 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) )1271 ENDDO1272 1273 !----------------------------------------1274 DO ji = 1, nlei_crs1275 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 11276 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 11277 nfactx(ji) = mie_crs(ji)-mie_crs(ji)+11278 ENDDO1279 1280 IF( iproci == jpni )THEN1281 nlei_crs=nlci_crs1282 mis_crs(nlei_crs)=mis_crs(nlei_crs-1)1283 mie_crs(nlei_crs)=mie_crs(nlei_crs-1)1284 ENDIF1285 1286 !----------------------------------------1287 1288 CASE DEFAULT1289 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported'1290 END SELECT1291 1292 !==========================================================================1293 ! dim along J1294 !==========================================================================1295 SELECT CASE ( nperio )1296 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold1297 1298 DO jj=1,jpjglo_crs1299 ijjs=nn_facty*(jj)-51300 ijje=nn_facty*(jj)-31301 mjs2_crs(jj)=ijjs1302 mje2_crs(jj)=ijje1303 ENDDO1304 1305 jj=11306 DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 )1307 jj=jj+11308 IF( jj==jpjglo_crs )EXIT1309 END DO1310 ijjs=jj1311 1312 !mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur1313 !ijjs =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur1314 !ij_start =indice local de mjs2_crs(jj)1315 ij_start = mjs2_crs(ijjs)-njmpp+11316 njmpp_crs = ijjs-11317 1318 nldj_crs = 21319 IF( noso == -1 )THEN1228 ENDIF 1229 1230 IF( nimpp==1 )nimpp_crs=1 1231 1232 !---------------------------------------- 1233 ji=jpiglo_crs 1234 DO WHILE( mie2_crs(ji) - nimpp + 1 .GT. jpi ) 1235 ji=ji-1 1236 IF( ji==1 )EXIT 1237 END DO 1238 ijie=ji 1239 nlei_crs=ijie-nimpp_crs+1 1240 nlci_crs=nlei_crs+jpreci 1241 1242 !---------------------------------------- 1243 DO ji = 1, jpi_crs 1244 mig_crs(ji) = ji + nimpp_crs - 1 1245 ENDDO 1246 DO ji = 1, jpiglo_crs 1247 mi0_crs(ji) = MAX( 1, MIN( ji - nimpp_crs + 1 , jpi_crs + 1 ) ) 1248 mi1_crs(ji) = MAX( 0, MIN( ji - nimpp_crs + 1 , jpi_crs ) ) 1249 ENDDO 1250 1251 !---------------------------------------- 1252 DO ji = 1, nlei_crs 1253 mis_crs(ji) = mis2_crs(mig_crs(ji)) - nimpp + 1 1254 mie_crs(ji) = mie2_crs(mig_crs(ji)) - nimpp + 1 1255 nfactx(ji) = mie_crs(ji)-mie_crs(ji)+1 1256 ENDDO 1257 1258 IF( iproci == jpni )THEN 1259 nlei_crs=nlci_crs 1260 mis_crs(nlei_crs)=mis_crs(nlei_crs-1) 1261 mie_crs(nlei_crs)=mie_crs(nlei_crs-1) 1262 ENDIF 1263 1264 !---------------------------------------- 1265 1266 CASE DEFAULT 1267 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 1268 END SELECT 1269 1270 !========================================================================== 1271 ! coarsened domain: dimensions along I 1272 !========================================================================== 1273 SELECT CASE ( nperio ) 1274 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 1275 1276 DO jj=1,jpjglo_crs 1277 ijjs=nn_facty*(jj)-5 1278 ijje=nn_facty*(jj)-3 1279 mjs2_crs(jj)=ijjs 1280 mje2_crs(jj)=ijje 1281 ENDDO 1282 1283 jj=1 1284 DO WHILE( mjs2_crs(jj) - njmpp + 1 .LT. 1 ) 1285 jj=jj+1 1286 IF( jj==jpjglo_crs )EXIT 1287 END DO 1288 ijjs=jj 1289 1290 !mjs2_crs(jj)=indice global ds la grille no crs de la premiere maille du premier pavé contenu ds le domaine intérieur 1291 !ijjs =indice global ds la grille crs de la premire maille qui est ds le domaine intérieur 1292 !ij_start =indice local de mjs2_crs(jj) 1293 ij_start = mjs2_crs(ijjs)-njmpp+1 1294 njmpp_crs = ijjs-1 1295 1296 nldj_crs = 2 1297 IF( noso == -1 )THEN 1320 1298 1321 1299 mje2_crs(ijjs-1) = mjs2_crs(ijjs)-1 … … 1327 1305 mjs2_crs(ijjs-1) = -1 1328 1306 CASE(2) 1329 !CBR? nldj_crs=11330 1307 nldj_crs=2 1331 1308 mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) 1332 1309 CASE(3) 1333 !CBR? nldj_crs=11334 1310 nldj_crs=2 1335 1311 mjs2_crs(ijjs-1) = mje2_crs(ijjs-1) -1 … … 1338 1314 END SELECT 1339 1315 1340 ENDIF 1341 IF( njmpp==1 )njmpp_crs=1 1342 1343 1344 !---------------------------------------- 1345 jj=jpjglo_crs 1346 DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj ) 1347 jj=jj-1 1348 IF( jj==1 )EXIT 1349 END DO 1350 ijje=jj 1351 1352 nlej_crs=ijje-njmpp_crs+1 1353 1354 !---------------------------------------- 1355 nlcj_crs=nlej_crs+jprecj 1356 IF( iprocj == jpnj )THEN 1357 nlej_crs=jpj_crs ! cbr -1 ???????????????????? 1358 nlcj_crs=nlej_crs 1359 ENDIF 1316 ENDIF 1317 IF( njmpp==1 )njmpp_crs=1 1318 1319 !---------------------------------------- 1320 jj=jpjglo_crs 1321 DO WHILE( mje2_crs(jj) - njmpp + 1 .GT. nlcj ) 1322 jj=jj-1 1323 IF( jj==1 )EXIT 1324 END DO 1325 ijje=jj 1326 1327 nlej_crs=ijje-njmpp_crs+1 1328 1329 !---------------------------------------- 1330 nlcj_crs=nlej_crs+jprecj 1331 IF( iprocj == jpnj )THEN 1332 nlej_crs=jpj_crs 1333 nlcj_crs=nlej_crs 1334 ENDIF 1360 1335 1361 !---------------------------------------- 1362 DO jj = 1, jpj_crs 1363 mjg_crs(jj) = jj + njmpp_crs - 1 1364 ENDDO 1365 DO jj = 1, jpjglo_crs 1366 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 1367 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 1368 ENDDO 1369 1370 !---------------------------------------- 1371 DO jj = 1, nlej_crs 1372 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 1373 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 1374 nfacty(jj) = mje_crs(jj)-mje_crs(jj)+1 1375 ENDDO 1376 1377 IF( iprocj == jpnj )THEN 1378 mjs_crs(nlej_crs)=mjs_crs(nlej_crs-1) 1379 mje_crs(nlej_crs)=mje_crs(nlej_crs-1) 1380 ENDIF 1381 1382 !---------------------------------------- 1383 1384 CASE DEFAULT 1385 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 1386 END SELECT 1387 1388 !========================================================================== 1389 IF( nlci_crs .GT. jpi_crs .OR. nlei_crs .GT. jpi_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlei_crs,nlci_crs,jpi_crs; CALL FLUSH(narea+8000-1) 1390 IF( nlcj_crs .GT. jpj_crs .OR. nlej_crs .GT. jpj_crs )WRITE(narea+8000-1,*)"BUGDIM ",nlej_crs,nlcj_crs,jpj_crs; CALL FLUSH(narea+8000-1) 1391 !========================================================================== 1392 1393 nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0 1394 nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0 1395 1396 CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs) 1397 CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs) 1398 CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs) 1399 CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs) 1400 1401 DO jj = 1 ,jpnj 1402 DO ji = 1 , jpni 1403 jn=nfipproc(ji,jj)+1 1404 IF( jn .GE. 1 )THEN 1405 nfiimpp_crs(ji,jj)=nimppt_crs(jn) 1406 ELSE 1407 nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 1408 ENDIF 1409 ENDDO 1410 ENDDO 1336 !---------------------------------------- 1337 DO jj = 1, jpj_crs 1338 mjg_crs(jj) = jj + njmpp_crs - 1 1339 ENDDO 1340 DO jj = 1, jpjglo_crs 1341 mj0_crs(jj) = MAX( 1, MIN( jj - njmpp_crs + 1 , jpj_crs + 1 ) ) 1342 mj1_crs(jj) = MAX( 0, MIN( jj - njmpp_crs + 1 , jpj_crs ) ) 1343 ENDDO 1344 1345 !---------------------------------------- 1346 DO jj = 1, nlej_crs 1347 mjs_crs(jj) = mjs2_crs(mjg_crs(jj)) - njmpp + 1 1348 mje_crs(jj) = mje2_crs(mjg_crs(jj)) - njmpp + 1 1349 nfacty(jj) = mje_crs(jj)-mje_crs(jj)+1 1350 ENDDO 1351 1352 IF( iprocj == jpnj )THEN 1353 mjs_crs(nlej_crs)=mjs_crs(nlej_crs-1) 1354 mje_crs(nlej_crs)=mje_crs(nlej_crs-1) 1355 ENDIF 1356 1357 !---------------------------------------- 1358 1359 CASE DEFAULT 1360 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4 supported' 1361 END SELECT 1362 1363 !========================================================================== 1364 ! send local start and end indices to all procs 1365 !========================================================================== 1366 1367 nldit_crs(:)=0 ; nleit_crs(:)=0 ; nlcit_crs(:)=0 ; nimppt_crs(:)=0 1368 nldjt_crs(:)=0 ; nlejt_crs(:)=0 ; nlcjt_crs(:)=0 ; njmppt_crs(:)=0 1369 1370 CALL mppgatheri((/nlci_crs/),0,nlcit_crs) ; CALL mppgatheri((/nlcj_crs/),0,nlcjt_crs) 1371 CALL mppgatheri((/nldi_crs/),0,nldit_crs) ; CALL mppgatheri((/nldj_crs/),0,nldjt_crs) 1372 CALL mppgatheri((/nlei_crs/),0,nleit_crs) ; CALL mppgatheri((/nlej_crs/),0,nlejt_crs) 1373 CALL mppgatheri((/nimpp_crs/),0,nimppt_crs) ; CALL mppgatheri((/njmpp_crs/),0,njmppt_crs) 1374 1375 DO jj = 1 ,jpnj 1376 DO ji = 1 , jpni 1377 jn=nfipproc(ji,jj)+1 1378 IF( jn .GE. 1 )THEN 1379 nfiimpp_crs(ji,jj)=nimppt_crs(jn) 1380 ELSE 1381 nfiimpp_crs(ji,jj) = ANINT( REAL( (nfiimpp(ji,jj) + 1 ) / nn_factx, wp ) ) + 1 1382 ENDIF 1383 ENDDO 1384 ENDDO 1411 1385 1412 !nogather=T 1413 nfsloop_crs = 1 1414 nfeloop_crs = nlci_crs 1415 DO jn = 2,jpni-1 1416 IF(nfipproc(jn,jpnj) .eq. (narea - 1)) THEN 1417 IF (nfipproc(jn - 1 ,jpnj) .eq. -1) THEN 1418 nfsloop_crs = nldi_crs 1419 ENDIF 1420 IF (nfipproc(jn + 1,jpnj) .eq. -1) THEN 1421 nfeloop_crs = nlei_crs 1422 ENDIF 1423 ENDIF 1424 END DO 1425 1426 !WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs 1427 !WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 1428 !WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs 1429 !WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 1430 !============================================================================================== 1431 IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP 1432 1433 ! Save the parent grid information 1434 jpi_full = jpi 1435 jpj_full = jpj 1436 jpim1_full = jpim1 1437 jpjm1_full = jpjm1 1438 nperio_full = nperio 1439 1440 npolj_full = npolj 1441 jpiglo_full = jpiglo 1442 jpjglo_full = jpjglo 1443 1444 nlcj_full = nlcj 1445 nlci_full = nlci 1446 nldi_full = nldi 1447 nldj_full = nldj 1448 nlei_full = nlei 1449 nlej_full = nlej 1450 nimpp_full = nimpp 1451 njmpp_full = njmpp 1386 !nogather=T 1387 nfsloop_crs = 1 1388 nfeloop_crs = nlci_crs 1389 DO jn = 2,jpni-1 1390 IF( nfipproc(jn,jpnj) .eq. (narea - 1) )THEN 1391 IF (nfipproc(jn - 1 ,jpnj) .eq. -1 )THEN 1392 nfsloop_crs = nldi_crs 1393 ENDIF 1394 IF( nfipproc(jn + 1,jpnj) .eq. -1 )THEN 1395 nfeloop_crs = nlei_crs 1396 ENDIF 1397 ENDIF 1398 END DO 1399 1400 !WRITE(narea+8000-1,*)"loc crs jpi nldi,nlei,nlci ",jpi_crs, nldi_crs ,nlei_crs ,nlci_crs 1401 !WRITE(narea+8000-1,*)"glo crs jpi nldi,nlei ",jpi_crs, nldi_crs+nimpp_crs-1,nlei_crs+nimpp_crs-1 1402 !WRITE(narea+8000-1,*)"loc crs jpj nldj,nlej,nlcj ",jpj_crs, nldj_crs ,nlej_crs ,nlcj_crs 1403 !WRITE(narea+8000-1,*)"glo crs jpj nldj,nlej ",jpj_crs, nldj_crs+njmpp_crs-1,nlej_crs+njmpp_crs-1 1404 !============================================================================================== 1405 IF( jpizoom /= 1 .OR. jpjzoom /= 1) STOP !cbr mettre un ctlstp et ailleurs ( crsini ) 1406 1407 !========================================================================== 1408 ! Save the parent grid information 1409 !========================================================================== 1410 jpi_full = jpi 1411 jpj_full = jpj 1412 jpim1_full = jpim1 1413 jpjm1_full = jpjm1 1414 nperio_full = nperio 1415 npolj_full = npolj 1416 jpiglo_full = jpiglo 1417 jpjglo_full = jpjglo 1418 1419 nlcj_full = nlcj 1420 nlci_full = nlci 1421 nldi_full = nldi 1422 nldj_full = nldj 1423 nlei_full = nlei 1424 nlej_full = nlej 1425 nimpp_full = nimpp 1426 njmpp_full = njmpp 1452 1427 1453 nlcit_full(:) = nlcit(:)1454 nldit_full(:) = nldit(:)1455 nleit_full(:) = nleit(:)1456 nimppt_full(:) = nimppt(:)1457 nlcjt_full(:) = nlcjt(:)1458 nldjt_full(:) = nldjt(:)1459 nlejt_full(:) = nlejt(:)1460 njmppt_full(:) = njmppt(:)1428 nlcit_full(:) = nlcit(:) 1429 nldit_full(:) = nldit(:) 1430 nleit_full(:) = nleit(:) 1431 nimppt_full(:) = nimppt(:) 1432 nlcjt_full(:) = nlcjt(:) 1433 nldjt_full(:) = nldjt(:) 1434 nlejt_full(:) = nlejt(:) 1435 njmppt_full(:) = njmppt(:) 1461 1436 1462 nfsloop_full = nfsloop 1463 nfeloop_full = nfeloop 1464 1465 nfiimpp_full(:,:) = nfiimpp(:,:) 1466 1467 1468 CALL dom_grid_crs !swich de grille 1469 1470 1471 IF(lwp) THEN 1472 WRITE(numout,*) 1473 WRITE(numout,*) 'crs_init : coarse grid dimensions' 1474 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo 1475 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo 1476 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi 1477 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj 1478 WRITE(numout,*) 1479 WRITE(numout,*) ' nproc = ' , nproc 1480 WRITE(numout,*) ' nlci = ' , nlci 1481 WRITE(numout,*) ' nlcj = ' , nlcj 1482 WRITE(numout,*) ' nldi = ' , nldi 1483 WRITE(numout,*) ' nldj = ' , nldj 1484 WRITE(numout,*) ' nlei = ' , nlei 1485 WRITE(numout,*) ' nlej = ' , nlej 1486 WRITE(numout,*) ' nlei_full=' , nlei_full 1487 WRITE(numout,*) ' nldi_full=' , nldi_full 1488 WRITE(numout,*) ' nimpp = ' , nimpp 1489 WRITE(numout,*) ' njmpp = ' , njmpp 1490 WRITE(numout,*) ' njmpp_full = ', njmpp_full 1491 WRITE(numout,*) 1492 ENDIF 1437 nfsloop_full = nfsloop 1438 nfeloop_full = nfeloop 1439 1440 nfiimpp_full(:,:) = nfiimpp(:,:) 1441 1442 1443 !========================================================================== 1444 ! control 1445 !========================================================================== 1446 CALL dom_grid_crs !swich from mother grid to coarsened grid 1447 1448 IF(lwp) THEN 1449 WRITE(numout,*) 1450 WRITE(numout,*) 'crs_init : coarse grid dimensions' 1451 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo 1452 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo 1453 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi 1454 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj 1455 WRITE(numout,*) 1456 WRITE(numout,*) ' nproc = ' , nproc 1457 WRITE(numout,*) ' nlci = ' , nlci 1458 WRITE(numout,*) ' nlcj = ' , nlcj 1459 WRITE(numout,*) ' nldi = ' , nldi 1460 WRITE(numout,*) ' nldj = ' , nldj 1461 WRITE(numout,*) ' nlei = ' , nlei 1462 WRITE(numout,*) ' nlej = ' , nlej 1463 WRITE(numout,*) ' nlei_full=' , nlei_full 1464 WRITE(numout,*) ' nldi_full=' , nldi_full 1465 WRITE(numout,*) ' nimpp = ' , nimpp 1466 WRITE(numout,*) ' njmpp = ' , njmpp 1467 WRITE(numout,*) ' njmpp_full = ', njmpp_full 1468 WRITE(numout,*) 1469 ENDIF 1493 1470 1494 CALL dom_grid_glo1471 CALL dom_grid_glo ! switch from coarsened grid to mother grid 1495 1472 1496 mxbinctr = INT( nn_factx * 0.5 ) 1497 mybinctr = INT( nn_facty * 0.5 ) 1498 1499 nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor 1500 nresty = MOD( nn_facty, 2 ) 1501 1502 IF ( nrestx == 0 ) THEN 1503 mxbinctr = mxbinctr - 1 1504 ENDIF 1505 1506 IF ( nresty == 0 ) THEN 1507 mybinctr = mybinctr - 1 1508 IF ( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 1509 IF ( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 1510 1511 IF ( npolj == 3 ) npolj_crs = 5 1512 IF ( npolj == 5 ) npolj_crs = 3 1513 ENDIF 1473 nrestx = MOD( nn_factx, 2 ) ! check if even- or odd- numbered reduction factor 1474 nresty = MOD( nn_facty, 2 ) 1475 1476 IF( nresty == 0 )THEN 1477 IF( jperio == 3 .OR. jperio == 4 ) nperio_crs = jperio + 2 1478 IF( jperio == 5 .OR. jperio == 6 ) nperio_crs = jperio - 2 1479 IF( npolj == 3 ) npolj_crs = 5 1480 IF( npolj == 5 ) npolj_crs = 3 1481 ENDIF 1514 1482 1515 rfactxy = nn_factx * nn_facty1483 rfactxy = nn_factx * nn_facty 1516 1484 1517 ENDIF 1485 ENDIF ! lk_mpp 1518 1486 ! 1519 1487 nistr = mis_crs(2) ; niend = mis_crs(nlci_crs - 1) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsfld.F90
r7217 r7222 62 62 !! 2. At time of output, rescale [1] by dimension and time 63 63 !! to yield the spatial and temporal average. 64 !! See. diawri_dimg.h90, sbcmod.F9065 64 !! 66 65 !! ** Method : 67 66 !!---------------------------------------------------------------------- 68 67 !! 69 70 68 INTEGER, INTENT( in ) :: kt ! ocean time-step index 71 69 !! 72 INTEGER :: ji, jj, jk ! dummy loop indices 73 !! 70 INTEGER :: ji, jj, jk ! dummy loop indices 71 REAL(wp) :: z2dcrsu, z2dcrsv 72 REAL(wp) :: z1_2dt 74 73 REAL(wp), POINTER, DIMENSION(:,:,:) :: zfse3t, zfse3u, zfse3v, zfse3w ! 3D workspace for e3 75 74 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt, zs , ztmp 76 75 REAL(wp), POINTER, DIMENSION(:,:) :: z2d,z2d_crs 77 76 REAL(wp), POINTER, DIMENSION(:,:,:) :: zt_crs, zs_crs 78 REAL(wp):: z2dcrsu, z2dcrsv79 REAL(wp):: z1_2dt80 REAL(wp):: zmin,zmax81 INTEGER :: i,j,ijis,ijie,ijjs,ijje82 INTEGER :: iji,ijj83 INTEGER :: jl,jm,jn84 !!85 77 !!---------------------------------------------------------------------- 86 78 … … 216 208 CALL crs_dom_e3( e1v, e2v, zfse3v, p_sfc_2d_crs=e1v_crs , cd_type='V', p_mask=vmask, p_e3_crs=zs_crs, p_e3_max_crs=e3v_max_n_crs) 217 209 218 !cbr ??????????????????? faut pas mettre le profile 1d plutot ??????????? 219 WHERE(e3t_max_n_crs == 0._wp) e3t_max_n_crs=r_inf 220 WHERE(e3u_max_n_crs == 0._wp) e3u_max_n_crs=r_inf 221 WHERE(e3v_max_n_crs == 0._wp) e3v_max_n_crs=r_inf 222 WHERE(e3w_max_n_crs == 0._wp) e3w_max_n_crs=r_inf 210 DO jk = 1, jpk 211 DO ji = 1, jpi_crs 212 DO jj = 1, jpj_crs 213 IF( e3t_max_n_crs(ji,jj,jk) == 0._wp ) e3t_max_n_crs(ji,jj,jk) = e3t_1d(jk) 214 IF( e3w_max_n_crs(ji,jj,jk) == 0._wp ) e3w_max_n_crs(ji,jj,jk) = e3w_1d(jk) 215 IF( e3u_max_n_crs(ji,jj,jk) == 0._wp ) e3u_max_n_crs(ji,jj,jk) = e3t_1d(jk) 216 IF( e3v_max_n_crs(ji,jj,jk) == 0._wp ) e3v_max_n_crs(ji,jj,jk) = e3t_1d(jk) 217 ENDDO 218 ENDDO 219 ENDDO 223 220 224 221 ! depth 225 222 CALL crs_dom_ope( gdepw_n, 'MAX', 'T', tmask, gdept_n_crs, p_e3=zfse3t, psgn=1.0 ) 226 223 CALL crs_dom_ope( gdepw_n, 'MAX', 'W', tmask, gdepw_n_crs, p_e3=zfse3w, psgn=1.0 ) 224 DO jk = 1, jpk 225 DO ji = 1, jpi_crs 226 DO jj = 1, jpj_crs 227 IF( gdept_n_crs(ji,jj,jk) .LE. 0._wp ) gdept_n_crs(ji,jj,jk) = gdept_1d(jk) 228 IF( gdepw_n_crs(ji,jj,jk) .LE. 0._wp ) gdepw_n_crs(ji,jj,jk) = gdepw_1d(jk) 229 ENDDO 230 ENDDO 231 ENDDO 227 232 228 233 ! volume and facvol … … 257 262 ! U-velocity 258 263 CALL crs_dom_ope( un, 'SUM', 'U', umask, un_crs, p_e12=e2u, p_e3=zfse3u, p_surf_crs=e2e3u_msk, psgn=-1.0 ) 259 un_crs(:,:,:) = un_crs(:,:,:)*umask_crs(:,:,:) !cbr utile ??????????????????260 264 CALL iom_put( "uoce" , un_crs ) ! i-current 261 265 262 266 ! V-velocity 263 267 CALL crs_dom_ope( vn, 'SUM', 'V', vmask, vn_crs, p_e12=e1v, p_e3=zfse3v, p_surf_crs=e1e3v_msk, psgn=-1.0 ) 264 vn_crs(:,:,:) = vn_crs(:,:,:)*vmask_crs(:,:,:) !cbr utile ??????????????????265 268 CALL iom_put( "voce" , vn_crs ) ! i-current 266 269 … … 346 349 zfse3t(:,:,:) = 1._wp 347 350 zt(:,:,:) = tmask(:,:,:) 348 ssha(:,:) = ssha(:,:) * tmask(:,:,1) !cbr utile ??????????????????349 351 CALL crs_dom_ope( ssha , 'VOL', 'T', zt, ssha_crs , p_e12=e1e2t, p_e3=zfse3t , psgn=1.0 ) 350 352 … … 371 373 ENDDO 372 374 373 !zt_crs=ocean_volume_crs_t ; zs_crs=facvol_t after time !!! ça sert à quoi ??????????????????????????????????????????? 374 CALL crs_dom_facvol( tmask, 'T', e1t, e2t, zfse3t, zt_crs, zs_crs ) 375 376 #endif 377 378 #if defined key_vvl 375 #endif 376 377 #if defined key_vvl 378 379 379 z1_2dt = 1._wp / ( 2. * rdt ) ! set time step size (Euler/Leapfrog) 380 380 IF( neuler == 0 .AND. kt == nit000 ) z1_2dt = 1._wp / rdt 381 381 382 wn_crs(:,:,jpk) = 0._wp 382 383 DO jk = jpkm1, 1, -1 … … 399 400 400 401 #endif 401 CALL crs_lbc_lnk( wn_crs, 'W', 1.0 ) !!!!!!!pas utile, nan ??????????????????????402 wn_crs(:,:,:) = wn_crs(:,:,:) * tmask_crs(:,:,:) !!!!!!!pas utile, nan ??????????????????????403 404 402 CALL iom_put( "woce", wn_crs ) ! vertical velocity 405 403 404 !--------------------------------------------------------------------------------------------------- 406 405 ! free memory 407 406 CALL wrk_dealloc( jpi, jpj, jpk, zfse3t, zfse3w ) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/TOP_SRC/trcstp.F90
r6772 r7222 132 132 INTEGER :: jn 133 133 134 IF( kt == nit trc000 ) THEN134 IF( kt == nit000 ) THEN 135 135 IF( ln_cpl ) THEN 136 136 rdt_sampl = 86400. / ncpl_qsr_freq
Note: See TracChangeset
for help on using the changeset viewer.