Changeset 704 for LMDZ4/branches/V3_test/libf/phylmd/interface_surf.F90
- Timestamp:
- Aug 17, 2006, 5:41:51 PM (18 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
LMDZ4/branches/V3_test/libf/phylmd/interface_surf.F90
r700 r704 22 22 ! L. Fairhead, LMD, 02/2000 23 23 24 USE ioipsl24 !ym USE ioipsl 25 25 26 26 IMPLICIT none … … 44 44 ! run_off ruissellement total 45 45 REAL, ALLOCATABLE, DIMENSION(:),SAVE :: run_off, run_off_lic 46 !$OMP THREADPRIVATE(run_off, run_off_lic) 46 47 real, allocatable, dimension(:),save :: coastalflow, riverflow 48 !$OMP THREADPRIVATE(coastalflow, riverflow) 47 49 !!$PB 48 50 REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: tmp_rriv, tmp_rcoa,tmp_rlic 51 !$OMP THREADPRIVATE(tmp_rriv, tmp_rcoa,tmp_rlic) 49 52 !! pour simuler la fonte des glaciers antarctiques 50 53 REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: coeff_iceberg 54 !$OMP THREADPRIVATE(coeff_iceberg) 51 55 real, save :: surf_maille 56 !$OMP THREADPRIVATE(surf_maille) 52 57 real, save :: cte_flux_iceberg = 6.3e7 58 !$OMP THREADPRIVATE(cte_flux_iceberg) 53 59 integer, save :: num_antarctic = 1 60 !$OMP THREADPRIVATE(num_antarctic) 54 61 REAL, save :: tau_calv 62 !$OMP THREADPRIVATE(tau_calv) 55 63 !!$ 56 64 CONTAINS … … 75 83 & evap, fluxsens, fluxlat, dflux_l, dflux_s, & 76 84 & tsol_rad, tsurf_new, alb_new, alblw, emis_new, & 77 & z0_new, pctsrf_new, agesno,fqcalving,f fonte, run_off_lic_0,&85 & z0_new, pctsrf_new, agesno,fqcalving,fqfonte,ffonte, run_off_lic_0,& 78 86 !IM "slab" ocean 79 87 & flux_o, flux_g, tslab, seaice) 80 88 81 89 90 USE dimphy,only : monocpu,jjphy_nb,omp_rank 82 91 ! Cette routine sert d'aiguillage entre l'atmosphere et la surface en general 83 92 ! (sols continentaux, oceans, glaces) pour les fluxs de chaleur et d'humidite. … … 189 198 real, dimension(klon), intent(INOUT) :: tslab 190 199 real, allocatable, dimension(:), save :: tmp_tslab 200 !$OMP THREADPRIVATE(tmp_tslab) 191 201 real, dimension(klon), intent(OUT) :: flux_o, flux_g 192 202 real, dimension(klon), intent(INOUT) :: seaice ! glace de mer (kg/m2) 193 203 real, dimension(klon) :: siceh ! hauteur glace de mer (m) 194 204 REAL, DIMENSION(klon), INTENT(INOUT) :: radsol,fder 205 206 ! real, dimension(klon), intent(IN) :: zmasq 195 207 real, dimension(klon), intent(IN) :: zmasq 196 208 real, dimension(klon), intent(IN) :: taux, tauy, rugos, rugoro … … 221 233 !jld a rajouter real, dimension(klon), intent(INOUT):: ffonte 222 234 real, dimension(klon), intent(INOUT):: ffonte 223 ! Flux d'eau "perdue" par la surface et n écessaire pour que limiter la224 ! hauteur de neige, en kg/m2/s 225 !jld a rajouter real, dimension(klon), intent(INOUT):: fqcalving 226 real, dimension(klon), intent(INOUT):: fqcalving235 ! Flux d'eau "perdue" par la surface et n�essaire pour que limiter la 236 ! hauteur de neige, en kg/m2/s. Et quantite d'eau de fonte de la calotte. 237 !jld a rajouter real, dimension(klon), intent(INOUT):: fqcalving, fqfonte 238 REAL, DIMENSION(klon), INTENT(INOUT):: fqcalving, fqfonte 227 239 !IM: "slab" ocean 228 240 real, dimension(klon) :: new_dif_grnd … … 232 244 integer i 233 245 real, allocatable, dimension(:), save :: tmp_flux_o, tmp_flux_g 246 !$OMP THREADPRIVATE(tmp_flux_o, tmp_flux_g) 234 247 real, allocatable, dimension(:), save :: tmp_radsol 248 !$OMP THREADPRIVATE(tmp_radsol) 235 249 real, allocatable, dimension(:,:), save :: tmp_pctsrf_slab 250 !$OMP THREADPRIVATE(tmp_pctsrf_slab) 236 251 real, allocatable, dimension(:), save :: tmp_seaice 237 252 !$OMP THREADPRIVATE(tmp_seaice) 238 253 ! Local 239 254 character (len = 20),save :: modname = 'interfsurf_hq' 255 !$OMP THREADPRIVATE(modname) 240 256 character (len = 80) :: abort_message 241 257 logical, save :: first_call = .true. 258 !$OMP THREADPRIVATE(first_call) 242 259 integer, save :: error 260 !$OMP THREADPRIVATE(error) 243 261 integer :: ii, index 244 logical,save :: check = .false. 262 logical,save :: check = .true. 263 !$OMP THREADPRIVATE(check) 245 264 real, dimension(klon):: cal, beta, dif_grnd, capsol 246 265 !!$PB real, parameter :: calice=1.0/(5.1444e+06*0.15), tau_gl=86400.*5. … … 258 277 real, dimension(klon):: fder_prev 259 278 REAL, dimension(klon) :: bidule 279 real, dimension(klon) :: ps_tmp,p1lay_tmp 280 INTEGER :: j 260 281 ! 261 282 !IM ?? quelques variables pour netcdf … … 308 329 ffonte(1:knon)=0. 309 330 fqcalving(1:knon)=0. 331 fqfonte (1:knon)=0. 332 310 333 311 334 cal = 999999. ; beta = 999999. ; dif_grnd = 999999. ; capsol = 999999. … … 406 429 407 430 !!$PB 408 ALLOCATE (tmp_rriv(iim,jj m+1), stat=error)431 ALLOCATE (tmp_rriv(iim,jjphy_nb), stat=error) 409 432 if (error /= 0) then 410 433 abort_message='Pb allocation tmp_rriv' 411 434 call abort_gcm(modname,abort_message,1) 412 435 endif 413 ALLOCATE (tmp_rcoa(iim,jjm+1), stat=error) 436 tmp_rriv=0. 437 ALLOCATE (tmp_rcoa(iim,jjphy_nb), stat=error) 414 438 if (error /= 0) then 415 439 abort_message='Pb allocation tmp_rcoa' 416 440 call abort_gcm(modname,abort_message,1) 417 441 endif 418 ALLOCATE (tmp_rlic(iim,jjm+1), stat=error) 442 tmp_rcoa=0. 443 !ym ALLOCATE (tmp_rlic(iim,jjm+1), stat=error) 444 ALLOCATE (tmp_rlic(iim,jjphy_nb), stat=error) 419 445 if (error /= 0) then 420 446 abort_message='Pb allocation tmp_rlic' 421 447 call abort_gcm(modname,abort_message,1) 422 448 endif 423 tmp_rriv = 0.0 424 tmp_rcoa = 0.0 425 tmp_rlic = 0.0 426 449 tmp_rlic=0. 427 450 !!$ 428 451 else if (size(coastalflow) /= knon) then … … 448 471 & alb_new, z0_new) 449 472 ! 450 ! calcul snow et qsurf, hydrol adapté 451 ! 473 ! calcul snow et qsurf, hydrol adapt�! 452 474 CALL calbeta(dtime, nisurf, knon, snow, qsol, beta, capsol, dif_grnd) 453 475 … … 473 495 & petAcoef, peqAcoef, petBcoef, peqBcoef, & 474 496 & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & 475 & fqcalving,f fonte, run_off_lic_0)497 & fqcalving,fqfonte,ffonte, run_off_lic_0) 476 498 477 499 … … 490 512 ! 491 513 #ifdef CPP_VEGET 492 call interfsol(itime, klon, dtime, date0, nisurf, knon, & 514 p1lay_tmp(1:knon)=p1lay(1:knon)/100. 515 ps_tmp(1:knon)=ps(1:knon)/100. 516 517 call interfsol(itime, klon, dtime, date0, nisurf, knon, & 493 518 & knindex, rlon, rlat, cufi, cvfi, iim, jjm, pctsrf, & 494 519 & debut, lafin, ok_veget, & … … 496 521 & tq_cdrag, petAcoef, peqAcoef, petBcoef, peqBcoef, & 497 522 & precip_rain, precip_snow, sollwdown, swnet, swdown, & 498 & tsurf, p1lay /100., ps/100., radsol, &523 & tsurf, p1lay_tmp, ps_tmp, radsol, & 499 524 & evap, fluxsens, fluxlat, & 500 525 & tsol_rad, tsurf_new, alb_new, alblw, & … … 778 803 & petAcoef, peqAcoef, petBcoef, peqBcoef, & 779 804 & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & 780 & fqcalving,f fonte, run_off_lic_0)805 & fqcalving,fqfonte,ffonte, run_off_lic_0) 781 806 782 807 ! calcul albedo … … 927 952 & petAcoef, peqAcoef, petBcoef, peqBcoef, & 928 953 & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & 929 & fqcalving,f fonte, run_off_lic_0)954 & fqcalving,fqfonte,ffonte, run_off_lic_0) 930 955 931 956 ! passage du run-off des glaciers calcule dans fonte_neige au coupleur … … 1009 1034 1010 1035 USE intersurf 1011 1036 USE parallel, only : pole_nord,pole_sud 1037 USE dimphy, klon_x=>klon 1038 IMPLICIT NONE 1012 1039 ! Cette routine sert d'interface entre le modele atmospherique et le 1013 1040 ! modele de sol continental. Appel a sechiba … … 1127 1154 ! offset pour calculer les point voisins 1128 1155 integer, dimension(8,3), save :: off_ini 1129 integer, dimension(8), save :: offset 1130 ! Identifieurs des fichiers restart et histoire 1156 ! Identifieurs des fichiers restart et histoire 1131 1157 integer, save :: rest_id, hist_id 1132 1158 integer, save :: rest_id_stom, hist_id_stom … … 1144 1170 integer, dimension(:), save, allocatable :: ig, jg 1145 1171 integer :: indi, indj 1146 integer, dimension(klon) :: ktindex1172 integer, save, allocatable,dimension(:) :: ktindex 1147 1173 REAL, dimension(klon) :: bidule 1148 1174 ! Essai cdrag 1149 1175 real, dimension(klon) :: cdrag 1150 1176 integer :: jjb,jje,ijb,ije 1177 INTEGER,SAVE :: offset 1178 REAL, dimension(klon2) :: rlon_g,rlat_g 1179 INTEGER, SAVE :: orch_comm 1151 1180 #include "temps.inc" 1152 1181 #include "YOMCST.inc" … … 1156 1185 if (check) write(lunout,*)'ok_veget = ',ok_veget 1157 1186 1158 ktindex(:) = knindex(:) + iim - 1 1159 1187 1188 1160 1189 ! initialisation 1190 1161 1191 if (debut) then 1162 1192 ALLOCATE(ktindex(klon)) 1163 1193 IF ( .NOT. allocated(albedo_keep)) THEN 1164 1194 ALLOCATE(albedo_keep(klon)) … … 1183 1213 ig(klon) = 1 1184 1214 jg(klon) = jjm + 1 1185 ! 1186 ! Initialisation des offset 1187 ! 1188 ! offset bord ouest 1189 off_ini(1,1) = - iim ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1 1190 off_ini(4,1) = iim + 1; off_ini(5,1) = iim ; off_ini(6,1) = 2 * iim - 1 1191 off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1 1192 ! offset point normal 1193 off_ini(1,2) = - iim ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1 1194 off_ini(4,2) = iim + 1; off_ini(5,2) = iim ; off_ini(6,2) = iim - 1 1195 off_ini(7,2) = -1 ; off_ini(8,2) = - iim - 1 1196 ! offset bord est 1197 off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1 1198 off_ini(4,3) = 1 ; off_ini(5,3) = iim ; off_ini(6,3) = iim - 1 1199 off_ini(7,3) = -1 ; off_ini(8,3) = - iim - 1 1200 ! 1201 ! Initialisation des correspondances point -> indices i,j 1202 ! 1203 if (( .not. allocated(correspond))) then 1204 allocate(correspond(iim,jjm+1), stat = error) 1205 if (error /= 0) then 1206 abort_message='Pb allocation correspond' 1207 call abort_gcm(modname,abort_message,1) 1208 endif 1209 endif 1210 ! 1211 ! Attention aux poles 1212 ! 1213 do igrid = 1, knon 1214 index = ktindex(igrid) 1215 jj = int((index - 1)/iim) + 1 1216 ij = index - (jj - 1) * iim 1217 correspond(ij,jj) = igrid 1218 enddo 1219 1220 ! Allouer et initialiser le tableau de coordonnees du sol 1221 ! 1215 1222 1216 if ((.not. allocated(lalo))) then 1223 1217 allocate(lalo(knon,2), stat = error) … … 1247 1241 lalo(igrid,2) = rlon(index) 1248 1242 lalo(igrid,1) = rlat(index) 1249 ij = index - int((index-1)/iim)*iim - 1 1250 jj = 2 + int((index-1)/iim) 1251 if (mod(index,iim) == 1 ) then 1252 jj = 1 + int((index-1)/iim) 1253 ij = iim 1254 endif 1255 ! lon_scat(ij,jj) = rlon(index) 1256 ! lat_scat(ij,jj) = rlat(index) 1243 1257 1244 enddo 1258 index = 1 1259 do jj = 2, jjm 1260 do ij = 1, iim 1261 index = index + 1 1262 lon_scat(ij,jj) = rlon(index) 1263 lat_scat(ij,jj) = rlat(index) 1245 1246 1247 1248 Call GatherField(rlon,rlon_g,1) 1249 Call GatherField(rlat,rlat_g,1) 1250 1251 IF (phy_rank==0) THEN 1252 index = 1 1253 do jj = 2, jjm 1254 do ij = 1, iim 1255 index = index + 1 1256 lon_scat(ij,jj) = rlon_g(index) 1257 lat_scat(ij,jj) = rlat_g(index) 1258 enddo 1264 1259 enddo 1265 enddo 1266 lon_scat(:,1) = lon_scat(:,2) 1267 lat_scat(:,1) = rlat(1) 1268 lon_scat(:,jjm+1) = lon_scat(:,2) 1269 lat_scat(:,jjm+1) = rlat(klon) 1270 ! Pb de correspondances de grilles! 1271 ! do igrid = 1, knon 1272 ! index = ktindex(igrid) 1273 ! ij = ig(index) 1274 ! jj = jg(index) 1275 ! lon_scat(ij,jj) = rlon(index) 1276 ! lat_scat(ij,jj) = rlat(index) 1277 ! enddo 1260 lon_scat(:,1) = lon_scat(:,2) 1261 lat_scat(:,1) = rlat_g(1) 1262 lon_scat(:,jjm+1) = lon_scat(:,2) 1263 lat_scat(:,jjm+1) = rlat_g(klon2) 1264 ENDIF 1265 1278 1266 1279 1267 ! … … 1301 1289 enddo 1302 1290 1303 do igrid = 1, knon 1304 iglob = ktindex(igrid) 1305 if (mod(iglob, iim) == 1) then 1306 offset = off_ini(:,1) 1307 else if(mod(iglob, iim) == 0) then 1308 offset = off_ini(:,3) 1309 else 1310 offset = off_ini(:,2) 1311 endif 1312 do i = 1, 8 1313 index = iglob + offset(i) 1314 ireal = (min(max(1, index - iim + 1), klon)) 1315 if (pctsrf(ireal, is_ter) > EPSFRA) then 1316 jj = int((index - 1)/iim) + 1 1317 ij = index - (jj - 1) * iim 1318 neighbours(igrid, i) = correspond(ij, jj) 1319 endif 1320 enddo 1321 enddo 1291 1292 CALL Init_neighbours(iim,jjm,knon,neighbours,knindex,pctsrf(:,is_ter)) 1322 1293 1323 1294 ! … … 1335 1306 resolution(igrid,2) = cvfi(ij) 1336 1307 enddo 1337 !IM tester la resolution que recoit Orchidee1338 IF((maxval(resolution(:,2)) == 0.).OR. &1339 & (maxval(resolution(:,1)) == 0.)) THEN1340 abort_message='STOP interfsol : resolution recue par Orchidee = 0.'1341 call abort_gcm(modname,abort_message,1)1342 ENDIF1343 1308 1344 1309 endif ! (fin debut) … … 1373 1338 ! Init Orchidee 1374 1339 ! 1340 ! if (pole_nord) then 1341 ! offset=0 1342 ! ktindex(:)=ktindex(:)+iim-1 1343 ! else 1344 ! offset = klon_begin-1+iim-1 1345 ! ktindex(:)=ktindex(:)+MOD(offset,iim) 1346 ! offset=offset-MOD(offset,iim) 1347 ! endif 1348 1349 PRINT *,'ORCHIDEE ------> KNON : ',knon 1350 1351 1375 1352 if (debut) then 1376 call intersurf_main (itime+itau_phy-1, iim, jjm+1, knon, ktindex, dtime, & 1377 & lrestart_read, lrestart_write, lalo, & 1378 & contfrac, neighbours, resolution, date0, & 1379 & zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & 1380 & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & 1381 & precip_rain, precip_snow, lwdown, swnet, swdown, ps, & 1382 & evap, fluxsens, fluxlat, coastalflow, riverflow, & 1383 & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & 1384 & lon_scat, lat_scat) 1385 1353 CALL Get_orchidee_communicator(knon,orch_comm) 1354 IF (knon /=0) THEN 1355 CALL Init_orchidee_index(iim,knon,orch_comm,knindex,offset,ktindex) 1356 1357 call intersurf_main (itime+itau_phy-1, iim, jjm+1,offset, knon, ktindex, & 1358 & orch_comm,dtime, lrestart_read, lrestart_write, lalo, & 1359 & contfrac, neighbours, resolution, date0, & 1360 & zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & 1361 & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & 1362 & precip_rain, precip_snow, lwdown, swnet, swdown, ps, & 1363 & evap, fluxsens, fluxlat, coastalflow, riverflow, & 1364 & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & 1365 & lon_scat, lat_scat) 1366 1367 ENDIF 1386 1368 !IM cf. JP +++ 1387 1369 albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. … … 1391 1373 1392 1374 !IM cf. JP +++ 1393 ! IMswdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon))1394 !IM modification faite dans clmain 1395 swdown_vrai(1:knon) = swdown(1:knon) 1375 ! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) 1376 swdown_vrai(1:knon) = swdown(1:knon) 1377 1396 1378 !IM cf. JP --- 1397 1398 call intersurf_main (itime+itau_phy, iim, jjm+1, knon, ktindex, dtime, & 1399 & lrestart_read, lrestart_write, lalo, & 1400 & contfrac, neighbours, resolution, date0, & 1401 & zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & 1402 & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & 1403 & precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, & 1404 & evap, fluxsens, fluxlat, coastalflow, riverflow, & 1405 & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & 1406 & lon_scat, lat_scat) 1407 1379 IF (knon /=0) THEN 1380 1381 call intersurf_main (itime+itau_phy, iim, jjm+1,offset, knon, ktindex, & 1382 & orch_comm,dtime, lrestart_read, lrestart_write, lalo, & 1383 & contfrac, neighbours, resolution, date0, & 1384 & zlev, u1_lay, v1_lay, spechum, temp_air, epot_air, ccanopy, & 1385 & cdrag, petA_orc, peqA_orc, petB_orc, peqB_orc, & 1386 & precip_rain, precip_snow, lwdown, swnet, swdown_vrai, ps, & 1387 & evap, fluxsens, fluxlat, coastalflow, riverflow, & 1388 & tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0_new, & 1389 & lon_scat, lat_scat) 1390 1391 ENDIF 1408 1392 !IM cf. JP +++ 1409 1393 albedo_keep(1:knon) = (albedo_out(1:knon,1)+albedo_out(1:knon,2))/2. … … 1412 1396 bidule=0. 1413 1397 bidule(1:knon)=riverflow(1:knon) 1414 call gath2cpl(bidule, tmp_rriv, klon, knon,iim,jj m,knindex)1398 call gath2cpl(bidule, tmp_rriv, klon, knon,iim,jjphy_nb,knindex) 1415 1399 bidule=0. 1416 1400 bidule(1:knon)=coastalflow(1:knon) 1417 call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jj m,knindex)1401 call gath2cpl(bidule, tmp_rcoa, klon, knon,iim,jjphy_nb,knindex) 1418 1402 alb_new(1:knon) = albedo_out(1:knon,1) 1419 1403 alblw(1:knon) = albedo_out(1:knon,2) … … 1429 1413 1430 1414 END SUBROUTINE interfsol 1415 1416 SUBROUTINE Init_orchidee_index(iim,knon,orch_comm,knindex,offset,ktindex) 1417 USE dimphy 1418 IMPLICIT NONE 1419 INTEGER,INTENT(IN) :: iim 1420 INTEGER,INTENT(IN) :: knon 1421 INTEGER,INTENT(IN) :: orch_comm 1422 INTEGER,INTENT(IN) :: knindex(knon) 1423 INTEGER,INTENT(OUT) :: offset 1424 INTEGER,INTENT(OUT) :: ktindex(knon) 1425 1426 #ifdef CPP_PARA 1427 INCLUDE 'mpif.h' 1428 INTEGER :: status(MPI_STATUS_SIZE) 1429 #endif 1430 INTEGER :: MyLastPoint 1431 INTEGER :: LastPoint 1432 INTEGER :: mpi_rank 1433 INTEGER :: mpi_size 1434 INTEGER :: ierr 1435 1436 MyLastPoint=klon_begin-1+knindex(knon)+iim-1 1437 1438 IF (.NOT. monocpu) THEN 1439 #ifdef CPP_PARA 1440 call MPI_COMM_SIZE(orch_comm,mpi_size,ierr) 1441 call MPI_COMM_RANK(orch_comm,mpi_rank,ierr) 1442 #endif 1443 ELSE 1444 mpi_rank=0 1445 mpi_size=1 1446 ENDIF 1447 1448 IF (.NOT. monocpu) THEN 1449 IF (mpi_rank /= 0) then 1450 #ifdef CPP_PARA 1451 CALL MPI_RECV(LastPoint,1,MPI_INTEGER,mpi_rank-1,1234,orch_comm,status,ierr) 1452 #endif 1453 ENDIF 1454 1455 IF (mpi_rank /= mpi_size-1) THEN 1456 #ifdef CPP_PARA 1457 CALL MPI_SEND(MyLastPoint,1,MPI_INTEGER,mpi_rank+1,1234,orch_comm,ierr) 1458 #endif 1459 ENDIF 1460 ENDIF 1461 1462 IF (mpi_rank==0) THEN 1463 offset=0 1464 ELSE 1465 offset=LastPoint-MOD(LastPoint,iim) 1466 ENDIF 1467 1468 ktindex(:)=knindex(:)+(klon_begin+iim-1)-offset-1 1469 1470 1471 END SUBROUTINE Init_orchidee_index 1472 1473 1474 SUBROUTINE Get_orchidee_communicator(knon,orch_comm) 1475 USE dimphy, only : phy_rank 1476 USE parallel, only : COMM_LMDZ 1477 IMPLICIT NONE 1478 #ifdef CPP_PARA 1479 include 'mpif.h' 1480 #endif 1481 INTEGER,INTENT(IN) :: knon 1482 INTEGER,INTENT(OUT) :: orch_comm 1483 1484 INTEGER :: color 1485 INTEGER :: ierr 1486 1487 IF (knon==0) THEN 1488 color = 0 1489 ELSE 1490 color = 1 1491 ENDIF 1492 1493 #ifdef CPP_PARA 1494 CALL MPI_COMM_SPLIT(COMM_LMDZ,color,phy_rank,orch_comm,ierr) 1495 #endif 1496 1497 END SUBROUTINE Get_orchidee_communicator 1498 1499 1500 SUBROUTINE Init_neighbours(iim,jjm,knon,neighbours,ktindex,pctsrf) 1501 USE parallel,only : COMM_LMDZ 1502 USE dimphy 1503 IMPLICIT NONE 1504 #ifdef CPP_PARA 1505 include 'mpif.h' 1506 #endif 1507 INTEGER :: iim,jjm 1508 INTEGER :: knon 1509 INTEGER :: neighbours(knon,8) 1510 INTEGER :: ktindex(knon) 1511 REAL :: pctsrf(klon) 1512 1513 INTEGER :: knon_nb(0:phy_size-1) 1514 INTEGER,DIMENSION(0:phy_size-1) :: displs,sendcount 1515 INTEGER,ALLOCATABLE :: ktindex_g(:) 1516 REAL*8 :: pctsrf_g(klon2) 1517 INTEGER,ALLOCATABLE ::neighbours_g(:,:) 1518 INTEGER :: knon_g 1519 REAL*8 :: correspond(iim,jjm+1) 1520 INTEGER :: i,igrid,jj,ij,iglob,ierr,ireal,index 1521 integer, dimension(8,3) :: off_ini 1522 integer, dimension(8) :: offset 1523 INTEGER :: ktindex_p(knon) 1524 1525 IF (monocpu) THEN 1526 knon_nb(:)=knon 1527 ELSE 1528 1529 #ifdef CPP_PARA 1530 CALL MPI_GATHER(knon,1,MPI_INTEGER,knon_nb,1,MPI_INTEGER,0,COMM_LMDZ,ierr) 1531 #endif 1532 1533 ENDIF 1534 1535 IF (phy_rank==0) THEN 1536 knon_g=sum(knon_nb(:)) 1537 ALLOCATE(ktindex_g(knon_g)) 1538 ALLOCATE(neighbours_g(knon_g,8)) 1539 neighbours_g(:,:)=-1 1540 displs(0)=0 1541 DO i=1,phy_size-1 1542 displs(i)=displs(i-1)+knon_nb(i-1) 1543 ENDDO 1544 ENDIF 1545 1546 ktindex_p(:)=ktindex(:)+klon_begin-1+iim-1 1547 1548 IF (monocpu) THEN 1549 ktindex_g(:)=ktindex_p(:) 1550 ELSE 1551 1552 #ifdef CPP_PARA 1553 CALL MPI_GATHERV(ktindex_p,knon,MPI_INTEGER,ktindex_g,knon_nb,displs,MPI_INTEGER,0,COMM_LMDZ,ierr) 1554 #endif 1555 1556 ENDIF 1557 1558 CALL GatherField(pctsrf,pctsrf_g,1) 1559 1560 IF (phy_rank==0) THEN 1561 ! Initialisation des offset 1562 ! 1563 ! offset bord ouest 1564 off_ini(1,1) = - iim ; off_ini(2,1) = - iim + 1; off_ini(3,1) = 1 1565 off_ini(4,1) = iim + 1; off_ini(5,1) = iim ; off_ini(6,1) = 2 * iim - 1 1566 off_ini(7,1) = iim -1 ; off_ini(8,1) = - 1 1567 ! offset point normal 1568 off_ini(1,2) = - iim ; off_ini(2,2) = - iim + 1; off_ini(3,2) = 1 1569 off_ini(4,2) = iim + 1; off_ini(5,2) = iim ; off_ini(6,2) = iim - 1 1570 off_ini(7,2) = -1 ; off_ini(8,2) = - iim - 1 1571 ! offset bord est 1572 off_ini(1,3) = - iim; off_ini(2,3) = - 2 * iim + 1; off_ini(3,3) = - iim + 1 1573 off_ini(4,3) = 1 ; off_ini(5,3) = iim ; off_ini(6,3) = iim - 1 1574 off_ini(7,3) = -1 ; off_ini(8,3) = - iim - 1 1575 ! 1576 ! 1577 ! Attention aux poles 1578 ! 1579 do igrid = 1, knon_g 1580 index = ktindex_g(igrid) 1581 jj = int((index - 1)/iim) + 1 1582 ij = index - (jj - 1) * iim 1583 correspond(ij,jj) = igrid 1584 enddo 1585 1586 do igrid = 1, knon_g 1587 iglob = ktindex_g(igrid) 1588 if (mod(iglob, iim) == 1) then 1589 offset = off_ini(:,1) 1590 else if(mod(iglob, iim) == 0) then 1591 offset = off_ini(:,3) 1592 else 1593 offset = off_ini(:,2) 1594 endif 1595 do i = 1, 8 1596 index = iglob + offset(i) 1597 ireal = (min(max(1, index - iim + 1), klon2)) 1598 if (pctsrf_g(ireal) > EPSFRA) then 1599 jj = int((index - 1)/iim) + 1 1600 ij = index - (jj - 1) * iim 1601 neighbours_g(igrid, i) = correspond(ij, jj) 1602 endif 1603 enddo 1604 enddo 1605 1606 ! DO i=0,phy_size-1 1607 ! displs(i)=displs(i)*8 1608 ! sendcount(i)=knon_nb(i)*8 1609 ! ENDDO 1610 1611 ENDIF 1612 1613 DO i=1,8 1614 IF (monocpu) THEN 1615 neighbours(:,i)=neighbours_g(:,i) 1616 ELSE 1617 #ifdef CPP_PARA 1618 CALL MPI_SCATTERV(neighbours_g(:,i),knon_nb,displs,MPI_INTEGER,neighbours(:,i),knon,MPI_INTEGER,0,COMM_LMDZ,ierr) 1619 #endif 1620 ENDIF 1621 ENDDO 1622 1623 END SUBROUTINE Init_neighbours 1431 1624 #endif 1432 1625 ! … … 1445 1638 & pctsrf_new) 1446 1639 1640 USE ioipsl 1641 USE dimphy, only : jjphy_nb, iiphy_begin,iiphy_end,phy_rank,phy_size, monocpu 1642 USE iophy 1643 #ifdef CPP_PARA 1644 USE parallel, only: pole_nord,pole_sud,COMM_LMDZ 1645 #endif 1646 #ifdef CPP_PSMILE 1647 USE oasis 1648 #endif 1649 USE write_field_phy 1650 implicit none 1651 #include "indicesol.inc" 1652 #include "YOMCST.inc" 1447 1653 ! Cette routine sert d'interface entre le modele atmospherique et un 1448 1654 ! coupleur avec un modele d'ocean 'complet' derriere … … 1499 1705 ! alb_ice albedo de la glace 1500 1706 ! 1501 #ifdef CPP_PSMILE 1502 USE oasis 1503 integer :: il_time_secs !time in seconds 1504 #endif 1707 1505 1708 1506 1709 ! Parametres d'entree … … 1560 1763 REAL, ALLOCATABLE, DIMENSION(:,:,:),SAVE :: tmp_tauy 1561 1764 ! variables a passer au coupleur 1562 real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 1563 real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice 1564 REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv 1565 REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy 1566 ! -- LOOP 1567 REAL, DIMENSION(iim, jjm+1) :: wri_windsp 1568 ! -- LOOP 1569 REAL, DIMENSION(iim, jjm+1) :: wri_calv 1570 REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz 1571 REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat 1765 !ym real, dimension(iim, jjm+1) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 1766 !ym real, dimension(iim, jjm+1) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice 1767 !ym REAL, DIMENSION(iim, jjm+1) :: wri_evap_sea, wri_rcoa, wri_rriv 1768 !ym REAL, DIMENSION(iim, jjm+1) :: wri_rain, wri_snow, wri_taux, wri_tauy 1769 !ym REAL, DIMENSION(iim, jjm+1) :: wri_calv 1770 !ym REAL, DIMENSION(iim, jjm+1) :: wri_tauxx, wri_tauyy, wri_tauzz 1771 !ym REAL, DIMENSION(iim, jjm+1) :: tmp_lon, tmp_lat 1772 1773 real, dimension(iim, jjphy_nb) :: wri_sol_ice, wri_sol_sea, wri_nsol_ice 1774 real, dimension(iim, jjphy_nb) :: wri_nsol_sea, wri_fder_ice, wri_evap_ice 1775 REAL, DIMENSION(iim, jjphy_nb) :: wri_evap_sea, wri_rcoa, wri_rriv 1776 REAL, DIMENSION(iim, jjphy_nb) :: wri_rain, wri_snow, wri_taux, wri_tauy 1777 REAL, DIMENSION(iim, jjphy_nb) :: wri_calv 1778 REAL, DIMENSION(iim, jjphy_nb) :: wri_tauxx, wri_tauyy, wri_tauzz 1779 REAL, DIMENSION(iim, jjphy_nb) :: tmp_lon, tmp_lat 1780 REAL, DIMENSION(iim, jjphy_nb) :: wri_windsp 1781 1572 1782 ! variables relues par le coupleur 1573 1783 ! read_sic = fraction de glace … … 1580 1790 ! l'avoir lu 1581 1791 real, allocatable,dimension(:,:),save :: pctsrf_sav 1582 real, dimension(iim, jj m+1, 2) :: tamp_srf1792 real, dimension(iim, jjphy_nb, 3) :: tamp_srf 1583 1793 integer, allocatable, dimension(:), save :: tamp_ind 1584 1794 real, allocatable, dimension(:,:),save :: tamp_zmasq 1585 real, dimension(iim, jj m+1) :: deno1795 real, dimension(iim, jjphy_nb) :: deno 1586 1796 integer :: idtime 1587 1797 integer, allocatable,dimension(:),save :: unity … … 1602 1812 integer :: nb_interf_cpl 1603 1813 ! -- LOOP 1814 1815 real :: Up,Down 1816 integer :: ierr 1817 integer :: il_time_secs 1818 real :: tmp_field(klon) 1819 1604 1820 #include "param_cou.h" 1605 1821 #include "inc_cpl.h" 1606 1822 #include "temps.inc" 1607 1823 #include "iniprint.h" 1824 1825 #ifdef CPP_PARA 1826 include 'mpif.h' 1827 integer :: status(MPI_STATUS_SIZE) 1828 #endif 1829 1608 1830 ! 1609 1831 ! Initialisation … … 1642 1864 ! -- LOOP 1643 1865 allocate(cpl_tauy(klon,2), stat = error); sum_error = sum_error + error 1644 ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error 1645 ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error 1646 ALLOCATE(cpl_rlic(iim,jjm+1), stat=error); sum_error = sum_error + error 1866 !ym ALLOCATE(cpl_rriv(iim,jjm+1), stat=error); sum_error = sum_error + error 1867 !ym ALLOCATE(cpl_rcoa(iim,jjm+1), stat=error); sum_error = sum_error + error 1868 !ym ALLOCATE(cpl_rlic(iim,jjm+1), stat=error); sum_error = sum_error + error 1869 ALLOCATE(cpl_rriv(iim,jjphy_nb), stat=error); sum_error = sum_error + error 1870 ALLOCATE(cpl_rcoa(iim,jjphy_nb), stat=error); sum_error = sum_error + error 1871 ALLOCATE(cpl_rlic(iim,jjphy_nb), stat=error); sum_error = sum_error + error 1872 1873 1647 1874 !! 1648 allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error 1649 allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error 1650 allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error 1651 allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error 1652 1875 !ym allocate(read_sst(iim, jjm+1), stat = error); sum_error = sum_error + error 1876 !ym allocate(read_sic(iim, jjm+1), stat = error); sum_error = sum_error + error 1877 !ym allocate(read_sit(iim, jjm+1), stat = error); sum_error = sum_error + error 1878 !ym allocate(read_alb_sic(iim, jjm+1), stat = error); sum_error = sum_error + error 1879 allocate(read_sst(iim, jjphy_nb), stat = error); sum_error = sum_error + error 1880 allocate(read_sic(iim, jjphy_nb), stat = error); sum_error = sum_error + error 1881 allocate(read_sit(iim, jjphy_nb), stat = error); sum_error = sum_error + error 1882 allocate(read_alb_sic(iim, jjphy_nb), stat = error); sum_error = sum_error + error 1883 read_sst=0. 1884 read_sic=0. 1885 read_sit=0. 1886 read_alb_sic=0. 1653 1887 if (sum_error /= 0) then 1654 1888 abort_message='Pb allocation variables couplees' … … 1664 1898 sum_error = 0 1665 1899 allocate(tamp_ind(klon), stat = error); sum_error = sum_error + error 1666 allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error 1900 !ym allocate(tamp_zmasq(iim, jjm+1), stat = error); sum_error = sum_error + error 1901 allocate(tamp_zmasq(iim, jjphy_nb), stat = error); sum_error = sum_error + error 1902 tamp_zmasq=1. 1903 1667 1904 do ig = 1, klon 1668 1905 tamp_ind(ig) = ig 1669 1906 enddo 1670 call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jj m, tamp_ind)1907 call gath2cpl(zmasq, tamp_zmasq, klon, klon, iim, jjphy_nb, tamp_ind) 1671 1908 ! 1672 1909 ! initialisation couplage … … 1675 1912 #ifdef CPP_COUPLE 1676 1913 #ifdef CPP_PSMILE 1677 1914 CALL inicma(iim, (jjm+1)) 1678 1915 #else 1916 if (.not. monocpu) then 1917 abort_message='coupleur parallele uniquement avec PSMILE' 1918 call abort_gcm(modname,abort_message,1) 1919 endif 1679 1920 call inicma(npas , nexca, idtime,(jjm+1)*iim) 1680 1921 #endif … … 1683 1924 ! initialisation sorties netcdf 1684 1925 ! 1926 !ym IO de check deconnect�pour le moment en // 1927 IF (monocpu) THEN 1685 1928 idayref = day_ini 1686 1929 CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) … … 1721 1964 CALL histsync(nidcs) 1722 1965 1966 ENDIF ! monocpu 1967 1723 1968 ! pour simuler la fonte des glaciers antarctiques 1724 1969 ! 1725 surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1)) 1726 ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error) 1727 if (error /= 0) then 1728 abort_message='Pb allocation variable coeff_iceberg' 1729 call abort_gcm(modname,abort_message,1) 1730 endif 1731 open (12,file='flux_iceberg',form='formatted',status='old') 1732 read (12,*) coeff_iceberg 1733 close (12) 1734 num_antarctic = max(1, count(coeff_iceberg > 0)) 1970 !ym => pour le moment, c'est en commentaire, donc je squizze 1971 1972 !ym surf_maille = (4. * rpi * ra**2) / (iim * (jjm +1)) 1973 !ym ALLOCATE(coeff_iceberg(iim,jjm+1), stat=error) 1974 !ym if (error /= 0) then 1975 !ym abort_message='Pb allocation variable coeff_iceberg' 1976 !ym call abort_gcm(modname,abort_message,1) 1977 !ym endif 1978 !ym open (12,file='flux_iceberg',form='formatted',status='old') 1979 !ym read (12,*) coeff_iceberg 1980 !ym close (12) 1981 !ym num_antarctic = max(1, count(coeff_iceberg > 0)) 1735 1982 1736 1983 first_appel = .false. … … 1799 2046 #ifdef CPP_PSMILE 1800 2047 il_time_secs=(itime-1)*dtime 1801 CALL fromcpl(il_time_secs, iim, (jjm+1), &2048 CALL fromcpl(il_time_secs, iim, jjphy_nb, & 1802 2049 & read_sst, read_sic, read_sit, read_alb_sic) 2050 print *,read_sst 1803 2051 #else 2052 if (.not. monocpu) then 2053 abort_message='coupleur parallele uniquement avec PSMILE' 2054 call abort_gcm(modname,abort_message,1) 2055 endif 2056 1804 2057 call fromcpl(itime-1,(jjm+1)*iim, & 1805 2058 & read_sst, read_sic, read_sit, read_alb_sic) … … 1809 2062 ! sorties NETCDF des champs recus 1810 2063 ! 1811 ndexcs(:)=01812 itau_w = itau_phy + itime1813 CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs)1814 CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs)1815 CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs)1816 CALL histwrite(nidcs,cl_read(4),itau_w,read_sit,iim*(jjm+1),ndexcs)1817 CALL histsync(nidcs)2064 !ym ndexcs(:)=0 2065 !ym itau_w = itau_phy + itime 2066 !ym CALL histwrite(nidcs,cl_read(1),itau_w,read_sst,iim*(jjm+1),ndexcs) 2067 !ym CALL histwrite(nidcs,cl_read(2),itau_w,read_sic,iim*(jjm+1),ndexcs) 2068 !ym CALL histwrite(nidcs,cl_read(3),itau_w,read_alb_sic,iim*(jjm+1),ndexcs) 2069 !ym CALL histwrite(nidcs,cl_read(4),itau_w,read_sit,iim*(jjm+1),ndexcs) 2070 !ym CALL histsync(nidcs) 1818 2071 ! pas utile IF (npas-itime.LT.nexca )CALL histclo(nidcs) 1819 2072 1820 do j = 1, jjm + 1 1821 do ig = 1, iim 2073 !ym do j = 1, jjm + 1 2074 do j = 1, jjphy_nb 2075 do ig = 1, iim 1822 2076 if (abs(1. - read_sic(ig,j)) < 0.00001) then 1823 2077 read_sst(ig,j) = RTT - 1.8 … … 1838 2092 ! transformer read_sic en pctsrf_sav 1839 2093 ! 1840 call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jj m, unity)2094 call cpl2gath(read_sic, tamp_sic , klon, klon,iim,jjphy_nb, unity) 1841 2095 do ig = 1, klon 1842 2096 IF (pctsrf(ig,is_oce) > epsfra .OR. & … … 1881 2135 if (nisurf == is_oce .and. (.not. cumul) ) then 1882 2136 sum_error = 0 1883 allocate(tmp_sols(iim,jj m+1,2), stat=error); sum_error = sum_error + error1884 allocate(tmp_nsol(iim,jj m+1,2), stat=error); sum_error = sum_error + error1885 allocate(tmp_rain(iim,jj m+1,2), stat=error); sum_error = sum_error + error1886 allocate(tmp_snow(iim,jj m+1,2), stat=error); sum_error = sum_error + error1887 allocate(tmp_evap(iim,jj m+1,2), stat=error); sum_error = sum_error + error1888 allocate(tmp_tsol(iim,jj m+1,2), stat=error); sum_error = sum_error + error1889 allocate(tmp_fder(iim,jj m+1,2), stat=error); sum_error = sum_error + error1890 allocate(tmp_albe(iim,jj m+1,2), stat=error); sum_error = sum_error + error1891 allocate(tmp_taux(iim,jj m+1,2), stat=error); sum_error = sum_error + error1892 allocate(tmp_tauy(iim,jj m+1,2), stat=error); sum_error = sum_error + error1893 ! -- LOOP 1894 allocate(tmp_windsp(iim,jj m+1,2), stat=error); sum_error = sum_error + error2137 allocate(tmp_sols(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2138 allocate(tmp_nsol(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2139 allocate(tmp_rain(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2140 allocate(tmp_snow(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2141 allocate(tmp_evap(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2142 allocate(tmp_tsol(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2143 allocate(tmp_fder(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2144 allocate(tmp_albe(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2145 allocate(tmp_taux(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2146 allocate(tmp_tauy(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 2147 ! -- LOOP 2148 allocate(tmp_windsp(iim,jjphy_nb,2), stat=error); sum_error = sum_error + error 1895 2149 ! -- LOOP 1896 2150 !!$ allocate(tmp_rriv(iim,jjm+1,2), stat=error); sum_error = sum_error + error … … 1907 2161 cpl_index = 1 1908 2162 if (nisurf == is_sic) cpl_index = 2 1909 call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jj m, knindex)1910 call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jj m, knindex)1911 call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jj m, knindex)1912 call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jj m, knindex)1913 call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jj m, knindex)1914 call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jj m, knindex)1915 call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jj m, knindex)1916 call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jj m, knindex)1917 call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jj m, knindex)1918 ! -- LOOP 1919 call gath2cpl(cpl_windsp(1,cpl_index), tmp_windsp(1,1,cpl_index), klon, knon,iim,jjm, knindex) 1920 ! -- LOOP 1921 call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jjm, knindex) 2163 call gath2cpl(cpl_sols(1,cpl_index), tmp_sols(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2164 call gath2cpl(cpl_nsol(1,cpl_index), tmp_nsol(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2165 call gath2cpl(cpl_rain(1,cpl_index), tmp_rain(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2166 call gath2cpl(cpl_snow(1,cpl_index), tmp_snow(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2167 call gath2cpl(cpl_evap(1,cpl_index), tmp_evap(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2168 call gath2cpl(cpl_tsol(1,cpl_index), tmp_tsol(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2169 call gath2cpl(cpl_fder(1,cpl_index), tmp_fder(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2170 call gath2cpl(cpl_albe(1,cpl_index), tmp_albe(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2171 call gath2cpl(cpl_taux(1,cpl_index), tmp_taux(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2172 call gath2cpl(cpl_tauy(1,cpl_index), tmp_tauy(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2173 ! -- LOOP 2174 call gath2cpl(cpl_windsp(1,cpl_index), tmp_windsp(1,1,cpl_index), klon, knon,iim,jjphy_nb, knindex) 2175 ! -- LOOP 1922 2176 1923 2177 ! … … 1930 2184 wri_windsp = 0. 1931 2185 ! -- LOOP 1932 call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jj m, tamp_ind)1933 call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jj m, tamp_ind)2186 call gath2cpl(pctsrf(1,is_oce), tamp_srf(1,1,1), klon, klon, iim, jjphy_nb, tamp_ind) 2187 call gath2cpl(pctsrf(1,is_sic), tamp_srf(1,1,2), klon, klon, iim, jjphy_nb, tamp_ind) 1934 2188 1935 2189 wri_sol_ice = tmp_sols(:,:,2) … … 1947 2201 wri_rriv = cpl_rriv(:,:) 1948 2202 wri_rcoa = cpl_rcoa(:,:) 1949 DO j = 1, jjm + 1 1950 wri_calv(:,j) = sum(cpl_rlic(:,j)) / iim 1951 enddo 1952 2203 2204 !ym !! ATTENTION ICI 2205 2206 !ym DO j = 1, jjm + 1 2207 !ym wri_calv(:,j) = sum(cpl_rlic(:,j)) / iim 2208 !ym enddo 2209 2210 !Essai OM+JLD : ca marche !!!! (17 mars 2006) 2211 tamp_srf(:,:,3)=0. 2212 CALL gath2cpl( pctsrf(1,is_lic), tamp_srf(1,1,3), klon, klon, iim, jjphy_nb, tamp_ind) 2213 2214 !YM pour retrouver resultat avant tamp_srf(:,3)=1. 2215 2216 DO j = 1, jjphy_nb 2217 wri_calv(:,j) = DOT_PRODUCT (cpl_rlic(1:iim,j), tamp_srf(1:iim,j,3)) / REAL(iim) 2218 ENDDO 2219 2220 !ym wri_calv(:,:)=0. 2221 !ym DO j = 1, jjphy_nb 2222 !ym wri_calv(:,j) = sum(cpl_rlic(:,j))/iim 2223 !ym enddo 2224 2225 IF (.NOT. monocpu) THEN 2226 if (phy_rank /= 0) then 2227 #ifdef CPP_PARA 2228 call MPI_RECV(Up,1,MPI_REAL8,phy_rank-1,1234,COMM_LMDZ,status,ierr) 2229 call MPI_SEND(wri_calv(1,1),1,MPI_REAL8,phy_rank-1,1234,COMM_LMDZ,ierr) 2230 #endif 2231 endif 2232 2233 if (phy_rank /= phy_size-1) then 2234 #ifdef CPP_PARA 2235 call MPI_SEND(wri_calv(1,jjphy_nb),1,MPI_REAL8,phy_rank+1,1234,COMM_LMDZ,ierr) 2236 call MPI_RECV(down,1,MPI_REAL8,phy_rank+1,1234,COMM_LMDZ,status,ierr) 2237 #endif 2238 endif 2239 2240 if (phy_rank /=0 .and. iiphy_begin /=1) then 2241 Up=Up+wri_calv(iim,1) 2242 wri_calv(:,1)=Up 2243 endif 2244 2245 if (phy_rank /=phy_size-1 .and. iiphy_end /= iim) then 2246 Down=Down+wri_calv(1,jjphy_nb) 2247 wri_calv(:,jjphy_nb)=Down 2248 endif 2249 ENDIF 2250 1953 2251 where (tamp_zmasq /= 1.) 1954 2252 deno = tamp_srf(:,:,1) + tamp_srf(:,:,2) … … 1969 2267 ! wri_calv = coeff_iceberg * cte_flux_iceberg / (num_antarctic * surf_maille) 1970 2268 ! 1971 ! on passe les coordonnées de la grille 1972 ! 1973 1974 CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon) 1975 CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat) 1976 1977 DO i = 1, iim 1978 tmp_lon(i,1) = rlon(i+1) 1979 tmp_lon(i,jjm + 1) = rlon(i+1) 1980 ENDDO 2269 ! on passe les coordonn�s de la grille 2270 ! 2271 2272 !ym CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlon,tmp_lon) 2273 !ym CALL gr_fi_ecrit(1,klon,iim,jjm+1,rlat,tmp_lat) 2274 2275 CALL phy2dyn(rlon,tmp_lon,1) 2276 CALL phy2dyn(rlat,tmp_lat,1) 2277 2278 !ym DO i = 1, iim 2279 !ym tmp_lon(i,1) = rlon(i+1) 2280 !ym tmp_lon(i,jjm + 1) = rlon(i+1) 2281 !ym ENDDO 2282 1981 2283 ! 1982 2284 ! sortie netcdf des champs pour le changement de repere 1983 2285 ! 1984 ndexct(:)=0 1985 CALL histwrite(nidct,'tauxe',itau_w,wri_taux,iim*(jjm+1),ndexct) 1986 CALL histwrite(nidct,'tauyn',itau_w,wri_tauy,iim*(jjm+1),ndexct) 1987 CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct) 1988 CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct) 1989 1990 ! 1991 ! calcul 3 coordonnées du vent 1992 ! 1993 CALL atm2geo (iim , jjm + 1, wri_taux, wri_tauy, tmp_lon, tmp_lat, & 2286 IF (monocpu) THEN 2287 ndexct(:)=0 2288 CALL histwrite(nidct,'tauxe',itau_w,wri_taux,iim*(jjm+1),ndexct) 2289 CALL histwrite(nidct,'tauyn',itau_w,wri_tauy,iim*(jjm+1),ndexct) 2290 CALL histwrite(nidct,'tmp_lon',itau_w,tmp_lon,iim*(jjm+1),ndexct) 2291 CALL histwrite(nidct,'tmp_lat',itau_w,tmp_lat,iim*(jjm+1),ndexct) 2292 ENDIF 2293 ! 2294 ! calcul 3 coordonn�s du vent 2295 ! 2296 CALL atm2geo (iim , jjphy_nb, wri_taux, wri_tauy, tmp_lon, tmp_lat, & 1994 2297 & wri_tauxx, wri_tauyy, wri_tauzz ) 1995 2298 ! … … 1997 2300 ! envoi au coupleur 1998 2301 ! 2302 IF (monocpu) THEN 1999 2303 CALL histwrite(nidct,cl_writ(8),itau_w,wri_sol_ice,iim*(jjm+1),ndexct) 2000 2304 CALL histwrite(nidct,cl_writ(9),itau_w,wri_sol_sea,iim*(jjm+1),ndexct) … … 2019 2323 ! -- LOOP 2020 2324 CALL histsync(nidct) 2325 ENDIF 2021 2326 ! pas utile IF (lafin) CALL histclo(nidct) 2022 2327 #ifdef CPP_COUPLE 2023 2328 #ifdef CPP_PSMILE 2024 2329 il_time_secs=(itime-1)*dtime 2025 2330 2026 2331 CALL intocpl(il_time_secs, iim, jjm+1, wri_sol_ice, wri_sol_sea, wri_nsol_ice,& 2027 2332 & wri_nsol_sea, wri_fder_ice, wri_evap_ice, wri_evap_sea, wri_rain, & … … 2080 2385 ! 2081 2386 if (nisurf == is_oce) then 2082 call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jj m, knindex)2387 call cpl2gath(read_sst, tsurf_new, klon, knon,iim,jjphy_nb, knindex) 2083 2388 else if (nisurf == is_sic) then 2084 call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jj m, knindex)2085 call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jj m, knindex)2389 call cpl2gath(read_sit, tsurf_new, klon, knon,iim,jjphy_nb, knindex) 2390 call cpl2gath(read_alb_sic, alb_new, klon, knon,iim,jjphy_nb, knindex) 2086 2391 endif 2087 2392 pctsrf_new(:,nisurf) = pctsrf_sav(:,nisurf) 2088 2393 2394 if (mod(itime, nexca) == -1) then 2395 tmp_field=0. 2396 do i = 1, knon 2397 ig = knindex(i) 2398 tmp_field(ig) = 1. 2399 enddo 2400 call WriteField_phy('knindex',tmp_field,1) 2401 2402 tmp_field=0. 2403 do i = 1, knon 2404 ig = knindex(i) 2405 tmp_field(ig) = tsurf_new(i) 2406 enddo 2407 call WriteField_phy('tsurf_new',tmp_field,1) 2408 2409 tmp_field=0. 2410 do i = 1, knon 2411 ig = knindex(i) 2412 tmp_field(ig) = alb_new(i) 2413 enddo 2414 call WriteField_phy('alb_new',tmp_field,1) 2415 2416 ! tmp_field=0. 2417 ! do i = 1, knon 2418 ! ig = knindex(i) 2419 ! tmp_field(ig) = pctsrf_new(i,nisurf) 2420 ! enddo 2421 call WriteField_phy('pctsrf_new', pctsrf_new(:,nisurf),1) 2422 endif 2423 !ym do j=1,jjphy_nb 2424 !ym do i=1,iim 2425 !ym print *,phy_rank,'read_sst(',i,',',j,')=',read_sst(i,j) 2426 !ym enddo 2427 !ym enddo 2428 2429 !ym do i=1,knon 2430 !ym print *,phy_rank,'tsurf_new(',i,')=',tsurf_new(i) 2431 !ym enddo 2089 2432 ! if (lafin) call quitcpl 2090 2433 … … 2316 2659 ! 2317 2660 SUBROUTINE interfoce_lim(itime, dtime, jour, & 2318 & klon , nisurf, knon, knindex, &2661 & klon_xx, nisurf, knon, knindex, & 2319 2662 & debut, & 2320 & lmt_sst, pctsrf_new) 2663 & lmt_sst_p, pctsrf_new_p) 2664 2665 USE dimphy,klon=>klon2,klon2=>klon 2666 2667 #include "indicesol.inc" 2321 2668 2322 2669 ! Cette routine sert d'interface entre le modele atmospherique et un fichier … … 2345 2692 real , intent(IN) :: dtime 2346 2693 integer, intent(IN) :: jour 2694 integer, intent(in) :: klon_xx 2347 2695 integer, intent(IN) :: nisurf 2348 2696 integer, intent(IN) :: knon 2349 integer, intent(IN) :: klon 2350 integer, dimension(klon), intent(in) :: knindex 2697 integer, dimension(klon2), intent(in) :: knindex 2351 2698 logical, intent(IN) :: debut 2352 2699 2353 2700 ! Parametres de sortie 2354 real, intent(out), dimension(klon) :: lmt_sst 2355 real, intent(out), dimension(klon,nbsrf) :: pctsrf_new 2701 real, intent(out), dimension(klon2) :: lmt_sst_p 2702 real, intent(out), dimension(klon2,nbsrf) :: pctsrf_new_p 2703 2704 ! real, dimension(klon) :: lmt_sst 2705 real, dimension(klon,nbsrf) :: pctsrf_new 2356 2706 2357 2707 ! Variables locales … … 2359 2709 INTEGER,save :: lmt_pas ! frequence de lecture des conditions limites 2360 2710 ! (en pas de physique) 2711 !$OMP THREADPRIVATE(lmt_pas) 2361 2712 logical,save :: deja_lu ! pour indiquer que le jour a lire a deja 2362 2713 ! lu pour une surface precedente 2714 !$OMP THREADPRIVATE(deja_lu) 2363 2715 integer,save :: jour_lu 2716 !$OMP THREADPRIVATE(jour_lu) 2364 2717 integer :: ierr 2365 2718 character (len = 20) :: modname = 'interfoce_lim' 2366 2719 character (len = 80) :: abort_message 2367 2720 character (len = 20),save :: fich ='limit.nc' 2721 !$OMP THREADPRIVATE(fich) 2368 2722 logical, save :: newlmt = .TRUE. 2723 !$OMP THREADPRIVATE(newlmt) 2369 2724 logical, save :: check = .FALSE. 2725 !$OMP THREADPRIVATE(check) 2370 2726 ! Champs lus dans le fichier de CL 2371 real, allocatable , save, dimension(:) :: sst_lu, rug_lu, nat_lu 2372 real, allocatable , save, dimension(:,:) :: pct_tmp 2727 real, allocatable , save, dimension(:) :: sst_lu_p 2728 !$OMP THREADPRIVATE(sst_lu_p) 2729 real, allocatable , save, dimension(:) :: sst_lu_mpi 2730 2731 real, allocatable , save, dimension(:,:) :: pct_tmp_p 2732 !$OMP THREADPRIVATE(pct_tmp_p) 2733 real, allocatable , save, dimension(:,:) :: pct_tmp_mpi 2734 real, dimension(klon,nbsrf) :: pct_tmp 2735 real, dimension(klon) :: sst_lu 2736 real, dimension(klon) :: nat_lu 2373 2737 ! 2374 2738 ! quelques variables pour netcdf … … 2378 2742 integer, dimension(2) :: start, epais 2379 2743 ! 2380 ! Fin d éclaration2381 ! 2382 2383 if (debut .and. .not. allocated(sst_lu )) then2744 ! Fin d�laration 2745 ! 2746 2747 if (debut .and. .not. allocated(sst_lu_p)) then 2384 2748 lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour 2385 2749 jour_lu = jour - 1 2386 allocate(sst_lu(klon)) 2387 allocate(nat_lu(klon)) 2388 allocate(pct_tmp(klon,nbsrf)) 2750 allocate(sst_lu_p(klon_omp)) 2751 allocate(pct_tmp_p(klon_omp,nbsrf)) 2389 2752 endif 2390 2753 … … 2399 2762 ! Ouverture du fichier 2400 2763 ! 2764 !$OMP MASTER 2765 if (.not. allocated(sst_lu_mpi)) allocate(sst_lu_mpi(klon_mpi)) 2766 if (.not. allocated(pct_tmp_mpi)) allocate(pct_tmp_mpi(klon_mpi,nbsrf)) 2767 2768 if (phy_rank==0) then 2769 2401 2770 fich = trim(fich) 2402 2771 ierr = NF_OPEN (fich, NF_NOWRITE,nid) … … 2538 2907 ! 2539 2908 ierr = NF_CLOSE(nid) 2540 deja_lu = .true. 2541 jour_lu = jour 2542 endif 2909 endif ! phyrank 2543 2910 ! 2544 2911 ! Recopie des variables dans les champs de sortie 2545 2912 ! 2546 lmt_sst = 999999999. 2913 call ScatterField(sst_lu,sst_lu_mpi,1) 2914 call ScatterField(pct_tmp(:,is_oce),pct_tmp_mpi(:,is_oce),1) 2915 call ScatterField(pct_tmp(:,is_sic),pct_tmp_mpi(:,is_sic),1) 2916 !$OMP END MASTER 2917 !$OMP BARRIER 2918 call ScatterField_omp(sst_lu_mpi,sst_lu_p,1) 2919 call ScatterField_omp(pct_tmp_mpi(:,is_oce),pct_tmp_p(:,is_oce),1) 2920 call ScatterField_omp(pct_tmp_mpi(:,is_sic),pct_tmp_p(:,is_sic),1) 2921 deja_lu = .true. 2922 jour_lu = jour 2923 endif 2924 2925 lmt_sst_p = 999999999. 2926 2547 2927 do ii = 1, knon 2548 lmt_sst (ii) = sst_lu(knindex(ii))2928 lmt_sst_p(ii) = sst_lu_p(knindex(ii)) 2549 2929 enddo 2550 2930 2551 pctsrf_new(:,is_oce) = pct_tmp(:,is_oce) 2552 pctsrf_new(:,is_sic) = pct_tmp(:,is_sic) 2931 do ii=1,klon2 2932 pctsrf_new_p(ii,is_oce)=pct_tmp_p(ii,is_oce) 2933 pctsrf_new_p(ii,is_sic)=pct_tmp_p(ii,is_sic) 2934 enddo 2935 2553 2936 2554 2937 END SUBROUTINE interfoce_lim … … 2558 2941 ! 2559 2942 SUBROUTINE interfsur_lim(itime, dtime, jour, & 2560 & klon , nisurf, knon, knindex, &2943 & klon_xx, nisurf, knon, knindex, & 2561 2944 & debut, & 2562 & lmt_alb, lmt_rug) 2945 & lmt_alb_p, lmt_rug_p) 2946 2947 USE dimphy,klon=>klon2,klon2=>klon 2563 2948 2564 2949 ! Cette routine sert d'interface entre le modele atmospherique et un fichier … … 2580 2965 ! lmt_sst SST lues dans le fichier de CL 2581 2966 ! lmt_alb Albedo lu 2582 ! lmt_rug longueur de rugosit élue2967 ! lmt_rug longueur de rugosit�lue 2583 2968 ! pctsrf_new sous-maille fractionnelle 2584 2969 ! … … 2591 2976 integer, intent(IN) :: nisurf 2592 2977 integer, intent(IN) :: knon 2593 integer, intent(IN) :: klon 2594 integer, dimension(klon ), intent(in) :: knindex2978 integer, intent(IN) :: klon_xx 2979 integer, dimension(klon2), intent(in) :: knindex 2595 2980 logical, intent(IN) :: debut 2596 2981 2597 2982 ! Parametres de sortie 2598 real, intent(out), dimension(klon) :: lmt_alb 2599 real, intent(out), dimension(klon) :: lmt_rug 2983 real, intent(out), dimension(klon2) :: lmt_alb_p 2984 real, intent(out), dimension(klon2) :: lmt_rug_p 2985 2986 ! real, dimension(klon) :: lmt_alb 2987 ! real, dimension(klon) :: lmt_rug 2600 2988 2601 2989 ! Variables locales … … 2603 2991 integer,save :: lmt_pas ! frequence de lecture des conditions limites 2604 2992 ! (en pas de physique) 2993 !$OMP THREADPRIVATE(lmt_pas) 2605 2994 logical,save :: deja_lu_sur! pour indiquer que le jour a lire a deja 2606 2995 ! lu pour une surface precedente 2996 !$OMP THREADPRIVATE(deja_lu_sur) 2607 2997 integer,save :: jour_lu_sur 2998 !$OMP THREADPRIVATE(jour_lu_sur) 2608 2999 integer :: ierr 2609 3000 character (len = 20) :: modname = 'interfsur_lim' 2610 3001 character (len = 80) :: abort_message 2611 3002 character (len = 20),save :: fich ='limit.nc' 3003 !$OMP THREADPRIVATE(fich) 2612 3004 logical,save :: newlmt = .false. 3005 !$OMP THREADPRIVATE(newlmt) 2613 3006 logical,save :: check = .false. 3007 !$OMP THREADPRIVATE(check) 2614 3008 ! Champs lus dans le fichier de CL 2615 real, allocatable , save, dimension(:) :: alb_lu, rug_lu 3009 real, allocatable , save, dimension(:) :: alb_lu_p, rug_lu_p 3010 !$OMP THREADPRIVATE(alb_lu_p, rug_lu_p) 3011 real, allocatable , save, dimension(:) :: alb_lu_mpi, rug_lu_mpi 3012 real, dimension(klon) :: alb_lu, rug_lu 2616 3013 ! 2617 3014 ! quelques variables pour netcdf … … 2619 3016 #include "netcdf.inc" 2620 3017 integer ,save :: nid, nvarid 3018 !$OMP THREADPRIVATE(nid, nvarid) 2621 3019 integer, dimension(2),save :: start, epais 2622 ! 2623 ! Fin déclaration 2624 ! 2625 3020 !$OMP THREADPRIVATE(start, epais) 3021 ! 3022 ! Fin d�laration 3023 ! 3024 2626 3025 if (debut) then 2627 3026 lmt_pas = nint(86400./dtime * 1.0) ! pour une lecture une fois par jour 2628 3027 jour_lu_sur = jour - 1 2629 allocate(alb_lu (klon))2630 allocate(rug_lu (klon))3028 allocate(alb_lu_p(klon_omp)) 3029 allocate(rug_lu_p(klon_omp)) 2631 3030 endif 2632 3031 … … 2639 3038 ! Tester d'abord si c'est le moment de lire le fichier 2640 3039 if (mod(itime-1, lmt_pas) == 0 .and. .not. deja_lu_sur) then 3040 3041 !$OMP MASTER 3042 if (.not. allocated(alb_lu_mpi)) allocate(alb_lu_mpi(klon_mpi)) 3043 if (.not. allocated(rug_lu_mpi)) allocate(rug_lu_mpi(klon_mpi)) 3044 if (phy_rank==0) then 2641 3045 ! 2642 3046 ! Ouverture du fichier … … 2675 3079 endif 2676 3080 ! 2677 ! Lecture rugosité 2678 ! 3081 ! Lecture rugosit�! 2679 3082 ierr = NF_INQ_VARID(nid, 'RUG', nvarid) 2680 3083 if (ierr /= NF_NOERR) then … … 2696 3099 ! 2697 3100 ierr = NF_CLOSE(nid) 3101 3102 3103 endif !! phyrank 3104 3105 call ScatterField(alb_lu,alb_lu_mpi,1) 3106 call ScatterField(rug_lu,rug_lu_mpi,1) 3107 !$OMP END MASTER 3108 !$OMP BARRIER 3109 3110 call ScatterField_omp(alb_lu_mpi,alb_lu_p,1) 3111 call ScatterField_omp(rug_lu_mpi,rug_lu_p,1) 3112 2698 3113 deja_lu_sur = .true. 2699 3114 jour_lu_sur = jour 3115 3116 2700 3117 endif 3118 2701 3119 ! 2702 3120 ! Recopie des variables dans les champs de sortie … … 2704 3122 !!$ lmt_alb(:) = 0.0 2705 3123 !!$ lmt_rug(:) = 0.0 2706 lmt_alb(:) = 999999. 2707 lmt_rug(:) = 999999. 3124 3125 lmt_alb_p(:) = 999999. 3126 lmt_rug_p(:) = 999999. 2708 3127 DO ii = 1, knon 2709 lmt_alb (ii) = alb_lu(knindex(ii))2710 lmt_rug (ii) = rug_lu(knindex(ii))3128 lmt_alb_p(ii) = alb_lu_p(knindex(ii)) 3129 lmt_rug_p(ii) = rug_lu_p(knindex(ii)) 2711 3130 enddo 3131 2712 3132 2713 3133 END SUBROUTINE interfsur_lim … … 2723 3143 & petAcoef, peqAcoef, petBcoef, peqBcoef, & 2724 3144 & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l) 2725 3145 USE dimphy,only : omp_rank 2726 3146 ! Cette routine calcule les fluxs en h et q a l'interface et eventuellement 2727 3147 ! une temperature de surface (au cas ou ok_veget = false) … … 2761 3181 #include "FCTTRE.inc" 2762 3182 #include "indicesol.inc" 3183 #include "YOMCST.inc" 2763 3184 2764 3185 ! Parametres d'entree … … 2794 3215 ! 2795 3216 logical, save :: check = .false. 3217 !$OMP THREADPRIVATE(check) 2796 3218 character (len = 20) :: modname = 'calcul_fluxs' 2797 3219 logical, save :: fonte_neige = .false. 3220 !$OMP THREADPRIVATE(fonte_neige) 2798 3221 real, save :: max_eau_sol = 150.0 3222 !$OMP THREADPRIVATE(max_eau_sol) 2799 3223 character (len = 80) :: abort_message 2800 3224 logical,save :: first = .true.,second=.false. 3225 !$OMP THREADPRIVATE(first,second) 2801 3226 2802 3227 if (check) write(*,*)'Entree ', modname,' surface = ',nisurf … … 2951 3376 !######################################################################### 2952 3377 ! 2953 SUBROUTINE gath2cpl(champ_in, champ_out, klon, knon, iim, jjm, knindex) 2954 3378 SUBROUTINE gath2cpl(champ_in, champ_out, klon, knon, iim, jmp1, knindex) 3379 use dimphy, only: liste_i,liste_j,jjphy_begin,jjphy_nb,phy_rank,phy_size 3380 implicit none 3381 2955 3382 ! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer 2956 3383 ! au coupleur. … … 2968 3395 ! 2969 3396 ! input 2970 integer :: klon, knon, iim, j jm3397 integer :: klon, knon, iim, jmp1 2971 3398 real, dimension(klon) :: champ_in 2972 3399 integer, dimension(klon) :: knindex 2973 3400 ! output 2974 real, dimension(iim,j jm+1) :: champ_out3401 real, dimension(iim,jmp1) :: champ_out 2975 3402 ! local 2976 3403 integer :: i, ig, j … … 2982 3409 tamp(ig) = champ_in(i) 2983 3410 enddo 2984 ig = 1 2985 champ_out(:,1) = tamp(ig) 2986 do j = 2, jjm 2987 do i = 1, iim 2988 ig = ig + 1 2989 champ_out(i,j) = tamp(ig) 2990 enddo 3411 3412 !ym ig = 1 3413 !ym champ_out(:,1) = tamp(ig) 3414 !ym do j = 2, jjm 3415 !ym do i = 1, iim 3416 !ym ig = ig + 1 3417 !ym champ_out(i,j) = tamp(ig) 3418 !ym enddo 3419 !ym enddo 3420 !ym ig = ig + 1 3421 !ym champ_out(:,jjm+1) = tamp(ig) 3422 3423 do ig=1,klon 3424 i=liste_i(ig) 3425 j=liste_j(ig)-jjphy_begin+1 3426 champ_out(i,j)=tamp(ig) 2991 3427 enddo 2992 ig = ig + 1 2993 champ_out(:,jjm+1) = tamp(ig) 3428 3429 if (phy_rank==0) champ_out(:,1)=tamp(1) 3430 if (phy_rank==phy_size-1) champ_out(:,jjphy_nb)=tamp(klon) 2994 3431 2995 3432 END SUBROUTINE gath2cpl … … 2997 3434 !######################################################################### 2998 3435 ! 2999 SUBROUTINE cpl2gath(champ_in, champ_out, klon, knon, iim, jjm, knindex) 3000 3436 SUBROUTINE cpl2gath(champ_in, champ_out, klon, knon, iim, jmp1, knindex) 3437 use dimphy, only : liste_i, liste_j, jjphy_begin 3438 implicit none 3001 3439 ! Cette routine ecrit un champ 'gathered' sur la grille 2D pour le passer 3002 3440 ! au coupleur. … … 3014 3452 ! 3015 3453 ! input 3016 integer :: klon, knon, iim, j jm3017 real, dimension(iim,j jm+1) :: champ_in3454 integer :: klon, knon, iim, jmp1 3455 real, dimension(iim,jmp1) :: champ_in 3018 3456 integer, dimension(klon) :: knindex 3019 3457 ! output … … 3024 3462 logical ,save :: check = .false. 3025 3463 3026 ig = 1 3027 tamp(ig) = champ_in(1,1) 3028 do j = 2, jjm 3029 do i = 1, iim 3030 ig = ig + 1 3031 tamp(ig) = champ_in(i,j) 3032 enddo 3464 !ym ig = 1 3465 !ym tamp(ig) = champ_in(1,1) 3466 !ym do j = 2, jjm 3467 !ym do i = 1, iim 3468 !ym ig = ig + 1 3469 !ym tamp(ig) = champ_in(i,j) 3470 !ym enddo 3471 !ym enddo 3472 !ym ig = ig + 1 3473 !ym tamp(ig) = champ_in(1,jjm+1) 3474 3475 do ig=1,klon 3476 i=liste_i(ig) 3477 j=liste_j(ig)-jjphy_begin+1 3478 tamp(ig)=champ_in(i,j) 3033 3479 enddo 3034 ig = ig + 1 3035 tamp(ig) = champ_in(1,jjm+1) 3036 3480 3037 3481 do i = 1, knon 3038 3482 ig = knindex(i) … … 3056 3500 3057 3501 REAL, DIMENSION(nvm),SAVE :: init, decay 3502 !$OMP THREADPRIVATE(init, decay) 3058 3503 REAL :: as 3059 3504 DATA init /0.55, 0.14, 0.18, 0.29, 0.15, 0.15, 0.14, 0./ … … 3091 3536 & petAcoef, peqAcoef, petBcoef, peqBcoef, & 3092 3537 & tsurf_new, evap, fluxlat, fluxsens, dflux_s, dflux_l, & 3093 & fqcalving,f fonte,run_off_lic_0)3538 & fqcalving,fqfonte,ffonte,run_off_lic_0) 3094 3539 3095 3540 ! Routine de traitement de la fonte de la neige dans le cas du traitement 3096 ! de sol simplifié 3097 ! 3541 ! de sol simplifi�! 3098 3542 ! LF 03/2001 3099 3543 ! input: … … 3125 3569 ! dflux_l derivee du flux de chaleur latente / Ts 3126 3570 ! in/out: 3127 ! run_off_lic_0 run off glacier du pas de temps pr écedent3571 ! run_off_lic_0 run off glacier du pas de temps pr�edent 3128 3572 ! 3129 3573 … … 3151 3595 ! Flux thermique utiliser pour fondre la neige 3152 3596 real, dimension(klon), intent(INOUT):: ffonte 3153 ! Flux d'eau "perdu e" par la surface et necessaire pour que limiter la3154 ! hauteur de neige, en kg/m2/s 3155 real, dimension(klon), intent(INOUT):: fqcalving3597 ! Flux d'eau "perdu" par la surface et necessaire pour que limiter la 3598 ! hauteur de neige, en kg/m2/s. Et flux d'eau de fonte de la calotte. 3599 REAL, DIMENSION(klon), INTENT(INOUT):: fqcalving, fqfonte 3156 3600 real, dimension(klon), intent(INOUT):: run_off_lic_0 3157 3601 ! Variables locales … … 3180 3624 ! 3181 3625 logical, save :: check = .FALSE. 3626 !$OMP THREADPRIVATE(check) 3182 3627 character (len = 20) :: modname = 'fonte_neige' 3183 3628 logical, save :: neige_fond = .false. 3629 !$OMP THREADPRIVATE(neige_fond) 3184 3630 real, save :: max_eau_sol = 150.0 3631 !$OMP THREADPRIVATE(max_eau_sol) 3185 3632 character (len = 80) :: abort_message 3186 3633 logical,save :: first = .true.,second=.false. 3634 !$OMP THREADPRIVATE(first,second) 3187 3635 real :: coeff_rel 3188 3636 #include "FCTTRE.inc" … … 3274 3722 fq_fonte = MIN( MAX((tsurf_new(i)-RTT )/chasno,0.0),snow(i)) 3275 3723 ffonte(i) = fq_fonte * RLMLT/dtime 3724 fqfonte(i) = fq_fonte/dtime 3276 3725 snow(i) = max(0., snow(i) - fq_fonte) 3277 3726 bil_eau_s(i) = bil_eau_s(i) + fq_fonte … … 3282 3731 fq_fonte = MAX((tsurf_new(i)-RTT )/chaice,0.0) 3283 3732 ffonte(i) = ffonte(i) + fq_fonte * RLMLT/dtime 3284 bil_eau_s(i) = bil_eau_s(i) + fq_fonte 3733 IF ( ok_lic_melt ) THEN 3734 fqfonte(i) = fqfonte(i) + fq_fonte/dtime 3735 bil_eau_s(i) = bil_eau_s(i) + fq_fonte 3736 ENDIF 3285 3737 tsurf_new(i) = RTT 3286 3738 ENDIF … … 3300 3752 & (1. - coeff_rel) * run_off_lic_0(i) 3301 3753 run_off_lic_0(i) = run_off_lic(i) 3302 run_off_lic(i) = run_off_lic(i) + bil_eau_s(i)/dtime3754 run_off_lic(i) = run_off_lic(i) + fqfonte(i)/dtime 3303 3755 endif 3304 3756 enddo
Note: See TracChangeset
for help on using the changeset viewer.
