Changeset 3605 for LMDZ6/branches/Ocean_skin/libf/phylmd/phyaqua_mod.F90
- Timestamp:
- Nov 21, 2019, 4:43:45 PM (5 years ago)
- Location:
- LMDZ6/branches/Ocean_skin
- Files:
-
- 2 edited
-
. (modified) (1 prop)
-
libf/phylmd/phyaqua_mod.F90 (modified) (35 diffs, 1 prop)
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Ocean_skin
-
LMDZ6/branches/Ocean_skin/libf/phylmd/phyaqua_mod.F90
-
Property
svn:keywords
set to
Id
r3401 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE phyaqua_mod 2 5 ! Routines complementaires pour la physique planetaire. … … 5 8 CONTAINS 6 9 7 SUBROUTINE iniaqua(nlon, 10 SUBROUTINE iniaqua(nlon,year_len,iflag_phys) 8 11 9 12 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 29 32 USE indice_sol_mod 30 33 USE nrtype, ONLY: pi 31 USE ioipsl 34 ! USE ioipsl 35 USE mod_phys_lmdz_para, ONLY: is_master 36 USE mod_phys_lmdz_transfert_para, ONLY: bcast 37 USE mod_grid_phy_lmdz 38 USE ioipsl_getin_p_mod, ONLY : getin_p 39 USE phys_cal_mod , ONLY: calend, year_len_phy => year_len 32 40 IMPLICIT NONE 33 41 … … 36 44 include "dimsoil.h" 37 45 38 INTEGER, INTENT (IN) :: nlon, iflag_phys46 INTEGER, INTENT (IN) :: nlon, year_len, iflag_phys 39 47 ! IM ajout latfi, lonfi 40 48 ! REAL, INTENT (IN) :: lonfi(nlon), latfi(nlon) … … 57 65 INTEGER it, unit, i, k, itap 58 66 59 REAL airefi, zcufi, zcvfi60 61 67 REAL rugos, albedo 62 68 REAL tsurf … … 64 70 REAL qsol_f 65 71 REAL rugsrel(nlon) 66 ! real zmea(nlon),zstd(nlon),zsig(nlon)67 ! real zgam(nlon),zthe(nlon),zpic(nlon),zval(nlon)68 ! real rlon(nlon),rlat(nlon)69 72 LOGICAL alb_ocean 70 ! integer demih_pas71 73 72 74 CHARACTER *80 ans, file_forctl, file_fordat, file_start … … 74 76 CHARACTER *2 cnbl 75 77 76 REAL phy_nat(nlon, 360)77 REAL phy_alb(nlon, 360)78 REAL phy_sst(nlon, 360)79 REAL phy_bil(nlon, 360)80 REAL phy_rug(nlon, 360)81 REAL phy_ice(nlon, 360)82 REAL phy_fter(nlon, 360)83 REAL phy_foce(nlon, 360)84 REAL phy_fsic(nlon, 360)85 REAL phy_flic(nlon, 360)78 REAL phy_nat(nlon, year_len) 79 REAL phy_alb(nlon, year_len) 80 REAL phy_sst(nlon, year_len) 81 REAL phy_bil(nlon, year_len) 82 REAL phy_rug(nlon, year_len) 83 REAL phy_ice(nlon, year_len) 84 REAL phy_fter(nlon, year_len) 85 REAL phy_foce(nlon, year_len) 86 REAL phy_fsic(nlon, year_len) 87 REAL phy_flic(nlon, year_len) 86 88 87 89 INTEGER, SAVE :: read_climoz = 0 ! read ozone climatology 88 89 ! intermediate variables to use getin (need to be "save" to be shared by 90 ! all threads) 91 INTEGER, SAVE :: nbapp_rad_omp 92 REAL, SAVE :: co2_ppm_omp, solaire_omp 93 LOGICAL, SAVE :: alb_ocean_omp 94 REAL, SAVE :: rugos_omp 90 !$OMP THREADPRIVATE(read_climoz) 91 95 92 ! ------------------------------------------------------------------------- 96 93 ! declaration pour l'appel a phyredem … … 117 114 INTEGER l, ierr, aslun 118 115 119 ! REAL longitude, latitude120 116 REAL paire 121 117 122 ! DATA latitude, longitude/48., 0./ 118 ! Local 119 CHARACTER (LEN=20) :: modname='phyaqua' 120 CHARACTER (LEN=80) :: abort_message 121 123 122 124 123 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 130 129 ! ------------------------------- 131 130 131 !IF (calend .EQ. "earth_360d") Then 132 year_len_phy = year_len 133 !END IF 134 135 if (year_len.ne.360) then 136 write (*,*) year_len 137 write (*,*) 'iniaqua: 360 day calendar is required !' 138 stop 139 endif 132 140 133 141 type_aqua = iflag_phys/100 … … 137 145 IF (klon/=nlon) THEN 138 146 WRITE (*, *) 'iniaqua: klon=', klon, ' nlon=', nlon 139 STOP 'probleme de dimensions dans iniaqua' 147 abort_message= 'probleme de dimensions dans iniaqua' 148 CALL abort_physic(modname,abort_message,1) 140 149 END IF 141 150 CALL phys_state_var_init(read_climoz) … … 148 157 time = 0. 149 158 150 ! IM ajout latfi, lonfi151 ! rlatd = latfi152 ! rlond = lonfi153 ! rlat = rlatd*180./pi154 ! rlon = rlond*180./pi155 156 159 ! ----------------------------------------------------------------------- 157 160 ! initialisations de la physique … … 160 163 day_ini = day_ref 161 164 day_end = day_ini + ndays 162 ! airefi = 1. 163 ! zcufi = 1. 164 ! zcvfi = 1. 165 !$OMP MASTER 166 nbapp_rad_omp = 24 167 CALL getin('nbapp_rad', nbapp_rad_omp) 168 !$OMP END MASTER 169 !$OMP BARRIER 170 nbapp_rad = nbapp_rad_omp 165 166 nbapp_rad = 24 167 CALL getin_p('nbapp_rad', nbapp_rad) 171 168 172 169 ! --------------------------------------------------------------------- … … 175 172 ! Initialisations des constantes 176 173 ! Ajouter les manquants dans planete.def... (albedo etc) 177 !$OMP MASTER 178 co2_ppm_omp = 348. 179 CALL getin('co2_ppm', co2_ppm_omp) 180 solaire_omp = 1365. 181 CALL getin('solaire', solaire_omp) 174 co2_ppm = 348. 175 CALL getin_p('co2_ppm', co2_ppm) 176 177 solaire = 1365. 178 CALL getin_p('solaire', solaire) 179 182 180 ! CALL getin('albedo',albedo) ! albedo is set below, depending on 183 181 ! type_aqua 184 alb_ocean_omp = .TRUE. 185 CALL getin('alb_ocean', alb_ocean_omp) 186 !$OMP END MASTER 187 !$OMP BARRIER 188 co2_ppm = co2_ppm_omp 182 alb_ocean = .TRUE. 183 CALL getin_p('alb_ocean', alb_ocean) 184 189 185 WRITE (*, *) 'iniaqua: co2_ppm=', co2_ppm 190 solaire = solaire_omp191 186 WRITE (*, *) 'iniaqua: solaire=', solaire 192 alb_ocean = alb_ocean_omp193 187 WRITE (*, *) 'iniaqua: alb_ocean=', alb_ocean 194 188 … … 226 220 END IF 227 221 228 !$OMP MASTER 229 rugos_omp = rugos 230 CALL getin('rugos', rugos_omp) 231 !$OMP END MASTER 232 !$OMP BARRIER 233 rugos = rugos_omp 222 CALL getin_p('rugos', rugos) 223 234 224 WRITE (*, *) 'iniaqua: rugos=', rugos 235 225 zmasq(:) = pctsrf(:, is_ter) … … 246 236 ! endif !alb_ocean 247 237 248 DO i = 1, 360238 DO i = 1, year_len 249 239 ! IM Terraplanete phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2 250 240 ! IM ajout calcul profil sst selon le cas considere (cf. FBr) … … 262 252 CALL profil_sst(nlon, latitude, type_profil, phy_sst) 263 253 264 CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, & 265 phy_fter, phy_foce, phy_flic, phy_fsic) 266 254 IF (grid_type==unstructured) THEN 255 CALL writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, & 256 phy_fter, phy_foce, phy_flic, phy_fsic) 257 ELSE 258 259 CALL writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, phy_ice, & 260 phy_fter, phy_foce, phy_flic, phy_fsic) 261 ENDIF 267 262 268 263 ! --------------------------------------------------------------------- … … 339 334 PRINT *, 'iniaqua: before phyredem' 340 335 341 pbl_tke(:,:,:) =1.e-8336 pbl_tke(:,:,:) = 1.e-8 342 337 falb1 = albedo 343 338 falb2 = albedo … … 349 344 wake_deltaq = 0. 350 345 wake_s = 0. 351 wake_dens = 0. 346 wake_dens = 0. 352 347 wake_cstar = 0. 353 348 wake_pe = 0. … … 360 355 alp_bl =0. 361 356 treedrg(:,:,:)=0. 357 358 u10m = 0. 359 v10m = 0. 360 361 ql_ancien = 0. 362 qs_ancien = 0. 363 u_ancien = 0. 364 v_ancien = 0. 365 prw_ancien = 0. 366 prlw_ancien = 0. 367 prsw_ancien = 0. 368 369 ale_wake = 0. 370 ale_bl_stat = 0. 371 372 373 !ym error : the sub surface dimension is the third not second : forgotten for iniaqua 374 ! falb_dir(:,is_ter,:)=0.08; falb_dir(:,is_lic,:)=0.6 375 ! falb_dir(:,is_oce,:)=0.5; falb_dir(:,is_sic,:)=0.6 376 falb_dir(:,:,is_ter)=0.08; falb_dir(:,:,is_lic)=0.6 377 falb_dir(:,:,is_oce)=0.5; falb_dir(:,:,is_sic)=0.6 378 379 !ym falb_dif has been forgotten, initialize with defaukt value found in phyetat0 or 0 ? 380 !ym probably the uninitialized value was 0 for standard (regular grid) case 381 falb_dif(:,:,:)=0 362 382 363 383 … … 488 508 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 489 509 490 SUBROUTINE writelim (klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, &510 SUBROUTINE writelim_unstruct(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, & 491 511 phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic) 492 512 493 USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_omp_root 494 USE mod_grid_phy_lmdz, ONLY: klon_glo 495 USE mod_phys_lmdz_transfert_para, ONLY: gather 513 USE mod_phys_lmdz_para, ONLY: is_omp_master, klon_mpi 514 USE mod_phys_lmdz_transfert_para, ONLY: gather_omp 515 #ifdef CPP_XIOS 516 USE xios 517 #endif 496 518 IMPLICIT NONE 519 497 520 include "netcdf.inc" 498 521 … … 509 532 REAL, INTENT (IN) :: phy_fsic(klon, 360) 510 533 511 REAL :: phy_glo(klon_glo, 360) ! temporary variable, to store phy_***(:) 534 REAL :: phy_mpi(klon_mpi, 360) ! temporary variable, to store phy_***(:) 535 ! on the whole physics grid 536 537 #ifdef CPP_XIOS 538 PRINT *, 'writelim: Ecriture du fichier limit' 539 540 CALL gather_omp(phy_foce, phy_mpi) 541 IF (is_omp_master) CALL xios_send_field('foce_limout',phy_mpi) 542 543 CALL gather_omp(phy_fsic, phy_mpi) 544 IF (is_omp_master) CALL xios_send_field('fsic_limout',phy_mpi) 545 546 CALL gather_omp(phy_fter, phy_mpi) 547 IF (is_omp_master) CALL xios_send_field('fter_limout',phy_mpi) 548 549 CALL gather_omp(phy_flic, phy_mpi) 550 IF (is_omp_master) CALL xios_send_field('flic_limout',phy_mpi) 551 552 CALL gather_omp(phy_sst, phy_mpi) 553 IF (is_omp_master) CALL xios_send_field('sst_limout',phy_mpi) 554 555 CALL gather_omp(phy_bil, phy_mpi) 556 IF (is_omp_master) CALL xios_send_field('bils_limout',phy_mpi) 557 558 CALL gather_omp(phy_alb, phy_mpi) 559 IF (is_omp_master) CALL xios_send_field('alb_limout',phy_mpi) 560 561 CALL gather_omp(phy_rug, phy_mpi) 562 IF (is_omp_master) CALL xios_send_field('rug_limout',phy_mpi) 563 #endif 564 END SUBROUTINE writelim_unstruct 565 566 567 568 SUBROUTINE writelim(klon, phy_nat, phy_alb, phy_sst, phy_bil, phy_rug, & 569 phy_ice, phy_fter, phy_foce, phy_flic, phy_fsic) 570 571 USE mod_phys_lmdz_para, ONLY: is_master 572 USE mod_grid_phy_lmdz, ONLY: klon_glo 573 USE mod_phys_lmdz_transfert_para, ONLY: gather 574 USE phys_cal_mod, ONLY: year_len 575 IMPLICIT NONE 576 include "netcdf.inc" 577 578 INTEGER, INTENT (IN) :: klon 579 REAL, INTENT (IN) :: phy_nat(klon, year_len) 580 REAL, INTENT (IN) :: phy_alb(klon, year_len) 581 REAL, INTENT (IN) :: phy_sst(klon, year_len) 582 REAL, INTENT (IN) :: phy_bil(klon, year_len) 583 REAL, INTENT (IN) :: phy_rug(klon, year_len) 584 REAL, INTENT (IN) :: phy_ice(klon, year_len) 585 REAL, INTENT (IN) :: phy_fter(klon, year_len) 586 REAL, INTENT (IN) :: phy_foce(klon, year_len) 587 REAL, INTENT (IN) :: phy_flic(klon, year_len) 588 REAL, INTENT (IN) :: phy_fsic(klon, year_len) 589 590 REAL :: phy_glo(klon_glo, year_len) ! temporary variable, to store phy_***(:) 512 591 ! on the whole physics grid 513 592 INTEGER :: k … … 522 601 INTEGER id_fter, id_foce, id_fsic, id_flic 523 602 524 IF (is_m pi_root .AND. is_omp_root) THEN603 IF (is_master) THEN 525 604 526 605 PRINT *, 'writelim: Ecriture du fichier limit' … … 615 694 616 695 ! write the 'times' 617 DO k = 1, 360696 DO k = 1, year_len 618 697 #ifdef NC_DOUBLE 619 698 ierr = nf_put_var1_double(nid, id_tim, k, dble(k)) … … 627 706 END DO 628 707 629 END IF ! of if (is_m pi_root.and.is_omp_root)708 END IF ! of if (is_master) 630 709 631 710 ! write the fields, after having collected them on master 632 711 633 712 CALL gather(phy_nat, phy_glo) 634 IF (is_m pi_root .AND. is_omp_root) THEN713 IF (is_master) THEN 635 714 #ifdef NC_DOUBLE 636 715 ierr = nf_put_var_double(nid, id_nat, phy_glo) … … 645 724 646 725 CALL gather(phy_sst, phy_glo) 647 IF (is_m pi_root .AND. is_omp_root) THEN726 IF (is_master) THEN 648 727 #ifdef NC_DOUBLE 649 728 ierr = nf_put_var_double(nid, id_sst, phy_glo) … … 658 737 659 738 CALL gather(phy_bil, phy_glo) 660 IF (is_m pi_root .AND. is_omp_root) THEN739 IF (is_master) THEN 661 740 #ifdef NC_DOUBLE 662 741 ierr = nf_put_var_double(nid, id_bils, phy_glo) … … 671 750 672 751 CALL gather(phy_alb, phy_glo) 673 IF (is_m pi_root .AND. is_omp_root) THEN752 IF (is_master) THEN 674 753 #ifdef NC_DOUBLE 675 754 ierr = nf_put_var_double(nid, id_alb, phy_glo) … … 684 763 685 764 CALL gather(phy_rug, phy_glo) 686 IF (is_m pi_root .AND. is_omp_root) THEN765 IF (is_master) THEN 687 766 #ifdef NC_DOUBLE 688 767 ierr = nf_put_var_double(nid, id_rug, phy_glo) … … 697 776 698 777 CALL gather(phy_fter, phy_glo) 699 IF (is_m pi_root .AND. is_omp_root) THEN778 IF (is_master) THEN 700 779 #ifdef NC_DOUBLE 701 780 ierr = nf_put_var_double(nid, id_fter, phy_glo) … … 710 789 711 790 CALL gather(phy_foce, phy_glo) 712 IF (is_m pi_root .AND. is_omp_root) THEN791 IF (is_master) THEN 713 792 #ifdef NC_DOUBLE 714 793 ierr = nf_put_var_double(nid, id_foce, phy_glo) … … 723 802 724 803 CALL gather(phy_fsic, phy_glo) 725 IF (is_m pi_root .AND. is_omp_root) THEN804 IF (is_master) THEN 726 805 #ifdef NC_DOUBLE 727 806 ierr = nf_put_var_double(nid, id_fsic, phy_glo) … … 736 815 737 816 CALL gather(phy_flic, phy_glo) 738 IF (is_m pi_root .AND. is_omp_root) THEN817 IF (is_master) THEN 739 818 #ifdef NC_DOUBLE 740 819 ierr = nf_put_var_double(nid, id_flic, phy_glo) … … 749 828 750 829 ! close file: 751 IF (is_m pi_root .AND. is_omp_root) THEN830 IF (is_master) THEN 752 831 ierr = nf_close(nid) 753 832 END IF … … 759 838 SUBROUTINE profil_sst(nlon, rlatd, type_profil, phy_sst) 760 839 USE dimphy 840 USE phys_cal_mod , ONLY: year_len 761 841 IMPLICIT NONE 762 842 763 843 INTEGER nlon, type_profil, i, k, j 764 REAL :: rlatd(nlon), phy_sst(nlon, 360)844 REAL :: rlatd(nlon), phy_sst(nlon, year_len) 765 845 INTEGER imn, imx, amn, amx, kmn, kmx 766 846 INTEGER p, pplus, nlat_max 767 847 PARAMETER (nlat_max=72) 768 848 REAL x_anom_sst(nlat_max) 769 770 IF (klon/=nlon) STOP 'probleme de dimensions dans iniaqua' 849 CHARACTER (LEN=20) :: modname='profil_sst' 850 CHARACTER (LEN=80) :: abort_message 851 852 IF (klon/=nlon) THEN 853 abort_message='probleme de dimensions dans profil_sst' 854 CALL abort_physic(modname,abort_message,1) 855 ENDIF 771 856 WRITE (*, *) ' profil_sst: type_profil=', type_profil 772 DO i = 1, 360857 DO i = 1, year_len 773 858 ! phy_sst(:,i) = 260.+50.*cos(rlatd(:))**2 774 859 … … 963 1048 imx = 1 964 1049 kmx = 1 965 DO k = 1, 3601050 DO k = 1, year_len 966 1051 DO i = 2, nlon 967 1052 IF (phy_sst(i,k)<amn) THEN -
Property
svn:keywords
set to
Note: See TracChangeset
for help on using the changeset viewer.
