Changeset 3823
- Timestamp:
- 2013-02-28T14:31:33+01:00 (11 years ago)
- Location:
- branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS
- Files:
-
- 5 edited
-
crs.F90 (modified) (33 diffs)
-
crs_dom.F90 (modified) (12 diffs)
-
crs_iom.F90 (modified) (1 diff)
-
crsdomwri.F90 (modified) (8 diffs)
-
crsini.F90 (modified) (12 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs.F90
r3790 r3823 32 32 33 33 USE dom_oce ! ocean space and time domain and to get jperio 34 !USE wrk_nemo ! work arrays34 USE wrk_nemo ! work arrays 35 35 USE crs_dom ! domain for coarse grid 36 36 USE in_out_manager … … 88 88 ! Initialize 89 89 DO jk = 1, jpk 90 DO ji = 2, jpi_crsm190 DO ji = 2, nlei_crs - 1 91 91 ijie = mie_crs(ji) 92 92 ijis = mis_crs(ji) 93 93 94 DO jj = 2, jpj_crsm194 DO jj = njstart, njend 95 95 ijje = mje_crs(jj) 96 96 ijjs = mjs_crs(jj) … … 163 163 INTEGER :: ijie,ijis,ijje,ijjs,ijpk 164 164 165 WRITE(numout,*) 'crsfun_coordinates. begin' 166 165 167 166 !! Initialize output fields 168 167 p_cgphi(:,:) = 0.e0 … … 170 169 171 170 172 DO ji = 2, jpi_crsm1171 DO ji = 2, nlei_crs - 1 173 172 174 173 IF ( cd_type == 'T' .OR. cd_type == 'V' ) ijis = mis_crs(ji) + mxbinctr 175 174 IF ( cd_type == 'U' .OR. cd_type == 'F' ) ijis = mie_crs(ji) 176 175 177 DO jj = 2, jpj_crsm1176 DO jj = njstart, njend 178 177 179 178 IF ( cd_type == 'T' .OR. cd_type == 'U' ) ijjs = mjs_crs(jj) + mybinctr … … 187 186 ENDDO 188 187 189 WRITE(numout,*) 'crsfun_coordinates. completed set new coords'190 188 191 189 ! Retroactively add back the boundary halo cells. 192 190 193 191 IF( nperio /= 0 ) THEN 194 WRITE(numout,*) 'crsfun_coordinates. call crs_lbc_lnk'195 196 192 CALL crs_lbc_lnk( cd_type,1.0,p_cgphi ) 197 193 CALL crs_lbc_lnk( cd_type,1.0,p_cglam ) … … 209 205 ENDIF 210 206 211 WRITE(numout,*) 'crsfun_coordinates. fill out edges'212 213 207 ! Fill up jrow=1 which is zeroed out or not handled by lbc_lnk and lbc_nfd 214 DO ji = 2, jpi_crsm1208 DO ji = 2, nlei_crs - 1 215 209 216 210 IF ( cd_type == 'T' .OR. cd_type == 'V' ) ijis = mis_crs(ji) + mxbinctr … … 235 229 !cc p_cglam(1,jpj_crs) = p_cglam(jpi_crs,jpj_crsm1) 236 230 !cc ENDIF 237 238 WRITE(numout,*) 'crsfun_coordinates. done'239 240 231 241 232 END SUBROUTINE crsfun_coordinates … … 300 291 INTEGER :: ijie,ijis,ijje,ijjs,ijpk 301 292 REAL(wp) :: zdAm ! masked face area 302 REAL(wp), DIMENSION(:,:), ALLOCATABLE:: ze1, ze2303 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE:: ze3304 REAL(wp), DIMENSION(:,:), ALLOCATABLE:: zcfield2d_1, zcfield2d_2305 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE:: zcfield3d_1, zcfield3d_2293 REAL(wp), DIMENSION(:,:), POINTER :: ze1, ze2 294 REAL(wp), DIMENSION(:,:,:), POINTER :: ze3 295 REAL(wp), DIMENSION(:,:), POINTER :: zcfield2d_1, zcfield2d_2 296 REAL(wp), DIMENSION(:,:,:), POINTER :: zcfield3d_1, zcfield3d_2 306 297 307 298 !!---------------------------------------------------------------- … … 309 300 310 301 ! Arrays, scalars initialization 311 ALLOCATE( ze1(jpi,jpj) , ze2(jpi,jpj))312 ALLOCATE( ze3(jpi,jpj,jpk))313 ALLOCATE( zcfield2d_1(jpi_crs,jpj_crs) , zcfield2d_2(jpi_crs,jpj_crs))314 ALLOCATE( zcfield3d_1(jpi_crs,jpj_crs,jpk), zcfield3d_2(jpi_crs,jpj_crs,jpk))302 CALL wrk_alloc(jpi , jpj , ze1, ze2 ) 303 CALL wrk_alloc(jpi , jpj , jpk, ze3 ) 304 CALL wrk_alloc(jpi_crs, jpj_crs, zcfield2d_1, zcfield2d_2 ) 305 CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d_1, zcfield3d_2 ) 315 306 316 307 ze1(:,:) = 1.0 … … 340 331 zcfield2d_1(:,:) = 0.0 ; zcfield2d_2(:,:) = 0.0 341 332 ! DO ji = 2, jpi_crsm1 342 DO ji = 1, jpi_crs333 DO ji = 2, nlei_crs - 1 343 334 ijie = mie_crs(ji) 344 335 ijis = mis_crs(ji) 345 336 346 337 ! DO jj = 1, jpj_crsm1 347 DO jj = 1, jpj_crs338 DO jj = njstart, njend 348 339 ijje = mje_crs(jj) 349 340 ijjs = mjs_crs(jj) … … 722 713 ENDIF 723 714 724 DEALLOCATE( ze1, ze2 )725 DEALLOCATE(ze3 )726 DEALLOCATE( zcfield2d_1 ,zcfield2d_2 )727 DEALLOCATE( zcfield3d_1 ,zcfield3d_2 )715 CALL wrk_dealloc(jpi , jpj , ze1, ze2 ) 716 CALL wrk_dealloc(jpi , jpj , jpk, ze3 ) 717 CALL wrk_dealloc(jpi_crs, jpj_crs, zcfield2d_1, zcfield2d_2 ) 718 CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d_1, zcfield3d_2 ) 728 719 729 720 END SUBROUTINE crsfun_wgt … … 768 759 INTEGER :: ji, jj, jk , jii, jjj ! dummy loop indices 769 760 INTEGER :: ijie, ijis, ijje, ijjs 770 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE:: zsurfcrs761 REAL(wp), DIMENSION(:,:,:), POINTER :: zsurfcrs 771 762 772 763 !!---------------------------------------------------------------- 773 764 774 ALLOCATE( zsurfcrs(jpi_crs,jpj_crs,jpk))765 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 775 766 zsurfcrs(:,:,:) = 1.0 776 767 IF ( PRESENT(p_surf_crs) ) THEN … … 780 771 DO jk = 1, jpk 781 772 782 DO ji = 2, jpi_crsm1773 DO ji = 2, nlei_crs - 1 783 774 ijie = mie_crs(ji) 784 775 ijis = mis_crs(ji) 785 776 786 DO jj = 2, jpj_crsm1777 DO jj = njstart, njend 787 778 ijje = mje_crs(jj) 788 779 ijjs = mjs_crs(jj) … … 821 812 ENDIF 822 813 823 DEALLOCATE(zsurfcrs )814 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zsurfcrs ) 824 815 825 816 END SUBROUTINE crsfun_UV … … 895 886 INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 896 887 INTEGER, DIMENSION(3) :: idims 897 REAL(wp), ALLOCATABLE, DIMENSION(:,:) :: ze1e2, zpfield2d, zcfield2d898 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3, zpfield3d, zcfield3d, zcmask, zpmask899 REAL(wp) 888 REAL(wp), POINTER, DIMENSION(:,:) :: ze1e2, zpfield2d, zcfield2d 889 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze3, zpfield3d, zcfield3d, zcmask, zpmask 890 REAL(wp) :: zdAm, zsgn 900 891 !!---------------------------------------------------------------- 901 892 ! Initialize 902 893 903 ALLOCATE( ze3(jpi,jpj,jpk) , zpfield3d(jpi,jpj,jpk) , zpmask(jpi,jpj,jpk) ) 904 ALLOCATE( ze1e2(jpi,jpj) , zpfield2d(jpi,jpj) ) 905 ALLOCATE( zcfield2d(jpi_crs,jpj_crs) ) 906 ALLOCATE( zcfield3d(jpi_crs,jpj_crs,jpk) , zcmask(jpi_crs,jpj_crs,jpk) ) 894 CALL wrk_alloc(jpi , jpj , ze1e2, zpfield2d ) 895 CALL wrk_alloc(jpi , jpj , jpk, ze3 , zpfield3d, zpmask ) 896 CALL wrk_alloc(jpi_crs, jpj_crs, zcfield2d ) 897 CALL wrk_alloc(jpi_crs, jpj_crs, jpk, zcfield3d, zcmask ) 898 907 899 908 900 ! Arrays, scalars initialization … … 998 990 zcfield2d(:,:) = 0.0 999 991 1000 DO ji = 2, jpi_crsm1992 DO ji = 2, nlei_crs - 1 1001 993 ijie = mie_crs(ji) 1002 994 ijis = mis_crs(ji) 1003 995 1004 ! DO jj = 2, jpj_crsm11005 DO jj = 1, jpj_crsm1996 DO jj = njstart, njend 997 ! DO jj = 1, jpj_crsm1 1006 998 ijje = mje_crs(jj) 1007 999 ijjs = mjs_crs(jj) … … 1103 1095 ENDIF 1104 1096 1105 DEALLOCATE( ze3 , zpfield3d , zpmask)1106 DEALLOCATE( ze1e2 , zpfield2d)1107 DEALLOCATE(zcfield2d )1108 DEALLOCATE( zcfield3d ,zcmask )1097 CALL wrk_dealloc(jpi , jpj , ze1e2, zpfield2d ) 1098 CALL wrk_dealloc(jpi , jpj , jpk, ze3 , zpfield3d, zpmask ) 1099 CALL wrk_dealloc(jpi_crs, jpj_crs, zcfield2d ) 1100 CALL wrk_dealloc(jpi_crs, jpj_crs, jpk, zcfield3d, zcmask ) 1109 1101 1110 1102 … … 1163 1155 !! 1164 1156 !! Arguments 1165 CHARACTER(len=1), 1166 REAL(wp), DIMENSION(jpi,jpj,jpk), 1167 REAL(wp), DIMENSION(jpi,jpj,jpk), OPTIONAL,INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid1168 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), OPTIONAL, INTENT(out):: p_e3_crs ! Coarse grid box east or north face quantity1157 CHARACTER(len=1), INTENT(in) :: cd_type ! grid type T, W ( U, V, F) 1158 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_mask ! Parent grid T mask 1159 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in) :: p_e3 ! 3D tracer T or W on parent grid 1160 REAL(wp), DIMENSION(jpi_crs,jpj_crs,jpk), INTENT(inout):: p_e3_crs ! Coarse grid box east or north face quantity 1169 1161 1170 1162 !! Local variables 1171 1163 INTEGER :: ji, jj, jk ! dummy loop indices 1172 INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 1173 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze3, ze3_crs, zpmask 1164 INTEGER :: ijie,ijis,ijje,ijjs,jii,jjj 1174 1165 !!---------------------------------------------------------------- 1175 1166 ! Initialize 1176 1177 ALLOCATE( ze3(jpi,jpj,jpk), zpmask(jpi,jpj,jpk) )1178 ALLOCATE( ze3_crs(jpi_crs,jpj_crs,jpk) )1179 1180 ! Arrays, scalars initialization1181 ze3(:,:,:) = p_e3(:,:,:)1182 ze3_crs(:,:,:) = 0.01183 zpmask(:,:,:) = p_mask(:,:,:)1184 ijpk = jpk1185 1167 1186 1168 SELECT CASE ( cd_type ) … … 1188 1170 CASE ('T') 1189 1171 1190 DO jk = 1 , ijpk1172 DO jk = 1 , jpk 1191 1173 1192 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1174 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1193 1175 ijie = mie_crs(ji) 1194 1176 ijis = mis_crs(ji) 1195 1177 1196 DO jj = 1, jpj_crs! jj = jpj_crs definit par pivot T1178 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1197 1179 ijje = mje_crs(jj) 1198 1180 ijjs = mjs_crs(jj) 1199 1181 1200 1182 DO jii = ijis, ijie 1201 1183 DO jjj = ijjs, ijje 1202 ze3_crs(ji,jj,jk) = max( ze3_crs(ji,jj,jk), ze3(jii,jjj,jk) * zpmask(jii,jjj,jk) )1184 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk) ) 1203 1185 ENDDO 1204 1186 ENDDO … … 1206 1188 ENDDO 1207 1189 ENDDO 1208 1190 1209 1191 CASE ('W') 1210 1192 1211 DO jk = 2 , ijpk1193 DO jk = 2 , jpk 1212 1194 1213 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1195 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1214 1196 ijie = mie_crs(ji) 1215 1197 ijis = mis_crs(ji) 1216 1198 1217 DO jj = 1, jpj_crs! jj = jpj_crs definit par pivot T1199 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1218 1200 ijje = mje_crs(jj) 1219 1201 ijjs = mjs_crs(jj) … … 1221 1203 DO jii = ijis, ijie 1222 1204 DO jjj = ijjs, ijje 1223 ze3_crs(ji,jj,jk) = max( ze3_crs(ji,jj,jk), ze3(jii,jjj,jk) * zpmask(jii,jjj,jk-1) )1205 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk-1) ) 1224 1206 ENDDO 1225 1207 ENDDO … … 1230 1212 jk = 1 ! cas particulier car zpmask(jii,jjj,0) n'existe pas 1231 1213 1232 DO ji = 1, jpi_crs1214 DO ji = 2, nlei_crs - 1 1233 1215 ijie = mie_crs(ji) 1234 1216 ijis = mis_crs(ji) 1235 1217 1236 DO jj = 1, jpj_crs1218 DO jj = njstart, njend 1237 1219 ijje = mje_crs(jj) 1238 1220 ijjs = mjs_crs(jj) … … 1240 1222 DO jii = ijis, ijie 1241 1223 DO jjj = ijjs, ijje 1242 ze3_crs(ji,jj,jk) = max( ze3_crs(ji,jj,jk), ze3(jii,jjj,jk) * zpmask(jii,jjj,jk) )1224 p_e3_crs(ji,jj,jk) = max( p_e3_crs(ji,jj,jk), p_e3(jii,jjj,jk) * p_mask(jii,jjj,jk) ) 1243 1225 ENDDO 1244 1226 ENDDO … … 1247 1229 1248 1230 END SELECT 1249 1250 p_e3_crs(:,:,:) = ze3_crs(:,:,:) 1251 1231 1252 1232 CALL crs_lbc_lnk( cd_type, 1.0, pt3d1=p_e3_crs ) 1253 1233 1254 1234 ! lbcnlk met la ligne jpj = 1 a 0 donc il faut la remettre en ne pas oubliant le cyclique est-ouest 1255 1235 1256 p_e3_crs( : ,1,:) = ze3_crs( : ,1,:) 1257 p_e3_crs( 1 ,1,:) = ze3_crs(jpi_crsm1,1,:) 1258 p_e3_crs(jpi_crs,1,:) = ze3_crs( 2 ,1,:) 1259 1260 1261 DEALLOCATE( ze3 , zpmask ) 1262 DEALLOCATE( ze3_crs ) 1236 p_e3_crs( 1 ,1,:) = p_e3_crs(jpi_crsm1,1,:) 1237 p_e3_crs(jpi_crs,1,:) = p_e3_crs( 2 ,1,:) 1238 1239 WRITE(numout,*) 'crs_e3_max : end of subroutine ' 1263 1240 1264 1241 … … 1326 1303 INTEGER :: ji, jj, jk ! dummy loop indices 1327 1304 INTEGER :: ijie,ijis,ijje,ijjs,ijpk,jii,jjj 1328 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: ze1, ze2, ze31329 REAL(wp), ALLOCATABLE, DIMENSION(:,:,:) :: zsurf_crs, zsurf_msk_crs, zpmask1305 REAL(wp), POINTER, DIMENSION(:,:,:) :: ze1, ze2, ze3 1306 REAL(wp), POINTER, DIMENSION(:,:,:) :: zsurf_crs, zsurf_msk_crs, zpmask 1330 1307 !!---------------------------------------------------------------- 1331 1308 ! Initialize 1332 1309 1333 ALLOCATE( ze1(jpi,jpj,jpk), ze2(jpi,jpj,jpk), ze3(jpi,jpj,jpk), zpmask(jpi,jpj,jpk))1334 ALLOCATE( zsurf_crs(jpi_crs,jpj_crs,jpk), zsurf_msk_crs(jpi_crs,jpj_crs,jpk))1310 CALL wrk_alloc( jpi , jpj , jpk, ze1, ze2, ze3, zpmask ) 1311 CALL wrk_alloc( jpi_crs, jpj_crs, jpk, zsurf_crs, zsurf_msk_crs ) 1335 1312 1336 1313 ! Arrays, scalars initialization … … 1349 1326 DO jk = 2 , ijpk 1350 1327 1351 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1328 DO ji = 2, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1352 1329 ijie = mie_crs(ji) 1353 1330 ijis = mis_crs(ji) … … 1366 1343 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1367 1344 1368 DO jj = 2, jpj_crs! jj = jpj_crs definit par pivot T1345 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1369 1346 ijje = mje_crs(jj) 1370 1347 ijjs = mjs_crs(jj) … … 1383 1360 jk = 1 !cas particulier ou on est en surface 1384 1361 1385 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1362 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1386 1363 ijie = mie_crs(ji) 1387 1364 ijis = mis_crs(ji) 1365 IF( njstart == 1 ) THEN 1388 1366 jj = 1 1389 1367 ijje = mje_crs(jj) … … 1398 1376 ENDDO 1399 1377 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1400 DO jj = 2, jpj_crs ! jj = jpj_crs definit par pivot T 1378 ENDIF 1379 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1401 1380 ijje = mje_crs(jj) 1402 1381 ijjs = mjs_crs(jj) … … 1415 1394 DO jk = 1 , ijpk 1416 1395 1417 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1396 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1418 1397 ijie = mie_crs(ji) 1419 1398 ijis = mis_crs(ji) 1399 IF( njstart == 1 ) THEN 1420 1400 jj = 1 1421 1401 ijje = mje_crs(jj) … … 1430 1410 1431 1411 zsurf_crs(ji,jj,jk) = zsurf_crs(ji,jj,jk) * 3 1432 1433 DO jj = 2, jpj_crs ! jj = jpj_crs definit par pivot T 1412 ENDIF 1413 1414 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1434 1415 ijje = mje_crs(jj) 1435 1416 ijjs = mjs_crs(jj) … … 1450 1431 DO jk = 1 , ijpk 1451 1432 1452 DO ji = 1, jpi_crs! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T1433 DO ji = 1, nlei_crs - 1 ! ji = 1 et jpi_crs definit par cyclique est-ouest et pivot T 1453 1434 ijie = mie_crs(ji) 1454 1435 ijis = mis_crs(ji) 1455 1436 1456 DO jj = 1, jpj_crs! jj = jpj_crs definit par pivot T1437 DO jj = njstart, njend ! jj = jpj_crs definit par pivot T 1457 1438 ijje = mje_crs(jj) 1458 1439 ijjs = mjs_crs(jj) … … 1485 1466 surf_msk_crs(jpi_crs,1,:) = zsurf_msk_crs( 2 ,1,:) 1486 1467 1487 DEALLOCATE( ze3 , ze2, ze1, zpmask )1488 DEALLOCATE( zsurf_msk_crs, zsurf_crs)1468 CALL wrk_dealloc( jpi , jpj , jpk, ze1, ze2, ze3, zpmask ) 1469 CALL wrk_dealloc( jpi_crs, jpj_crs, jpk, zsurf_crs, zsurf_msk_crs ) 1489 1470 1490 1471 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs_dom.F90
r3809 r3823 8 8 !!---------------------------------------------------------------------- 9 9 USE par_oce 10 USE dom_oce, ONLY: nperio, narea, npolj, nlci, nlcj, nldi, nldj, nlei, nlej 10 USE dom_oce 11 USE in_out_manager 11 12 12 13 IMPLICIT NONE … … 14 15 15 16 16 17 PUBLIC crs_dom_alloc ! Called from crsini.F90 17 18 PUBLIC dom_grid_glo 18 PUBLIC dom_grid_crs 19 PUBLIC dom_grid_crs 19 20 20 21 ! Domain variables … … 26 27 jpj_full !: 2nd dimension of local parent grid domain 27 28 29 INTEGER :: nistart, njstart 30 INTEGER :: niend , njend 31 28 32 INTEGER :: jpi_crsm1, jpj_crsm1 !: loop indices 29 33 INTEGER :: jpiglo_crsm1, jpjglo_crsm1 !: loop indices … … 31 35 INTEGER :: npolj_full, npolj_crs !: north fold mark 32 36 INTEGER :: jpiglo_full, jpjglo_full !: jpiglo / jpjglo 33 INTEGER :: npiglo, npjglo !: jpjglo37 INTEGER :: npiglo, npjglo !: jpjglo 34 38 INTEGER :: nlci_full, nlcj_full !: i-, j-dimension of local or sub domain on parent grid 35 39 INTEGER :: nldi_full, nldj_full !: starting indices of internal sub-domain on parent grid … … 43 47 INTEGER :: nimpp_full, njmpp_full !: global position of point (1,1) of subdomain on parent grid 44 48 INTEGER :: nimpp_crs, njmpp_crs !: set to 1,1 for now . Valid only for monoproc 45 46 47 INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs, mjs_crs, mje_crs 48 ! starting and ending indices of parent subset 49 INTEGER :: nreci_full, nrecj_full 50 INTEGER :: nreci_crs, nrecj_crs 51 !cc 52 INTEGER :: noea_full, nowe_full !: index of the local neighboring processors in 53 INTEGER :: noso_full, nono_full !: east, west, south and north directions 54 INTEGER :: npne_full, npnw_full !: index of north east and north west processor 55 INTEGER :: npse_full, npsw_full !: index of south east and south west processor 56 INTEGER :: nbne_full, nbnw_full !: logical of north east & north west processor 57 INTEGER :: nbse_full, nbsw_full !: logical of south east & south west processor 58 INTEGER :: nidom_full !: ??? 59 INTEGER :: nproc_full !:number for local processor 60 INTEGER :: nbondi_full, nbondj_full !: mark of i- and j-direction local boundaries 61 INTEGER :: noea_crs, nowe_crs !: index of the local neighboring processors in 62 INTEGER :: noso_crs, nono_crs !: east, west, south and north directions 63 INTEGER :: npne_crs, npnw_crs !: index of north east and north west processor 64 INTEGER :: npse_crs, npsw_crs !: index of south east and south west processor 65 INTEGER :: nbne_crs, nbnw_crs !: logical of north east & north west processor 66 INTEGER :: nbse_crs, nbsw_crs !: logical of south east & south west processor 67 INTEGER :: nidom_crs !: ??? 68 INTEGER :: nproc_crs !:number for local processor 69 INTEGER :: nbondi_crs, nbondj_crs !: mark of i- and j-direction local boundaries 70 71 72 INTEGER, DIMENSION(:), ALLOCATABLE :: mis_crs, mie_crs ! starting and ending i-indices of parent subset 73 INTEGER, DIMENSION(:), ALLOCATABLE :: mjs_crs, mje_crs ! starting and ending j-indices of parent subset 49 74 INTEGER :: mxbinctr, mybinctr ! central point in grid box 50 75 … … 135 160 !!------------------------------------------------------------------- 136 161 !! Local variables 137 INTEGER, DIMENSION(1 5) :: ierr162 INTEGER, DIMENSION(17) :: ierr 138 163 139 164 ierr(:) = 0 … … 206 231 ALLOCATE( nmln_crs(jpi_crs,jpj_crs) , hmld_crs(jpi_crs,jpj_crs) , & 207 232 & hmlp_crs(jpi_crs,jpj_crs) , hmlpt_crs(jpi_crs,jpj_crs) , STAT=ierr(14) ) 208 209 233 210 234 crs_dom_alloc = MAXVAL(ierr) 211 235 … … 227 251 228 252 npolj = npolj_full 229 jpnij = jpnij_full230 narea = narea_full231 253 jpiglo = jpiglo_full 232 254 jpjglo = jpjglo_full 233 255 256 nlci = nlci_full 234 257 nlcj = nlcj_full 235 nlci = nlci_full236 258 nldi = nldi_full 259 nldj = nldj_full 237 260 nlei = nlei_full 238 261 nlej = nlej_full 239 240 nldj = nldj_full 262 nimpp = nimpp_full 263 njmpp = njmpp_full 264 241 265 242 266 END SUBROUTINE dom_grid_glo … … 257 281 258 282 npolj_full = npolj 259 jpnij_full = jpnij260 narea_full = narea261 283 jpiglo_full = jpiglo 262 284 jpjglo_full = jpjglo … … 265 287 nlci_full = nlci 266 288 nldi_full = nldi 289 nldj_full = nldj 267 290 nlei_full = nlei 268 291 nlej_full = nlej 269 nldj_full = nldj 270 292 nimpp_full = nimpp 293 njmpp_full = njmpp 294 ! 271 295 ! Switch to coarse grid domain 272 296 jpi = jpi_crs … … 277 301 278 302 npolj = npolj_crs 279 jpnij = jpnij_crs280 narea = narea_crs281 303 jpiglo = jpiglo_crs 282 304 jpjglo = jpjglo_crs 305 283 306 284 307 nlci = nlci_crs … … 287 310 nlei = nlei_crs 288 311 nlej = nlej_crs 289 290 312 nldj = nldj_crs 291 313 nimpp = nimpp_crs 314 njmpp = njmpp_crs 315 ! 292 316 END SUBROUTINE dom_grid_crs 317 293 318 !!====================================================================== 294 319 -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crs_iom.F90
r3778 r3823 88 88 ENDIF 89 89 IF ( PRESENT(kdom) ) idomcrs = kdom 90 91 WRITE(numout,*) 'crs_iom_open. kiomid=', kiomid92 90 93 91 CALL iom_open( cdname, kiomid, ldwrt, idomcrs, kiolib ) -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsdomwri.F90
r3778 r3823 69 69 IF( nn_timing == 1 ) CALL timing_start('crs_dom_wri') 70 70 ! 71 ALLOCATE( zprt (jpi_crs,jpj_crs), zprw(jpi_crs,jpj_crs) )72 ALLOCATE( zdepu(jpi_crs,jpj_crs,jpk) 73 ALLOCATE( ze3tp(jpi_crs,jpj_crs) , ze3wp(jpi_crs,jpj_crs) )71 ALLOCATE( zprt (jpi_crs,jpj_crs) , zprw(jpi_crs,jpj_crs) ) 72 ALLOCATE( zdepu(jpi_crs,jpj_crs,jpk), zdepv(jpi_crs,jpj_crs,jpk) ) 73 ALLOCATE( ze3tp(jpi_crs,jpj_crs) , ze3wp(jpi_crs,jpj_crs) ) 74 74 75 75 ze3tp(:,:) = 0.0 … … 118 118 !======================================================== 119 119 ! ! masks (inum2) 120 CALL crs_iom_rstput( 0, 0, inum2, 'tmask _crs', pv_r3d=tmask_crs, ktype = jp_i1 ) ! ! land-sea mask121 CALL crs_iom_rstput( 0, 0, inum2, 'umask _crs', pv_r3d=umask_crs, ktype = jp_i1 )122 CALL crs_iom_rstput( 0, 0, inum2, 'vmask _crs', pv_r3d=vmask_crs, ktype = jp_i1 )123 CALL crs_iom_rstput( 0, 0, inum2, 'fmask _crs', pv_r3d=fmask_crs, ktype = jp_i1 )120 CALL crs_iom_rstput( 0, 0, inum2, 'tmask', pv_r3d=tmask_crs, ktype = jp_i1 ) ! ! land-sea mask 121 CALL crs_iom_rstput( 0, 0, inum2, 'umask', pv_r3d=umask_crs, ktype = jp_i1 ) 122 CALL crs_iom_rstput( 0, 0, inum2, 'vmask', pv_r3d=vmask_crs, ktype = jp_i1 ) 123 CALL crs_iom_rstput( 0, 0, inum2, 'fmask', pv_r3d=fmask_crs, ktype = jp_i1 ) 124 124 125 125 CALL crs_dom_uniq( zprw, 'T' ) 126 126 tmask_i_crs(:,:) = tmask_crs(:,:,1) * zprw ! ! unique point mask 127 CALL crs_iom_rstput( 0, 0, inum2, 'tmaskutil _crs', pv_r2d=tmask_i_crs, ktype = jp_i1 )127 CALL crs_iom_rstput( 0, 0, inum2, 'tmaskutil', pv_r2d=tmask_i_crs, ktype = jp_i1 ) 128 128 CALL crs_dom_uniq( zprw, 'U' ) 129 129 zprt = umask_crs(:,:,1) * zprw 130 CALL crs_iom_rstput( 0, 0, inum2, 'umaskutil _crs', pv_r2d=zprt, ktype = jp_i1 )130 CALL crs_iom_rstput( 0, 0, inum2, 'umaskutil', pv_r2d=zprt, ktype = jp_i1 ) 131 131 CALL crs_dom_uniq( zprw, 'V' ) 132 132 zprt = vmask_crs(:,:,1) * zprw 133 CALL crs_iom_rstput( 0, 0, inum2, 'vmaskutil _crs', pv_r2d=zprt, ktype = jp_i1 )133 CALL crs_iom_rstput( 0, 0, inum2, 'vmaskutil', pv_r2d=zprt, ktype = jp_i1 ) 134 134 CALL crs_dom_uniq( zprw, 'F' ) 135 135 zprt = fmask_crs(:,:,1) * zprw 136 CALL crs_iom_rstput( 0, 0, inum2, 'fmaskutil _crs', pv_r2d=zprt, ktype = jp_i1 )136 CALL crs_iom_rstput( 0, 0, inum2, 'fmaskutil', pv_r2d=zprt, ktype = jp_i1 ) 137 137 !======================================================== 138 138 ! ! horizontal mesh (inum3) … … 157 157 CALL crs_iom_rstput( 0, 0, inum3, 'e2f', pv_r2d=e2f_crs, ktype = jp_r8 ) 158 158 159 CALL crs_iom_rstput( 0, 0, inum3, 'ff _crs', pv_r2d=ff_crs, ktype = jp_r8 ) ! ! coriolis factor159 CALL crs_iom_rstput( 0, 0, inum3, 'ff', pv_r2d=ff_crs, ktype = jp_r8 ) ! ! coriolis factor 160 160 161 161 !======================================================== … … 184 184 CALL crs_lbc_lnk( 'W', 1.0, ze3wp ) 185 185 186 CALL crs_iom_rstput( 0, 0, inum4, 'e3t_ps _crs', pv_r2d=ze3tp )187 CALL crs_iom_rstput( 0, 0, inum4, 'e3w_ps _crs', pv_r2d=ze3wp )186 CALL crs_iom_rstput( 0, 0, inum4, 'e3t_ps', pv_r2d=ze3tp ) 187 CALL crs_iom_rstput( 0, 0, inum4, 'e3w_ps', pv_r2d=ze3wp ) 188 188 ENDIF 189 189 190 190 IF ( nn_msh_crs <= 3 ) THEN 191 CALL crs_iom_rstput( 0, 0, inum4, 'gdept _crs', pv_r3d=gdept_crs, ktype = jp_r4 )191 CALL crs_iom_rstput( 0, 0, inum4, 'gdept', pv_r3d=gdept_crs, ktype = jp_r4 ) 192 192 DO jk = 1,jpk 193 193 DO jj = 1, jpj_crsm1 … … 200 200 201 201 CALL crs_lbc_lnk( 'U', 1.,pt3d1=zdepu ) ; CALL crs_lbc_lnk( 'V', 1.,pt3d1=zdepv ) 202 CALL crs_iom_rstput( 0, 0, inum4, 'gdepu _crs', pv_r3d=zdepu, ktype = jp_r4 )203 CALL crs_iom_rstput( 0, 0, inum4, 'gdepv _crs', pv_r3d=zdepv, ktype = jp_r4 )204 CALL crs_iom_rstput( 0, 0, inum4, 'gdepw _crs', pv_r3d=gdepw_crs, ktype = jp_r4 )202 CALL crs_iom_rstput( 0, 0, inum4, 'gdepu', pv_r3d=zdepu, ktype = jp_r4 ) 203 CALL crs_iom_rstput( 0, 0, inum4, 'gdepv', pv_r3d=zdepv, ktype = jp_r4 ) 204 CALL crs_iom_rstput( 0, 0, inum4, 'gdepw', pv_r3d=gdepw_crs, ktype = jp_r4 ) 205 205 ELSE 206 206 DO jj = 1,jpj_crs … … 214 214 ENDIF 215 215 216 CALL iom_rstput( 0, 0, inum4, 'gdept_0 _crs', gdept_0 ) ! ! reference z-coord.217 CALL iom_rstput( 0, 0, inum4, 'gdepw_0 _crs', gdepw_0 )218 CALL iom_rstput( 0, 0, inum4, 'e3t_0 _crs' , e3t_0 )219 CALL iom_rstput( 0, 0, inum4, 'e3w_0 _crs' , e3w_0 )220 221 CALL crs_iom_rstput( 0, 0, inum4, 'ocean_volume_ crs_t', pv_r3d=ocean_volume_crs_t )216 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 ) ! ! reference z-coord. 217 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 ) 218 CALL iom_rstput( 0, 0, inum4, 'e3t_0' , e3t_0 ) 219 CALL iom_rstput( 0, 0, inum4, 'e3w_0' , e3w_0 ) 220 221 CALL crs_iom_rstput( 0, 0, inum4, 'ocean_volume_t', pv_r3d=ocean_volume_crs_t ) 222 222 CALL crs_iom_rstput( 0, 0, inum4, 'facvol_t' , pv_r3d=facvol_t ) 223 223 CALL crs_iom_rstput( 0, 0, inum4, 'facvol_w' , pv_r3d=facvol_w ) … … 230 230 CALL crs_iom_rstput( 0, 0, inum4, 'e2e3u' , pv_r3d=e2e3u ) 231 231 CALL crs_iom_rstput( 0, 0, inum4, 'e1e3v' , pv_r3d=e1e3v ) 232 CALL crs_iom_rstput( 0, 0, inum4, 'bt _crs', pv_r3d=bt_crs )233 CALL crs_iom_rstput( 0, 0, inum4, 'r1_bt _crs', pv_r3d=r1_bt_crs)232 CALL crs_iom_rstput( 0, 0, inum4, 'bt' , pv_r3d=bt_crs ) 233 CALL crs_iom_rstput( 0, 0, inum4, 'r1_bt' , pv_r3d=r1_bt_crs) 234 234 235 235 CALL crs_iom_rstput( 0, 0, inum4, 'crs_surfu_wgt', pv_r3d=crs_surfu_wgt) … … 243 243 IF( ln_zco ) THEN 244 244 ! ! z-coordinate - full steps 245 CALL iom_rstput( 0, 0, inum4, 'gdept_0 _crs', gdept_0 ) ! ! depth246 CALL iom_rstput( 0, 0, inum4, 'gdepw_0 _crs', gdepw_0 )247 CALL iom_rstput( 0, 0, inum4, 'e3t_0 _crs' , e3t_0 ) ! ! scale factors248 CALL iom_rstput( 0, 0, inum4, 'e3w_0 _crs' , e3w_0 )245 CALL iom_rstput( 0, 0, inum4, 'gdept_0', gdept_0 ) ! ! depth 246 CALL iom_rstput( 0, 0, inum4, 'gdepw_0', gdepw_0 ) 247 CALL iom_rstput( 0, 0, inum4, 'e3t_0' , e3t_0 ) ! ! scale factors 248 CALL iom_rstput( 0, 0, inum4, 'e3w_0' , e3w_0 ) 249 249 ENDIF 250 250 ! ! ============================ -
branches/2013/dev_r3411_CNRS4_IOCRS/NEMOGCM/NEMO/OPA_SRC/CRS/crsini.F90
r3779 r3823 12 12 USE crs_dom ! Coarse grid domain 13 13 USE phycst, ONLY: omega, rad ! physical constants 14 !USE wrk_nemo14 USE wrk_nemo 15 15 USE in_out_manager 16 16 USE par_kind, ONLY: wp … … 18 18 USE crsdomwri 19 19 USE crslbclnk 20 USE lib_mpp 20 21 21 22 IMPLICIT NONE … … 63 64 !!------------------------------------------------------------------- 64 65 !! Local variables 65 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje 66 INTEGER :: ji,jj,jk,ijjgloT,ijis,ijie,ijjs,ijje,jn ! dummy indices 66 67 INTEGER :: ierr ! allocation error status 67 68 REAL(wp) :: zrestx, zresty ! for determining odd or even reduction factor 68 REAL(wp), DIMENSION(:,:), ALLOCATABLE :: zmbk 69 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zfse3t, zfse3u, zfse3v, zfse3f 70 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zfse3w, zfse3t_n, zfse3t_b 69 REAL(wp), DIMENSION(:,:) , POINTER :: zmbk 70 REAL(wp), DIMENSION(:,:,:), POINTER :: zfse3t, zfse3u, zfse3v, zfse3w 71 71 LOGICAL :: llok 72 72 … … 96 96 WRITE(numout,*) ' nn_msh_crs = ', nn_msh_crs 97 97 ENDIF 98 98 99 99 rfactx_r = 1./nn_factx 100 100 rfacty_r = 1./nn_facty … … 107 107 jpjglo_crs = INT( (jpjglo - 2) / nn_facty ) + 2 ! the -2 removes j=1, j=jpj 108 108 jpiglo_crsm1 = jpiglo_crs - 1 109 jpjglo_crsm1 = jpjglo_crs - 1 110 jpkm1 = jpk - 1 109 jpjglo_crsm1 = jpjglo_crs - 1 111 110 112 111 ! 2.b. Define local domain indices 113 jpi_crs = ( jpiglo_crs-2 *jpreci + (jpni-1) ) / jpni + 2*jpreci114 jpj_crs = ( jpjglo_crs-2 *jprecj + (jpnj-1) ) / jpnj + 2*jprecj115 jpi_crsm1 = jpi_crs - 1116 jp j_crsm1 = jpj_crs - 1117 112 jpi_crs = ( jpiglo_crs-2 * jpreci + (jpni-1) ) / jpni + 2*jpreci 113 jpj_crs = ( jpjglo_crs-2 * jprecj + (jpnj-1) ) / jpnj + 2*jprecj 114 115 jpi_crsm1 = jpi_crs - 1 116 jpj_crsm1 = jpj_crs - 1 118 117 nperio_crs = jperio 119 118 npolj_crs = npolj 120 121 IF ( jpnij == 1 ) THEN 122 jpnij_crs = jpnij 123 narea_crs = narea 124 nimpp_crs = nimpp 125 njmpp_crs = njmpp 119 120 ierr = crs_dom_alloc() ! allocate most coarse grid arrays 121 122 IF( .NOT. lk_mpp ) THEN 123 nimpp_crs = 1 124 njmpp_crs = 1 125 nlci_crs = jpi_crs 126 nlcj_crs = jpj_crs 127 nldi_crs = 1 128 nldj_crs = 1 129 nlei_crs = jpi_crs 130 nlej_crs = jpj_crs 131 126 132 ELSE 127 WRITE(numout,*) 'crsini.F90. mpp not supported... Stopping' 128 STOP 129 ENDIF 130 131 nlcj_crs = jpj_crs 132 nlci_crs = jpi_crs 133 nldi_crs = 1 134 nlei_crs = jpi_crs 135 nlej_crs = jpj_crs 136 nldj_crs = 1 133 ! Initialisation of most local variables - 134 nimpp_crs = 1 135 njmpp_crs = 1 136 nlci_crs = jpi_crs 137 nlcj_crs = jpj_crs 138 nldi_crs = 1 139 nldj_crs = 1 140 nlei_crs = jpi_crs 141 nlej_crs = jpj_crs 142 143 SELECT CASE ( npolj ) 144 145 CASE ( 0 ) 146 147 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 148 & - AINT( REAL( ( jpjglo - mjg(nlej-1) ) / nn_facty, wp ) ) 149 IF( noso == -1 ) THEN 150 IF( MOD( jpjglo - njmpp , nn_facty ) > 0 ) nlej_crs = nlej_crs + 1 151 ELSE 152 IF( MOD( jpjglo - njmpp + 1 , nn_facty ) > nn_facty / 2 ) nlej_crs = nlej_crs + 1 153 ENDIF 154 155 CASE ( 3, 4, 5, 6 ) 156 157 nlej_crs = AINT( REAL( ( jpjglo - (njmpp - 1) ) / nn_facty, wp ) ) & 158 & - AINT( REAL( ( jpjglo - mjg(nlej) + 1 ) / nn_facty, wp ) ) + 1 159 160 CASE DEFAULT 161 WRITE(numout,*) 'crs_init. Only jperio =0, 3, 4, 5, 6 supported' 162 STOP 163 END SELECT 164 165 IF (noso > -1) THEN 166 nlej_crs = nlej_crs + 1 167 nldj_crs = 2 168 ELSE 169 nldj_crs = 1 170 ENDIF 171 172 IF ( nono < jpnj ) THEN 173 nlcj_crs = nlej_crs + 1 174 ELSE 175 nlcj_crs = nlej_crs 176 ENDIF 177 178 njmpp_crs = jpjglo_crs - ANINT( REAL( (jpjglo - njmpp ) / nn_facty, wp ) ) - 1 179 IF( MOD( jpjglo - njmpp , nn_facty ) > nn_facty / 2 ) njmpp_crs = njmpp_crs - 1 180 181 ENDIF 182 183 CALL dom_grid_crs !swich de grille 184 137 185 138 186 IF (lwp) THEN 139 187 WRITE(numout,*) 140 188 WRITE(numout,*) 'crs_init : coarse grid dimensions' 141 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo_crs = ', jpjglo_crs 142 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo_crs = ', jpiglo_crs 143 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi_crs = ', jpi_crs 144 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj_crs = ', jpj_crs 189 WRITE(numout,*) '~~~~~~~ coarse domain global j-dimension jpjglo = ', jpjglo 190 WRITE(numout,*) '~~~~~~~ coarse domain global i-dimension jpiglo = ', jpiglo 191 WRITE(numout,*) '~~~~~~~ coarse domain local i-dimension jpi = ', jpi 192 WRITE(numout,*) '~~~~~~~ coarse domain local j-dimension jpj = ', jpj 193 WRITE(numout,*) 194 WRITE(numout,*) ' nproc = ', narea 195 WRITE(numout,*) ' nlci = ', nlci 196 WRITE(numout,*) ' nlcj = ', nlcj 197 WRITE(numout,*) ' nldi = ', nldi 198 WRITE(numout,*) ' nldj = ', nldj 199 WRITE(numout,*) ' nlei = ', nlei 200 WRITE(numout,*) ' nlej = ', nlej 201 WRITE(numout,*) ' nimpp = ', nimpp 202 WRITE(numout,*) ' njmpp = ', njmpp 203 WRITE(numout,*) 145 204 ENDIF 146 147 205 206 CALL dom_grid_glo 207 148 208 mxbinctr = INT( nn_factx * 0.5 ) 149 209 mybinctr = INT( nn_facty * 0.5 ) … … 169 229 170 230 !jes. TODO Need to deallocate these if ln_crs = F 171 ierr = crs_dom_alloc() ! allocate most coarse grid arrays231 172 232 173 233 ! jes. TODO. Add the next two lines when mpp is done … … 181 241 mjs_crs(:) = 0; mje_crs(:) = 0 182 242 243 183 244 SELECT CASE ( cn_binref ) 184 245 185 246 CASE ( 'NORTH' ) 186 247 187 SELECT CASE ( nperio ) 248 SELECT CASE ( npolj ) 249 !cc 250 CASE ( 0, 1, 3, 4 ) ! 3, 4 : T-Pivot at North Fold 251 252 DO ji = 2, jpiglo_crsm1 253 ijie = (ji*nn_factx)-nn_factx !cc 254 ijis = ijie-nn_factx+1 255 mis_crs(ji) = ijis 256 mie_crs(ji) = ijie 257 ENDDO 258 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 259 260 ! Handle first the northernmost bin 261 IF ( nn_facty == 2 ) THEN ; ijjgloT = jpjglo - 1 262 ELSE ; ijjgloT = jpjglo 263 ENDIF 264 265 DO jj = 2, jpjglo_crsm1 266 ijje = ijjgloT-nn_facty*(jj-2) 267 ijjs = ijje-nn_facty+1 268 mjs_crs(jpjglo_crs-jj+1) = ijjs 269 mje_crs(jpjglo_crs-jj+1) = ijje 270 ENDDO 188 271 189 272 CASE ( 2 ) 190 273 WRITE(numout,*) 'crs_init, jperio=2 not supported' 191 274 192 CASE ( 3, 4 ) ! T-Pivot at North Fold275 CASE ( 5, 6 ) ! F-pivot at North Fold 193 276 194 277 DO ji = 2, jpiglo_crsm1 195 !cc ijie = (ji*nn_factx)-nn_factx+1 196 ijie = (ji*nn_factx)-nn_factx !cc 278 ijie = (ji*nn_factx)-nn_factx 197 279 ijis = ijie-nn_factx+1 198 199 IF ( ji == jpiglo_crsm1 ) THEN 200 IF ( ((jpiglo-1)-ijie) <= nn_factx ) ijie = jpiglo-2 ! ijie = jpiglo-1 !cc 201 ENDIF 202 203 ! Handle first the northernmost bin 204 IF ( nn_facty == 2 ) THEN 205 ijjgloT=jpjglo-1 206 ELSE 207 ijjgloT=jpjglo 208 ENDIF 209 210 DO jj = 2, jpjglo_crsm1 211 ! cc ijje = ijjgloT-nn_facty*(jj-2) 212 ijje = ijjgloT-nn_facty*(jj-2) - 1 213 ijjs = ijje-nn_facty+1 214 215 IF ( ijjs <= nn_facty ) ijjs = 2 216 217 mis_crs(ji) = ijis 218 mie_crs(ji) = ijie 219 mjs_crs(jpjglo_crs-jj+1) = ijjs 220 mje_crs(jpjglo_crs-jj+1) = ijje 221 222 ENDDO 223 ENDDO 224 225 CASE ( 5, 6 ) ! F-pivot at North Fold 226 227 DO ji = 2, jpiglo_crsm1 228 ijie = (ji*nn_factx)-nn_factx+1 229 ijis = ijie-nn_factx+1 230 231 IF ( ji == jpiglo_crsm1 ) THEN 232 IF ( ((jpiglo-1)-ijie) <= nn_factx ) ijie = jpiglo-1 233 ENDIF 234 235 ! Treat the northernmost bin separately. 236 jj = 2 237 ijje = jpjglo-nn_facty*(jj-2) 238 IF ( nn_facty == 3 ) THEN 239 ijjs=ijje-1 240 ELSE 241 ijjs=ijje-nn_facty+1 242 ENDIF 243 244 mis_crs(ji) = ijis 245 mie_crs(ji) = ijie 246 mjs_crs(jpjglo_crs-jj+1) = ijjs 247 mje_crs(jpjglo_crs-jj+1) = ijje 248 249 ! Now bin the rest, any remainder at the south is lumped in the southern bin 250 DO jj = 3, jpjglo_crsm1 251 252 ijje = jpjglo-nn_facty*(jj-2) 253 ijjs = ijje-nn_facty+1 254 255 IF ( ijjs <= nn_facty ) ijjs = 2 256 257 mis_crs(ji) = ijis 258 mie_crs(ji) = ijie 259 mjs_crs(jpjglo_crs-jj+1) = ijjs 260 mje_crs(jpjglo_crs-jj+1) = ijje 261 ENDDO 280 mis_crs(ji) = ijis 281 mie_crs(ji) = ijie 262 282 ENDDO 283 IF ( jpiglo - 1 - mie_crs(jpiglo_crsm1) <= nn_factx ) mie_crs(jpiglo_crsm1) = jpiglo-2 ! ijie = jpiglo-1 !cc 284 285 ! Treat the northernmost bin separately. 286 jj = 2 287 ijje = jpj-nn_facty*(jj-2) 288 IF ( nn_facty == 3 ) THEN ; ijjs = ijje - 1 289 ELSE ; ijjs = ijje - nn_facty + 1 290 ENDIF 291 mjs_crs(jpj_crs-jj+1) = ijjs 292 mje_crs(jpj_crs-jj+1) = ijje 293 294 ! Now bin the rest, any remainder at the south is lumped in the southern bin 295 DO jj = 3, jpjglo_crsm1 296 ijje = jpjglo-nn_facty*(jj-2) 297 ijjs = ijje-nn_facty+1 298 IF ( ijjs <= nn_facty ) ijjs = 2 299 mjs_crs(jpj_crs-jj+1) = ijjs 300 mje_crs(jpj_crs-jj+1) = ijje 301 ENDDO 263 302 264 303 CASE DEFAULT 265 WRITE(numout,*) 'crs_init. Only jperio = 3, 4, 5, 6 supported'304 WRITE(numout,*) 'crs_init. Only jperio = 0, 1, 3, 4, 5, 6 supported' 266 305 267 306 END SELECT … … 271 310 272 311 END SELECT 312 273 313 274 314 ! Pad the boundaries, do not know if it is necessary 275 315 mis_crs(1) = 1 ; mis_crs(jpiglo_crs) = mie_crs(jpiglo_crs - 1) + 1 !cc 276 316 mie_crs(1) = nn_factx ; mie_crs(jpiglo_crs) = jpiglo !cc 277 mjs_crs(1) = 1 ; mjs_crs(jpjglo_crs) = mje_crs(jpjglo_crs - 1) + 1 317 ! Probleme de segmentation je sais pas pourquoi 318 mjs_crs(1) = 1 ; mjs_crs(jpjglo_crs) = mje_crs(jpjglo_crsm1) + 1 278 319 mje_crs(1) = mjs_crs(2)-1; mje_crs(jpjglo_crs) = jpjglo 279 320 280 ! WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 281 ! WRITE(numout,'(1x,a,62(1x,i3),/)') 'mis_crs=', mis_crs 282 ! WRITE(numout,'(1x,a,62(1x,i3),/)') 'mie_crs=', mie_crs 283 ! WRITE(numout,'(1x,a,51(1x,i3),/)') 'mjs_crs=', mjs_crs 284 ! WRITE(numout,'(1x,a,51(1x,i3),/)') 'mje_crs=', mje_crs 285 286 321 ! WRITE(numout,*) 'crs_init. coarse grid bounds on parent grid' 322 ! WRITE(numout,*) 'mis_crs=', mis_crs 323 ! WRITE(numout,*) 'mie_crs=', mie_crs 324 ! WRITE(numout,*) 'mjs_crs=', mjs_crs 325 ! WRITE(numout,*) 'mje_crs=', mje_crs 326 327 328 IF( .NOT. lk_mpp ) THEN 329 njstart = 1 ; njend = jpj_crsm1 330 ELSE 331 ! 332 IF( noso == -1 ) THEN ; njstart = 1 333 ELSE ; njstart = 2 334 ENDIF 335 ! 336 IF( mje_crs(nlej_crs) >= jpj ) THEN ; njend = nlej_crs - 1 337 ELSE ; njend = nlej_crs 338 ENDIF 339 ! 340 ENDIF 341 287 342 !--------------------------------------------------------- 288 343 ! 3. Mask and Mesh … … 310 365 311 366 CALL crsfun( gphit, glamt, 'T', gphit_crs, glamt_crs ) 312 WRITE(numout,*) 'crsini. gphit_crs(15,15)', gphit_crs(15,15)313 WRITE(numout,*) 'crsini. glamt_crs(15,15)', glamt_crs(15,15)314 315 WRITE(numout,*) 'crsini. count 1'367 ! WRITE(numout,*) 'crsini. gphit_crs(15,15)', gphit_crs(15,15) 368 ! WRITE(numout,*) 'crsini. glamt_crs(15,15)', glamt_crs(15,15) 369 370 ! WRITE(numout,*) 'crsini. count 1' 316 371 317 372 CALL crsfun( gphiu, glamu, 'U', gphiu_crs, glamu_crs ) !cc 318 WRITE(numout,*) 'crsini. gphiu_crs(15,15)', gphiu_crs(15,15) !cc319 WRITE(numout,*) 'crsini. glamu_crs(15,15)', glamu_crs(15,15) !cc320 WRITE(numout,*) 'crsini. count 2'373 ! WRITE(numout,*) 'crsini. gphiu_crs(15,15)', gphiu_crs(15,15) !cc 374 ! WRITE(numout,*) 'crsini. glamu_crs(15,15)', glamu_crs(15,15) !cc 375 ! WRITE(numout,*) 'crsini. count 2' 321 376 322 377 CALL crsfun( p_pgphi=gphiv, p_pglam=glamv, cd_type='V', p_cgphi=gphiv_crs, p_cglam=glamv_crs ) !cc 323 WRITE(numout,*) 'crsini. gphiv_crs(15,15)', gphiv_crs(15,15) !cc324 WRITE(numout,*) 'crsini. glamv_crs(15,15)', glamv_crs(15,15) !cc325 326 WRITE(numout,*) 'crsini. count 3'378 ! WRITE(numout,*) 'crsini. gphiv_crs(15,15)', gphiv_crs(15,15) !cc 379 ! WRITE(numout,*) 'crsini. glamv_crs(15,15)', glamv_crs(15,15) !cc 380 381 ! WRITE(numout,*) 'crsini. count 3' 327 382 CALL crsfun( p_pgphi=gphif, p_pglam=glamf, cd_type='F', p_cgphi=gphif_crs, p_cglam=glamf_crs ) !cc 328 WRITE(numout,*) 'crsini. gphif_crs(15,15)', gphif_crs(15,15) !cc329 WRITE(numout,*) 'crsini. glamf_crs(15,15)', glamf_crs(15,15) !cc330 331 WRITE(numout,*) 'crsini. count 4'383 ! WRITE(numout,*) 'crsini. gphif_crs(15,15)', gphif_crs(15,15) !cc 384 ! WRITE(numout,*) 'crsini. glamf_crs(15,15)', glamf_crs(15,15) !cc 385 386 ! WRITE(numout,*) 'crsini. count 4' 332 387 ELSEIF ( zresty /= 0 .AND. zrestx == 0 ) THEN 333 388 CALL crsfun( p_pgphi=gphiu, p_pglam=glamu, cd_type='T', p_cgphi=gphit_crs, p_cglam=glamt_crs ) … … 406 461 ENDDO 407 462 408 ALLOCATE( zmbk(jpi_crs,jpj_crs))463 CALL wrk_alloc( jpi_crs, jpj_crs, zmbk ) 409 464 410 465 zmbk(:,:) = 0.0 … … 438 493 439 494 ! 3.d.2 Vertical scale factors 440 441 ALLOCATE( zfse3t(jpi,jpj,jpk), zfse3u(jpi,jpj,jpk), zfse3v(jpi,jpj,jpk), zfse3f(jpi,jpj,jpk), & 442 & zfse3w(jpi,jpj,jpk), zfse3t_n(jpi,jpj,jpk), zfse3t_b(jpi,jpj,jpk) ) 495 CALL wrk_alloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 496 ! 443 497 zfse3t(:,:,:) = fse3t(:,:,:) 444 498 zfse3u(:,:,:) = fse3u(:,:,:) 445 499 zfse3v(:,:,:) = fse3v(:,:,:) 446 zfse3f(:,:,:) = fse3f(:,:,:)447 500 zfse3w(:,:,:) = fse3w(:,:,:) 448 501 449 502 450 451 !CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, p_pfield3d_1=zfse3t, p_cfield3d=e3t_crs ) 452 !CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, p_ptmask=tmask, p_pfield3d_1=zfse3w, p_cfield3d=e3w_crs ) 503 WRITE(numout,*) 'crs_init : beginning section 3.d.2 ! ' 504 !CALL crsfun( p_e1e2t=e1e2t, cd_type='T', cd_op='MAX', p_cmask=tmask_crs, & 505 ! & p_ptmask=tmask, p_pfield3d_1=zfse3t, p_cfield3d=e3t_crs ) 506 !CALL crsfun( p_e1e2t=e1e2t, cd_type='W', cd_op='MAX', p_cmask=tmask_crs, & 507 ! & p_ptmask=tmask, p_pfield3d_1=zfse3w, p_cfield3d=e3w_crs ) 453 508 !CALL crsfun( p_e1e2t=e1e2t, cd_type='U', cd_op='MIN', p_cmask=umask_crs, p_ptmask=umask, p_pfield3d_1=zfse3u, p_cfield3d=e3u_crs ) 454 509 !CALL crsfun( p_e1e2t=e1e2t, cd_type='V', cd_op='MIN', p_cmask=vmask_crs, p_ptmask=vmask, p_pfield3d_1=zfse3v, p_cfield3d=e3v_crs ) 455 510 !CALL crsfun( p_e1e2t=e1e2t, cd_type='F', cd_op='MIN', p_cmask=fmask_crs, p_ptmask=fmask, p_pfield3d_1=zfse3f, p_cfield3d=e3f_crs ) 511 456 512 CALL crs_e3_max( p_e3=zfse3t, cd_type='T', p_mask=tmask, p_e3_crs=e3t_crs) 457 513 CALL crs_e3_max( p_e3=zfse3w, cd_type='W', p_mask=tmask, p_e3_crs=e3w_crs) 514 515 WRITE(numout,*) 'crs_init : crs_e3_max ' 516 458 517 459 518 ! Reset 0 to e3t_0 or e3w_0 … … 522 581 ! 7. Finish and clean-up 523 582 !--------------------------------------------------------- 524 DEALLOCATE( zmbk ) 525 DEALLOCATE( zfse3t, zfse3u, zfse3v, zfse3f ) 526 DEALLOCATE( zfse3w, zfse3t_n, zfse3t_b ) 527 528 583 CALL wrk_dealloc( jpi_crs, jpj_crs, zmbk ) 584 CALL wrk_dealloc(jpi, jpj, jpk, zfse3t, zfse3u, zfse3v, zfse3w ) 585 586 529 587 END SUBROUTINE crs_init 530 588
Note: See TracChangeset
for help on using the changeset viewer.
