Changeset 3605 for LMDZ6/branches/Ocean_skin/libf
- Timestamp:
- Nov 21, 2019, 4:43:45 PM (5 years ago)
- Location:
- LMDZ6/branches/Ocean_skin
- Files:
-
- 1 deleted
- 134 edited
- 20 copied
Legend:
- Unmodified
- Added
- Removed
-
LMDZ6/branches/Ocean_skin
-
LMDZ6/branches/Ocean_skin/libf/dyn3d/conf_gcm.F90
r2665 r3605 21 21 USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, & 22 22 alphax,alphay,taux,tauy 23 USE temps_mod, ONLY: calend 23 USE temps_mod, ONLY: calend, year_len 24 24 25 25 IMPLICIT NONE … … 115 115 calend = 'earth_360d' 116 116 CALL getin('calend', calend) 117 ! initialize year_len for aquaplanets and 1D 118 if (calend == 'earth_360d') then 119 year_len=360 120 else if (calend == 'earth_365d') then 121 year_len=365 122 else if (calend == 'earth_366d') then 123 year_len=366 124 else 125 year_len=1 126 endif 117 127 118 128 !Config Key = dayref -
LMDZ6/branches/Ocean_skin/libf/dyn3d/gcm.F90
r2622 r3605 241 241 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' 242 242 if (.not.read_start) then 243 start_time=0. 244 annee_ref=anneeref 243 245 CALL iniacademic(vcov,ucov,teta,q,masse,ps,phis,time_0) 244 246 endif … … 377 379 tetagdiv, tetagrot , tetatemp, vert_prof_dissip) 378 380 381 ! numero de stockage pour les fichiers de redemarrage: 382 383 !----------------------------------------------------------------------- 384 ! Initialisation des I/O : 385 ! ------------------------ 386 387 388 if (nday>=0) then 389 day_end = day_ini + nday 390 else 391 day_end = day_ini - nday/day_step 392 endif 393 WRITE(lunout,300)day_ini,day_end 394 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) 395 396 #ifdef CPP_IOIPSL 397 call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) 398 write (lunout,301)jour, mois, an 399 call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) 400 write (lunout,302)jour, mois, an 401 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) 402 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) 403 #endif 404 379 405 !----------------------------------------------------------------------- 380 406 ! Initialisation de la physique : … … 391 417 #endif 392 418 ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100)) 393 394 ! numero de stockage pour les fichiers de redemarrage:395 396 !-----------------------------------------------------------------------397 ! Initialisation des I/O :398 ! ------------------------399 400 401 if (nday>=0) then402 day_end = day_ini + nday403 else404 day_end = day_ini - nday/day_step405 endif406 WRITE(lunout,300)day_ini,day_end407 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)408 409 #ifdef CPP_IOIPSL410 call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)411 write (lunout,301)jour, mois, an412 call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)413 write (lunout,302)jour, mois, an414 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)415 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4)416 #endif417 419 418 420 ! if (planet_type.eq."earth") then -
LMDZ6/branches/Ocean_skin/libf/dyn3d/temps_mod.F90
r2601 r3605 13 13 INTEGER annee_ref 14 14 INTEGER day_ref 15 INTEGER year_len 15 16 REAL dt ! (dynamics) time step (changes if doing Matsuno or LF step) 16 17 REAL jD_ref ! reference julian day date (beginning of experiment) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/caladvtrac_mod.F90
r1907 r3605 44 44 CALL allocate_u(massem,llm,d) 45 45 CALL allocate_u(pbaruc,llm,d) 46 pbaruc(:,:)=0 46 47 CALL allocate_v(pbarvc,llm,d) 48 pbarvc(:,:)=0 47 49 CALL allocate_u(pbarug,llm,d) 48 50 CALL allocate_v(pbarvg,llm,d) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/call_calfis_mod.F90
r2603 r3605 52 52 CALL allocate_u(p,llmp1,d) 53 53 CALL allocate_u(pks,d) 54 pks(:)=0 54 55 CALL allocate_u(pk,llm,d) 56 pk(:,:)=0 55 57 CALL allocate_u(pkf,llm,d) 56 58 CALL allocate_u(phi,llm,d) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/call_dissip_mod.F90
r1987 r3605 31 31 32 32 CALL allocate_u(ucov,llm,d) 33 ucov(:,:)=0 33 34 CALL allocate_v(vcov,llm,d) 35 vcov(:,:)=0 34 36 CALL allocate_u(teta,llm,d) 35 37 CALL allocate_u(p,llmp1,d) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/conf_gcm.F90
r2665 r3605 25 25 USE serre_mod, ONLY: clon,clat,grossismx,grossismy,dzoomx,dzoomy, & 26 26 alphax,alphay,taux,tauy 27 USE temps_mod, ONLY: calend 27 USE temps_mod, ONLY: calend, year_len 28 28 29 29 IMPLICIT NONE … … 144 144 !Config 145 145 calend = 'earth_360d' 146 ! initialize year_len for aquaplanets and 1D 146 147 CALL getin('calend', calend) 148 if (calend == 'earth_360d') then 149 year_len=360 150 else if (calend == 'earth_365d') then 151 year_len=365 152 else if (calend == 'earth_366d') then 153 year_len=366 154 else 155 year_len=1 156 endif 157 147 158 148 159 !Config Key = dayref -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/gcm.F90
r2622 r3605 233 233 'GCM: AVANT iniacademic AVANT AVANT AVANT AVANT' 234 234 if (.not.read_start) then 235 start_time=0. 236 annee_ref=anneeref 235 237 CALL iniacademic_loc(vcov,ucov,teta,q,masse,ps,phis,time_0) 236 238 endif … … 368 370 369 371 !----------------------------------------------------------------------- 372 ! Initialisation des I/O : 373 ! ------------------------ 374 375 376 if (nday>=0) then 377 day_end = day_ini + nday 378 else 379 day_end = day_ini - nday/day_step 380 endif 381 382 WRITE(lunout,300)day_ini,day_end 383 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//) 384 385 #ifdef CPP_IOIPSL 386 call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure) 387 write (lunout,301)jour, mois, an 388 call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure) 389 write (lunout,302)jour, mois, an 390 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4) 391 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4) 392 #endif 393 394 !----------------------------------------------------------------------- 370 395 ! Initialisation de la physique : 371 396 ! ------------------------------- … … 381 406 ENDIF ! of IF ((iflag_phys==1).or.(iflag_phys>=100)) 382 407 383 384 !-----------------------------------------------------------------------385 ! Initialisation des I/O :386 ! ------------------------387 388 389 if (nday>=0) then390 day_end = day_ini + nday391 else392 day_end = day_ini - nday/day_step393 endif394 395 WRITE(lunout,300)day_ini,day_end396 300 FORMAT('1'/,15x,'run du jour',i7,2x,'au jour',i7//)397 398 #ifdef CPP_IOIPSL399 call ju2ymds(jD_ref + day_ini - day_ref, an, mois, jour, heure)400 write (lunout,301)jour, mois, an401 call ju2ymds(jD_ref + day_end - day_ref, an, mois, jour, heure)402 write (lunout,302)jour, mois, an403 301 FORMAT('1'/,15x,'run du ', i2,'/',i2,'/',i4)404 302 FORMAT('1'/,15x,' au ', i2,'/',i2,'/',i4)405 #endif406 408 407 409 ! if (planet_type.eq."earth") then -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/guide_loc_mod.F90
r2740 r3605 1212 1212 enddo 1213 1213 endif 1214 if (pole_ nord) then1214 if (pole_sud) then 1215 1215 do i=1,iip1 1216 1216 qgui1(ip1jm+i,l)=qgui1(ip1jm+1,l) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/iniacademic_loc.F90
r2622 r3605 101 101 time_0=0. 102 102 day_ref=1 103 annee_ref=0103 ! annee_ref=0 104 104 105 105 im = iim -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/integrd_mod.F90
r1907 r3605 23 23 CALL allocate_u(deltap,llm,d) 24 24 CALL allocate_u(ps,d) 25 ps(:)=0 25 26 26 27 -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/leapfrog_loc.F
r2622 r3605 29 29 USE call_dissip_mod, ONLY : call_dissip 30 30 USE call_calfis_mod, ONLY : call_calfis 31 USE leapfrog_mod 31 USE leapfrog_mod, ONLY : ucov,vcov,teta,ps,masse,phis,q,dq 32 & ,ucovm1,vcovm1,tetam1,massem1,psm1,p,pks,pk,pkf,flxw 33 & ,pbaru,pbarv,du,dv,dteta,phi,dp,w 34 & ,leapfrog_allocate,leapfrog_switch_caldyn,leapfrog_switch_dissip 35 32 36 use exner_hyb_loc_m, only: exner_hyb_loc 33 37 use exner_milieu_loc_m, only: exner_milieu_loc … … 1535 1539 1536 1540 #ifdef INCA 1537 call finalize_inca 1541 if (type_trac == 'inca') then 1542 call finalize_inca 1543 endif 1538 1544 #endif 1539 1545 … … 1583 1589 1584 1590 #ifdef INCA 1585 call finalize_inca 1591 if (type_trac == 'inca') then 1592 call finalize_inca 1593 endif 1586 1594 #endif 1587 1595 … … 1732 1740 1733 1741 #ifdef INCA 1734 call finalize_inca 1742 if (type_trac == 'inca') then 1743 call finalize_inca 1744 endif 1735 1745 #endif 1736 1746 … … 1820 1830 1821 1831 #ifdef INCA 1822 call finalize_inca 1832 if (type_trac == 'inca') then 1833 call finalize_inca 1834 endif 1823 1835 #endif 1824 1836 -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/temps_mod.F90
r2601 r3605 13 13 INTEGER annee_ref 14 14 INTEGER day_ref 15 INTEGER year_len 15 16 REAL dt ! (dynamics) time step (changes if doing Matsuno or LF step) 16 17 REAL jD_ref ! reference julian day date (beginning of experiment) -
LMDZ6/branches/Ocean_skin/libf/dyn3dmem/vlsplt_loc.F
r2765 r3605 19 19 include "dimensions.h" 20 20 include "paramet.h" 21 include "iniprint.h" 21 22 c 22 23 c … … 872 873 include "dimensions.h" 873 874 include "paramet.h" 875 include "iniprint.h" 874 876 c 875 877 c … … 1027 1029 ELSE ! countcfl>=1 1028 1030 1029 PRINT*,'vlz passage dans le non local' 1031 IF (prt_level>9) THEN 1032 WRITE(lunout,*)'vlz passage dans le non local' 1033 ENDIF 1030 1034 c --------------------------------------------------------------- 1031 1035 c Debut du traitement du cas ou on viole le CFL : w > masse … … 1059 1063 c le critère 1060 1064 DO WHILE (countcfl>=1) 1061 print*,'On viole le CFL Vertical sur ',countcfl,' pts' 1065 IF (prt_level>9) THEN 1066 WRITE(lunout,*)'On viole le CFL Vertical sur ',countcfl,' pts' 1067 ENDIF 1062 1068 countcfl=0 1063 1069 -
LMDZ6/branches/Ocean_skin/libf/dynphy_lonlat/inigeomphy_mod.F90
r2963 r3605 76 76 REAL,ALLOCATABLE,SAVE :: boundslonfi(:,:) 77 77 REAL,ALLOCATABLE,SAVE :: boundslatfi(:,:) 78 !$OMP THREADPRIVATE (latfi,lonfi,cufi,cvfi,airefi,boundslonfi,boundslatfi) 78 INTEGER,ALLOCATABLE,SAVE :: ind_cell_glo_fi(:) 79 !$OMP THREADPRIVATE (latfi,lonfi,cufi,cvfi,airefi,boundslonfi,boundslatfi,ind_cell_glo_fi) 79 80 80 81 ! Initialize Physics distibution and parameters and interface with dynamics … … 93 94 94 95 DO i=1,iim 96 boundslon_reg(i,east)=rlonu(i+1) 95 97 boundslon_reg(i,west)=rlonu(i) 96 boundslon_reg(i,east)=rlonu(i+1)97 98 ENDDO 98 99 … … 204 205 ALLOCATE(boundslonfi(klon_omp,4)) 205 206 ALLOCATE(boundslatfi(klon_omp,4)) 207 ALLOCATE(ind_cell_glo_fi(klon_omp)) 206 208 207 209 … … 214 216 boundslonfi(1:klon_omp,:) = boundslonfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:) 215 217 boundslatfi(1:klon_omp,:) = boundslatfi_glo(offset+klon_omp_begin:offset+klon_omp_end,:) 218 ind_cell_glo_fi(1:klon_omp)=(/ (i,i=offset+klon_omp_begin,offset+klon_omp_end) /) 216 219 217 220 ! copy over local grid longitudes and latitudes 218 221 CALL init_geometry(klon_omp,lonfi,latfi,boundslonfi,boundslatfi, & 219 airefi, cufi,cvfi)222 airefi,ind_cell_glo_fi,cufi,cvfi) 220 223 221 224 ! copy over preff , ap(), bp(), etc -
LMDZ6/branches/Ocean_skin/libf/dynphy_lonlat/phydev/iniphysiq_mod.F90
r2588 r3605 71 71 CALL inifis(prad,pg,pr,pcpp) 72 72 73 ! Initialize dimphy module74 CALL Init_dimphy(klon_omp,nlayer)75 76 73 ! Initialize tracer names, numbers, etc. for physics 77 74 CALL init_infotrac_phy(nqtot,type_trac) -
LMDZ6/branches/Ocean_skin/libf/dynphy_lonlat/phylmd/etat0dyn_netcdf.F90
r2941 r3605 100 100 101 101 deg2rad = pi/180.0 102 102 y(:,:,:)=0 !ym warning unitialized variable 103 103 104 ! Compute psol AND tsol, knowing phis. 104 105 !******************************************************************************* -
LMDZ6/branches/Ocean_skin/libf/dynphy_lonlat/phylmd/etat0phys_netcdf.F90
r3412 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE etat0phys 2 5 ! … … 40 43 USE phys_state_var_mod, ONLY: zmea, zstd, zsig, zgam, zthe, zpic, zval, z0m, & 41 44 solsw, radsol, t_ancien, wake_deltat, wake_s, rain_fall, qsol, z0h, & 42 sollw, rugoro, q_ancien, wake_deltaq, wake_pe, snow_fall, ratqs,w01, &45 sollw,sollwdown, rugoro, q_ancien, wake_deltaq, wake_pe, snow_fall, ratqs,w01, & 43 46 sig1, ftsol, clwcon, fm_therm, wake_Cstar, pctsrf, entr_therm,radpas, f0,& 44 zmax0,fevap, rnebcon,falb_dir, wake_fip, agesno, detr_therm, pbl_tke, &47 zmax0,fevap, rnebcon,falb_dir, falb_dif, wake_fip, agesno, detr_therm, pbl_tke, & 45 48 phys_state_var_init, ql_ancien, qs_ancien, prlw_ancien, prsw_ancien, & 46 prw_ancien 49 prw_ancien, u10m,v10m, treedrg, u_ancien, v_ancien, wake_delta_pbl_TKE, wake_dens, & 50 ale_bl, ale_bl_trig, alp_bl, & 51 ale_wake, ale_bl_stat 52 47 53 USE comconst_mod, ONLY: pi, dtvr 48 54 … … 110 116 INTEGER :: iflag_radia, iflag_cldcon, iflag_ratqs 111 117 REAL :: ratqsbas, ratqshaut, tau_ratqs 112 LOGICAL :: ok_ade, ok_aie, ok_ alw, ok_cdnc, aerosol_couple, chemistry_couple118 LOGICAL :: ok_ade, ok_aie, ok_volcan, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple 113 119 INTEGER :: flag_aerosol 114 120 INTEGER :: flag_aerosol_strat … … 133 139 iflag_cldcon, & 134 140 iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & 135 ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple, & 141 ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, & 142 aerosol_couple, & 136 143 chemistry_couple, flag_aerosol, flag_aerosol_strat, & 137 144 flag_aer_feedback, & … … 194 201 falb_dir(:, :, is_oce) = 0.5 195 202 falb_dir(:, :, is_sic) = 0.6 203 204 !ym warning missing init for falb_dif => set to 0 205 falb_dif(:,:,:)=0 206 207 u10m(:,:)=0 208 v10m(:,:)=0 209 treedrg(:,:,:)=0 210 196 211 fevap(:,:) = 0. 197 212 DO i=1,nbsrf; qsolsrf(:,i)=150.; END DO … … 201 216 solsw = 165. 202 217 sollw = -53. 218 !ym warning missing init for sollwdown => set to 0 219 sollwdown = 0. 203 220 t_ancien = 273.15 204 221 q_ancien = 0. … … 209 226 prw_ancien = 0. 210 227 agesno = 0. 211 228 229 u_ancien = 0. 230 v_ancien = 0. 231 wake_delta_pbl_TKE(:,:,:)=0 232 wake_dens(:)=0 233 ale_bl = 0. 234 ale_bl_trig =0. 235 alp_bl=0. 236 ale_wake=0. 237 ale_bl_stat=0. 238 239 z0m(:,:)=0 ! ym missing 5th subsurface initialization 240 212 241 z0m(:,is_oce) = rugmer(:) 213 242 z0m(:,is_ter) = MAX(1.0e-05,zstd(:)*zsig(:)/2.0) … … 315 344 ALLOCATE(zmea0(iml,jml),zstd0(iml,jml)) !--- Mean orography and std deviation 316 345 ALLOCATE(zsig0(iml,jml),zgam0(iml,jml)) !--- Slope and nisotropy 346 zsig0(:,:)=0 !ym uninitialized variable 347 zgam0(:,:)=0 !ym uninitialized variable 317 348 ALLOCATE(zthe0(iml,jml)) !--- Highest slope orientation 349 zthe0(:,:)=0 !ym uninitialized variable 318 350 ALLOCATE(zpic0(iml,jml),zval0(iml,jml)) !--- Peaks and valley heights 319 351 -
LMDZ6/branches/Ocean_skin/libf/dynphy_lonlat/phylmd/iniphysiq_mod.F90
r3125 r3605 31 31 USE inifis_mod, ONLY: inifis 32 32 USE time_phylmdz_mod, ONLY: init_time 33 USE temps_mod, ONLY: annee_ref, day_ini, day_ref, start_time, calend 33 USE temps_mod, ONLY: annee_ref, day_ini, day_ref, start_time, calend, year_len 34 34 USE infotrac_phy, ONLY: init_infotrac_phy 35 35 USE phystokenc_mod, ONLY: init_phystokenc 36 36 USE phyaqua_mod, ONLY: iniaqua 37 USE comconst_mod, ONLY: omeg, rad 37 38 #ifdef INCA 38 39 USE indice_sol_mod, ONLY: nbsrf, is_oce, is_sic, is_ter, is_lic … … 118 119 119 120 ! Initialize dimphy module (unless in 1D where it has already been done) 120 IF (klon_glo>1) CALL Init_dimphy(klon_omp,nlayer)121 ! IF (klon_glo>1) CALL Init_dimphy(klon_omp,nlayer) 121 122 122 123 ! Copy over "offline" settings … … 134 135 cu,cuvsurcv,cv,cvusurcu, & 135 136 aire,apoln,apols, & 136 aireu,airev,rlatvdyn )137 aireu,airev,rlatvdyn,rad,omeg) 137 138 END IF 138 139 … … 172 173 ! Additional initializations for aquaplanets 173 174 IF (iflag_phys>=100) THEN 174 CALL iniaqua(klon_omp, iflag_phys)175 CALL iniaqua(klon_omp,year_len,iflag_phys) 175 176 END IF 176 177 -
LMDZ6/branches/Ocean_skin/libf/misc/handle_err_m.F90
r2094 r3605 39 39 end if 40 40 end if 41 call abort_ gcm("NetCDF95 handle_err", "", 1)41 call abort_physic("NetCDF95 handle_err", "", 1) 42 42 end if 43 43 -
LMDZ6/branches/Ocean_skin/libf/misc/wxios.F90
r3165 r3605 15 15 16 16 INTEGER, SAVE :: g_comm 17 CHARACTER(len=100), SAVE :: g_ctx_name 17 CHARACTER(len=100), SAVE :: g_ctx_name ="LMDZ" 18 18 TYPE(xios_context), SAVE :: g_ctx 19 19 !$OMP THREADPRIVATE(g_comm,g_cts_name,g_ctx) … … 136 136 g_ctx_name = xios_ctx_name 137 137 138 ! Si couple alors init fait dans cpl_init139 IF (.not. PRESENT(type_ocean)) THEN140 CALL wxios_context_init()141 ENDIF138 ! ! Si couple alors init fait dans cpl_init 139 ! IF (.not. PRESENT(type_ocean)) THEN 140 ! CALL wxios_context_init() 141 ! ENDIF 142 142 143 143 END SUBROUTINE wxios_init … … 145 145 SUBROUTINE wxios_context_init() 146 146 USE print_control_mod, ONLY : prt_level, lunout 147 !USE mod_phys_lmdz_mpi_data, ONLY : COMM_LMDZ_PHY147 USE mod_phys_lmdz_mpi_data, ONLY : COMM_LMDZ_PHY 148 148 IMPLICIT NONE 149 149 … … 152 152 !$OMP MASTER 153 153 !Initialisation du contexte: 154 CALL xios_context_initialize(g_ctx_name, g_comm) 154 !!CALL xios_context_initialize(g_ctx_name, g_comm) 155 CALL xios_context_initialize(g_ctx_name, COMM_LMDZ_PHY) 155 156 CALL xios_get_handle(g_ctx_name, xios_ctx) !Récupération 156 157 CALL xios_set_current_context(xios_ctx) !Activation … … 165 166 !$OMP END MASTER 166 167 END SUBROUTINE wxios_context_init 168 169 170 SUBROUTINE wxios_set_context() 171 IMPLICIT NONE 172 TYPE(xios_context) :: xios_ctx 173 174 !$OMP MASTER 175 CALL xios_get_handle(g_ctx_name, xios_ctx) !Récupération 176 CALL xios_set_current_context(xios_ctx) !Activation 177 !$OMP END MASTER 178 179 END SUBROUTINE wxios_set_context 167 180 168 181 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! … … 203 216 CASE DEFAULT 204 217 abort_message = 'wxios_set_cal: Mauvais choix de calendrier' 205 CALL abort_ gcm('Gcm:Xios',abort_message,1)218 CALL abort_physic('Gcm:Xios',abort_message,1) 206 219 END SELECT 207 220 … … 237 250 ! Pour initialiser un domaine !!!!!!!!!!!!!!!!!!!! 238 251 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 239 SUBROUTINE wxios_domain_param(dom_id, is_sequential, ni, nj, ni_glo, nj_glo, & 240 ibegin, iend, ii_begin, ii_end, jbegin, jend, & 241 data_ni, data_ibegin, data_iend, & 242 io_lat, io_lon,is_south_pole,mpi_rank) 243 244 245 USE print_control_mod, ONLY : prt_level, lunout 246 IMPLICIT NONE 247 252 SUBROUTINE wxios_domain_param(dom_id) 253 USE dimphy, only: klon 254 USE mod_phys_lmdz_transfert_para, ONLY: gather, bcast 255 USE mod_phys_lmdz_para, only: jj_nb, jj_begin, jj_end, ii_begin, ii_end, & 256 mpi_size, mpi_rank, klon_mpi, & 257 is_sequential, is_south_pole_dyn 258 USE mod_grid_phy_lmdz, only: nbp_lon, nbp_lat, klon_glo 259 USE print_control_mod, ONLY : prt_level, lunout 260 USE geometry_mod 261 262 IMPLICIT NONE 248 263 CHARACTER(len=*),INTENT(IN) :: dom_id ! domain identifier 249 LOGICAL,INTENT(IN) :: is_sequential ! flag 250 INTEGER,INTENT(IN) :: ni ! local MPI domain number of longitudes 251 INTEGER,INTENT(IN) :: nj ! local MPI domain number of latitudes 252 INTEGER,INTENT(IN) :: ni_glo ! global grid number of longitudes 253 INTEGER,INTENT(IN) :: nj_glo ! global grid number of latitudes 254 INTEGER,INTENT(IN) :: ibegin ! start index, on global grid, of local MPI domain 255 INTEGER,INTENT(IN) :: iend ! end index, on global grid, of local MPI domain 256 INTEGER,INTENT(IN) :: ii_begin ! i index at which local data starts (first row) 257 INTEGER,INTENT(IN) :: ii_end ! i index at which local data ends (last row) 258 INTEGER,INTENT(IN) :: jbegin ! start index, on global grid, of local MPI domain 259 INTEGER,INTENT(IN) :: jend ! end index, on global grid, of local MPI domain 260 INTEGER,INTENT(IN) :: data_ni 261 INTEGER,INTENT(IN) :: data_ibegin 262 INTEGER,INTENT(IN) :: data_iend 263 REAL,INTENT(IN) :: io_lat(:) ! latitudes (of global grid) 264 REAL,INTENT(IN) :: io_lon(:) ! longitudes (of global grid) 265 logical,intent(in) :: is_south_pole ! does this process include the south pole? 266 integer,intent(in) :: mpi_rank ! rank of process 267 264 265 REAL :: rlat_glo(klon_glo) 266 REAL :: rlon_glo(klon_glo) 267 REAL :: io_lat(nbp_lat) 268 REAL :: io_lon(nbp_lon) 269 LOGICAL :: mask(nbp_lon,jj_nb) !Masque pour les problèmes de recouvrement MPI 268 270 TYPE(xios_domain) :: dom 271 INTEGER :: i 269 272 LOGICAL :: boool 270 273 271 !Masque pour les problèmes de recouvrement MPI: 272 LOGICAL :: mask(ni,nj) 274 275 276 CALL gather(latitude_deg,rlat_glo) 277 CALL bcast(rlat_glo) 278 CALL gather(longitude_deg,rlon_glo) 279 CALL bcast(rlon_glo) 280 281 !$OMP MASTER 282 io_lat(1)=rlat_glo(1) 283 io_lat(nbp_lat)=rlat_glo(klon_glo) 284 IF ((nbp_lon*nbp_lat) > 1) then 285 DO i=2,nbp_lat-1 286 io_lat(i)=rlat_glo(2+(i-2)*nbp_lon) 287 ENDDO 288 ENDIF 289 290 IF (klon_glo == 1) THEN 291 io_lon(1)=rlon_glo(1) 292 ELSE 293 io_lon(1:nbp_lon)=rlon_glo(2:nbp_lon+1) 294 ENDIF 295 273 296 274 297 !On récupère le handle: 275 298 CALL xios_get_domain_handle(dom_id, dom) 276 299 277 IF (prt_level >= 10) THEN278 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ni:",ni," ni_glo:", ni_glo, " nj:", nj, " nj_glo:", nj_glo279 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ibegin:",ibegin," iend:", iend, " jbegin:", jbegin, " jend:", jend280 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," ii_begin:",ii_begin," ii_end:", ii_end281 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," Size io_lon:", SIZE(io_lon(ibegin:iend)), " io_lat:", SIZE(io_lat(jbegin:jend))282 ENDIF283 284 300 !On parametrise le domaine: 285 CALL xios_set_domain_attr_hdl(dom, ni_glo=ni_glo, ibegin=ibegin-1, ni=ni, type="rectilinear") 286 CALL xios_set_domain_attr_hdl(dom, nj_glo=nj_glo, jbegin=jbegin-1, nj=nj, data_dim=2) 287 CALL xios_set_domain_attr_hdl(dom, lonvalue_1d=io_lon(ibegin:iend), latvalue_1d=io_lat(jbegin:jend)) 301 CALL xios_set_domain_attr_hdl(dom, ni_glo=nbp_lon, ibegin=0, ni=nbp_lon, type="rectilinear") 302 CALL xios_set_domain_attr_hdl(dom, nj_glo=nbp_lat, jbegin=jj_begin-1, nj=jj_nb, data_dim=2) 303 CALL xios_set_domain_attr_hdl(dom, lonvalue_1d=io_lon(1:nbp_lon), latvalue_1d=io_lat(jj_begin:jj_end)) 304 CALL xios_set_domain_attr("dom_out", domain_ref=dom_id) 305 288 306 !On definit un axe de latitudes pour les moyennes zonales 289 307 IF (xios_is_valid_axis("axis_lat")) THEN 290 CALL xios_set_axis_attr( "axis_lat", n_glo=n j_glo, n=nj, begin=jbegin-1, value=io_lat(jbegin:jend))308 CALL xios_set_axis_attr( "axis_lat", n_glo=nbp_lat, n=jj_nb, begin=jj_begin-1, value=io_lat(jj_begin:jj_end)) 291 309 ENDIF 292 310 … … 294 312 mask(:,:)=.TRUE. 295 313 if (ii_begin>1) mask(1:ii_begin-1,1) = .FALSE. 296 if (ii_end<n i) mask(ii_end+1:ni,nj) = .FALSE.314 if (ii_end<nbp_lon) mask(ii_end+1:nbp_lon,jj_nb) = .FALSE. 297 315 ! special case for south pole 298 if ((ii_end .eq.1).and.(is_south_pole)) mask(1:ni,nj)=.true.316 if ((ii_end==1).and.(is_south_pole_dyn)) mask(1:nbp_lon,jj_nb)=.true. 299 317 IF (prt_level >= 10) THEN 300 318 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,1)=",mask(:,1) 301 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:, nj)=",mask(:,nj)319 WRITE(lunout,*) "wxios_domain_param: mpirank=",mpi_rank," mask(:,jj_nb)=",mask(:,jj_nb) 302 320 ENDIF 303 321 CALL xios_set_domain_attr_hdl(dom, mask_2d=mask) … … 311 329 IF (prt_level >= 10) WRITE(lunout,*) "wxios_domain_param: Invalid domain: ", trim(dom_id) 312 330 END IF 331 !$OMP END MASTER 332 313 333 END SUBROUTINE wxios_domain_param 314 334 335 336 SUBROUTINE wxios_domain_param_unstructured(dom_id) 337 USE geometry_mod, ONLY : longitude, latitude, boundslon, boundslat,ind_cell_glo 338 USE mod_grid_phy_lmdz, ONLY : nvertex, klon_glo 339 USE mod_phys_lmdz_para 340 USE nrtype, ONLY : PI 341 USE ioipsl_getin_p_mod, ONLY : getin_p 342 IMPLICIT NONE 343 CHARACTER(len=*),INTENT(IN) :: dom_id ! domain identifier 344 REAL :: lon_mpi(klon_mpi) 345 REAL :: lat_mpi(klon_mpi) 346 REAL :: boundslon_mpi(klon_mpi,nvertex) 347 REAL :: boundslat_mpi(klon_mpi,nvertex) 348 INTEGER :: ind_cell_glo_mpi(klon_mpi) 349 TYPE(xios_domain) :: dom 350 351 LOGICAL :: remap_output 352 353 CALL gather_omp(longitude*180/PI,lon_mpi) 354 CALL gather_omp(latitude*180/PI,lat_mpi) 355 CALL gather_omp(boundslon*180/PI,boundslon_mpi) 356 CALL gather_omp(boundslat*180/PI,boundslat_mpi) 357 CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi) 358 359 remap_output=.TRUE. 360 CALL getin_p("remap_output",remap_output) 361 362 !$OMP MASTER 363 CALL xios_get_domain_handle(dom_id, dom) 364 365 !On parametrise le domaine: 366 CALL xios_set_attr(dom, ni_glo=klon_glo, ibegin=ij_begin-1, ni=ij_nb, type="unstructured") 367 CALL xios_set_attr(dom, nvertex=nvertex, lonvalue_1d=lon_mpi, latvalue_1d=lat_mpi, & 368 bounds_lon_1d=TRANSPOSE(boundslon_mpi), bounds_lat_1d=TRANSPOSE(boundslat_mpi) ) 369 CALL xios_set_attr(dom, i_index=ind_cell_glo_mpi(:)-1) 370 IF (remap_output) THEN 371 CALL xios_set_domain_attr("dom_out", domain_ref="dom_regular") 372 CALL xios_set_fieldgroup_attr("remap_expr", expr="@this_ref") 373 CALL xios_set_fieldgroup_attr("remap_1800s", freq_op=xios_duration_convert_from_string("1800s")) 374 CALL xios_set_fieldgroup_attr("remap_1h", freq_op=xios_duration_convert_from_string("1h")) 375 CALL xios_set_fieldgroup_attr("remap_3h", freq_op=xios_duration_convert_from_string("3h")) 376 CALL xios_set_fieldgroup_attr("remap_6h", freq_op=xios_duration_convert_from_string("6h")) 377 CALL xios_set_fieldgroup_attr("remap_1d", freq_op=xios_duration_convert_from_string("1d")) 378 CALL xios_set_fieldgroup_attr("remap_1mo", freq_op=xios_duration_convert_from_string("1mo")) 379 ENDIF 380 !$OMP END MASTER 381 382 END SUBROUTINE wxios_domain_param_unstructured 383 384 385 386 315 387 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 316 388 ! Pour déclarer un axe vertical !!!!!!!!!!!!!!! -
LMDZ6/branches/Ocean_skin/libf/phy_common/geometry_mod.F90
r2395 r3605 30 30 !$OMP THREADPRIVATE(cell_area) 31 31 32 INTEGER,SAVE,ALLOCATABLE :: ind_cell_glo(:) ! global indice of a local cell 33 !$OMP THREADPRIVATE(ind_cell_glo) 32 34 33 35 CONTAINS … … 35 37 SUBROUTINE init_geometry(klon,longitude_,latitude_, & 36 38 boundslon_,boundslat_, & 37 cell_area_, dx_,dy_)39 cell_area_,ind_cell_glo_,dx_,dy_) 38 40 USE mod_grid_phy_lmdz, ONLY: nvertex 39 41 USE nrtype, ONLY : PI … … 45 47 REAL,INTENT(IN) :: boundslat_(klon,nvertex) 46 48 REAL,INTENT(IN) :: cell_area_(klon) 49 INTEGER,OPTIONAL,INTENT(IN) :: ind_cell_glo_(klon) 47 50 REAL,OPTIONAL,INTENT(IN) :: dx_(klon) 48 51 REAL,OPTIONAL,INTENT(IN) :: dy_(klon) … … 55 58 ALLOCATE(boundslat(klon,nvertex)) 56 59 ALLOCATE(cell_area(klon)) 60 IF (PRESENT(ind_cell_glo_)) ALLOCATE(ind_cell_glo(klon)) 57 61 IF (PRESENT(dx_)) ALLOCATE(dx(klon)) 58 62 IF (PRESENT(dy_))ALLOCATE(dy(klon)) … … 65 69 boundslat(:,:) = boundslat_(:,:) 66 70 cell_area(:) = cell_area_(:) 71 IF (PRESENT(ind_cell_glo_)) ind_cell_glo(:) = ind_cell_glo_(:) 67 72 IF (PRESENT(dx_)) dx(:) = dx_(:) 68 73 IF (PRESENT(dy_)) dy(:) = dy_(:) -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_mpi_data.F90
r2429 r3605 3 3 ! 4 4 MODULE mod_phys_lmdz_mpi_data 5 ! USE mod_const_mpi6 5 7 6 INTEGER,SAVE :: ii_begin … … 36 35 INTEGER,SAVE :: mpi_size 37 36 INTEGER,SAVE :: mpi_master 38 ! INTEGER,SAVE :: mpi_root39 37 LOGICAL,SAVE :: is_mpi_root 40 38 LOGICAL,SAVE :: is_using_mpi 41 39 42 40 43 ! LOGICAL,SAVE :: is_north_pole44 ! LOGICAL,SAVE :: is_south_pole45 41 LOGICAL,SAVE :: is_north_pole_dyn 46 42 LOGICAL,SAVE :: is_south_pole_dyn … … 50 46 CONTAINS 51 47 52 ! SUBROUTINE Init_phys_lmdz_mpi_data(iim,jjp1,nb_proc,distrib)53 48 SUBROUTINE init_phys_lmdz_mpi_data(nbp, nbp_lon, nbp_lat, communicator) 54 ! USE mod_const_mpi, ONLY : COMM_LMDZ55 49 IMPLICIT NONE 56 50 #ifdef CPP_MPI 57 51 INCLUDE 'mpif.h' 58 52 #endif 59 INTEGER,INTENT( in) :: nbp60 INTEGER,INTENT( in) :: nbp_lon61 INTEGER,INTENT( in) :: nbp_lat62 INTEGER,INTENT( in) :: communicator53 INTEGER,INTENT(IN) :: nbp 54 INTEGER,INTENT(IN) :: nbp_lon 55 INTEGER,INTENT(IN) :: nbp_lat 56 INTEGER,INTENT(IN) :: communicator 63 57 64 58 INTEGER,ALLOCATABLE :: distrib(:) … … 189 183 190 184 SUBROUTINE print_module_data 191 !USE print_control_mod, ONLY: lunout185 USE print_control_mod, ONLY: lunout 192 186 IMPLICIT NONE 193 INCLUDE "iniprint.h"187 ! INCLUDE "iniprint.h" 194 188 195 189 WRITE(lunout,*) 'ii_begin =', ii_begin -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_mpi_transfert.F90
r2429 r3605 42 42 END INTERFACE 43 43 44 INTERFACE reduce_min_mpi 45 MODULE PROCEDURE reduce_min_mpi_i,reduce_min_mpi_i1,reduce_min_mpi_i2,reduce_min_mpi_i3,reduce_min_mpi_i4, & 46 reduce_min_mpi_r,reduce_min_mpi_r1,reduce_min_mpi_r2,reduce_min_mpi_r3,reduce_min_mpi_r4 47 END INTERFACE 48 44 49 INTERFACE grid1dTo2d_mpi 45 50 MODULE PROCEDURE grid1dTo2d_mpi_i,grid1dTo2d_mpi_i1,grid1dTo2d_mpi_i2,grid1dTo2d_mpi_i3, & … … 986 991 END SUBROUTINE reduce_sum_mpi_r4 987 992 993 994 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 995 !! Definition des reduce_min --> 4D !! 996 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 997 998 SUBROUTINE reduce_min_mpi_i(VarIn, VarOut) 999 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1000 IMPLICIT NONE 1001 1002 INTEGER,INTENT(IN) :: VarIn 1003 INTEGER,INTENT(OUT) :: VarOut 1004 INTEGER :: VarIn_tmp(1) 1005 INTEGER :: VarOut_tmp(1) 1006 1007 VarIn_tmp(1)=VarIn 1008 CALL reduce_min_mpi_igen(VarIn_tmp,Varout_tmp,1) 1009 VarOut=VarOut_tmp(1) 1010 1011 END SUBROUTINE reduce_min_mpi_i 1012 1013 SUBROUTINE reduce_min_mpi_i1(VarIn, VarOut) 1014 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1015 IMPLICIT NONE 1016 1017 INTEGER,INTENT(IN),DIMENSION(:) :: VarIn 1018 INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut 1019 1020 CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn)) 1021 1022 END SUBROUTINE reduce_min_mpi_i1 1023 1024 SUBROUTINE reduce_min_mpi_i2(VarIn, VarOut) 1025 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1026 IMPLICIT NONE 1027 1028 INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn 1029 INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut 1030 1031 CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn)) 1032 1033 END SUBROUTINE reduce_min_mpi_i2 1034 1035 SUBROUTINE reduce_min_mpi_i3(VarIn, VarOut) 1036 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1037 IMPLICIT NONE 1038 1039 INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn 1040 INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 1041 1042 CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn)) 1043 1044 END SUBROUTINE reduce_min_mpi_i3 1045 1046 SUBROUTINE reduce_min_mpi_i4(VarIn, VarOut) 1047 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1048 IMPLICIT NONE 1049 1050 INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 1051 INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 1052 1053 CALL reduce_min_mpi_igen(VarIn,Varout,SIZE(VarIn)) 1054 1055 END SUBROUTINE reduce_min_mpi_i4 1056 1057 1058 SUBROUTINE reduce_min_mpi_r(VarIn, VarOut) 1059 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1060 IMPLICIT NONE 1061 1062 REAL,INTENT(IN) :: VarIn 1063 REAL,INTENT(OUT) :: VarOut 1064 REAL :: VarIn_tmp(1) 1065 REAL :: VarOut_tmp(1) 1066 1067 VarIn_tmp(1)=VarIn 1068 CALL reduce_min_mpi_rgen(VarIn_tmp,Varout_tmp,1) 1069 VarOut=VarOut_tmp(1) 1070 1071 END SUBROUTINE reduce_min_mpi_r 1072 1073 SUBROUTINE reduce_min_mpi_r1(VarIn, VarOut) 1074 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1075 IMPLICIT NONE 1076 1077 REAL,INTENT(IN),DIMENSION(:) :: VarIn 1078 REAL,INTENT(OUT),DIMENSION(:) :: VarOut 1079 1080 CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn)) 1081 1082 END SUBROUTINE reduce_min_mpi_r1 1083 1084 SUBROUTINE reduce_min_mpi_r2(VarIn, VarOut) 1085 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1086 IMPLICIT NONE 1087 1088 REAL,INTENT(IN),DIMENSION(:,:) :: VarIn 1089 REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut 1090 1091 CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn)) 1092 1093 END SUBROUTINE reduce_min_mpi_r2 1094 1095 SUBROUTINE reduce_min_mpi_r3(VarIn, VarOut) 1096 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1097 IMPLICIT NONE 1098 1099 REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn 1100 REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 1101 1102 CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn)) 1103 1104 END SUBROUTINE reduce_min_mpi_r3 1105 1106 SUBROUTINE reduce_min_mpi_r4(VarIn, VarOut) 1107 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 1108 IMPLICIT NONE 1109 1110 REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 1111 REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 1112 1113 CALL reduce_min_mpi_rgen(VarIn,Varout,SIZE(VarIn)) 1114 1115 END SUBROUTINE reduce_min_mpi_r4 1116 1117 988 1118 989 1119 … … 1678 1808 1679 1809 1810 SUBROUTINE reduce_min_mpi_igen(VarIn,VarOut,nb) 1811 USE mod_phys_lmdz_mpi_data 1812 USE mod_grid_phy_lmdz 1813 IMPLICIT NONE 1814 1815 #ifdef CPP_MPI 1816 INCLUDE 'mpif.h' 1817 #endif 1818 1819 INTEGER,INTENT(IN) :: nb 1820 INTEGER,DIMENSION(nb),INTENT(IN) :: VarIn 1821 INTEGER,DIMENSION(nb),INTENT(OUT) :: VarOut 1822 INTEGER :: ierr 1823 1824 IF (.not.is_using_mpi) THEN 1825 VarOut(:)=VarIn(:) 1826 RETURN 1827 ENDIF 1828 1829 1830 #ifdef CPP_MPI 1831 CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_INTEGER,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr) 1832 #endif 1833 1834 END SUBROUTINE reduce_min_mpi_igen 1835 1836 SUBROUTINE reduce_min_mpi_rgen(VarIn,VarOut,nb) 1837 USE mod_phys_lmdz_mpi_data 1838 USE mod_grid_phy_lmdz 1839 1840 IMPLICIT NONE 1841 1842 #ifdef CPP_MPI 1843 INCLUDE 'mpif.h' 1844 #endif 1845 1846 INTEGER,INTENT(IN) :: nb 1847 REAL,DIMENSION(nb),INTENT(IN) :: VarIn 1848 REAL,DIMENSION(nb),INTENT(OUT) :: VarOut 1849 INTEGER :: ierr 1850 1851 IF (.not.is_using_mpi) THEN 1852 VarOut(:)=VarIn(:) 1853 RETURN 1854 ENDIF 1855 1856 #ifdef CPP_MPI 1857 CALL MPI_REDUCE(VarIn,VarOut,nb,MPI_REAL_LMDZ,MPI_MIN,mpi_master,COMM_LMDZ_PHY,ierr) 1858 #endif 1859 1860 END SUBROUTINE reduce_min_mpi_rgen 1861 1862 1863 1864 1865 1866 1867 1680 1868 SUBROUTINE grid1dTo2d_mpi_igen(VarIn,VarOut,dimsize) 1681 1869 USE mod_phys_lmdz_mpi_data -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_omp_data.F90
r2429 r3605 7 7 INTEGER,SAVE :: omp_rank 8 8 LOGICAL,SAVE :: is_omp_root 9 LOGICAL,SAVE :: is_omp_master ! alias of is_omp_root 9 10 LOGICAL,SAVE :: is_using_omp 10 11 LOGICAL,SAVE :: is_north_pole_phy, is_south_pole_phy … … 17 18 INTEGER,SAVE :: klon_omp_begin 18 19 INTEGER,SAVE :: klon_omp_end 19 !$OMP THREADPRIVATE(omp_rank,klon_omp,is_omp_root, klon_omp_begin,klon_omp_end)20 !$OMP THREADPRIVATE(omp_rank,klon_omp,is_omp_root,is_omp_master,klon_omp_begin,klon_omp_end) 20 21 !$OMP THREADPRIVATE(is_north_pole_phy, is_south_pole_phy) 21 22 … … 60 61 ELSE 61 62 abort_message = 'ANORMAL : OMP_MASTER /= 0' 62 CALL abort_ gcm(modname,abort_message,1)63 CALL abort_physic (modname,abort_message,1) 63 64 ENDIF 64 65 !$OMP END MASTER 65 66 is_omp_master=is_omp_root 66 67 67 68 !$OMP MASTER … … 106 107 107 108 SUBROUTINE Print_module_data 109 USE print_control_mod, ONLY: lunout 108 110 IMPLICIT NONE 109 INCLUDE "iniprint.h"111 ! INCLUDE "iniprint.h" 110 112 111 113 !$OMP CRITICAL -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_omp_transfert.F90
r2326 r3605 47 47 END INTERFACE 48 48 49 50 PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp, omp_barrier 49 INTERFACE reduce_min_omp 50 MODULE PROCEDURE reduce_min_omp_i,reduce_min_omp_i1,reduce_min_omp_i2,reduce_min_omp_i3,reduce_min_omp_i4, & 51 reduce_min_omp_r,reduce_min_omp_r1,reduce_min_omp_r2,reduce_min_omp_r3,reduce_min_omp_r4 52 END INTERFACE 53 54 55 PUBLIC bcast_omp,scatter_omp,gather_omp,reduce_sum_omp, reduce_min_omp, omp_barrier 51 56 52 57 CONTAINS … … 710 715 END SUBROUTINE reduce_sum_omp_r4 711 716 717 718 719 SUBROUTINE reduce_min_omp_i(VarIn, VarOut) 720 IMPLICIT NONE 721 722 INTEGER,INTENT(IN) :: VarIn 723 INTEGER,INTENT(OUT) :: VarOut 724 INTEGER :: VarIn_tmp(1) 725 INTEGER :: VarOut_tmp(1) 726 727 VarIn_tmp(1)=VarIn 728 CALL Check_buffer_i(1) 729 CALL reduce_min_omp_igen(VarIn_tmp,Varout_tmp,1,buffer_i) 730 VarOut=VarOut_tmp(1) 731 732 END SUBROUTINE reduce_min_omp_i 733 734 SUBROUTINE reduce_min_omp_i1(VarIn, VarOut) 735 IMPLICIT NONE 736 737 INTEGER,INTENT(IN),DIMENSION(:) :: VarIn 738 INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut 739 740 CALL Check_buffer_i(size(VarIn)) 741 CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 742 743 END SUBROUTINE reduce_min_omp_i1 744 745 746 SUBROUTINE reduce_min_omp_i2(VarIn, VarOut) 747 IMPLICIT NONE 748 749 INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn 750 INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut 751 752 CALL Check_buffer_i(size(VarIn)) 753 CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 754 755 END SUBROUTINE reduce_min_omp_i2 756 757 758 SUBROUTINE reduce_min_omp_i3(VarIn, VarOut) 759 IMPLICIT NONE 760 761 INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn 762 INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 763 764 CALL Check_buffer_i(size(VarIn)) 765 CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 766 767 END SUBROUTINE reduce_min_omp_i3 768 769 770 SUBROUTINE reduce_min_omp_i4(VarIn, VarOut) 771 IMPLICIT NONE 772 773 INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 774 INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 775 776 CALL Check_buffer_i(size(VarIn)) 777 CALL reduce_min_omp_igen(VarIn,Varout,Size(VarIn),buffer_i) 778 779 END SUBROUTINE reduce_min_omp_i4 780 781 782 SUBROUTINE reduce_min_omp_r(VarIn, VarOut) 783 IMPLICIT NONE 784 785 REAL,INTENT(IN) :: VarIn 786 REAL,INTENT(OUT) :: VarOut 787 REAL :: VarIn_tmp(1) 788 REAL :: VarOut_tmp(1) 789 790 VarIn_tmp(1)=VarIn 791 CALL Check_buffer_r(1) 792 CALL reduce_min_omp_rgen(VarIn_tmp,Varout_tmp,1,buffer_r) 793 VarOut=VarOut_tmp(1) 794 795 END SUBROUTINE reduce_min_omp_r 796 797 SUBROUTINE reduce_min_omp_r1(VarIn, VarOut) 798 IMPLICIT NONE 799 800 REAL,INTENT(IN),DIMENSION(:) :: VarIn 801 REAL,INTENT(OUT),DIMENSION(:) :: VarOut 802 803 CALL Check_buffer_r(size(VarIn)) 804 CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 805 806 END SUBROUTINE reduce_min_omp_r1 807 808 809 SUBROUTINE reduce_min_omp_r2(VarIn, VarOut) 810 IMPLICIT NONE 811 812 REAL,INTENT(IN),DIMENSION(:,:) :: VarIn 813 REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut 814 815 CALL Check_buffer_r(size(VarIn)) 816 CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 817 818 END SUBROUTINE reduce_min_omp_r2 819 820 821 SUBROUTINE reduce_min_omp_r3(VarIn, VarOut) 822 IMPLICIT NONE 823 824 REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn 825 REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 826 827 CALL Check_buffer_r(size(VarIn)) 828 CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 829 830 END SUBROUTINE reduce_min_omp_r3 831 832 833 SUBROUTINE reduce_min_omp_r4(VarIn, VarOut) 834 IMPLICIT NONE 835 836 REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 837 REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 838 839 CALL Check_buffer_r(size(VarIn)) 840 CALL reduce_min_omp_rgen(VarIn,Varout,Size(VarIn),buffer_r) 841 842 END SUBROUTINE reduce_min_omp_r4 843 844 845 846 712 847 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 713 848 ! LES ROUTINES GENERIQUES ! … … 1062 1197 END SUBROUTINE reduce_sum_omp_rgen 1063 1198 1199 1200 SUBROUTINE reduce_min_omp_igen(VarIn,VarOut,dimsize,Buff) 1201 IMPLICIT NONE 1202 1203 INTEGER,INTENT(IN) :: dimsize 1204 INTEGER,INTENT(IN),DIMENSION(dimsize) :: VarIn 1205 INTEGER,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1206 INTEGER,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1207 1208 INTEGER :: i 1209 INTEGER :: var 1210 1211 !$OMP MASTER 1212 Buff(:)=HUGE(var) 1213 !$OMP END MASTER 1214 !$OMP BARRIER 1215 1216 !$OMP CRITICAL 1217 DO i=1,dimsize 1218 Buff(i)=MIN(Buff(i),VarIn(i)) 1219 ENDDO 1220 !$OMP END CRITICAL 1221 !$OMP BARRIER 1222 1223 !$OMP MASTER 1224 DO i=1,dimsize 1225 VarOut(i)=Buff(i) 1226 ENDDO 1227 !$OMP END MASTER 1228 !$OMP BARRIER 1229 1230 END SUBROUTINE reduce_min_omp_igen 1231 1232 SUBROUTINE reduce_min_omp_rgen(VarIn,VarOut,dimsize,Buff) 1233 IMPLICIT NONE 1234 1235 INTEGER,INTENT(IN) :: dimsize 1236 REAL,INTENT(IN),DIMENSION(dimsize) :: VarIn 1237 REAL,INTENT(OUT),DIMENSION(dimsize) :: VarOut 1238 REAL,INTENT(INOUT),DIMENSION(dimsize) :: Buff 1239 1240 INTEGER :: i 1241 REAL :: var 1242 1243 !$OMP MASTER 1244 Buff(:)=HUGE(var) 1245 !$OMP END MASTER 1246 !$OMP BARRIER 1247 1248 !$OMP CRITICAL 1249 DO i=1,dimsize 1250 Buff(i)=MIN(Buff(i),VarIn(i)) 1251 ENDDO 1252 !$OMP END CRITICAL 1253 !$OMP BARRIER 1254 1255 !$OMP MASTER 1256 DO i=1,dimsize 1257 VarOut(i)=Buff(i) 1258 ENDDO 1259 !$OMP END MASTER 1260 !$OMP BARRIER 1261 1262 END SUBROUTINE reduce_min_omp_rgen 1263 1264 1064 1265 END MODULE mod_phys_lmdz_omp_transfert -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_para.F90
r2429 r3605 33 33 is_master=.FALSE. 34 34 ENDIF 35 CALL Test_transfert35 !ym CALL Test_transfert 36 36 !$OMP END PARALLEL 37 37 IF (is_using_mpi .OR. is_using_omp) THEN … … 49 49 SUBROUTINE Test_transfert 50 50 USE mod_grid_phy_lmdz 51 USE print_control_mod, ONLY: lunout 51 52 IMPLICIT NONE 52 INCLUDE "iniprint.h"53 ! INCLUDE "iniprint.h" 53 54 54 55 REAL :: Test_Field1d_glo(klon_glo,nbp_lev) -
LMDZ6/branches/Ocean_skin/libf/phy_common/mod_phys_lmdz_transfert_para.F90
r2326 r3605 1 1 ! 2 !$ Header$2 !$Id$ 3 3 ! 4 4 MODULE mod_phys_lmdz_transfert_para … … 46 46 END INTERFACE 47 47 48 INTERFACE reduce_min 49 MODULE PROCEDURE reduce_min_i,reduce_min_i1,reduce_min_i2,reduce_min_i3,reduce_min_i4, & 50 reduce_min_r,reduce_min_r1,reduce_min_r2,reduce_min_r3,reduce_min_r4 51 END INTERFACE 48 52 49 53 CONTAINS … … 1271 1275 END SUBROUTINE reduce_sum_r4 1272 1276 1277 1278 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1279 !! Definition des reduce_min --> 4D !! 1280 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1281 1282 ! Les entiers 1283 1284 SUBROUTINE reduce_min_i(VarIn, VarOut) 1285 IMPLICIT NONE 1286 1287 INTEGER,INTENT(IN) :: VarIn 1288 INTEGER,INTENT(OUT) :: VarOut 1289 1290 INTEGER :: Var_tmp 1291 1292 CALL reduce_min_omp(VarIn,Var_tmp) 1293 !$OMP MASTER 1294 CALL reduce_min_mpi(Var_tmp,VarOut) 1295 !$OMP END MASTER 1296 1297 END SUBROUTINE reduce_min_i 1298 1299 1300 SUBROUTINE reduce_min_i1(VarIn, VarOut) 1301 IMPLICIT NONE 1302 1303 INTEGER,INTENT(IN),DIMENSION(:) :: VarIn 1304 INTEGER,INTENT(OUT),DIMENSION(:) :: VarOut 1305 1306 INTEGER,DIMENSION(SIZE(VarIn)) :: Var_tmp 1307 1308 CALL reduce_min_omp(VarIn,Var_tmp) 1309 !$OMP MASTER 1310 CALL reduce_min_mpi(Var_tmp,VarOut) 1311 !$OMP END MASTER 1312 1313 END SUBROUTINE reduce_min_i1 1314 1315 1316 SUBROUTINE reduce_min_i2(VarIn, VarOut) 1317 IMPLICIT NONE 1318 1319 INTEGER,INTENT(IN),DIMENSION(:,:) :: VarIn 1320 INTEGER,INTENT(OUT),DIMENSION(:,:) :: VarOut 1321 1322 INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp 1323 1324 CALL reduce_min_omp(VarIn,Var_tmp) 1325 !$OMP MASTER 1326 CALL reduce_min_mpi(Var_tmp,VarOut) 1327 !$OMP END MASTER 1328 1329 END SUBROUTINE reduce_min_i2 1330 1331 1332 SUBROUTINE reduce_min_i3(VarIn, VarOut) 1333 IMPLICIT NONE 1334 1335 INTEGER,INTENT(IN),DIMENSION(:,:,:) :: VarIn 1336 INTEGER,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 1337 1338 INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp 1339 1340 CALL reduce_min_omp(VarIn,Var_tmp) 1341 !$OMP MASTER 1342 CALL reduce_min_mpi(Var_tmp,VarOut) 1343 !$OMP END MASTER 1344 1345 END SUBROUTINE reduce_min_i3 1346 1347 1348 SUBROUTINE reduce_min_i4(VarIn, VarOut) 1349 IMPLICIT NONE 1350 1351 INTEGER,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 1352 INTEGER,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 1353 1354 INTEGER,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp 1355 1356 CALL reduce_min_omp(VarIn,Var_tmp) 1357 !$OMP MASTER 1358 CALL reduce_min_mpi(Var_tmp,VarOut) 1359 !$OMP END MASTER 1360 1361 END SUBROUTINE reduce_min_i4 1362 1363 1364 ! Les reels 1365 1366 SUBROUTINE reduce_min_r(VarIn, VarOut) 1367 IMPLICIT NONE 1368 1369 REAL,INTENT(IN) :: VarIn 1370 REAL,INTENT(OUT) :: VarOut 1371 1372 REAL :: Var_tmp 1373 1374 CALL reduce_min_omp(VarIn,Var_tmp) 1375 !$OMP MASTER 1376 CALL reduce_min_mpi(Var_tmp,VarOut) 1377 !$OMP END MASTER 1378 1379 END SUBROUTINE reduce_min_r 1380 1381 1382 SUBROUTINE reduce_min_r1(VarIn, VarOut) 1383 IMPLICIT NONE 1384 1385 REAL,INTENT(IN),DIMENSION(:) :: VarIn 1386 REAL,INTENT(OUT),DIMENSION(:) :: VarOut 1387 1388 REAL,DIMENSION(SIZE(VarIn)) :: Var_tmp 1389 1390 CALL reduce_min_omp(VarIn,Var_tmp) 1391 !$OMP MASTER 1392 CALL reduce_min_mpi(Var_tmp,VarOut) 1393 !$OMP END MASTER 1394 1395 END SUBROUTINE reduce_min_r1 1396 1397 1398 SUBROUTINE reduce_min_r2(VarIn, VarOut) 1399 IMPLICIT NONE 1400 1401 REAL,INTENT(IN),DIMENSION(:,:) :: VarIn 1402 REAL,INTENT(OUT),DIMENSION(:,:) :: VarOut 1403 1404 REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2)) :: Var_tmp 1405 1406 CALL reduce_min_omp(VarIn,Var_tmp) 1407 !$OMP MASTER 1408 CALL reduce_min_mpi(Var_tmp,VarOut) 1409 !$OMP END MASTER 1410 1411 END SUBROUTINE reduce_min_r2 1412 1413 1414 SUBROUTINE reduce_min_r3(VarIn, VarOut) 1415 IMPLICIT NONE 1416 1417 REAL,INTENT(IN),DIMENSION(:,:,:) :: VarIn 1418 REAL,INTENT(OUT),DIMENSION(:,:,:) :: VarOut 1419 1420 REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3)) :: Var_tmp 1421 1422 CALL reduce_min_omp(VarIn,Var_tmp) 1423 !$OMP MASTER 1424 CALL reduce_min_mpi(Var_tmp,VarOut) 1425 !$OMP END MASTER 1426 1427 END SUBROUTINE reduce_min_r3 1428 1429 1430 SUBROUTINE reduce_min_r4(VarIn, VarOut) 1431 IMPLICIT NONE 1432 1433 REAL,INTENT(IN),DIMENSION(:,:,:,:) :: VarIn 1434 REAL,INTENT(OUT),DIMENSION(:,:,:,:) :: VarOut 1435 1436 REAL,DIMENSION(SIZE(VarIn,1),SIZE(VarIn,2),SIZE(VarIn,3),SIZE(VarIn,4)) :: Var_tmp 1437 1438 CALL reduce_min_omp(VarIn,Var_tmp) 1439 !$OMP MASTER 1440 CALL reduce_min_mpi(Var_tmp,VarOut) 1441 !$OMP END MASTER 1442 1443 END SUBROUTINE reduce_min_r4 1444 1445 1273 1446 1274 1447 END MODULE mod_phys_lmdz_transfert_para -
LMDZ6/branches/Ocean_skin/libf/phy_common/physics_distribution_mod.F90
r2351 r3605 10 10 nbp, nbp_lon, nbp_lat, nbp_lev, & 11 11 communicator) 12 USE mod_phys_lmdz_para, ONLY: init_phys_lmdz_para 12 USE mod_phys_lmdz_para, ONLY: init_phys_lmdz_para, klon_omp 13 13 USE mod_grid_phy_lmdz, ONLY: init_grid_phy_lmdz 14 USE dimphy, ONLY : Init_dimphy 15 USE infotrac_phy, ONLY : type_trac 16 #ifdef REPROBUS 17 USE CHEM_REP, ONLY : Init_chem_rep_phys 18 #endif 19 14 20 IMPLICIT NONE 15 21 INTEGER,INTENT(IN) :: grid_type … … 24 30 CALL init_grid_phy_lmdz(grid_type,nvertex, nbp_lon,nbp_lat,nbp_lev) 25 31 CALL init_phys_lmdz_para(nbp,nbp_lon, nbp_lat, communicator) 32 !$OMP PARALLEL 33 CALL init_dimphy(klon_omp,nbp_lev) 34 35 ! Initialization of Reprobus 36 IF (type_trac == 'repr') THEN 37 #ifdef REPROBUS 38 CALL Init_chem_rep_phys(klon_omp,nbp_lev) 39 #endif 40 END IF 41 42 !$OMP END PARALLEL 26 43 27 44 END SUBROUTINE init_physics_distribution -
LMDZ6/branches/Ocean_skin/libf/phy_common/print_control_mod.F90
r2326 r3605 7 7 !$OMP THREADPRIVATE(lunout,prt_level,debug) 8 8 9 ! NB: Module variable Initializations done by set_print_control 10 ! routine from init_print_control_mod to avoid circular 11 ! module dependencies 12 9 13 CONTAINS 10 14 11 SUBROUTINE init_print_control 12 USE ioipsl_getin_p_mod, ONLY : getin_p 13 USE mod_phys_lmdz_para, ONLY: is_omp_root, is_master 15 SUBROUTINE set_print_control(lunout_,prt_level_,debug_) 14 16 IMPLICIT NONE 15 16 LOGICAL :: opened 17 INTEGER :: number 17 INTEGER :: lunout_ 18 INTEGER :: prt_level_ 19 LOGICAL :: debug_ 20 21 lunout = lunout_ 22 prt_level = prt_level_ 23 debug = debug_ 18 24 19 !Config Key = prt_level 20 !Config Desc = niveau d'impressions de débogage 21 !Config Def = 0 22 !Config Help = Niveau d'impression pour le débogage 23 !Config (0 = minimum d'impression) 24 prt_level = 0 25 CALL getin_p('prt_level',prt_level) 26 27 !Config Key = lunout 28 !Config Desc = unite de fichier pour les impressions 29 !Config Def = 6 30 !Config Help = unite de fichier pour les impressions 31 !Config (defaut sortie standard = 6) 32 lunout=6 33 CALL getin_p('lunout', lunout) 34 35 IF (is_omp_root) THEN 36 IF (lunout /= 5 .and. lunout /= 6) THEN 37 INQUIRE(FILE='lmdz.out_0000',OPENED=opened,NUMBER=number) 38 IF (opened) THEN 39 lunout=number 40 ELSE 41 OPEN(UNIT=lunout,FILE='lmdz.out_0000',ACTION='write', & 42 STATUS='unknown',FORM='formatted') 43 ENDIF 44 ENDIF 45 ENDIF 46 47 !Config Key = debug 48 !Config Desc = mode debogage 49 !Config Def = false 50 !Config Help = positionne le mode debogage 51 52 debug = .FALSE. 53 CALL getin_p('debug',debug) 54 55 IF (is_master) THEN 56 WRITE(lunout,*)"init_print_control: prt_level=",prt_level 57 WRITE(lunout,*)"init_print_control: lunout=",lunout 58 WRITE(lunout,*)"init_print_control: debug=",debug 59 ENDIF 60 61 END SUBROUTINE init_print_control 25 END SUBROUTINE set_print_control 62 26 63 27 END MODULE print_control_mod -
LMDZ6/branches/Ocean_skin/libf/phydev/inifis_mod.F90
r2311 r3605 1 ! $Id :$1 ! $Id$ 2 2 MODULE inifis_mod 3 3 … … 6 6 SUBROUTINE inifis(prad, pg, pr, pcpp) 7 7 ! Initialize some physical constants and settings 8 USE print_control_mod, ONLY: init_print_control8 USE init_print_control_mod, ONLY: init_print_control 9 9 USE comcstphy, ONLY: rradius, & ! planet radius (m) 10 10 rr, & ! recuced gas constant: R/molar mass of atm -
LMDZ6/branches/Ocean_skin/libf/phydev/phyredem.F90
r2395 r3605 5 5 6 6 USE geometry_mod, ONLY : longitude_deg, latitude_deg 7 USE iostart, ONLY: open_restartphy, close_restartphy, put_var, put_field 7 USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var 8 8 9 9 10 IMPLICIT NONE … … 13 14 INTEGER,PARAMETER :: tab_cntrl_len=100 14 15 REAL :: tab_cntrl(tab_cntrl_len) 16 INTEGER :: pass 15 17 16 18 ! open file … … 21 23 22 24 tab_cntrl(:)=0.0 23 24 25 25 CALL put_var("controle", "Control parameters", tab_cntrl) 26 DO pass=1,2 ! pass=1 netcdf definition ; pass=2 netcdf write 27 28 CALL put_var(pass, "controle", "Control parameters", tab_cntrl) 26 29 27 30 ! coordinates 28 31 29 CALL put_field("longitude", "Longitudes on physics grid", longitude_deg)32 CALL put_field(pass, "longitude", "Longitudes on physics grid", longitude_deg) 30 33 31 CALL put_field("latitude", "Latitudes on physics grid", latitude_deg)34 CALL put_field(pass, "latitude", "Latitudes on physics grid", latitude_deg) 32 35 36 IF (pass==1) CALL enddef_restartphy 37 IF (pass==2) CALL close_restartphy 38 39 ENDDO 33 40 ! close file 34 41 -
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/aer_sedimnt.F90
-
Property
svn:keywords
set to
Id
r2752 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE AER_SEDIMNT(pdtphys, t_seri, pplay, paprs, tr_seri, dens_aer) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/aerophys.F90
-
Property
svn:keywords
set to
Id
-
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/calcaerosolstrato_rrtm.F90
-
Property
svn:keywords
set to
Id
r2715 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE calcaerosolstrato_rrtm(pplay,t_seri,paprs,debut) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/coagulate.F90
-
Property
svn:keywords
set to
Id
r2950 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE COAGULATE(pdtcoag,mdw,tr_seri,t_seri,pplay,dens_aer,is_strato) 2 5 ! ----------------------------------------------------------------------- -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/cond_evap_tstep_mod.F90
-
Property
svn:keywords
set to
Id
r2695 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE cond_evap_tstep_mod 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/interp_sulf_input.F90
-
Property
svn:keywords
set to
Id
r3097 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE interp_sulf_input(debutphy,pdtphys,paprs,tr_seri) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/micphy_tstep.F90
-
Property
svn:keywords
set to
Id
r3098 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE micphy_tstep(pdtphys,tr_seri,t_seri,pplay,paprs,rh,is_strato) 2 5 6 USE geometry_mod, ONLY : latitude_deg !NL- latitude corr. to local domain 3 7 USE dimphy, ONLY : klon,klev 4 8 USE aerophys … … 9 13 USE sulfate_aer_mod, ONLY : STRAACT 10 14 USE YOMCST, ONLY : RPI, RD, RG 11 15 USE print_control_mod, ONLY: lunout 16 USE strataer_mod 17 12 18 IMPLICIT NONE 13 19 … … 89 95 ! compute nucleation rate in kg(H2SO4)/kgA/s 90 96 CALL nucleation_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev),rh(ilon,ilev), & 91 & a_xm,b_xm,c_xm,nucl_rate,ntot,x) 97 & a_xm,b_xm,c_xm,nucl_rate,ntot,x) 98 !NL - add nucleation box (if flag on) 99 IF (flag_nuc_rate_box) THEN 100 IF (latitude_deg(ilon).LE.nuclat_min .OR. latitude_deg(ilon).GE.nuclat_max & 101 .OR. pplay(ilon,ilev).GE.nucpres_max .AND. pplay(ilon,ilev).LE.nucpres_min) THEN 102 nucl_rate=0.0 103 ENDIF 104 ENDIF 92 105 ! compute cond/evap rate in kg(H2SO4)/kgA/s 93 106 CALL condens_evapor_rate(rhoa,t_seri(ilon,ilev),pplay(ilon,ilev), & … … 160 173 DO it=1, nbtr 161 174 IF (tr_seri(ilon,ilev,it).LT.0.0) THEN 162 PRINT *,'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it175 WRITE(lunout,*) 'micphy_tstep: negative concentration', tr_seri(ilon,ilev,it), ilon, ilev, it 163 176 ENDIF 164 177 ENDDO -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/miecalc_aer.F90
-
Property
svn:keywords
set to
Id
r2948 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE MIECALC_AER(tau_strat, piz_strat, cg_strat, tau_strat_wave, tau_lw_abs_rrtm, paprs, debut) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/minmaxsimple.F90
-
Property
svn:keywords
set to
Id
r2690 r3605 1 1 ! 2 ! $Id : minmaxsimple.F90 1910 2013-11-29 08:40:25Z fairhead$2 ! $Id$ 3 3 ! 4 4 SUBROUTINE minmaxsimple(zq,qmin,qmax,comment) -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/nucleation_tstep_mod.F90
-
Property
svn:keywords
set to
Id
r2695 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE nucleation_tstep_mod 2 5 3 6 CONTAINS 4 7 5 SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot ,x)8 SUBROUTINE nucleation_rate(rhoa,t_seri,pplay,rh,a_xm,b_xm,c_xm,nucl_rate,ntot_n,x_n) 6 9 7 10 USE aerophys 8 11 USE infotrac 9 USE YOMCST, ONLY : RPI, RD 12 USE YOMCST, ONLY : RPI, RD, RMD, RKBOL, RNAVO 10 13 11 14 IMPLICIT NONE 12 15 13 16 ! input variables 14 REAL rhoa !H2SO4 number density [molecules/cm3] 15 REAL t_seri 16 REAL pplay 17 REAL rh 17 LOGICAL, PARAMETER :: flag_new_nucl=.TRUE. 18 REAL rhoa ! H2SO4 number density [molecules/cm3] 19 REAL t_seri ! temperature (K) 20 REAL pplay ! pressure (Pa) 21 REAL rh ! relative humidity (between 0 and 1) 18 22 REAL a_xm, b_xm, c_xm 19 23 20 24 ! output variables 21 25 REAL nucl_rate 22 REAL ntot ! total number of molecules in the critical cluster23 REAL x ! molefraction of H2SO4 in the critical cluster26 REAL ntot_n ! total number of molecules in the critical cluster for neutral nucleation 27 REAL x_n ! mole fraction of H2SO4 in the critical cluster for neutral nucleation 24 28 25 29 ! local variables 26 REAL, PARAMETER :: k_B=1.3806E-23 ! Boltzmann constant [J/K] 27 REAL :: jnuc !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) 28 REAL :: rc !radius of the critical cluster in nm 30 REAL jnuc_n ! nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) for neutral nucleation 31 REAL rc_n ! radius of the critical cluster in nm for neutral nucleation 32 REAL na_n ! sulfuric acid molecules in the neutral critical cluster (NOT IN USE) 33 LOGICAL kinetic_n ! true if kinetic neutral nucleation (NOT IN USE) 34 LOGICAL kinetic_i ! true if kinetic ion-induced nucleation (NOT IN USE) 35 REAL rhoatres ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation (NOT IN USE) 29 36 REAL VH2SO4mol 37 REAL ntot_i, x_i, jnuc_i, rc_i, na_i, n_i ! quantities for charged nucleation (NOT IN USE) 38 REAL csi ! Ion condensation sink (s-1) NOT IN USE 39 REAL airn ! Air molecule concentration in (cm-3) NOT IN USE 40 REAL ipr ! Ion pair production rate (cm-3 s-1) NOT IN USE 30 41 31 42 ! call nucleation routine 32 CALL binapara(t_seri,rh,rhoa,jnuc,x,ntot,rc) 33 34 IF (ntot < 4.0) THEN 35 !set jnuc to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki) 36 VH2SO4mol=mH2SO4mol/(1.e-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3 37 jnuc = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*k_B*t_seri/mH2SO4mol)**0.5 & 38 & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s) 39 ntot=2.0 40 x=1.0 41 ENDIF 42 43 ! convert jnuc from particles/cm3/s to kg(H2SO4)/kgA/s 44 nucl_rate=jnuc*ntot*x*mH2SO4mol/(pplay/t_seri/RD/1.E6) 43 IF (.NOT.flag_new_nucl) THEN 44 ! Use older routine from Hanna Vehkamäki (FMI) 45 CALL binapara(t_seri,rh,rhoa,jnuc_n,x_n,ntot_n,rc_n) 46 ! when total number of molecules is too small 47 ! then set jnuc_n to collision rate of two H2SO4 molecules (following personal communication of Ulrike Niemeier and Hanna Vehkamäki) 48 IF (ntot_n < 4.0) THEN 49 VH2SO4mol=mH2SO4mol/(1.E-3*(a_xm+t_seri*(b_xm+t_seri*c_xm))) !cm3 50 jnuc_n = rhoa**2. *(3./4.*RPI)**(1./6.) *(12.*RKBOL*t_seri/mH2SO4mol)**0.5 & 51 & *100.*(2.*VH2SO4mol**(1./3.))**2. !1/(cm3s) 52 ntot_n=2.0 53 x_n=1.0 54 ENDIF 55 ELSE 56 ! Use new routine from Anni Maattanen (LATMOS) 57 csi=0.0 ! no charged nucleation for now 58 ipr=-1.0 ! dummy value to make sure charged nucleation does not occur 59 airn=0.0 ! NOT IN USE 60 ! airn=pplay/t_seri/RD/1.E3*RNAVO/RMD ! molec cm-3 (for future use, to be confirmed) 61 CALL newbinapara(t_seri,rh,rhoa,csi,airn,ipr,jnuc_n,ntot_n,jnuc_i,ntot_i, & 62 & x_n,x_i,na_n,na_i,rc_n,rc_i,n_i,kinetic_n,kinetic_i,rhoatres) 63 ENDIF 64 65 ! convert jnuc_n from particles/cm3/s to kg(H2SO4)/kgA/s 66 nucl_rate=jnuc_n*ntot_n*x_n*mH2SO4mol/(pplay/t_seri/RD/1.E6) 45 67 46 68 END SUBROUTINE nucleation_rate … … 55 77 IMPLICIT NONE 56 78 57 ! input variable s79 ! input variable 58 80 REAL nucl_rate 59 81 REAL ntot ! total number of molecules in the critical cluster 60 REAL x ! mole fraction of H2SO4 in the critical cluster82 REAL x ! mole raction of H2SO4 in the critical cluster 61 83 REAL dt 62 84 REAL Vbin(nbtr_bin) 63 85 64 ! output variable s86 ! output variable 65 87 REAL tr_seri(nbtr) 66 88 67 ! local variable s89 ! local variable 68 90 INTEGER k 69 91 REAL Vnew … … 77 99 DO k=1, nbtr_bin 78 100 ! CK 20160531: bug fix for first bin 79 IF (k.LE. (nbtr_bin-1)) THEN101 IF (k.LE.nbtr_bin-1) THEN 80 102 IF (Vbin(k).LE.Vnew.AND.Vnew.LT.Vbin(k+1)) THEN 81 103 ff(k)= Vbin(k)/Vnew*(Vbin(k+1)-Vnew)/(Vbin(k+1)-Vbin(k)) … … 132 154 133 155 REAL :: pt,t !temperature in K (190.15-300.15K) 134 REAL :: prh,rh !saturatio ratio of water (0.0001-1)135 REAL, intent(in) :: rhoa_in !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3)136 REAL, intent(out) :: jnuc !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s)137 REAL, intent(out) :: ntot !total number of molecules in the critical cluster (ntot>4)138 REAL, intent(out) :: x ! molefraction of H2SO4 in the critical cluster139 REAL, intent(out) :: rc !radius of the critical cluster in nm140 REAL :: rhotres ! t reshold concentration of h2so4 (1/cm^3)156 REAL :: prh,rh !saturation ratio of water (0.0001-1) 157 REAL,INTENT(IN) :: rhoa_in !sulfuric acid concentration in 1/cm3 (10^4-10^11 1/cm3) 158 REAL,INTENT(OUT) :: jnuc !nucleation rate in 1/cm3s (10^-7-10^10 1/cm3s) 159 REAL,INTENT(OUT) :: ntot !total number of molecules in the critical cluster (ntot>4) 160 REAL,INTENT(OUT) :: x ! mole fraction of H2SO4 in the critical cluster 161 REAL,INTENT(OUT) :: rc !radius of the critical cluster in nm 162 REAL :: rhotres ! threshold concentration of h2so4 (1/cm^3) 141 163 ! which produces nucleation rate 1/(cm^3 s) as a function of rh and t 142 164 REAL rhoa 143 165 144 ! CK: use intermediate variable sto avoid overwriting166 ! CK: use intermediate variable to avoid overwriting 145 167 t=pt 146 168 rh=prh … … 178 200 ENDIF 179 201 180 x= 0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*L og(rh) &181 & - 0.0001832894131464668*t*L og(rh) + 0.001574072538464286*Log(rh)**2 &182 & - 0.00001790589121766952*t*L og(rh)**2 + 0.0001844027436573778*Log(rh)**3 &183 & - 1.503452308794887 e-6*t*Log(rh)**3 - 0.003499978417957668*Log(rhoa) &184 & + 0.0000504021689382576*t*L og(rhoa)202 x= 0.7409967177282139 - 0.002663785665140117*t + 0.002010478847383187*LOG(rh) & 203 & - 0.0001832894131464668*t*LOG(rh) + 0.001574072538464286*LOG(rh)**2 & 204 & - 0.00001790589121766952*t*LOG(rh)**2 + 0.0001844027436573778*LOG(rh)**3 & 205 & - 1.503452308794887E-6*t*LOG(rh)**3 - 0.003499978417957668*LOG(rhoa) & 206 & + 0.0000504021689382576*t*LOG(rhoa) 185 207 186 208 jnuc= 0.1430901615568665 + 2.219563673425199*t - 0.02739106114964264*t**2 + & 187 209 & 0.00007228107239317088*t**3 + 5.91822263375044/x + & 188 & 0.1174886643003278*L og(rh) + 0.4625315047693772*t*Log(rh) - &189 & 0.01180591129059253*t**2*L og(rh) + &190 & 0.0000404196487152575*t**3*L og(rh) + (15.79628615047088*Log(rh))/x - &191 & 0.215553951893509*L og(rh)**2 - 0.0810269192332194*t*Log(rh)**2 + &192 & 0.001435808434184642*t**2*L og(rh)**2 - &193 & 4.775796947178588 e-6*t**3*Log(rh)**2 - &194 & (2.912974063702185*L og(rh)**2)/x - 3.588557942822751*Log(rh)**3 + &195 & 0.04950795302831703*t*L og(rh)**3 - &196 & 0.0002138195118737068*t**2*L og(rh)**3 + &197 & 3.108005107949533 e-7*t**3*Log(rh)**3 - &198 & (0.02933332747098296*L og(rh)**3)/x + &199 & 1.145983818561277*L og(rhoa) - &200 & 0.6007956227856778*t*L og(rhoa) + &201 & 0.00864244733283759*t**2*L og(rhoa) - &202 & 0.00002289467254710888*t**3*L og(rhoa) - &203 & (8.44984513869014*L og(rhoa))/x + &204 & 2.158548369286559*L og(rh)*Log(rhoa) + &205 & 0.0808121412840917*t*L og(rh)*Log(rhoa) - &206 & 0.0004073815255395214*t**2*L og(rh)*Log(rhoa) - &207 & 4.019572560156515 e-7*t**3*Log(rh)*Log(rhoa) + &208 & (0.7213255852557236*L og(rh)*Log(rhoa))/x + &209 & 1.62409850488771*L og(rh)**2*Log(rhoa) - &210 & 0.01601062035325362*t*L og(rh)**2*Log(rhoa) + &211 & 0.00003771238979714162*t**2*L og(rh)**2*Log(rhoa) + &212 & 3.217942606371182 e-8*t**3*Log(rh)**2*Log(rhoa) - &213 & (0.01132550810022116*L og(rh)**2*Log(rhoa))/x + &214 & 9.71681713056504*L og(rhoa)**2 - &215 & 0.1150478558347306*t*L og(rhoa)**2 + &216 & 0.0001570982486038294*t**2*L og(rhoa)**2 + &217 & 4.009144680125015 e-7*t**3*Log(rhoa)**2 + &218 & (0.7118597859976135*L og(rhoa)**2)/x - &219 & 1.056105824379897*L og(rh)*Log(rhoa)**2 + &220 & 0.00903377584628419*t*L og(rh)*Log(rhoa)**2 - &221 & 0.00001984167387090606*t**2*L og(rh)*Log(rhoa)**2 + &222 & 2.460478196482179 e-8*t**3*Log(rh)*Log(rhoa)**2 - &223 & (0.05790872906645181*L og(rh)*Log(rhoa)**2)/x - &224 & 0.1487119673397459*L og(rhoa)**3 + &225 & 0.002835082097822667*t*L og(rhoa)**3 - &226 & 9.24618825471694 e-6*t**2*Log(rhoa)**3 + &227 & 5.004267665960894 e-9*t**3*Log(rhoa)**3 - &228 & (0.01270805101481648*L og(rhoa)**3)/x229 jnuc= exp(jnuc) !1/(cm3s)230 231 ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116 e-6*t**3 - &232 & 0.1017165718716887/x - 0.002050640345231486*L og(rh) - 0.007585041382707174*t*Log(rh) + &233 & 0.0001926539658089536*t**2*L og(rh) - 6.70429719683894e-7*t**3*Log(rh) - &234 & (0.2557744774673163*L og(rh))/x + 0.003223076552477191*Log(rh)**2 + 0.000852636632240633*t*Log(rh)**2 - &235 & 0.00001547571354871789*t**2*L og(rh)**2 + 5.666608424980593e-8*t**3*Log(rh)**2 + &236 & (0.03384437400744206*L og(rh)**2)/x + 0.04743226764572505*Log(rh)**3 - &237 & 0.0006251042204583412*t*L og(rh)**3 + 2.650663328519478e-6*t**2*Log(rh)**3 - &238 & 3.674710848763778 e-9*t**3*Log(rh)**3 - (0.0002672510825259393*Log(rh)**3)/x - &239 & 0.01252108546759328*L og(rhoa) + 0.005806550506277202*t*Log(rhoa) - &240 & 0.0001016735312443444*t**2*L og(rhoa) + 2.881946187214505e-7*t**3*Log(rhoa) + &241 & (0.0942243379396279*L og(rhoa))/x - 0.0385459592773097*Log(rh)*Log(rhoa) - &242 & 0.0006723156277391984*t*L og(rh)*Log(rhoa) + 2.602884877659698e-6*t**2*Log(rh)*Log(rhoa) + &243 & 1.194163699688297 e-8*t**3*Log(rh)*Log(rhoa) - (0.00851515345806281*Log(rh)*Log(rhoa))/x - &244 & 0.01837488495738111*L og(rh)**2*Log(rhoa) + 0.0001720723574407498*t*Log(rh)**2*Log(rhoa) - &245 & 3.717657974086814 e-7*t**2*Log(rh)**2*Log(rhoa) - &246 & 5.148746022615196 e-10*t**3*Log(rh)**2*Log(rhoa) + &247 & (0.0002686602132926594*L og(rh)**2*Log(rhoa))/x - 0.06199739728812199*Log(rhoa)**2 + &248 & 0.000906958053583576*t*L og(rhoa)**2 - 9.11727926129757e-7*t**2*Log(rhoa)**2 - &249 & 5.367963396508457 e-9*t**3*Log(rhoa)**2 - (0.007742343393937707*Log(rhoa)**2)/x + &250 & 0.0121827103101659*L og(rh)*Log(rhoa)**2 - 0.0001066499571188091*t*Log(rh)*Log(rhoa)**2 + &251 & 2.534598655067518 e-7*t**2*Log(rh)*Log(rhoa)**2 - &252 & 3.635186504599571 e-10*t**3*Log(rh)*Log(rhoa)**2 + &253 & (0.0006100650851863252*L og(rh)*Log(rhoa)**2)/x + 0.0003201836700403512*Log(rhoa)**3 - &254 & 0.0000174761713262546*t*L og(rhoa)**3 + 6.065037668052182e-8*t**2*Log(rhoa)**3 - &255 & 1.421771723004557 e-11*t**3*Log(rhoa)**3 + (0.0001357509859501723*Log(rhoa)**3)/x256 ntot= exp(ntot)257 258 rc= exp(-1.6524245+0.42316402*x+0.33466487*log(ntot)) !nm259 260 IF (jnuc < 1. e-7) THEN261 ! print *,'Warning (ilon=',ilon,'ilev=',ilev'): nucleation rate < 1 e-7/cm3s, using 0.0/cm3s,'210 & 0.1174886643003278*LOG(rh) + 0.4625315047693772*t*LOG(rh) - & 211 & 0.01180591129059253*t**2*LOG(rh) + & 212 & 0.0000404196487152575*t**3*LOG(rh) + (15.79628615047088*LOG(rh))/x - & 213 & 0.215553951893509*LOG(rh)**2 - 0.0810269192332194*t*LOG(rh)**2 + & 214 & 0.001435808434184642*t**2*LOG(rh)**2 - & 215 & 4.775796947178588E-6*t**3*LOG(rh)**2 - & 216 & (2.912974063702185*LOG(rh)**2)/x - 3.588557942822751*LOG(rh)**3 + & 217 & 0.04950795302831703*t*LOG(rh)**3 - & 218 & 0.0002138195118737068*t**2*LOG(rh)**3 + & 219 & 3.108005107949533E-7*t**3*LOG(rh)**3 - & 220 & (0.02933332747098296*LOG(rh)**3)/x + & 221 & 1.145983818561277*LOG(rhoa) - & 222 & 0.6007956227856778*t*LOG(rhoa) + & 223 & 0.00864244733283759*t**2*LOG(rhoa) - & 224 & 0.00002289467254710888*t**3*LOG(rhoa) - & 225 & (8.44984513869014*LOG(rhoa))/x + & 226 & 2.158548369286559*LOG(rh)*LOG(rhoa) + & 227 & 0.0808121412840917*t*LOG(rh)*LOG(rhoa) - & 228 & 0.0004073815255395214*t**2*LOG(rh)*LOG(rhoa) - & 229 & 4.019572560156515E-7*t**3*LOG(rh)*LOG(rhoa) + & 230 & (0.7213255852557236*LOG(rh)*LOG(rhoa))/x + & 231 & 1.62409850488771*LOG(rh)**2*LOG(rhoa) - & 232 & 0.01601062035325362*t*LOG(rh)**2*LOG(rhoa) + & 233 & 0.00003771238979714162*t**2*LOG(rh)**2*LOG(rhoa) + & 234 & 3.217942606371182E-8*t**3*LOG(rh)**2*LOG(rhoa) - & 235 & (0.01132550810022116*LOG(rh)**2*LOG(rhoa))/x + & 236 & 9.71681713056504*LOG(rhoa)**2 - & 237 & 0.1150478558347306*t*LOG(rhoa)**2 + & 238 & 0.0001570982486038294*t**2*LOG(rhoa)**2 + & 239 & 4.009144680125015E-7*t**3*LOG(rhoa)**2 + & 240 & (0.7118597859976135*LOG(rhoa)**2)/x - & 241 & 1.056105824379897*LOG(rh)*LOG(rhoa)**2 + & 242 & 0.00903377584628419*t*LOG(rh)*LOG(rhoa)**2 - & 243 & 0.00001984167387090606*t**2*LOG(rh)*LOG(rhoa)**2 + & 244 & 2.460478196482179E-8*t**3*LOG(rh)*LOG(rhoa)**2 - & 245 & (0.05790872906645181*LOG(rh)*LOG(rhoa)**2)/x - & 246 & 0.1487119673397459*LOG(rhoa)**3 + & 247 & 0.002835082097822667*t*LOG(rhoa)**3 - & 248 & 9.24618825471694E-6*t**2*LOG(rhoa)**3 + & 249 & 5.004267665960894E-9*t**3*LOG(rhoa)**3 - & 250 & (0.01270805101481648*LOG(rhoa)**3)/x 251 jnuc=EXP(jnuc) !1/(cm3s) 252 253 ntot =-0.002954125078716302 - 0.0976834264241286*t + 0.001024847927067835*t**2 - 2.186459697726116E-6*t**3 - & 254 & 0.1017165718716887/x - 0.002050640345231486*LOG(rh) - 0.007585041382707174*t*LOG(rh) + & 255 & 0.0001926539658089536*t**2*LOG(rh) - 6.70429719683894E-7*t**3*LOG(rh) - & 256 & (0.2557744774673163*LOG(rh))/x + 0.003223076552477191*LOG(rh)**2 + 0.000852636632240633*t*LOG(rh)**2 - & 257 & 0.00001547571354871789*t**2*LOG(rh)**2 + 5.666608424980593E-8*t**3*LOG(rh)**2 + & 258 & (0.03384437400744206*LOG(rh)**2)/x + 0.04743226764572505*LOG(rh)**3 - & 259 & 0.0006251042204583412*t*LOG(rh)**3 + 2.650663328519478E-6*t**2*LOG(rh)**3 - & 260 & 3.674710848763778E-9*t**3*LOG(rh)**3 - (0.0002672510825259393*LOG(rh)**3)/x - & 261 & 0.01252108546759328*LOG(rhoa) + 0.005806550506277202*t*LOG(rhoa) - & 262 & 0.0001016735312443444*t**2*LOG(rhoa) + 2.881946187214505E-7*t**3*LOG(rhoa) + & 263 & (0.0942243379396279*LOG(rhoa))/x - 0.0385459592773097*LOG(rh)*LOG(rhoa) - & 264 & 0.0006723156277391984*t*LOG(rh)*LOG(rhoa) + 2.602884877659698E-6*t**2*LOG(rh)*LOG(rhoa) + & 265 & 1.194163699688297E-8*t**3*LOG(rh)*LOG(rhoa) - (0.00851515345806281*LOG(rh)*LOG(rhoa))/x - & 266 & 0.01837488495738111*LOG(rh)**2*LOG(rhoa) + 0.0001720723574407498*t*LOG(rh)**2*LOG(rhoa) - & 267 & 3.717657974086814E-7*t**2*LOG(rh)**2*LOG(rhoa) - & 268 & 5.148746022615196E-10*t**3*LOG(rh)**2*LOG(rhoa) + & 269 & (0.0002686602132926594*LOG(rh)**2*LOG(rhoa))/x - 0.06199739728812199*LOG(rhoa)**2 + & 270 & 0.000906958053583576*t*LOG(rhoa)**2 - 9.11727926129757E-7*t**2*LOG(rhoa)**2 - & 271 & 5.367963396508457E-9*t**3*LOG(rhoa)**2 - (0.007742343393937707*LOG(rhoa)**2)/x + & 272 & 0.0121827103101659*LOG(rh)*LOG(rhoa)**2 - 0.0001066499571188091*t*LOG(rh)*LOG(rhoa)**2 + & 273 & 2.534598655067518E-7*t**2*LOG(rh)*LOG(rhoa)**2 - & 274 & 3.635186504599571E-10*t**3*LOG(rh)*LOG(rhoa)**2 + & 275 & (0.0006100650851863252*LOG(rh)*LOG(rhoa)**2)/x + 0.0003201836700403512*LOG(rhoa)**3 - & 276 & 0.0000174761713262546*t*LOG(rhoa)**3 + 6.065037668052182E-8*t**2*LOG(rhoa)**3 - & 277 & 1.421771723004557E-11*t**3*LOG(rhoa)**3 + (0.0001357509859501723*LOG(rhoa)**3)/x 278 ntot=EXP(ntot) 279 280 rc=EXP(-1.6524245+0.42316402*x+0.33466487*LOG(ntot)) !nm 281 282 IF (jnuc < 1.E-7) THEN 283 ! print *,'Warning (ilon=',ilon,'ilev=',ilev'): nucleation rate < 1E-7/cm3s, using 0.0/cm3s,' 262 284 jnuc=0.0 263 285 ENDIF … … 269 291 ENDIF 270 292 271 rhotres= exp( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t &293 rhotres=EXP( -279.2430007512709 + 11.73439886096903*rh + 22700.92970508331/t & 272 294 & - (1088.644983466801*rh)/t + 1.144362942094912*t & 273 295 & - 0.03023314602163684*rh*t - 0.001302541390154324*t**2 & 274 & - 6.386965238433532*L og(rh) + (854.980361026715*Log(rh))/t &275 & + 0.00879662256826497*t*L og(rh)) !1/cm3296 & - 6.386965238433532*LOG(rh) + (854.980361026715*LOG(rh))/t & 297 & + 0.00879662256826497*t*LOG(rh)) !1/cm3 276 298 277 299 RETURN … … 279 301 END SUBROUTINE binapara 280 302 303 !--------------------------------------------------------------------------------------------------- 304 305 SUBROUTINE newbinapara(t,satrat,rhoa,csi,airn,ipr,jnuc_n_real,ntot_n_real,jnuc_i_real,ntot_i_real, & 306 & x_n_real,x_i_real,na_n_real,na_i_real,rc_n_real,rc_i_real,n_i_real, & 307 & kinetic_n,kinetic_i,rhoatres_real) 308 309 ! Fortran 90 subroutine newbinapara 310 ! 311 ! Calculates parametrized values for neutral and ion-induced sulfuric acid-water particle formation rate 312 ! of critical clusters, 313 ! number of particle in the critical clusters, the radii of the critical clusters 314 ! in H2O-H2SO4-ion system if temperature, saturation ratio of water, sulfuric acid concentration, 315 ! and, optionally, either condensation sink due to pre-existing particle and ion pair production rate, 316 ! or atmospheric concentration of negative ions are given. 317 ! 318 ! The code calculates also the kinetic limit and the particle formation rate 319 ! above this limit (in which case we set ntot=1 and na=1) 320 ! 321 ! Copyright (C)2018 Määttänen et al. 2018 322 ! 323 ! anni.maattanen@latmos.ipsl.fr 324 ! joonas.merikanto@fmi.fi 325 ! hanna.vehkamaki@helsinki.fi 326 ! 327 ! References 328 ! A. Määttänen, J. Merikanto, H. Henschel, J. Duplissy, R. Makkonen, 329 ! I. K. Ortega and H. Vehkamäki (2018), New parameterizations for 330 ! neutral and ion-induced sulfuric acid-water particle formation in 331 ! nucleation and kinetic regimes, J. Geophys. Res. Atmos., 122, doi:10.1002/2017JD027429. 332 ! 333 ! Brasseur, G., and A. Chatel (1983), paper presented at the 9th Annual Meeting of the 334 ! European Geophysical Society, Leeds, Great Britain, August 1982. 335 ! 336 ! Dunne, Eimear M., et al.(2016), Global atmospheric particle formation from CERN CLOUD measurements, 337 ! Science 354.6316, 1119-1124. 338 ! 339 340 USE aerophys 341 USE YOMCST, ONLY : RPI, RKBOL 342 343 IMPLICIT NONE 344 345 !---------------------------------------------------- 346 347 !Global intent in 348 REAL,INTENT(IN) :: t ! temperature in K 349 REAL,INTENT(IN) :: satrat ! saturatio ratio of water (between zero and 1) 350 REAL,INTENT(IN) :: rhoa ! sulfuric acid concentration in 1/cm3 351 REAL,INTENT(IN) :: csi ! Ion condensation sink (s-1) 352 REAL,INTENT(IN) :: airn ! Air molecule concentration in (cm-3) 353 REAL,INTENT(IN) :: ipr ! Ion pair production rate (cm-3 s-1) 354 !Global intent out 355 REAL,INTENT(OUT) :: jnuc_n_real ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s) 356 REAL,INTENT(OUT) :: ntot_n_real ! total number of molecules in the neutral critical cluster 357 REAL,INTENT(OUT) :: jnuc_i_real ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s) 358 REAL,INTENT(OUT) :: ntot_i_real ! total number of molecules in the charged critical cluster 359 REAL,INTENT(OUT) :: x_n_real ! mole fraction of H2SO4 in the neutral critical cluster 360 REAL,INTENT(OUT) :: x_i_real ! mole fraction of H2SO4 in the charged critical cluster 361 ! (note that x_n=x_i in nucleation regime) 362 REAL,INTENT(OUT) :: na_n_real ! sulfuric acid molecules in the neutral critical cluster 363 REAL,INTENT(OUT) :: na_i_real ! sulfuric molecules in the charged critical cluster 364 REAL,INTENT(OUT) :: rc_n_real ! radius of the charged critical cluster in nm 365 REAL,INTENT(OUT) :: rc_i_real ! radius of the charged critical cluster in nm 366 REAL,INTENT(OUT) :: n_i_real ! number of ion pairs in air (cm-3) 367 REAL,INTENT(OUT) :: rhoatres_real ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation 368 LOGICAL,INTENT(OUT) :: kinetic_n ! true if kinetic neutral nucleation 369 LOGICAL,INTENT(OUT) :: kinetic_i ! true if kinetic ion-induced nucleation 370 371 ! Local 372 DOUBLE PRECISION :: jnuc_n ! Neutral nucleation rate in 1/cm3s (J>10^-7 1/cm3s) 373 DOUBLE PRECISION :: ntot_n ! total number of molecules in the neutral critical cluster 374 DOUBLE PRECISION :: jnuc_i ! Charged nucleation rate in 1/cm3s (J>10^-7 1/cm3s) 375 DOUBLE PRECISION :: ntot_i ! total number of molecules in the charged critical cluster 376 DOUBLE PRECISION :: x_n ! mole fraction of H2SO4 in the neutral critical cluster 377 DOUBLE PRECISION :: x_i ! mole fraction of H2SO4 in the charged critical cluster 378 ! (note that x_n=x_i in nucleation regime) 379 DOUBLE PRECISION :: na_n ! sulfuric acid molecules in the neutral critical cluster 380 DOUBLE PRECISION :: na_i ! sulfuric molecules in the charged critical cluster 381 DOUBLE PRECISION :: rc_n ! radius of the charged critical cluster in nm 382 DOUBLE PRECISION :: rc_i ! radius of the charged critical cluster in nm 383 DOUBLE PRECISION :: n_i ! number of ion pairs in air (cm-3) 384 DOUBLE PRECISION :: rhoatres ! threshold concentration of H2SO4 (1/cm^3) for neutral kinetic nucleation 385 DOUBLE PRECISION :: x ! mole fraction of H2SO4 in the critical cluster 386 DOUBLE PRECISION :: satratln ! bounded water saturation ratio for neutral case (between 5.E-6 - 1.0) 387 DOUBLE PRECISION :: satratli ! bounded water saturation ratio for ion-induced case (between 1.E-7 - 0.95) 388 DOUBLE PRECISION :: rhoaln ! bounded concentration of h2so4 for neutral case (between 10^10 - 10^19 m-3) 389 DOUBLE PRECISION :: rhoali ! bounded concentration of h2so4 for ion-induced case (between 10^10 - 10^22 m-3) 390 DOUBLE PRECISION :: tln ! bounded temperature for neutral case (between 165-400 K) 391 DOUBLE PRECISION :: tli ! bounded temperature for ion-induced case (195-400 K) 392 DOUBLE PRECISION :: kinrhotresn ! threshold sulfuric acid for neutral kinetic nucleation 393 DOUBLE PRECISION :: kinrhotresi ! threshold sulfuric acid for ion-induced kinetic nucleation 394 DOUBLE PRECISION :: jnuc_i1 ! Ion-induced rate for n_i=1 cm-3 395 DOUBLE PRECISION :: xloss ! Ion loss rate 396 DOUBLE PRECISION :: recomb ! Ion-ion recombination rate 397 398 !--- 0) Initializations: 399 400 kinetic_n=.FALSE. 401 kinetic_i=.FALSE. 402 jnuc_n=0.0 403 jnuc_i=0.0 404 ntot_n=0.0 405 ntot_i=0.0 406 na_n=0.0 407 na_i=0.0 408 rc_n=0.0 409 rc_i=0.0 410 x=0.0 411 x_n=0.0 412 x_i=0.0 413 satratln=satrat 414 satratli=satrat 415 rhoaln=rhoa 416 rhoali=rhoa 417 tln=t 418 tli=t 419 n_i=0.0 420 421 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 422 423 !Boundary values according to parameterization limits 424 425 !Temperature bounds 426 IF (t.LE.165.) THEN 427 ! print *,'Warning: temperature < 165.0 K, using 165.0 K in neutral nucleation calculation' 428 tln=165.0 429 ENDIF 430 IF (t.LE.195.) THEN 431 ! print *,'Warning: temperature < 195.0 K, using 195.0 K in ion-induced nucleation calculation' 432 tli=195.0 433 ENDIF 434 IF (t.GE.400.) THEN 435 ! print *,'Warning: temperature > 400. K, using 400. K in nucleation calculations' 436 tln=400. 437 tli=400. 438 ENDIF 439 440 ! Saturation ratio bounds 441 IF (satrat.LT.1.E-7) THEN 442 ! print *,'Warning: saturation ratio of water < 1.E-7, using 1.E-7 in ion-induced nucleation calculation' 443 satratli=1.E-7 444 ENDIF 445 IF (satrat.LT.1.E-5) THEN 446 ! print *,'Warning: saturation ratio of water < 1.E-5, using 1.E-5 in neutral nucleation calculation' 447 satratln=1.E-5 448 ENDIF 449 IF (satrat.GT.0.95) THEN 450 ! print *,'Warning: saturation ratio of water > 0.95, using 0.95 in ion-induced nucleation calculation' 451 satratli=0.95 452 ENDIF 453 IF (satrat.GT.1.0) THEN 454 ! print *,'Warning: saturation ratio of water > 1 using 1 in neutral nucleation calculation' 455 satratln=1.0 456 ENDIF 457 458 ! Sulfuric acid concentration bounds 459 IF (rhoa.LE.1.E4) THEN 460 ! print *,'Warning: sulfuric acid < 1e4 1/cm3, using 1e4 1/cm3 in nucleation calculation' 461 rhoaln=1.E4 462 rhoali=1.E4 463 ENDIF 464 IF (rhoa.GT.1.E13) THEN 465 ! print *,'Warning: sulfuric acid > 1e13 1/cm3, using 1e13 1/cm3 in neutral nucleation calculation' 466 rhoaln=1.E13 467 ENDIF 468 IF (rhoa.GT.1.E16) THEN 469 ! print *,'Warning: sulfuric acid concentration > 1e16 1/cm3, using 1e16 1/cm3 in ion-induced nucleation calculation' 470 rhoali=1.E16 471 ENDIF 472 473 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 474 475 !Critical cluster composition (valid for both cases, bounds not used here) 476 x_n= 7.9036365428891719E-1 - 2.8414059650092153E-3*tln + 1.4976802556584141E-2*LOG(satratln) & 477 & - 2.4511581740839115E-4*tln*LOG(satratln) + 3.4319869471066424E-3 *LOG(satratln)**2 & 478 & - 2.8799393617748428E-5*tln*LOG(satratln)**2 + 3.0174314126331765E-4*LOG(satratln)**3 & 479 & - 2.2673492408841294E-6*tln*LOG(satratln)**3 - 4.3948464567032377E-3*LOG(rhoaln) & 480 & + 5.3305314722492146E-5*tln*LOG(rhoaln) 481 x_i= 7.9036365428891719E-1 - 2.8414059650092153E-3*tli + 1.4976802556584141E-2*LOG(satratli) & 482 & - 2.4511581740839115E-4*tli*LOG(satratli) + 3.4319869471066424E-3 *LOG(satratli)**2 & 483 & - 2.8799393617748428E-5*tli*LOG(satratli)**2 + 3.0174314126331765E-4*LOG(satratli)**3 & 484 & - 2.2673492408841294E-6*tli*LOG(satratli)**3 - 4.3948464567032377E-3*LOG(rhoali) & 485 & + 5.3305314722492146E-5*tli*LOG(rhoali) 486 487 x_n=MIN(MAX(x_n,1.E-30),1.) 488 x_i=MIN(MAX(x_i,1.E-30),1.) 489 490 !Neutral nucleation 491 492 !Kinetic limit check 493 IF (satratln .GE. 1.E-2 .AND. satratln .LE. 1.) THEN 494 kinrhotresn=EXP(7.8920778706888086E+1 + 7.3665492897447082*satratln - 1.2420166571163805E+4/tln & 495 & + (-6.1831234251470971E+2*satratln)/tln - 2.4501159970109945E-2*tln & 496 & -1.3463066443605762E-2*satratln*tln + 8.3736373989909194E-06*tln**2 & 497 & -1.4673887785408892*LOG(satratln) + (-3.2141890006517094E+1*LOG(satratln))/tln & 498 & + 2.7137429081917556E-3*tln*LOG(satratln)) !1/cm3 499 IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE. 500 ENDIF 501 502 IF (satratln .GE. 1.E-4 .AND. satratln .LT. 1.E-2) THEN 503 kinrhotresn=EXP(7.9074383049843647E+1 - 2.8746005462158347E+1*satratln - 1.2070272068458380E+4/tln & 504 & + (-5.9205040320056632E+3*satratln)/tln - 2.4800372593452726E-2*tln & 505 & -4.3983007681295948E-2*satratln*tln + 2.5943854791342071E-5*tln**2 & 506 & -2.3141363245211317*LOG(satratln) + (9.9186787997857735E+1*LOG(satratln))/tln & 507 & + 5.6819382556144681E-3*tln*LOG(satratln)) !1/cm3 508 IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE. 509 ENDIF 510 511 IF (satratln .GE. 5.E-6 .AND. satratln .LT. 1.E-4) THEN 512 kinrhotresn=EXP(8.5599712000361677E+1 + 2.7335119660796581E+3*satratln - 1.1842350246291651E+4/tln & 513 & + (-1.2439843468881438E+6*satratln)/tln - 5.4536964974944230E-2*tln & 514 & + 5.0886987425326087*satratln*tln + 7.1964722655507067E-5*tln**2 & 515 & -2.4472627526306372*LOG(satratln) + (1.7561478001423779E+2*LOG(satratln))/tln & 516 & + 6.2640132818141811E-3*tln*LOG(satratln)) !1/cm3 517 IF (kinrhotresn.LT.rhoaln) kinetic_n=.TRUE. 518 ENDIF 519 520 IF (kinetic_n) THEN 521 ! Dimer formation rate 522 jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))/2.*SQRT(t)*rhoa**2. 523 ! jnuc_n=1.E6*(2.*0.3E-9)**2.*SQRT(8.*3.141593*1.38E-23*(1./(1.661E-27*98.07)+1./(1.661E-27*98.07)))/2.*SQRT(t)*rhoa**2. 524 ntot_n=1. !set to 1 525 na_n=1. ! The critical cluster contains one molecules but the produced cluster contains 2 molecules 526 x_n=na_n/ntot_n ! so also set this to 1 527 rc_n=0.3E-9 528 ELSE 529 jnuc_n= 2.1361182605986115E-1 + 3.3827029855551838*tln -3.2423555796175563E-2*tln**2 + & 530 & 7.0120069477221989E-5*tln**3 +8.0286874752695141/x_n + & 531 & -2.6939840579762231E-1*LOG(satratln) +1.6079879299099518*tln*LOG(satratln) + & 532 & -1.9667486968141933E-2*tln**2*LOG(satratln) + & 533 & 5.5244755979770844E-5*tln**3*LOG(satratln) + (7.8884704837892468*LOG(satratln))/x_n + & 534 & 4.6374659198909596*LOG(satratln)**2 - 8.2002809894792153E-2*tln*LOG(satratln)**2 + & 535 & 8.5077424451172196E-4*tln**2*LOG(satratln)**2 + & 536 & -2.6518510168987462E-6*tln**3*LOG(satratln)**2 + & 537 & (-1.4625482500575278*LOG(satratln)**2)/x_n - 5.2413002989192037E-1*LOG(satratln)**3 + & 538 & 5.2755117653715865E-3*tln*LOG(satratln)**3 + & 539 & -2.9491061332113830E-6*tln**2*LOG(satratln)**3 + & 540 & -2.4815454194486752E-8*tln**3*LOG(satratln)**3 + & 541 & (-5.2663760117394626E-2*LOG(satratln)**3)/x_n + & 542 & 1.6496664658266762*LOG(rhoaln) + & 543 & -8.0809397859218401E-1*tln*LOG(rhoaln) + & 544 & 8.9302927091946642E-3*tln**2*LOG(rhoaln) + & 545 & -1.9583649496497497E-5*tln**3*LOG(rhoaln) + & 546 & (-8.9505572676891685*LOG(rhoaln))/x_n + & 547 & -3.0025283601622881E+1*LOG(satratln)*LOG(rhoaln) + & 548 & 3.0783365644763633E-1*tln*LOG(satratln)*LOG(rhoaln) + & 549 & -7.4521756337984706E-4*tln**2*LOG(satratln)*LOG(rhoaln) + & 550 & -5.7651433870681853E-7*tln**3*LOG(satratln)*LOG(rhoaln) + & 551 & (1.2872868529673207*LOG(satratln)*LOG(rhoaln))/x_n + & 552 & -6.1739867501526535E-1*LOG(satratln)**2*LOG(rhoaln) + & 553 & 7.2347385705333975E-3*tln*LOG(satratln)**2*LOG(rhoaln) + & 554 & -3.0640494530822439E-5*tln**2*LOG(satratln)**2*LOG(rhoaln) + & 555 & 6.5944609194346214E-8*tln**3*LOG(satratln)**2*LOG(rhoaln) + & 556 & (-2.8681650332461055E-2*LOG(satratln)**2*LOG(rhoaln))/x_n + & 557 & 6.5213802375160306*LOG(rhoaln)**2 + & 558 & -4.7907162004793016E-2*tln*LOG(rhoaln)**2 + & 559 & -1.0727890114215117E-4*tln**2*LOG(rhoaln)**2 + & 560 & 5.6401818280534507E-7*tln**3*LOG(rhoaln)**2 + & 561 & (5.4113070888923009E-1*LOG(rhoaln)**2)/x_n + & 562 & 5.2062808476476330E-1*LOG(satratln)*LOG(rhoaln)**2 + & 563 & -6.0696882500824584E-3*tln*LOG(satratln)*LOG(rhoaln)**2 + & 564 & 2.3851383302608477E-5*tln**2*LOG(satratln)*LOG(rhoaln)**2 + & 565 & -1.5243837103067096E-8*tln**3*LOG(satratln)*LOG(rhoaln)**2 + & 566 & (-5.6543192378015687E-2*LOG(satratln)*LOG(rhoaln)**2)/x_n + & 567 & -1.1630806410696815E-1*LOG(rhoaln)**3 + & 568 & 1.3806404273119610E-3*tln*LOG(rhoaln)**3 + & 569 & -2.0199865087650833E-6*tln**2*LOG(rhoaln)**3 + & 570 & -3.0200284885763192E-9*tln**3*LOG(rhoaln)**3 + & 571 & (-6.9425267104126316E-3*LOG(rhoaln)**3)/x_n 572 jnuc_n=EXP(jnuc_n) 573 574 ntot_n =-3.5863435141979573E-3 - 1.0098670235841110E-1*tln + 8.9741268319259721E-4*tln**2 - 1.4855098605195757E-6*tln**3 & 575 & - 1.2080330016937095E-1/x_n + 1.1902674923928015E-3*LOG(satratln) - 1.9211358507172177E-2*tln*LOG(satratln) + & 576 & 2.4648094311204255E-4*tln**2*LOG(satratln) - 7.5641448594711666E-7*tln**3*LOG(satratln) + & 577 & (-2.0668639384228818E-02*LOG(satratln))/x_n - 3.7593072011595188E-2*LOG(satratln)**2 + & 578 & 9.0993182774415718E-4 *tln*LOG(satratln)**2 + & 579 & -9.5698412164297149E-6*tln**2*LOG(satratln)**2 + 3.7163166416110421E-8*tln**3*LOG(satratln)**2 + & 580 & (1.1026579525210847E-2*LOG(satratln)**2)/x_n + 1.1530844115561925E-2 *LOG(satratln)**3 + & 581 & - 1.8083253906466668E-4 *tln*LOG(satratln)**3 + 8.0213604053330654E-7*tln**2*LOG(satratln)**3 + & 582 & -8.5797885383051337E-10*tln**3*LOG(satratln)**3 + (1.0243693899717402E-3*LOG(satratln)**3)/x_n + & 583 & -1.7248695296299649E-2*LOG(rhoaln) + 1.1294004162437157E-2*tln*LOG(rhoaln) + & 584 & -1.2283640163189278E-4*tln**2*LOG(rhoaln) + 2.7391732258259009E-7*tln**3*LOG(rhoaln) + & 585 & (6.8505583974029602E-2*LOG(rhoaln))/x_n +2.9750968179523635E-1*LOG(satratln)*LOG(rhoaln) + & 586 & -3.6681154503992296E-3 *tln*LOG(satratln)*LOG(rhoaln) + 1.0636473034653114E-5*tln**2*LOG(satratln)*LOG(rhoaln)+ & 587 & 5.8687098466515866E-9*tln**3*LOG(satratln)*LOG(rhoaln) + (-5.2028866094191509E-3*LOG(satratln)*LOG(rhoaln))/x_n+& 588 & 7.6971988880587231E-4*LOG(satratln)**2*LOG(rhoaln) - 2.4605575820433763E-5*tln*LOG(satratln)**2*LOG(rhoaln) + & 589 & 2.3818484400893008E-7*tln**2*LOG(satratln)**2*LOG(rhoaln) + & 590 & -8.8474102392445200E-10*tln**3*LOG(satratln)**2*LOG(rhoaln) + & 591 & (-1.6640566678168968E-4*LOG(satratln)**2*LOG(rhoaln))/x_n - 7.7390093776705471E-2*LOG(rhoaln)**2 + & 592 & 5.8220163188828482E-4*tln*LOG(rhoaln)**2 + 1.2291679321523287E-6*tln**2*LOG(rhoaln)**2 + & 593 & -7.4690997508075749E-9*tln**3*LOG(rhoaln)**2 + (-5.6357941220497648E-3*LOG(rhoaln)**2)/x_n + & 594 & -4.7170109625089768E-3*LOG(satratln)*LOG(rhoaln)**2 + 6.9828868534370193E-5*tln*LOG(satratln)*LOG(rhoaln)**2 + & 595 & -3.1738912157036403E-7*tln**2*LOG(satratln)*LOG(rhoaln)**2 + & 596 & 2.3975538706787416E-10*tln**3*LOG(satratln)*LOG(rhoaln)**2 + & 597 & (4.2304213386288567E-4*LOG(satratln)*LOG(rhoaln)**2)/x_n + 1.3696520973423231E-3*LOG(rhoaln)**3 + & 598 & -1.6863387574788199E-5*tln*LOG(rhoaln)**3 + 2.7959499278844516E-8*tln**2*LOG(rhoaln)**3 + & 599 & 3.9423927013227455E-11*tln**3*LOG(rhoaln)**3 + (8.6136359966337272E-5*LOG(rhoaln)**3)/x_n 600 ntot_n=EXP(ntot_n) 601 602 rc_n=EXP(-22.378268374023630+0.44462953606125100*x_n+0.33499495707849131*LOG(ntot_n)) !in meters 603 604 na_n=x_n*ntot_n 605 IF (na_n .LT. 1.) THEN 606 print *, 'Warning: number of acid molecules < 1 in nucleation regime, setting na_n=1' 607 na_n=1.0 608 ENDIF 609 ENDIF 610 611 ! Set the neutral nucleation rate to 0.0 if less than 1.0E-7 612 IF (jnuc_n.LT.1.E-7) THEN 613 jnuc_n=0.0 614 ENDIF 615 616 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 617 618 ! Threshold neutral nucleation rate (j > 1/cm3s) parameterization (can be commented out if not needed) 619 IF (tln .GE. 310.) THEN 620 rhoatres=EXP(-2.8220714121794250 + 1.1492362322651116E+1*satratln -3.3034839106184218E+3/tln & 621 & + (-7.1828571490168133E+2*satratln)/tln + 1.4649510835204091E-1*tln & 622 & -3.0442736551916524E-2*satratln*tln -9.3258567137451497E-5*tln**2 & 623 & -1.1583992506895649E+1*LOG(satratln) + (1.5184848765906165E+3*LOG(satratln))/tln & 624 & + 1.8144983916747057E-2*tln*LOG(satratln)) !1/cm3 625 ENDIF 626 627 IF (tln .GT. 190. .AND. tln .LT. 310.) THEN 628 rhoatres=EXP(-3.1820396091231999E+2 + 7.2451289153199676*satratln + 2.6729355170089486E+4/tln & 629 & + (-7.1492506076423069E+2*satratln)/tln + 1.2617291148391978*tln & 630 & - 1.6438112080468487E-2*satratln*tln -1.4185518234553220E-3*tln**2 & 631 & -9.2864597847386694*LOG(satratln) + (1.2607421852455602E+3*LOG(satratln))/tln & 632 & + 1.3324434472218746E-2*tln*LOG(satratln)) !1/cm3 633 ENDIF 634 635 IF (tln .LT. 185. .AND. tln .GT. 155.) THEN 636 rhoatres=1.1788859232398459E+5 - 1.0244255702550814E+4*satratln + & 637 & 4.6815029684321962E+3*satratln**2 -1.6755952338499657E+2*tln 638 ENDIF 639 640 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 641 642 ! Ion-induced nucleation parameterization 643 644 IF (ipr.GT.0.0) THEN ! if the ion production rate is above zero 645 646 ! Calculate the ion induced nucleation rate wrt. concentration of 1 ion/cm3 647 648 kinrhotresi = 5.3742280876674478E1 - 6.6837931590012266E-3 *LOG(satratli)**(-2) & 649 & - 1.0142598385422842E-01 * LOG(satratli)**(-1) - 6.4170597272606873E+00 * LOG(satratli) & 650 & - 6.4315798914824518E-01 * LOG(satratli)**2 - 2.4428391714772721E-02 * LOG(satratli)**3 & 651 & - 3.5356658734539019E-04 * LOG(satratli)**4 + 2.5400015099140506E-05 * tli * LOG(satratli)**(-2) & 652 & - 2.7928900816637790E-04 * tli * LOG(satratli)**(-1) + 4.4108573484923690E-02 * tli * LOG(satratli) & 653 & + 6.3943789012475532E-03 * tli * LOG(satratli)**(2) + 2.3164296174966580E-04 * tli * LOG(satratli)**(3) & 654 & + 3.0372070669934950E-06 * tli * LOG(satratli)**4 + 3.8255873977423475E-06 * tli**2 * LOG(satratli)**(-1) & 655 & - 1.2344793083561629E-04 * tli**2 * LOG(satratli) - 1.7959048869810192E-05 * tli**2 * LOG(satratli)**(2) & 656 & - 3.2165622558722767E-07 * tli**2 * LOG(satratli)**3 - 4.7136923780988659E-09 * tli**3 * LOG(satratli)**(-1) & 657 & + 1.1873317184482216E-07 * tli**3 * LOG(satratli) + 1.5685860354866621E-08 * tli**3 * LOG(satratli)**2 & 658 & - 1.4329645891059557E+04 * tli**(-1) + 1.3842599842575321E-01 * tli & 659 & - 4.1376265912842938E-04 * tli**(2) + 3.9147639775826004E-07 * tli**3 660 661 kinrhotresi=EXP(kinrhotresi) !1/cm3 662 663 IF (kinrhotresi.LT.rhoali) kinetic_i=.true. 664 665 IF (kinetic_i) THEN 666 ! jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*3.141593*1.38E-23*(1./(1.661E-27*98.07)+1./(1.661E-27*98.07)))* & 667 jnuc_i1=1.0E6*(0.3E-9 + 0.487E-9)**2.*SQRT(8.*RPI*RKBOL*(1./mH2SO4mol+1./mH2SO4mol))* & 668 & SQRT(tli)*rhoali !1/cm3s 669 ntot_i=1. !set to 1 670 na_i=1. 671 x_i=na_i/ntot_i ! so also set this to 1 672 rc_i=0.487E-9 673 ELSE 674 jnuc_i1 = 3.0108954259038608E+01+tli*6.1176722090512577E+01+(tli**2)*8.7240333618891663E-01+(tli**3)* & 675 & -4.6191788649375719E-03+(tli**(-1))*8.3537059107024481E-01 + & 676 & (1.5028549216690628E+01+tli*-1.9310989753720623E-01+(tli**2)*8.0155514634860480E-04+(tli**3)* & 677 & -1.0832730707799128E-06+(tli**(-1))*1.7577660457989019)*(LOG(satratli)**(-2)) + & 678 & (-2.0487870170216488E-01 + tli * 1.3263949252910405E-03 + (tli**2) * -8.4195688402450274E-06 + & 679 & (tli**3)*1.6154895940993287E-08 + (tli**(-1))*3.8734212545203874E+01) * (LOG(satratli)**(-2)*LOG(rhoali)) + & 680 & (1.4955918863858371 + tli * 9.2290004245522454E+01 + (tli**2) * -8.9006965195392618E-01 + & 681 & (tli**3) * 2.2319123411013099E-03 + (tli**(-1)) * 4.0180079996840852E-03) * & 682 & (LOG(satratli)**(-1) * LOG(rhoali)**(-1)) + & 683 & (7.9018031228561085 + tli * -1.1649433968658949E+01 + (tli**2) * 1.1400827854910951E-01 + & 684 & (tli**3) * -3.1941526492127755E-04 + (tli**(-1)) * -3.7662115740271446E-01) * (LOG(satratli)**(-1)) + & 685 & (1.5725237111225979E+02 + tli * -1.0051649979836277 + (tli**2) * 1.1866484014507624E-03 + & 686 & (tli**3) * 7.3557614998540389E-06 + (tli**(-1)) * 2.6270197023115189) * (LOG(satratli)**(-1) * LOG(rhoali)) + & 687 & (-1.6973840122470968E+01 + tli * 1.1258423691432135E-01 + (tli**2) * -2.9850139351463793E-04 + (tli**3) * & 688 & 1.4301286324827064E-07 + (tli**(-1)) * 1.3163389235253725E+01) * (LOG(satratli)**(-1) * LOG(rhoali)**2) + & 689 & (-1.0399591631839757 + tli * 2.7022055588257691E-03 + (tli**2) * -2.1507467231330936E-06 + (tli**3) * & 690 & 3.8059489037584171E-10 + (tli**(-1)) * 1.5000492788553410E+02) * (LOG(satratli)**(-1) * LOG(rhoali)**3) + & 691 & (1.2250990965305315 + tli * 3.0495946490079444E+01 + (tli**2) * 2.1051563135187106E+01 + (tli**3) * & 692 & -8.2200682916580878E-02 + (tli**(-1)) * 2.9965871386685029E-02) * (LOG(rhoali)**(-2)) + & 693 & (4.8281605955680433 + tli * 1.7346551710836445E+02 + (tli**2) * -1.0113602140796010E+01 + (tli**3) * & 694 & 3.7482518458685089E-02 + (tli**(-1)) * -1.4449998158558205E-01) * (LOG(rhoali)**(-1)) + & 695 & (2.3399230964451237E+02 + tli * -2.3099267235261948E+01 + (tli**2) * 8.0122962140916354E-02 + & 696 & (tli**3) * 6.1542576994557088E-05 + (tli**(-1)) * 5.3718413254843007) * (LOG(rhoali)) + & 697 & (1.0299715519499360E+02 + tli * -6.4663357203364136E-02 + (tli**2) * -2.0487150565050316E-03 + & 698 & (tli**3) * 8.7935289055530897E-07 + (tli**(-1)) * 3.6013204601215229E+01) * (LOG(rhoali)**2) + & 699 & (-3.5452115439584042 + tli * 1.7083445731159330E-02 + (tli**2) * -1.2552625290862626E-05 + (tli**3) * & 700 & 1.2968447449182847E-09 + (tli**(-1)) * 1.5748687512056560E+02) * (LOG(rhoali)**3) + & 701 & (2.2338490119517975 + tli * 1.0229410216045540E+02 + (tli**2) * -3.2103611955174052 + (tli**3) * & 702 & 1.3397152304977591E-02 + (tli**(-1)) * -2.4155187776460030E-02) * (LOG(satratli)* LOG(rhoali)**(-2)) + & 703 & (3.7592282990713963 + tli * -1.5257988769009816E+02 + (tli**2) * 2.6113805420558802 + (tli**3) * & 704 & -9.0380721653694363E-03 + (tli**(-1)) * -1.3974197138171082E-01) * (LOG(satratli)* LOG(rhoali)**(-1)) + & 705 & (1.8293600730573988E+01 + tli * 1.8344728606002992E+01 + (tli**2) * -4.0063363221106751E-01 + (tli**3) & 706 & * 1.4842749371258522E-03 + (tli**(-1)) * 1.1848846003282287) * (LOG(satratli)) + & 707 & (-1.7634531623032314E+02 + tli * 4.9011762441271278 + (tli**2) * -1.3195821562746339E-02 + (tli**3) * & 708 & -2.8668619526430859E-05 + (tli**(-1)) * -2.9823396976393551E-01) * (LOG(satratli)* LOG(rhoali)) + & 709 & (-3.2944043694275727E+01 + tli * 1.2517571921051887E-01 + (tli**2) * 8.3239769771186714E-05 + (tli**3) * & 710 & 2.8191859341519507E-07 + (tli**(-1)) * -2.7352880736682319E+01) * (LOG(satratli)* LOG(rhoali)**2) + & 711 & (-1.1451811137553243 + tli * 2.0625997485732494E-03 + (tli**2) * -3.4225389469233624E-06 + (tli**3) * & 712 & 4.4437613496984567E-10 + (tli**(-1)) * 1.8666644332606754E+02) * (LOG(satratli)* LOG(rhoali)**3) + & 713 & (3.2270897099493567E+01 + tli * 7.7898447327513687E-01 + (tli**2) * -6.5662738484679626E-03 + (tli**3) * & 714 & 3.7899330796456790E-06 + (tli**(-1)) * 7.1106427501756542E-01) * (LOG(satratli)**2 * LOG(rhoali)**(-1)) + & 715 & (-2.8901906781697811E+01 + tli * -1.5356398793054860 + (tli**2) * 1.9267271774384788E-02 + (tli**3) * & 716 & -5.3886270475516162E-05 + (tli**(-1)) * 5.0490415975693426E-01) * (LOG(satratli)**2) + & 717 & (3.3365683645733924E+01 + tli * -3.6114561564894537E-01 + (tli**2) * 9.2977354471929262E-04 + (tli**3) * & 718 & 1.9549769069511355E-07 + (tli**(-1)) * -8.8865930095112855) * (LOG(satratli)**2 * LOG(rhoali)) + & 719 & (2.4592563042806375 + tli * -8.3227071743101084E-03 + (tli**2) * 8.2563338043447783E-06 + (tli**3) * & 720 & -8.4374976698593496E-09 + (tli**(-1)) * -2.0938173949893473E+02) * (LOG(satratli)**2 * LOG(rhoali)**2) + & 721 & (4.4099823444352317E+01 + tli * 2.5915665826835252 + (tli**2) * -1.6449091819482634E-02 + (tli**3) * & 722 & 2.6797249816144721E-05 + (tli**(-1)) * 5.5045672663909995E-01)* satratli 723 jnuc_i1=EXP(jnuc_i1) 724 725 ntot_i = ABS((-4.8324296064013375E+04 + tli * 5.0469120697428906E+02 + (tli**2) * -1.1528940488496042E+00 + & 726 & (tli**(-1)) * -8.6892744676239192E+02 + (tli**(3)) * 4.0030302028120469E-04) + & 727 & (-6.7259105232039847E+03 + tli * 1.9197488157452008E+02 + (tli**2) * -1.3602976930126354E+00 + & 728 & (tli**(-1)) * -1.1212637938360332E+02 + (tli**(3)) * 2.8515597265933207E-03) * & 729 & LOG(satratli)**(-2) * LOG(rhoali)**(-2) + & 730 & (2.6216455217763342E+02 + tli * -2.3687553252750821E+00 + (tli**2) * 7.4074554767517521E-03 + & 731 & (tli**(-1)) * -1.9213956820114927E+03 + (tli**(3)) * -9.3839114856129453E-06) * LOG(satratli)**(-2) + & 732 & (3.9652478944137344E+00 + tli * 1.2469375098256536E-02 + (tli**2) * -9.9837754694045633E-05 + (tli**(-1)) * & 733 & -5.1919499210175138E+02 + (tli**(3)) * 1.6489001324583862E-07) * LOG(satratli)**(-2) * LOG(rhoali) + & 734 & (2.4975714429096206E+02 + tli * 1.7107594562445172E+02 + (tli**2) * -7.8988711365135289E-01 + (tli**(-1)) * & 735 & -2.2243599782483177E+01 + (tli**(3)) * -1.6291523004095427E-04) * LOG(satratli)**(-1) * LOG(rhoali)**(-2) + & 736 & (-8.9270715592533611E+02 + tli * 1.2053538883338946E+02 + (tli**2) * -1.5490408828541018E+00 + (tli**(-1)) * & 737 & -1.1243275579419826E+01 + (tli**(3)) * 4.8053105606904655E-03) * LOG(satratli)**(-1) * LOG(rhoali)**(-1) + & 738 & (7.6426441642091631E+03 + tli * -7.1785462414656578E+01 + (tli**2) * 2.3851864923199523E-01 + (tli**(-1)) * & 739 & 8.5591775688708395E+01 + (tli**(3)) * -3.7000473243342858E-04) * LOG(satratli)**(-1) + & 740 & (-5.1516826398607911E+01 + tli * 9.1385720811460558E-01 + (tli**2) * -3.5477100262158974E-03 + & 741 & (tli**(-1)) * 2.7545544507625586E+03 + (tli**(3)) * 5.4708262093640928E-06) * LOG(satratli)**(-1) * LOG(rhoali) + & 742 & (-3.0386767129196176E+02 + tli * -1.1033438883583569E+04 + (tli**2) * 8.1296859732896067E+01 + (tli**(-1)) * & 743 & 1.2625883141097162E+01 + (tli**(3)) * -1.2728497822219101E-01) * LOG(rhoali)**(-2) + & 744 & (-3.3763494256461472E+03 + tli * 3.1916579136391006E+03 + (tli**2) * -2.7234339474441143E+01 + (tli**(-1)) * & 745 & -2.1897653262707397E+01 + (tli**(3)) * 5.1788505812259071E-02) * LOG(rhoali)**(-1) + & 746 & (-1.8817843873687068E+03 + tli * 4.3038072285882070E+00 + (tli**2) * 6.6244087689671860E-03 + (tli**(-1)) * & 747 & -2.7133073605696295E+03 + (tli**(3)) * -1.7951557394285043E-05) * LOG(rhoali) + & 748 & (-1.7668827539244447E+02 + tli * 4.8160932330629913E-01 + (tli**2) * -6.3133007671100293E-04 + (tli**(-1)) * & 749 & 2.5631774669873157E+04 + (tli**(3)) * 4.1534484127873519E-07) * LOG(rhoali)**(2) + & 750 & (-1.6661835889222382E+03 + tli * 1.3708900504682877E+03 + (tli**2) * -1.7919060052198969E+01 + (tli**(-1)) * & 751 & -3.5145029804436405E+01 + (tli**(3)) * 5.1047240947371224E-02) * LOG(satratli)* LOG(rhoali)**(-2) + & 752 & (1.0843549363030939E+04 + tli * -7.3557073636139577E+01 + (tli**2) * 1.2054625131778862E+00 + (tli**(-1)) * & 753 & 1.9358737917864391E+02 + (tli**(3)) * -4.2871620775911338E-03) * LOG(satratli)* LOG(rhoali)**(-1) + & 754 & (-2.4269802549752835E+03 + tli * 1.1348265061941714E+01 + (tli**2) * -5.0430423939495157E-02 + (tli**(-1)) * & 755 & 2.3709874548950634E+03 + (tli**(3)) * 1.4091851828620244E-04) * LOG(satratli) + & 756 & (5.2745372575251588E+02 + tli * -2.6080675912627314E+00 + (tli**2) * 5.6902218056670145E-03 + (tli**(-1)) * & 757 & -3.2149319482897838E+04 + (tli**(3)) * -5.4121996056745853E-06) * LOG(satratli)* LOG(rhoali) + & 758 & (-1.6401959518360403E+01 + tli * 2.4322962162439640E-01 + (tli**2) * 1.1744366627725344E-03 + (tli**(-1)) * & 759 & -8.2694427518413195E+03 + (tli**(3)) * -5.0028379203873102E-06)* LOG(satratli)**(2) + & 760 & (-2.7556572017167782E+03 + tli * 4.9293344495058264E+01 + (tli**2) * -2.6503456520676050E-01 + (tli**(-1)) * & 761 & 1.2130698030982167E+03 + (tli**(3)) * 4.3530610668042957E-04)* LOG(satratli)**2 * LOG(rhoali)**(-1) + & 762 & (-6.3419182228959192E+00 + tli * 4.0636212834605827E-02 + (tli**2) * -1.0450112687842742E-04 + (tli**(-1)) * & 763 & 3.1035882189759656E+02 + (tli**(3)) * 9.4328418657873500E-08)* LOG(satratli)**(-3) + & 764 & (3.0189213304689042E+03 + tli * -2.3804654203861684E+01 + (tli**2) * 6.8113013411972942E-02 + (tli**(-1)) * & 765 & 6.3112071081188913E+02 + (tli**(3)) * -9.4460854261685723E-05)* (satratli) * LOG(rhoali) + & 766 & (1.1924791930673702E+04 + tli * -1.1973824959206000E+02 + (tli**2) * 1.6888713097971020E-01 + (tli**(-1)) * & 767 & 1.8735938211539585E+02 + (tli**(3)) * 5.0974564680442852E-04)* (satratli) + & 768 & (3.6409071302482083E+01 + tli * 1.7919859306449623E-01 + (tli**2) * -1.0020116255895206E-03 + (tli**(-1)) * & 769 & -8.3521083354432303E+03 + (tli**(3)) * 1.5879900546795635E-06)* satratli * LOG(rhoali)**(2)) 770 771 rc_i = (-3.6318550637865524E-08 + tli * 2.1740704135789128E-09 + (tli**2) * & 772 & -8.5521429066506161E-12 + (tli**3) * -9.3538647454573390E-15) + & 773 & (2.1366936839394922E-08 + tli * -2.4087168827395623E-10 + (tli**2) * 8.7969869277074319E-13 + & 774 & (tli**3) * -1.0294466881303291E-15)* LOG(satratli)**(-2) * LOG(rhoali)**(-1) + & 775 & (-7.7804007761164303E-10 + tli * 1.0327058173517932E-11 + (tli**2) * -4.2557697639692428E-14 + & 776 & (tli**3) * 5.4082507061618662E-17)* LOG(satratli)**(-2) + & 777 & (3.2628927397420860E-12 + tli * -7.6475692919751066E-14 + (tli**2) * 4.1985816845259788E-16 + & 778 & (tli**3) * -6.2281395889592719E-19)* LOG(satratli)**(-2) * LOG(rhoali) + & 779 & (2.0442205540818555E-09 + tli * 4.0441858911249830E-08 + (tli**2) * -3.3423487629482825E-10 + & 780 & (tli**3) * 6.8000404742985678E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-2) + & 781 & (1.8381489183824627E-08 + tli * -8.9853322951518919E-09 + (tli**2) * 7.5888799566036185E-11 + & 782 & (tli**3) * -1.5823457864755549E-13)* LOG(satratli)**(-1) * LOG(rhoali)**(-1) + & 783 & (1.1795760639695057E-07 + tli * -8.1046722896375875E-10 + (tli**2) * 9.1868604369041857E-14 + & 784 & (tli**3) * 4.7882428237444610E-15)* LOG(satratli)**(-1) + & 785 & (-4.4028846582545952E-09 + tli * 4.6541269232626618E-11 + (tli**2) * -1.1939929984285194E-13 + & 786 & (tli**3) * 2.3602037016614437E-17)* LOG(satratli)**(-1) * LOG(rhoali) + & 787 & (2.7885056884209128E-11 + tli * -4.5167129624119121E-13 + (tli**2) * 1.6558404997394422E-15 + & 788 & (tli**3) * -1.2037336621218054E-18)* LOG(satratli)**(-1) * LOG(rhoali)**2 + & 789 & (-2.3719627171699983E-09 + tli * -1.5260127909292053E-07 + (tli**2) * 1.7177017944754134E-09 + & 790 & (tli**3) * -4.7031737537526395E-12)* LOG(rhoali)**(-2) + & 791 & (-5.6946433724699646E-09 + tli * 8.4629788237081735E-09 + (tli**2) * -1.7674135187061521E-10 + & 792 & (tli**3) * 6.6236547903091862E-13)* LOG(rhoali)**(-1) + & 793 & (-2.2808617930606012E-08 + tli * 1.4773376696847775E-10 + (tli**2) * -1.3076953119957355E-13 + & 794 & (tli**3) * 2.3625301497914000E-16)* LOG(rhoali) + & 795 & (1.4014269939947841E-10 + tli * -2.3675117757377632E-12 + (tli**2) * 5.1514033966707879E-15 + & 796 & (tli**3) * -4.8864233454747856E-18)* LOG(rhoali)**2 + & 797 & (6.5464943868885886E-11 + tli * 1.6494354816942769E-08 + (tli**2) * -1.7480097393483653E-10 + & 798 & (tli**3) * 4.7460075628523984E-13)* LOG(satratli)* LOG(rhoali)**(-2) + & 799 & (8.4737893183927871E-09 + tli * -6.0243327445597118E-09 + (tli**2) * 5.8766070529814883E-11 + & 800 & (tli**3) * -1.4926748560042018E-13)* LOG(satratli)* LOG(rhoali)**(-1) + & 801 & (1.0761964135701397E-07 + tli * -1.0142496009071148E-09 + (tli**2) * 2.1337312466519190E-12 + & 802 & (tli**3) * 1.6376014957685404E-15)* LOG(satratli) + & 803 & (-3.5621571395968670E-09 + tli * 4.1175339587760905E-11 + (tli**2) * -1.3535372357998504E-13 + & 804 & (tli**3) * 8.9334219536920720E-17)* LOG(satratli)* LOG(rhoali) + & 805 & (2.0700482083136289E-11 + tli * -3.9238944562717421E-13 + (tli**2) * 1.5850961422040196E-15 + & 806 & (tli**3) * -1.5336775610911665E-18)* LOG(satratli)* LOG(rhoali)**2 + & 807 & (1.8524255464416206E-09 + tli * -2.1959816152743264E-11 + (tli**2) * -6.4478119501677012E-14 + & 808 & (tli**3) * 5.5135243833766056E-16)* LOG(satratli)**2 * LOG(rhoali)**(-1) + & 809 & (1.9349488650922679E-09 + tli * -2.2647295919976428E-11 + (tli**2) * 9.2917479748268751E-14 + & 810 & (tli**3) * -1.2741959892173170E-16)* LOG(satratli)**2 + & 811 & (2.1484978031650972E-11 + tli * -9.3976642475838013E-14 + (tli**2) * -4.8892738002751923E-16 + & 812 & (tli**3) * 1.4676120441783832E-18)* LOG(satratli)**2 * LOG(rhoali) + & 813 & (6.7565715216420310E-13 + tli * -3.5421162549480807E-15 + (tli**2) * -3.4201196868693569E-18 + & 814 & (tli**3) * 2.2260187650412392E-20)* LOG(satratli)**3 * LOG(rhoali) 815 816 na_i=x_i*ntot_i 817 IF (na_i .LT. 1.) THEN 818 ! print *, 'Warning: number of acid molecules < 1 in nucleation regime, setting na_n=1' 819 na_n=1.0 820 ENDIF 821 ENDIF 822 823 jnuc_i=jnuc_i1 824 ! Ion loss rate (1/s) 825 xloss=csi+jnuc_i 826 827 ! Recombination (here following Brasseur and Chatel, 1983) 828 recomb=6.0E-8*SQRT(300./tli)+6.0E-26*airn*(300./tli)**4 829 830 ! Small ion concentration in air (1/cm3) (following Dunne et al., 2016) 831 ! max function is to avoid n_i to go practically zero at very high J_ion 832 n_i=MAX(0.01,(SQRT(xloss**2.0+4.0*recomb*ipr)-xloss)/(2.0*recomb)) 833 834 ! Ion-induced nucleation rate 835 ! Min function is to ensure that max function above does not cause J_ion to overshoot 836 jnuc_i=MIN(ipr,n_i*jnuc_i1) 837 ! Set the ion-induced nucleation rate to 0.0 if less than 1.0E-7 838 IF (jnuc_i.LT.1.E-7) THEN 839 jnuc_i=0.0 840 ENDIF 841 842 ENDIF 843 844 !--conversion from double precision to float in case the model is run in single precision 845 jnuc_n_real = jnuc_n 846 ntot_n_real = ntot_n 847 jnuc_i_real = jnuc_i 848 ntot_i_real = ntot_i 849 x_n_real = x_n 850 x_i_real = x_i 851 na_n_real = na_n 852 na_i_real = na_i 853 rc_n_real = rc_n 854 rc_i_real = rc_i 855 n_i_real = n_i 856 rhoatres_real = rhoatres 857 858 END SUBROUTINE newbinapara 859 281 860 END MODULE nucleation_tstep_mod -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/ocs_to_so2.F90
-
Property
svn:keywords
set to
Id
r2752 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE ocs_to_so2(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/so2_to_h2so4.F90
-
Property
svn:keywords
set to
Id
r2752 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE SO2_TO_H2SO4(pdtphys,tr_seri,t_seri,pplay,paprs,is_strato) 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/sulfate_aer_mod.F90
-
Property
svn:keywords
set to
Id
r2690 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE sulfate_aer_mod 2 5 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/StratAer/traccoag_mod.F90
-
Property
svn:keywords
set to
Id
r3114 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE traccoag_mod 2 5 ! … … 16 19 USE infotrac 17 20 USE aerophys 18 USE geometry_mod, ONLY : cell_area 21 USE geometry_mod, ONLY : cell_area, boundslat 19 22 USE mod_grid_phy_lmdz 20 23 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root … … 24 27 USE phys_local_var_mod, ONLY: stratomask 25 28 USE YOMCST 29 USE print_control_mod, ONLY: lunout 30 USE strataer_mod 31 USE phys_cal_mod, ONLY : year_len 26 32 27 33 IMPLICIT NONE … … 52 58 ! Local variables 53 59 !---------------- 54 ! flag for sulfur emission scenario: (0) background aerosol ; (1) volcanic eruption ; (2) stratospheric aerosol injections (SAI) 55 INTEGER,PARAMETER :: flag_sulf_emit=2 56 ! 57 !--flag_sulf_emit=1 --example Pinatubo 58 INTEGER,PARAMETER :: year_emit_vol=1991 ! year of emission date 59 INTEGER,PARAMETER :: mth_emit_vol=6 ! month of emission date 60 INTEGER,PARAMETER :: day_emit_vol=15 ! day of emission date 61 REAL,PARAMETER :: m_aer_emiss_vol=7.e9 ! emitted sulfur mass in kgS, e.g. 7Tg(S)=14Tg(SO2) 62 REAL,PARAMETER :: altemiss_vol=17.e3 ! emission altitude in m 63 REAL,PARAMETER :: sigma_alt_vol=1.e3 ! standard deviation of emission altitude in m 64 REAL,PARAMETER :: xlat_vol=15.14 ! latitude of volcano in degree 65 REAL,PARAMETER :: xlon_vol=120.35 ! longitude of volcano in degree 66 67 !--flag_sulf_emit=2 --SAI 68 REAL,PARAMETER :: m_aer_emiss_sai=1.e10 ! emitted sulfur mass in kgS, eg 1e9=1TgS, 1e10=10TgS 69 REAL,PARAMETER :: altemiss_sai=17.e3 ! emission altitude in m 70 REAL,PARAMETER :: sigma_alt_sai=1.e3 ! standard deviation of emission altitude in m 71 REAL,PARAMETER :: xlat_sai=0.01 ! latitude of SAI in degree 72 REAL,PARAMETER :: xlon_sai=120.35 ! longitude of SAI in degree 73 74 !--other local variables 75 INTEGER :: it, k, i, ilon, ilev, itime, i_int 60 REAL :: m_aer_emiss_vol_daily ! daily injection mass emission 61 INTEGER :: it, k, i, ilon, ilev, itime, i_int, ieru 76 62 LOGICAL,DIMENSION(klon,klev) :: is_strato ! true = above tropopause, false = below 77 63 REAL,DIMENSION(klon,klev) :: m_air_gridbox ! mass of air in every grid box [kg] … … 90 76 REAL,DIMENSION(klev) :: zdm ! mass of atm. model layer in kg 91 77 REAL,DIMENSION(klon,klev) :: dens_aer ! density of aerosol particles [kg/m3 aerosol] with default H2SO4 mass fraction 92 REAL :: dlat, dlon ! d latitude and d longitude of grid in degree93 78 REAL :: emission ! emission 79 REAL :: theta_min, theta_max ! for SAI computation between two latitudes 80 REAL :: dlat_loc 94 81 95 82 IF (is_mpi_root) THEN 96 PRINT *,'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour 83 WRITE(lunout,*) 'in traccoag: date from phys_cal_mod =',year_cur,'-',mth_cur,'-',day_cur,'-',hour 84 WRITE(lunout,*) 'IN traccoag flag_sulf_emit: ',flag_sulf_emit 97 85 ENDIF 98 99 dlat=180./2./FLOAT(nbp_lat) ! d latitude in degree 100 dlon=360./2./FLOAT(nbp_lon) ! d longitude in degree 101 86 102 87 DO it=1, nbtr_bin 103 88 r_bin(it)=mdw(it)/2. … … 120 105 IF (debutphy .and. is_mpi_root) THEN 121 106 DO it=1, nbtr_bin 122 PRINT *,'radius bin', it, ':', r_bin(it), '(from', r_lower(it), 'to', r_upper(it), ')'107 WRITE(lunout,*) 'radius bin', it, ':', r_bin(it), '(from', r_lower(it), 'to', r_upper(it), ')' 123 108 ENDDO 124 109 ENDIF … … 170 155 !--only emit on day of eruption 171 156 ! stretch emission over one day of Pinatubo eruption 172 IF (year_cur==year_emit_vol.AND.mth_cur==mth_emit_vol.AND.day_cur==day_emit_vol) THEN 173 ! 174 DO i=1,klon 175 !Pinatubo eruption at 15.14N, 120.35E 176 IF ( xlat(i).GE.xlat_vol-dlat .AND. xlat(i).LT.xlat_vol+dlat .AND. & 177 xlon(i).GE.xlon_vol-dlon .AND. xlon(i).LT.xlon_vol+dlon ) THEN 178 ! 179 PRINT *,'coordinates of volcanic injection point=',xlat(i), xlon(i), day_cur, mth_cur, year_cur 180 ! compute altLMDz 181 altLMDz(:)=0.0 182 DO k=1, klev 183 zrho=pplay(i,k)/t_seri(i,k)/RD !air density in kg/m3 184 zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG !mass of layer in kg 185 zdz=zdm(k)/zrho !thickness of layer in m 186 altLMDz(k+1)=altLMDz(k)+zdz !altitude of interface 187 ENDDO 188 !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude) 189 f_lay_sum=0.0 190 DO k=1, klev 191 f_lay_emiss(k)=0.0 192 DO i_int=1, n_int_alt 193 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 194 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_vol)* & 195 & exp(-0.5*((alt-altemiss_vol)/sigma_alt_vol)**2.)* & 196 & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 197 ENDDO 198 f_lay_sum=f_lay_sum+f_lay_emiss(k) 199 ENDDO 200 !correct for step integration error 201 f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum 202 !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss) 203 !vertically distributed emission 204 DO k=1, klev 205 ! stretch emission over one day (minus one timestep) of Pinatubo eruption 206 emission=m_aer_emiss_vol*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/1./(86400.-pdtphys) 207 tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys 208 budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol 209 ENDDO 210 ENDIF ! emission grid cell 211 ENDDO ! klon loop 212 ENDIF ! emission period 213 157 DO ieru=1, nErupt 158 IF (year_cur==year_emit_vol(ieru).AND.mth_cur==mth_emit_vol(ieru).AND.& 159 day_cur>=day_emit_vol(ieru).AND.day_cur<(day_emit_vol(ieru)+injdur)) THEN 160 ! 161 ! daily injection mass emission - NL 162 m_aer_emiss_vol_daily = m_aer_emiss_vol(ieru)/(REAL(injdur)*REAL(ponde_lonlat_vol(ieru))) 163 WRITE(lunout,*) 'IN traccoag DD m_aer_emiss_vol(ieru)=',m_aer_emiss_vol(ieru), & 164 'ponde_lonlat_vol(ieru)=',ponde_lonlat_vol(ieru),'(injdur*ponde_lonlat_vol(ieru))', & 165 (injdur*ponde_lonlat_vol(ieru)),'m_aer_emiss_vol_daily=',m_aer_emiss_vol_daily,'ieru=',ieru 166 WRITE(lunout,*) 'IN traccoag, dlon=',dlon 167 DO i=1,klon 168 !Pinatubo eruption at 15.14N, 120.35E 169 dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes 170 WRITE(lunout,*) 'IN traccoag, dlat=',dlat_loc 171 IF ( xlat(i).GE.xlat_min_vol(ieru)-dlat_loc .AND. xlat(i).LT.xlat_max_vol(ieru)+dlat_loc .AND. & 172 xlon(i).GE.xlon_min_vol(ieru)-dlon .AND. xlon(i).LT.xlon_max_vol(ieru)+dlon ) THEN 173 ! 174 WRITE(lunout,*) 'coordinates of volcanic injection point=',xlat(i),xlon(i),day_cur,mth_cur,year_cur 175 WRITE(lunout,*) 'DD m_aer_emiss_vol_daily=',m_aer_emiss_vol_daily 176 ! compute altLMDz 177 altLMDz(:)=0.0 178 DO k=1, klev 179 zrho=pplay(i,k)/t_seri(i,k)/RD !air density in kg/m3 180 zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG !mass of layer in kg 181 zdz=zdm(k)/zrho !thickness of layer in m 182 altLMDz(k+1)=altLMDz(k)+zdz !altitude of interface 183 ENDDO 184 185 SELECT CASE(flag_sulf_emit_distrib) 186 187 CASE(0) ! Gaussian distribution 188 !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude) 189 f_lay_sum=0.0 190 DO k=1, klev 191 f_lay_emiss(k)=0.0 192 DO i_int=1, n_int_alt 193 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 194 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_vol(ieru))* & 195 & exp(-0.5*((alt-altemiss_vol(ieru))/sigma_alt_vol(ieru))**2.)* & 196 & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 197 ENDDO 198 f_lay_sum=f_lay_sum+f_lay_emiss(k) 199 ENDDO 200 201 CASE(1) ! Uniform distribution 202 ! In this case, parameter sigma_alt_vol(ieru) is considered to be half the 203 ! height of the injection, centered around altemiss_vol(ieru) 204 DO k=1, klev 205 f_lay_emiss(k)=max(min(altemiss_vol(ieru)+sigma_alt_vol(ieru),altLMDz(k+1))- & 206 & max(altemiss_vol(ieru)-sigma_alt_vol(ieru),altLMDz(k)),0.)/(2.*sigma_alt_vol(ieru)) 207 f_lay_sum=f_lay_sum+f_lay_emiss(k) 208 ENDDO 209 210 END SELECT ! End CASE over flag_sulf_emit_distrib) 211 212 WRITE(lunout,*) "IN traccoag m_aer_emiss_vol=",m_aer_emiss_vol(ieru) 213 WRITE(lunout,*) "IN traccoag f_lay_emiss=",f_lay_emiss 214 !correct for step integration error 215 f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum 216 !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss) 217 !vertically distributed emission 218 DO k=1, klev 219 ! stretch emission over one day of Pinatubo eruption 220 emission=m_aer_emiss_vol_daily*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/1./(86400.-pdtphys) 221 tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys 222 budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol 223 ENDDO 224 ENDIF ! emission grid cell 225 ENDDO ! klon loop 226 WRITE(lunout,*) "IN traccoag (ieru=",ieru,") m_aer_emiss_vol_daily=",m_aer_emiss_vol_daily 227 ENDIF ! emission period 228 ENDDO ! eruption number 229 214 230 CASE(2) ! stratospheric aerosol injections (SAI) 215 231 ! … … 217 233 ! SAI standard scenario with continuous emission from 1 grid point at the equator 218 234 ! SAI emission on single month 219 ! IF ((mth_cur==4 .AND. &220 235 ! SAI continuous emission o 221 IF ( xlat(i).GE.xlat_sai-dlat .AND. xlat(i).LT.xlat_sai+dlat .AND. & 236 dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes 237 IF ( xlat(i).GE.xlat_sai-dlat_loc .AND. xlat(i).LT.xlat_sai+dlat_loc .AND. & 222 238 & xlon(i).GE.xlon_sai-dlon .AND. xlon(i).LT.xlon_sai+dlon ) THEN 223 239 ! 224 PRINT *,'coordinates of SAI point=',xlat(i), xlon(i), day_cur, mth_cur, year_cur225 240 ! compute altLMDz 226 241 altLMDz(:)=0.0 … … 231 246 altLMDz(k+1)=altLMDz(k)+zdz !altitude of interface 232 247 ENDDO 248 249 SELECT CASE(flag_sulf_emit_distrib) 250 251 CASE(0) ! Gaussian distribution 233 252 !compute distribution of emission to vertical model layers (based on Gaussian peak in altitude) 234 253 f_lay_sum=0.0 235 DO k=1, klev 236 f_lay_emiss(k)=0.0 237 DO i_int=1, n_int_alt 238 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 239 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* & 240 & exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)* & 241 & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 242 ENDDO 243 f_lay_sum=f_lay_sum+f_lay_emiss(k) 244 ENDDO 254 DO k=1, klev 255 f_lay_emiss(k)=0.0 256 DO i_int=1, n_int_alt 257 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 258 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* & 259 & exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)* & 260 & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 261 ENDDO 262 f_lay_sum=f_lay_sum+f_lay_emiss(k) 263 ENDDO 264 265 CASE(1) ! Uniform distribution 266 f_lay_sum=0.0 267 ! In this case, parameter sigma_alt_vol(ieru) is considered to be half 268 ! the height of the injection, centered around altemiss_sai 269 DO k=1, klev 270 f_lay_emiss(k)=max(min(altemiss_sai+sigma_alt_sai,altLMDz(k+1))- & 271 & max(altemiss_sai-sigma_alt_sai,altLMDz(k)),0.)/(2.*sigma_alt_sai) 272 f_lay_sum=f_lay_sum+f_lay_emiss(k) 273 ENDDO 274 275 END SELECT ! Gaussian or uniform distribution 276 245 277 !correct for step integration error 246 278 f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum … … 249 281 DO k=1, klev 250 282 ! stretch emission over whole year (360d) 251 emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/ 360./86400.283 emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/FLOAT(year_len)/86400. 252 284 tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys 253 285 budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol 254 286 ENDDO 287 255 288 ! !emission as monodisperse particles with 0.1um dry radius (BIN21) 256 289 ! !vertically distributed emission 257 290 ! DO k=1, klev 258 291 ! ! stretch emission over whole year (360d) 259 ! emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/360./86400 292 ! emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/FLOAT(year_len)/86400. 293 ! tr_seri(i,k,id_BIN01_strat+20)=tr_seri(i,k,id_BIN01_strat+20)+emission*pdtphys 294 ! budg_emi_part(i)=budg_emi_part(i)+emission*zdm(k)*mSatom/mH2SO4mol 295 ! ENDDO 296 ENDIF ! emission grid cell 297 ENDDO ! klon loop 298 299 CASE(3) ! --- SAI injection over a single band of longitude and between 300 ! lat_min and lat_max 301 302 DO i=1,klon 303 ! SAI scenario with continuous emission 304 dlat_loc=180./RPI/2.*(boundslat(i,1)-boundslat(i,3)) ! dlat = half difference of boundary latitudes 305 theta_min = max(xlat(i)-dlat_loc,xlat_min_sai) 306 theta_max = min(xlat(i)+dlat_loc,xlat_max_sai) 307 IF ( xlat(i).GE.xlat_min_sai-dlat_loc .AND. xlat(i).LT.xlat_max_sai+dlat_loc .AND. & 308 & xlon(i).GE.xlon_sai-dlon .AND. xlon(i).LT.xlon_sai+dlon ) THEN 309 ! 310 ! compute altLMDz 311 altLMDz(:)=0.0 312 DO k=1, klev 313 zrho=pplay(i,k)/t_seri(i,k)/RD !air density in kg/m3 314 zdm(k)=(paprs(i,k)-paprs(i,k+1))/RG !mass of layer in kg 315 zdz=zdm(k)/zrho !thickness of layer in m 316 altLMDz(k+1)=altLMDz(k)+zdz !altitude of interface 317 ENDDO 318 319 SELECT CASE(flag_sulf_emit_distrib) 320 321 CASE(0) ! Gaussian distribution 322 !compute distribution of emission to vertical model layers (based on 323 !Gaussian peak in altitude) 324 f_lay_sum=0.0 325 DO k=1, klev 326 f_lay_emiss(k)=0.0 327 DO i_int=1, n_int_alt 328 alt=altLMDz(k)+float(i_int)*(altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 329 f_lay_emiss(k)=f_lay_emiss(k)+1./(sqrt(2.*RPI)*sigma_alt_sai)* & 330 & exp(-0.5*((alt-altemiss_sai)/sigma_alt_sai)**2.)* & 331 & (altLMDz(k+1)-altLMDz(k))/float(n_int_alt) 332 ENDDO 333 f_lay_sum=f_lay_sum+f_lay_emiss(k) 334 ENDDO 335 336 CASE(1) ! Uniform distribution 337 f_lay_sum=0.0 338 ! In this case, parameter sigma_alt_vol(ieru) is considered to be half 339 ! the height of the injection, centered around altemiss_sai 340 DO k=1, klev 341 f_lay_emiss(k)=max(min(altemiss_sai+sigma_alt_sai,altLMDz(k+1))- & 342 & max(altemiss_sai-sigma_alt_sai,altLMDz(k)),0.)/(2.*sigma_alt_sai) 343 f_lay_sum=f_lay_sum+f_lay_emiss(k) 344 ENDDO 345 346 END SELECT ! Gaussian or uniform distribution 347 348 !correct for step integration error 349 f_lay_emiss(:)=f_lay_emiss(:)/f_lay_sum 350 !emission as SO2 gas (with m(SO2)=64/32*m_aer_emiss) 351 !vertically distributed emission 352 DO k=1, klev 353 ! stretch emission over whole year (360d) 354 emission=m_aer_emiss_sai*(mSO2mol/mSatom)/m_air_gridbox(i,k)*f_lay_emiss(k)/ & 355 & FLOAT(year_len)/86400.*(sin(theta_max/180.*RPI)-sin(theta_min/180.*RPI))/ & 356 & (sin(xlat_max_sai/180.*RPI)-sin(xlat_min_sai/180.*RPI)) 357 tr_seri(i,k,id_SO2_strat)=tr_seri(i,k,id_SO2_strat)+emission*pdtphys 358 budg_emi_so2(i)=budg_emi_so2(i)+emission*zdm(k)*mSatom/mSO2mol 359 ENDDO 360 361 ! !emission as monodisperse particles with 0.1um dry radius (BIN21) 362 ! !vertically distributed emission 363 ! DO k=1, klev 364 ! ! stretch emission over whole year (360d) 365 ! emission=m_aer_emiss*(mH2SO4mol/mSatom)/m_part_dry(21)/m_air_gridbox(i,k)*f_lay_emiss(k)/year_len/86400 260 366 ! tr_seri(i,k,id_BIN01_strat+20)=tr_seri(i,k,id_BIN01_strat+20)+emission*pdtphys 261 367 ! budg_emi_part(i)=budg_emi_part(i)+emission*zdm(k)*mSatom/mH2SO4mol … … 291 397 IF (mdw(it) .LT. 2.5e-6) THEN 292 398 !surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas)*m_part(i,1,it) & 293 !assume that particles consist of ammonium sulfate at the surface (132g/mol) and are dry at T = 20 deg. C and 50 perc. humidity 399 !assume that particles consist of ammonium sulfate at the surface (132g/mol) 400 !and are dry at T = 20 deg. C and 50 perc. humidity 294 401 surf_PM25_sulf(i)=surf_PM25_sulf(i)+tr_seri(i,1,it+nbtr_sulgas) & 295 402 & *132./98.*dens_aer_dry*4./3.*RPI*(mdw(it)/2.)**3 & -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/YOMCST.h
r3429 r3605 20 20 REAL RSIGMA 21 21 ! A1.4 Thermodynamic gas phase 22 REAL R,RMD,RMO3,RMCO2,RMC,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV 22 REAL RMO3,RMCO2,RMC,RMCH4,RMN2O,RMCFC11,RMCFC12 23 REAL R,RMD,RMV,RD,RV,RCPD,RCPV,RCVD,RCVV 23 24 REAL RKAPPA,RETV, eps_w 24 25 ! A1.5,6 Thermodynamic liquid,solid phases … … 35 36 & ,RA ,RG ,R1SA & 36 37 & ,RSIGMA & 37 & ,R ,RMD ,RMO3 ,RMCO2, RMC, RMV ,RD ,RV ,RCPD & 38 & ,R ,RMD ,RMV ,RD ,RV ,RCPD & 39 & ,RMO3 ,RMCO2 ,RMC ,RMCH4 ,RMN2O ,RMCFC11 ,RMCFC12 & 38 40 & ,RCPV ,RCVD ,RCVV ,RKAPPA,RETV, eps_w & 39 41 & ,RCW ,RCS & -
LMDZ6/branches/Ocean_skin/libf/phylmd/acama_gwd_rando_m.F90
-
Property
svn:keywords
set to
Id
r3198 r3605 1 ! 2 ! $Id$ 3 ! 1 4 module ACAMA_GWD_rando_m 2 5 … … 120 123 !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) 121 124 122 CHARACTER (LEN=20) :: modname=' flott_gwd_rando'125 CHARACTER (LEN=20) :: modname='acama_gwd_rando_m' 123 126 CHARACTER (LEN=80) :: abort_message 124 127 … … 208 211 209 212 IF(DELTAT < DTIME)THEN 210 PRINT *, 'flott_gwd_rando: deltat < dtime!' 211 STOP 1 213 ! PRINT *, 'flott_gwd_rando: deltat < dtime!' 214 ! STOP 1 215 abort_message=' deltat < dtime! ' 216 CALL abort_physic(modname,abort_message,1) 212 217 ENDIF 213 218 214 219 IF (KLEV < NW) THEN 215 PRINT *, 'flott_gwd_rando: you will have problem with random numbers' 216 STOP 1 220 ! PRINT *, 'flott_gwd_rando: you will have problem with random numbers' 221 ! STOP 1 222 abort_message=' you will have problem with random numbers' 223 CALL abort_physic(modname,abort_message,1) 217 224 ENDIF 218 225 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/add_phys_tend_mod.F90
r2848 r3605 1 ! 2 ! $Id$ 3 ! 1 4 ! 2 5 MODULE add_phys_tend_mod … … 98 101 99 102 USE dimphy, ONLY: klon, klev 100 USE phys_state_var_mod, ONLY : dtime103 USE phys_state_var_mod, ONLY : phys_tstep 101 104 USE phys_local_var_mod, ONLY: u_seri, v_seri, ql_seri, qs_seri, q_seri, t_seri 102 105 USE phys_state_var_mod, ONLY: ftsol … … 451 454 ! ------------------------------------------------ 452 455 453 d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/ dtime454 d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/ dtime455 d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/ dtime456 d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep 457 d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep 458 d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep 456 459 d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) 457 460 458 d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/ dtime459 460 d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/ dtime461 d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/ dtime462 d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/ dtime463 d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/ dtime464 465 d_h_col = (zh_col(:,2)-zh_col(:,1))/ dtime461 d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep 462 463 d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep 464 d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep 465 d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep 466 d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep 467 468 d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 466 469 467 470 end if ! end if (fl_ebil .GT. 0) … … 494 497 !====================================================================== 495 498 496 USE phys_state_var_mod, ONLY : dtime, ftsol499 USE phys_state_var_mod, ONLY : phys_tstep, ftsol 497 500 USE geometry_mod, ONLY: longitude_deg, latitude_deg 498 501 USE print_control_mod, ONLY: prt_level … … 621 624 ! ------------------------------------------------ 622 625 623 d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/ dtime624 d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/ dtime625 d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/ dtime626 d_qw_col(:) = (zqw_col(:,2)-zqw_col(:,1))/phys_tstep 627 d_ql_col(:) = (zql_col(:,2)-zql_col(:,1))/phys_tstep 628 d_qs_col(:) = (zqs_col(:,2)-zqs_col(:,1))/phys_tstep 626 629 d_qt_col(:) = d_qw_col(:) + d_ql_col(:) + d_qs_col(:) 627 630 628 d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/ dtime631 d_ek_col(:) = (zek_col(:,2)-zek_col(:,1))/phys_tstep 629 632 630 633 print *,'zdu ', zdu … … 632 635 print *,'d_ek_col, zek_col(2), zek_col(1) ',d_ek_col(1), zek_col(1,2), zek_col(1,1) 633 636 634 d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/ dtime635 d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/ dtime636 d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/ dtime637 d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/ dtime638 639 d_h_col = (zh_col(:,2)-zh_col(:,1))/ dtime637 d_h_dair_col(:) = (zh_dair_col(:,2)-zh_dair_col(:,1))/phys_tstep 638 d_h_qw_col(:) = (zh_qw_col(:,2)-zh_qw_col(:,1))/phys_tstep 639 d_h_ql_col(:) = (zh_ql_col(:,2)-zh_ql_col(:,1))/phys_tstep 640 d_h_qs_col(:) = (zh_qs_col(:,2)-zh_qs_col(:,1))/phys_tstep 641 642 d_h_col = (zh_col(:,2)-zh_col(:,1))/phys_tstep 640 643 641 644 end if ! end if (fl_ebil .GT. 0) … … 716 719 717 720 USE dimphy, ONLY: klon, klev 718 USE phys_state_var_mod, ONLY : dtime721 USE phys_state_var_mod, ONLY : phys_tstep 719 722 USE phys_state_var_mod, ONLY : topsw, toplw, solsw, sollw, rain_con, snow_con 720 723 USE geometry_mod, ONLY: longitude_deg, latitude_deg -
LMDZ6/branches/Ocean_skin/libf/phylmd/alpale_th.F90
-
Property
svn:keywords
set to
Id
r3209 r3605 1 ! 2 ! $Id$ 3 ! 1 4 SUBROUTINE alpale_th ( dtime, lmax_th, t_seri, cell_area, & 2 5 cin, s2, n2, & … … 62 65 REAL umexp ! expression of (1.-exp(-x))/x valid for all x, especially when x->0 63 66 REAL x 67 CHARACTER (LEN=20) :: modname='alpale_th' 68 CHARACTER (LEN=80) :: abort_message 69 64 70 umexp(x) = max(sign(1.,x-1.e-3),0.)*(1.-exp(-x))/max(x,1.e-3) + & 65 71 (1.-max(sign(1.,x-1.e-3),0.))*(1.-0.5*x*(1.-x/3.*(1.-0.25*x))) !!! correct formula (jyg) … … 104 110 ! 105 111 IF (prt_level .GE. 10) THEN 106 print *,'cin, ale_bl_stat, alp_bl, alp_bl_stat ', &112 WRITE(lunout,*)'cin, ale_bl_stat, alp_bl, alp_bl_stat ', & 107 113 cin, ale_bl_stat, alp_bl, alp_bl_stat 108 114 ENDIF … … 122 128 ! 123 129 IF (prt_level .GE. 10) THEN 124 print *,'random_notrig, tau_trig ', &130 WRITE(lunout,*)'random_notrig, tau_trig ', & 125 131 random_notrig, tau_trig 126 print *,'s_trig,s2,n2 ', &132 WRITE(lunout,*)'s_trig,s2,n2 ', & 127 133 s_trig,s2,n2 128 134 ENDIF … … 178 184 ! 179 185 IF (prt_level .GE. 10) THEN 180 print *,'proba_notrig, ale_bl_trig ', &186 WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & 181 187 proba_notrig, ale_bl_trig 182 188 ENDIF … … 224 230 ! 225 231 IF (prt_level .GE. 10) THEN 226 print *,'cin, ale_bl_stat, alp_bl_stat ', &232 WRITE(lunout,*)'cin, ale_bl_stat, alp_bl_stat ', & 227 233 cin, ale_bl_stat, alp_bl_stat 228 234 ENDIF … … 253 259 ! 254 260 IF (prt_level .GE. 10) THEN 255 print *,'random_notrig, tau_trig ', &261 WRITE(lunout,*)'random_notrig, tau_trig ', & 256 262 random_notrig, tau_trig 257 print *,'s_trig,s2,n2 ', &263 WRITE(lunout,*)'s_trig,s2,n2 ', & 258 264 s_trig,s2,n2 259 265 ENDIF … … 289 295 ! 290 296 IF (prt_level .GE. 10) THEN 291 print *,'proba_notrig, ale_bl_trig ', &297 WRITE(lunout,*)'proba_notrig, ale_bl_trig ', & 292 298 proba_notrig, ale_bl_trig 293 299 ENDIF … … 300 306 301 307 IF (prt_level .GE. 10) THEN 302 print *,'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', &308 WRITE(lunout,*)'alpale_th: ale_bl_trig, alp_bl_stat, birth_rate ', & 303 309 ale_bl_trig(1), alp_bl_stat(1), birth_rate(1) 304 310 ENDIF … … 310 316 if (iflag_coupl==2) then 311 317 IF (prt_level .GE. 10) THEN 312 print*,'Couplage Thermiques/Emanuel seulement si T<0'318 WRITE(lunout,*)'Couplage Thermiques/Emanuel seulement si T<0' 313 319 ENDIF 314 320 do i=1,klon … … 317 323 endif 318 324 enddo 319 print *,'In order to run with iflag_coupl=2, you have to comment out the following stop' 320 STOP 325 ! print *,'In order to run with iflag_coupl=2, you have to comment out the following stop' 326 ! STOP 327 abort_message='In order to run with iflag_coupl=2, you have to comment out the following abort' 328 CALL abort_physic(modname,abort_message,1) 321 329 endif 322 330 RETURN -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/atm2geo.F90
r2429 r3605 5 5 USE dimphy 6 6 USE mod_phys_lmdz_para 7 USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat 7 8 IMPLICIT NONE 8 9 INCLUDE 'YOMCST.h' 10 11 CHARACTER (len = 6) :: clmodnam 12 CHARACTER (len = 20) :: modname = 'atm2geo' 13 CHARACTER (len = 80) :: abort_message 14 9 15 ! 10 16 ! Change wind local atmospheric coordinates to geocentric 11 17 ! 18 ! Geocentric : 19 ! axe x is eastward : crosses (0 N, 0 E) point. 20 ! axe y crosses (0 N, 90 E) point. 21 ! axe z is 'up' : crosses north pole 12 22 INTEGER, INTENT (in) :: im, jm 13 REAL, DIMENSION (im,jm), INTENT (in) :: pte, ptn 23 REAL, DIMENSION (im,jm), INTENT (in) :: pte ! Eastward vector component 24 REAL, DIMENSION (im,jm), INTENT (in) :: ptn ! Northward vector component 14 25 REAL, DIMENSION (im,jm), INTENT (in) :: plon, plat 15 REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz 16 17 REAL :: rad 18 26 REAL, DIMENSION (im,jm), INTENT(out) :: pxx, pyy, pzz ! Component in the geocentric referential 27 REAL :: rad, reps 19 28 20 29 rad = rpi / 180.0E0 30 reps = 1.0e-5 21 31 22 32 pxx(:,:) = & … … 31 41 + ptn(:,:) * COS(rad * plat (:,:)) 32 42 33 ! Value at North Pole 34 IF (is_north_pole_dyn) THEN 35 pxx(:, 1) = - pte (1, 1) 36 pyy(:, 1) = - ptn (1, 1) 37 pzz(:, 1) = pzz(1,1) 38 ENDIF 43 IF (grid_type==regular_lonlat) THEN 44 ! Value at North Pole 45 IF (is_north_pole_dyn) THEN 46 pxx(:, 1) = - pte (1, 1) 47 pyy(:, 1) = - ptn (1, 1) 48 pzz(:, 1) = pzz(1,1) ! => 0 49 ENDIF 39 50 40 ! Value at South Pole 41 IF (is_south_pole_dyn) THEN 42 pxx(:,jm) = pxx(1,jm) 43 pyy(:,jm) = pyy(1,jm) 44 pzz(:,jm) = pzz(1,jm) 45 ENDIF 51 ! Value at South Pole 52 IF (is_south_pole_dyn) THEN 53 pxx(:,jm) = pxx(1,jm) 54 pyy(:,jm) = pyy(1,jm) 55 pzz(:,jm) = pzz(1,jm) ! => 0 56 ENDIF 57 58 ELSE IF (grid_type==unstructured) THEN 59 ! Pole nord pour Dynamico 60 WHERE ( plat(:,:) >= 90.0d+0-reps ) 61 pxx (:,:) = -ptn (:,:) 62 pyy (:,:) = pte (:,:) 63 pzz (:,:) = 0.0e0 64 END WHERE 65 66 ELSE 67 abort_message='Problem: unknown grid type' 68 CALL abort_physic(modname,abort_message,1) 69 END IF 70 46 71 47 72 END SUBROUTINE atm2geo -
LMDZ6/branches/Ocean_skin/libf/phylmd/calcul_divers.h
r2825 r3605 1 1 ! 2 ! $Header$ 2 ! $Id$ 3 ! 3 4 ! 4 5 ! Initialisations diverses au tout debut … … 14 15 15 16 ! Calcul fin de journee : total_rain, nday_rain 16 IF(MOD(itap,NINT(un_jour/ dtime)).EQ.0) THEN17 IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.0) THEN 17 18 ! print*,'calcul nday_rain itap ',itap 18 19 DO i = 1, klon … … 23 24 24 25 ! Initialisation fin de mois 25 IF(MOD(itap-itapm1,NINT(mth_len*un_jour/ dtime)).EQ.0) THEN26 itapm1=itapm1+NINT(mth_len*un_jour/ dtime)26 IF(MOD(itap-itapm1,NINT(mth_len*un_jour/phys_tstep)).EQ.0) THEN 27 itapm1=itapm1+NINT(mth_len*un_jour/phys_tstep) 27 28 ! print*,'initialisation itapm1 ',itapm1 28 29 ENDIF … … 35 36 t2m_max_mon=0. 36 37 ENDIF 37 IF(MOD(itap,NINT(un_jour/ dtime)).EQ.1) THEN38 IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.1) THEN 38 39 zt2m_min_mon=zt2m 39 40 zt2m_max_mon=zt2m … … 45 46 ENDDO 46 47 !fin de journee 47 IF(MOD(itap,NINT(un_jour/ dtime)).EQ.0) THEN48 IF(MOD(itap,NINT(un_jour/phys_tstep)).EQ.0) THEN 48 49 t2m_min_mon=t2m_min_mon+zt2m_min_mon 49 50 t2m_max_mon=t2m_max_mon+zt2m_max_mon -
LMDZ6/branches/Ocean_skin/libf/phylmd/carbon_cycle_mod.F90
r3421 r3605 7 7 ! ----------------------- 8 8 ! Control module for the carbon CO2 tracers : 9 ! - Identification 10 ! - Get concentrations comming from coupled model or read from file to tracers 11 ! - Calculate new RCO2 for radiation scheme 12 ! - Calculate new carbon flux for sending to coupled models (PISCES and ORCHIDEE) 13 ! 14 ! Module permettant de mettre a jour les champs (puits et sources) pour le 15 ! transport de CO2 en online (IPSL-CM et LMDZOR) et offline (lecture de carte) 9 ! - Initialisation of carbon cycle fields 10 ! - Definition of fluxes to be exchanged 11 ! 12 ! Rest of code is in tracco2i.F90 16 13 ! 17 14 ! Le cas online/offline est defini par le flag carbon_cycle_cpl (y/n) … … 35 32 SAVE 36 33 PRIVATE 37 PUBLIC :: carbon_cycle_init, carbon_cycle,infocfields_init34 PUBLIC :: carbon_cycle_init, infocfields_init 38 35 39 36 ! Variables read from parmeter file physiq.def 37 LOGICAL, PUBLIC :: carbon_cycle_cpl ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES) 38 !$OMP THREADPRIVATE(carbon_cycle_cpl) 40 39 LOGICAL, PUBLIC :: carbon_cycle_tr ! 3D transport of CO2 in the atmosphere, parameter read in conf_phys 41 40 !$OMP THREADPRIVATE(carbon_cycle_tr) 42 LOGICAL, PUBLIC :: carbon_cycle_ cpl ! Coupling of CO2 fluxes between LMDZ/ORCHIDEE and LMDZ/OCEAN(PISCES)43 !$OMP THREADPRIVATE(carbon_cycle_ cpl)41 LOGICAL, PUBLIC :: carbon_cycle_rad ! CO2 interactive radiatively 42 !$OMP THREADPRIVATE(carbon_cycle_rad) 44 43 INTEGER, PUBLIC :: level_coupling_esm ! Level of coupling for the ESM - 0, 1, 2, 3 45 44 !$OMP THREADPRIVATE(level_coupling_esm) 45 REAL, PUBLIC :: RCO2_glo 46 !$OMP THREADPRIVATE(RCO2_glo) 47 REAL, PUBLIC :: RCO2_tot 48 !$OMP THREADPRIVATE(RCO2_tot) 46 49 47 50 LOGICAL :: carbon_cycle_emis_comp_omp=.FALSE. … … 78 81 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_bb ! Emission from biomass burning [kgCO2/m2/s] 79 82 !$OMP THREADPRIVATE(fco2_bb) 83 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 84 !$OMP THREADPRIVATE(fco2_land) 85 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nbp ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 86 !$OMP THREADPRIVATE(fco2_land_nbp) 87 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_nep ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 88 !$OMP THREADPRIVATE(fco2_land_nep) 89 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fLuc ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 90 !$OMP THREADPRIVATE(fco2_land_fLuc) 91 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fwoodharvest ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 92 !$OMP THREADPRIVATE(fco2_land_fwoodharvest) 93 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_land_fHarvest ! Net flux from terrestrial ecocsystems [kgCO2/m2/s] 94 !$OMP THREADPRIVATE(fco2_land_fHarvest) 95 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: fco2_ocean ! Net flux from ocean [kgCO2/m2/s] 96 !$OMP THREADPRIVATE(fco2_ocean) 80 97 81 98 REAL, DIMENSION(:,:), ALLOCATABLE :: dtr_add ! Tracer concentration to be injected … … 91 108 REAL, DIMENSION(:), ALLOCATABLE, PUBLIC :: co2_send ! Field allocated in phyetat0 92 109 !$OMP THREADPRIVATE(co2_send) 110 111 INTEGER, PARAMETER, PUBLIC :: id_CO2=1 !--temporaire OB -- to be changed 93 112 94 113 ! nbfields : total number of fields … … 181 200 CONTAINS 182 201 183 SUBROUTINE carbon_cycle_init( tr_seri, pdtphys, aerosol, radio)202 SUBROUTINE carbon_cycle_init() 184 203 ! This subroutine is called from traclmdz_init, only at first timestep. 185 204 ! - Read controle parameters from .def input file … … 189 208 190 209 USE dimphy 191 USE geometry_mod, ONLY : cell_area192 USE mod_phys_lmdz_transfert_para193 USE infotrac_phy, ONLY: nbtr, nqo, niadv, tname194 210 USE IOIPSL 195 USE surface_data, ONLY : ok_veget, type_ocean196 USE phys_cal_mod, ONLY : mth_len197 211 USE print_control_mod, ONLY: lunout 198 212 … … 200 214 INCLUDE "clesphys.h" 201 215 202 ! Input argument203 REAL,DIMENSION(klon,klev,nbtr),INTENT(IN) :: tr_seri ! Concentration Traceur [U/KgA]204 REAL,INTENT(IN) :: pdtphys ! length of time step in physiq (sec)205 206 ! InOutput arguments207 LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: aerosol208 LOGICAL,DIMENSION(nbtr), INTENT(INOUT) :: radio209 210 216 ! Local variables 211 INTEGER :: ierr, it, iiq, itc 212 INTEGER :: teststop 213 214 ! 1) Read controle parameters from .def input file 215 ! ------------------------------------------------ 216 ! Read fosil fuel value if no transport 217 IF (.NOT. carbon_cycle_tr) THEN 218 !$OMP MASTER 219 fos_fuel_s_omp = 0. 220 CALL getin ('carbon_cycle_fos_fuel',fos_fuel_s_omp) 221 !$OMP END MASTER 222 !$OMP BARRIER 223 fos_fuel_s=fos_fuel_s_omp 224 WRITE(lunout,*) 'carbon_cycle_fos_fuel = ', fos_fuel_s 225 END IF 226 227 ! Read parmeter for calculation compatible emission 228 IF (.NOT. carbon_cycle_tr) THEN 229 !$OMP MASTER 230 carbon_cycle_emis_comp_omp=.FALSE. 231 CALL getin('carbon_cycle_emis_comp',carbon_cycle_emis_comp_omp) 232 !$OMP END MASTER 233 !$OMP BARRIER 234 carbon_cycle_emis_comp=carbon_cycle_emis_comp_omp 235 WRITE(lunout,*) 'carbon_cycle_emis_comp = ',carbon_cycle_emis_comp 236 IF (carbon_cycle_emis_comp) THEN 237 CALL abort_physic('carbon_cycle_init', 'carbon_cycle_emis_comp option not yet implemented!!',1) 238 END IF 239 END IF 240 241 ! Read parameter for interactive calculation of the CO2 value for the radiation scheme 242 !$OMP MASTER 243 RCO2_inter_omp=.FALSE. 244 CALL getin('RCO2_inter',RCO2_inter_omp) 245 !$OMP END MASTER 246 !$OMP BARRIER 247 RCO2_inter=RCO2_inter_omp 248 WRITE(lunout,*) 'RCO2_inter = ', RCO2_inter 249 IF (RCO2_inter) THEN 250 WRITE(lunout,*) 'RCO2 will be recalculated once a day' 251 WRITE(lunout,*) 'RCO2 initial = ', RCO2 252 END IF 253 254 255 ! 2) Search for carbon tracers and set default values 256 ! --------------------------------------------------- 257 itc=0 258 DO it=1,nbtr 259 !! iiq=niadv(it+2) ! jyg 260 iiq=niadv(it+nqo) ! jyg 261 262 SELECT CASE(tname(iiq)) 263 CASE("fCO2_ocn") 264 itc = itc + 1 265 co2trac(itc)%name='fCO2_ocn' 266 co2trac(itc)%id=it 267 co2trac(itc)%file='fl_co2_ocean.nc' 268 IF (carbon_cycle_cpl .AND. type_ocean=='couple') THEN 269 co2trac(itc)%cpl=.TRUE. 270 co2trac(itc)%updatefreq = 86400 ! Once a day as the coupling with OASIS/PISCES 271 ELSE 272 co2trac(itc)%cpl=.FALSE. 273 co2trac(itc)%updatefreq = 86400*mth_len ! Once a month 274 END IF 275 CASE("fCO2_land") 276 itc = itc + 1 277 co2trac(itc)%name='fCO2_land' 278 co2trac(itc)%id=it 279 co2trac(itc)%file='fl_co2_land.nc' 280 IF (carbon_cycle_cpl .AND. ok_veget) THEN 281 co2trac(itc)%cpl=.TRUE. 282 co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE 283 ELSE 284 co2trac(itc)%cpl=.FALSE. 285 ! co2trac(itc)%updatefreq = 10800 ! 10800sec = 3H 286 co2trac(itc)%updatefreq = 86400*mth_len ! Once a month 287 END IF 288 CASE("fCO2_land_use") 289 itc = itc + 1 290 co2trac(itc)%name='fCO2_land_use' 291 co2trac(itc)%id=it 292 co2trac(itc)%file='fl_co2_land_use.nc' 293 IF (carbon_cycle_cpl .AND. ok_veget) THEN 294 co2trac(it)%cpl=.TRUE. 295 co2trac(itc)%updatefreq = INT(pdtphys) ! Each timestep as the coupling with ORCHIDEE 296 ELSE 297 co2trac(itc)%cpl=.FALSE. 298 co2trac(itc)%updatefreq = 10800 ! 10800sec = 3H 299 END IF 300 CASE("fCO2_fos_fuel") 301 itc = itc + 1 302 co2trac(itc)%name='fCO2_fos_fuel' 303 co2trac(itc)%id=it 304 co2trac(itc)%file='fossil_fuel.nc' 305 co2trac(itc)%cpl=.FALSE. ! This tracer always read from file 306 ! co2trac(itc)%updatefreq = 86400 ! 86400sec = 24H Cadule case 307 co2trac(itc)%updatefreq = 86400*mth_len ! Once a month 308 CASE("fCO2_bbg") 309 itc = itc + 1 310 co2trac(itc)%name='fCO2_bbg' 311 co2trac(itc)%id=it 312 co2trac(itc)%file='fl_co2_bbg.nc' 313 co2trac(itc)%cpl=.FALSE. ! This tracer always read from file 314 co2trac(itc)%updatefreq = 86400*mth_len ! Once a month 315 CASE("fCO2") 316 ! fCO2 : One tracer transporting the total CO2 flux 317 itc = itc + 1 318 co2trac(itc)%name='fCO2' 319 co2trac(itc)%id=it 320 co2trac(itc)%file='fl_co2.nc' 321 IF (carbon_cycle_cpl) THEN 322 co2trac(itc)%cpl=.TRUE. 323 ELSE 324 co2trac(itc)%cpl=.FALSE. 325 END IF 326 co2trac(itc)%updatefreq = 86400 327 ! DOES THIS WORK ???? Problematic due to implementation of the coupled fluxes... 328 CALL abort_physic('carbon_cycle_init','transport of total CO2 has to be implemented and tested',1) 329 END SELECT 330 END DO 331 332 ! Total number of carbon CO2 tracers 333 ntr_co2 = itc 334 335 ! Definition of control varaiables for the tracers 336 DO it=1,ntr_co2 337 aerosol(co2trac(it)%id) = .FALSE. 338 radio(co2trac(it)%id) = .FALSE. 339 END DO 340 341 ! Vector indicating which timestep to read for each tracer 342 ! Always start read in the beginning of the file 343 co2trac(:)%readstep = 0 344 345 346 ! 3) Allocate variables 347 ! --------------------- 348 ! Allocate vector for storing fluxes to inject 349 ALLOCATE(dtr_add(klon,maxco2trac), stat=ierr) 350 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 11',1) 351 352 ! Allocate variables for cumulating fluxes from ORCHIDEE 353 IF (RCO2_inter) THEN 354 IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN 355 ALLOCATE(fco2_land_day(klon), stat=ierr) 356 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 2',1) 357 fco2_land_day(1:klon) = 0. 358 359 ALLOCATE(fco2_lu_day(klon), stat=ierr) 360 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation 3',1) 361 fco2_lu_day(1:klon) = 0. 362 END IF 363 END IF 364 365 366 ! 4) Test for compatibility 367 ! ------------------------- 368 ! IF (carbon_cycle_cpl .AND. type_ocean/='couple') THEN 369 ! WRITE(lunout,*) 'Coupling with ocean model is needed for carbon_cycle_cpl' 370 ! CALL abort_physic('carbon_cycle_init', 'coupled ocean is needed for carbon_cycle_cpl',1) 371 ! END IF 372 ! 373 ! IF (carbon_cycle_cpl .AND..NOT. ok_veget) THEN 374 ! WRITE(lunout,*) 'Coupling with surface land model ORCHDIEE is needed for carbon_cycle_cpl' 375 ! CALL abort_physic('carbon_cycle_init', 'ok_veget is needed for carbon_cycle_cpl',1) 376 ! END IF 377 378 ! Compiler test : following should never happen 379 teststop=0 380 DO it=1,teststop 381 CALL abort_physic('carbon_cycle_init', 'Entering loop from 1 to 0',1) 382 END DO 383 384 IF (ntr_co2==0) THEN 385 ! No carbon tracers found in tracer.def. It is not possible to do carbon cycle 386 WRITE(lunout,*) 'No carbon tracers found in tracer.def. Not ok with carbon_cycle_tr and/or carbon_cycle_cp' 387 CALL abort_physic('carbon_cycle_init', 'No carbon tracers found in tracer.def',1) 388 END IF 389 390 ! 5) Calculate total area of the earth surface 391 ! -------------------------------------------- 392 CALL reduce_sum(SUM(cell_area),airetot) 393 CALL bcast(airetot) 217 INTEGER :: ierr 218 219 IF (carbon_cycle_cpl) THEN 220 221 ierr=0 222 223 IF (.NOT.ALLOCATED(fco2_land)) ALLOCATE(fco2_land(klon), stat=ierr) 224 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land',1) 225 fco2_land(1:klon) = 0. 226 227 IF (.NOT.ALLOCATED(fco2_land_nbp)) ALLOCATE(fco2_land_nbp(klon), stat=ierr) 228 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nbp',1) 229 fco2_land_nbp(1:klon) = 0. 230 231 IF (.NOT.ALLOCATED(fco2_land_nep)) ALLOCATE(fco2_land_nep(klon), stat=ierr) 232 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_nep',1) 233 fco2_land_nep(1:klon) = 0. 234 235 IF (.NOT.ALLOCATED(fco2_land_fLuc)) ALLOCATE(fco2_land_fLuc(klon), stat=ierr) 236 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fLuc',1) 237 fco2_land_fLuc(1:klon) = 0. 238 239 IF (.NOT.ALLOCATED(fco2_land_fwoodharvest)) ALLOCATE(fco2_land_fwoodharvest(klon), stat=ierr) 240 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fwoodharvest',1) 241 fco2_land_fwoodharvest(1:klon) = 0. 242 243 IF (.NOT.ALLOCATED(fco2_land_fHarvest)) ALLOCATE(fco2_land_fHarvest(klon), stat=ierr) 244 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_land_fHarvest',1) 245 fco2_land_fHarvest(1:klon) = 0. 246 247 IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon), stat=ierr) 248 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ff',1) 249 fco2_ff(1:klon) = 0. 250 251 IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon), stat=ierr) 252 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_bb',1) 253 fco2_bb(1:klon) = 0. 254 255 IF (.NOT.ALLOCATED(fco2_ocean)) ALLOCATE(fco2_ocean(klon), stat=ierr) 256 IF (ierr /= 0) CALL abort_physic('carbon_cycle_init', 'pb in allocation fco2_ocean',1) 257 fco2_bb(1:klon) = 0. 258 ENDIF 394 259 395 260 END SUBROUTINE carbon_cycle_init 396 261 397 SUBROUTINE carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)398 ! Subroutine for injection of co2 in the tracers399 !400 ! - Find out if it is time to update401 ! - Get tracer from coupled model or from file402 ! - Calculate new RCO2 value for the radiation scheme403 ! - Calculate CO2 flux to send to ocean and land models (PISCES and ORCHIDEE)404 405 USE infotrac_phy, ONLY: nbtr406 USE dimphy407 USE mod_phys_lmdz_transfert_para408 USE phys_cal_mod, ONLY : mth_cur, mth_len409 USE phys_cal_mod, ONLY : day_cur410 USE indice_sol_mod411 USE print_control_mod, ONLY: lunout412 USE geometry_mod, ONLY : cell_area413 414 IMPLICIT NONE415 416 INCLUDE "clesphys.h"417 INCLUDE "YOMCST.h"418 419 ! In/Output arguments420 INTEGER,INTENT(IN) :: nstep ! time step in physiq421 REAL,INTENT(IN) :: pdtphys ! length of time step in physiq (sec)422 REAL,DIMENSION(klon,nbsrf),INTENT(IN) :: pctsrf ! Surface fraction423 REAL, DIMENSION(klon,klev,nbtr), INTENT(INOUT) :: tr_seri ! All tracers424 REAL, DIMENSION(klon,nbtr), INTENT(INOUT) :: source ! Source for all tracers425 426 ! Local variables427 INTEGER :: it428 LOGICAL :: newmonth ! indicates if a new month just started429 LOGICAL :: newday ! indicates if a new day just started430 LOGICAL :: endday ! indicated if last time step in a day431 432 REAL, PARAMETER :: fact=1.E-15/2.12 ! transformation factor from gC/m2/day => ppm/m2/day433 REAL, DIMENSION(klon) :: fco2_tmp434 REAL :: sumtmp435 REAL :: delta_co2_ppm436 437 438 ! 1) Calculate logicals indicating if it is a new month, new day or the last time step in a day (end day)439 ! -------------------------------------------------------------------------------------------------------440 441 newday = .FALSE.; endday = .FALSE.; newmonth = .FALSE.442 443 IF (MOD(nstep,INT(86400./pdtphys))==1) newday=.TRUE.444 IF (MOD(nstep,INT(86400./pdtphys))==0) endday=.TRUE.445 IF (newday .AND. day_cur==1) newmonth=.TRUE.446 447 ! 2) For each carbon tracer find out if it is time to inject (update)448 ! --------------------------------------------------------------------449 DO it = 1, ntr_co2450 IF ( MOD(nstep,INT(co2trac(it)%updatefreq/pdtphys)) == 1 ) THEN451 co2trac(it)%updatenow = .TRUE.452 ELSE453 co2trac(it)%updatenow = .FALSE.454 END IF455 END DO456 457 ! 3) Get tracer update458 ! --------------------------------------459 DO it = 1, ntr_co2460 IF ( co2trac(it)%updatenow ) THEN461 IF ( co2trac(it)%cpl ) THEN462 ! Get tracer from coupled model463 SELECT CASE(co2trac(it)%name)464 CASE('fCO2_land') ! from ORCHIDEE465 dtr_add(:,it) = fco2_land_inst(:)*pctsrf(:,is_ter)*fact ! [ppm/m2/day]466 CASE('fCO2_land_use') ! from ORCHIDEE467 dtr_add(:,it) = fco2_lu_inst(:) *pctsrf(:,is_ter)*fact ! [ppm/m2/day]468 CASE('fCO2_ocn') ! from PISCES469 dtr_add(:,it) = fco2_ocn_day(:) *pctsrf(:,is_oce)*fact ! [ppm/m2/day]470 CASE DEFAULT471 WRITE(lunout,*) 'Error with tracer ',co2trac(it)%name472 CALL abort_physic('carbon_cycle', 'No coupling implemented for this tracer',1)473 END SELECT474 ELSE475 ! Read tracer from file476 co2trac(it)%readstep = co2trac(it)%readstep + 1 ! increment time step in file477 ! Patricia CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.FALSE.,dtr_add(:,it))478 CALL read_map2D(co2trac(it)%file,'fco2',co2trac(it)%readstep,.TRUE.,dtr_add(:,it))479 480 ! Converte from kgC/m2/h to kgC/m2/s481 dtr_add(:,it) = dtr_add(:,it)/3600482 ! Add individual treatment of values read from file483 SELECT CASE(co2trac(it)%name)484 CASE('fCO2_land')485 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)486 CASE('fCO2_land_use')487 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_ter)488 CASE('fCO2_ocn')489 dtr_add(:,it) = dtr_add(:,it) *pctsrf(:,is_oce)490 ! Patricia :491 ! CASE('fCO2_fos_fuel')492 ! dtr_add(:,it) = dtr_add(:,it)/mth_len493 ! co2trac(it)%readstep = 0 ! Always read same value for fossil fuel(Cadule case)494 END SELECT495 END IF496 END IF497 END DO498 499 ! 4) Update co2 tracers :500 ! Loop over all carbon tracers and add source501 ! ------------------------------------------------------------------502 IF (carbon_cycle_tr) THEN503 DO it = 1, ntr_co2504 IF (.FALSE.) THEN505 tr_seri(1:klon,1,co2trac(it)%id) = tr_seri(1:klon,1,co2trac(it)%id) + dtr_add(1:klon,it)506 source(1:klon,co2trac(it)%id) = 0.507 ELSE508 source(1:klon,co2trac(it)%id) = dtr_add(1:klon,it)509 END IF510 END DO511 END IF512 513 514 ! 5) Calculations for new CO2 value for the radiation scheme(instead of reading value from .def)515 ! ----------------------------------------------------------------------------------------------516 IF (RCO2_inter) THEN517 ! Cumulate fluxes from ORCHIDEE at each timestep518 IF (.NOT. carbon_cycle_tr .AND. carbon_cycle_cpl) THEN519 IF (newday) THEN ! Reset cumulative variables once a day520 fco2_land_day(1:klon) = 0.521 fco2_lu_day(1:klon) = 0.522 END IF523 fco2_land_day(1:klon) = fco2_land_day(1:klon) + fco2_land_inst(1:klon) ![gC/m2/day]524 fco2_lu_day(1:klon) = fco2_lu_day(1:klon) + fco2_lu_inst(1:klon) ![gC/m2/day]525 END IF526 527 ! At the end of a new day, calculate a mean scalare value of CO2528 ! JG : Ici on utilise uniquement le traceur du premier couche du modele. Est-ce que c'est correcte ?529 IF (endday) THEN530 531 IF (carbon_cycle_tr) THEN532 ! Sum all co2 tracers to get the total delta CO2 flux533 fco2_tmp(:) = 0.534 DO it = 1, ntr_co2535 fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)536 END DO537 538 ELSE IF (carbon_cycle_cpl) THEN ! no carbon_cycle_tr539 ! Sum co2 fluxes comming from coupled models and parameter for fossil fuel540 fco2_tmp(1:klon) = fos_fuel_s + ((fco2_lu_day(1:klon) + fco2_land_day(1:klon))*pctsrf(1:klon,is_ter) &541 + fco2_ocn_day(:)*pctsrf(:,is_oce)) * fact542 END IF543 544 ! Calculate a global mean value of delta CO2 flux545 fco2_tmp(1:klon) = fco2_tmp(1:klon) * cell_area(1:klon)546 CALL reduce_sum(SUM(fco2_tmp),sumtmp)547 CALL bcast(sumtmp)548 delta_co2_ppm = sumtmp/airetot549 550 ! Add initial value for co2_ppm and delta value551 co2_ppm = co2_ppm0 + delta_co2_ppm552 553 ! Transformation of atmospheric CO2 concentration for the radiation code554 RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97555 556 WRITE(lunout,*) 'RCO2 is now updated! RCO2 = ', RCO2557 END IF ! endday558 559 END IF ! RCO2_inter560 561 562 ! 6) Calculate CO2 flux to send to ocean and land models : PISCES and ORCHIDEE563 ! ----------------------------------------------------------------------------564 IF (carbon_cycle_cpl) THEN565 566 IF (carbon_cycle_tr) THEN567 ! Sum all co2 tracers to get the total delta CO2 flux at first model layer568 fco2_tmp(:) = 0.569 DO it = 1, ntr_co2570 fco2_tmp(1:klon) = fco2_tmp(1:klon) + tr_seri(1:klon,1,co2trac(it)%id)571 END DO572 co2_send(1:klon) = fco2_tmp(1:klon) + co2_ppm0573 ELSE574 ! Send a scalare value in 2D variable to ocean and land model (PISCES and ORCHIDEE)575 co2_send(1:klon) = co2_ppm576 END IF577 578 END IF579 580 END SUBROUTINE carbon_cycle581 582 262 SUBROUTINE infocfields_init 583 263 584 USE control_mod, ONLY: planet_type264 ! USE control_mod, ONLY: planet_type 585 265 USE phys_cal_mod, ONLY : mth_cur 586 266 USE mod_synchro_omp … … 656 336 657 337 CHARACTER(len=*),parameter :: modname="infocfields" 338 339 CHARACTER(len=10),SAVE :: planet_type="earth" 658 340 659 341 !----------------------------------------------------------------------- … … 718 400 WRITE(lunout,*) 'abort_gcm --- nbcf_in : ',nbcf_in 719 401 WRITE(lunout,*) 'abort_gcm --- nbcf_out: ',nbcf_out 720 CALL abort_ gcm('infocfields_init','Problem in the definition of the coupling fields',1)402 CALL abort_physic('infocfields_init','Problem in the definition of the coupling fields',1) 721 403 ENDIF 722 404 ENDDO !DO iq=1,nbcf … … 836 518 837 519 ALLOCATE(fields_in(klon,nbcf_in),stat=error) 838 IF (error /= 0) CALL abort_ gcm(modname,'Pb in allocation fields_in',1)520 IF (error /= 0) CALL abort_physic(modname,'Pb in allocation fields_in',1) 839 521 ALLOCATE(yfields_in(klon,nbcf_in),stat=error) 840 IF (error /= 0) CALL abort_ gcm(modname,'Pb in allocation yfields_in',1)522 IF (error /= 0) CALL abort_physic(modname,'Pb in allocation yfields_in',1) 841 523 ALLOCATE(fields_out(klon,nbcf_out),stat=error) 842 IF (error /= 0) CALL abort_ gcm(modname,'Pb in allocation fields_out',1)524 IF (error /= 0) CALL abort_physic(modname,'Pb in allocation fields_out',1) 843 525 ALLOCATE(yfields_out(klon,nbcf_out),stat=error) 844 IF (error /= 0) CALL abort_ gcm(modname,'Pb in allocation yfields_out',1)526 IF (error /= 0) CALL abort_physic(modname,'Pb in allocation yfields_out',1) 845 527 846 528 END SUBROUTINE infocfields_init -
LMDZ6/branches/Ocean_skin/libf/phylmd/clesphys.h
r3327 r3605 70 70 !IM freq_outNMC : frequences de sortie fichiers niveaux de pression (histmthNMC, histdayNMC, histhfNMC) 71 71 !IM freq_calNMC : frequences de calcul fis. hist*NMC.nc 72 !IM pasphys : pas de temps de physique (secondes)73 REAL pasphys74 72 LOGICAL ok_histNMC(3) 75 73 INTEGER levout_histNMC(3) … … 111 109 & , min_wind_speed,f_gust_wk,f_gust_bl,f_qsat_oce,f_z0qh_oce & 112 110 & , z0m_seaice,z0h_seaice & 113 & , pasphys , freq_outNMC, freq_calNMC&111 & , freq_outNMC, freq_calNMC & 114 112 & , lonmin_ins, lonmax_ins, latmin_ins, latmax_ins & 115 113 & , freq_ISCCP, ecrit_ISCCP, freq_COSP, freq_AIRS & -
LMDZ6/branches/Ocean_skin/libf/phylmd/cloudth_mod.F90
r2960 r3605 7 7 SUBROUTINE cloudth(ngrid,klev,ind2, & 8 8 & ztv,po,zqta,fraca, & 9 & qcloud,ctot,zpspsk,paprs, ztla,zthl, &9 & qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, & 10 10 & ratqs,zqs,t) 11 11 … … 38 38 REAL zpspsk(ngrid,klev) 39 39 REAL paprs(ngrid,klev+1) 40 REAL pplay(ngrid,klev) 40 41 REAL ztla(ngrid,klev) 41 42 REAL zthl(ngrid,klev) … … 78 79 CALL cloudth_vert(ngrid,klev,ind2, & 79 80 & ztv,po,zqta,fraca, & 80 & qcloud,ctot,zpspsk,paprs, ztla,zthl, &81 & qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, & 81 82 & ratqs,zqs,t) 82 83 RETURN … … 251 252 SUBROUTINE cloudth_vert(ngrid,klev,ind2, & 252 253 & ztv,po,zqta,fraca, & 253 & qcloud,ctot,zpspsk,paprs, ztla,zthl, &254 & qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, & 254 255 & ratqs,zqs,t) 255 256 … … 282 283 REAL zpspsk(ngrid,klev) 283 284 REAL paprs(ngrid,klev+1) 285 REAL pplay(ngrid,klev) 284 286 REAL ztla(ngrid,klev) 285 287 REAL zthl(ngrid,klev) … … 585 587 END SUBROUTINE cloudth_vert 586 588 589 590 591 587 592 SUBROUTINE cloudth_v3(ngrid,klev,ind2, & 588 593 & ztv,po,zqta,fraca, & 589 & qcloud,ctot,ctot_vol,zpspsk,paprs, ztla,zthl, &594 & qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 590 595 & ratqs,zqs,t) 591 596 … … 618 623 REAL zpspsk(ngrid,klev) 619 624 REAL paprs(ngrid,klev+1) 625 REAL pplay(ngrid,klev) 620 626 REAL ztla(ngrid,klev) 621 627 REAL zthl(ngrid,klev) … … 641 647 REAL alth,alenv,ath,aenv 642 648 REAL sth,senv,sigma1s,sigma2s,xth,xenv, exp_xenv1, exp_xenv2,exp_xth1,exp_xth2 649 REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks 643 650 REAL Tbef,zdelta,qsatbef,zcor 644 651 REAL qlbef … … 654 661 CALL cloudth_vert_v3(ngrid,klev,ind2, & 655 662 & ztv,po,zqta,fraca, & 656 & qcloud,ctot,ctot_vol,zpspsk,paprs, ztla,zthl, &663 & qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 657 664 & ratqs,zqs,t) 658 665 RETURN … … 808 815 SUBROUTINE cloudth_vert_v3(ngrid,klev,ind2, & 809 816 & ztv,po,zqta,fraca, & 810 & qcloud,ctot,ctot_vol,zpspsk,paprs, ztla,zthl, &817 & qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 811 818 & ratqs,zqs,t) 812 819 … … 841 848 REAL zpspsk(ngrid,klev) 842 849 REAL paprs(ngrid,klev+1) 850 REAL pplay(ngrid,klev) 843 851 REAL ztla(ngrid,klev) 844 852 REAL zthl(ngrid,klev) … … 864 872 REAL alth,alenv,ath,aenv 865 873 REAL sth,senv,sigma1s,sigma2s,sigma1s_fraca,sigma1s_ratqs 874 REAL inverse_rho,beta,a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks 866 875 REAL xth,xenv,exp_xenv1,exp_xenv2,exp_xth1,exp_xth2 867 876 REAL xth1,xth2,xenv1,xenv2,deltasth, deltasenv … … 876 885 REAL,SAVE :: sigma1s_factor=1.1 877 886 REAL,SAVE :: sigma1s_power=0.6 887 REAL,SAVE :: sigma2s_factor=0.09 888 REAL,SAVE :: sigma2s_power=0.5 878 889 REAL,SAVE :: cloudth_ratqsmin=-1. 879 !$OMP THREADPRIVATE(sigma1s_factor,sigma1s_power, cloudth_ratqsmin)890 !$OMP THREADPRIVATE(sigma1s_factor,sigma1s_power,sigma2s_factor,sigma2s_power,cloudth_ratqsmin) 880 891 INTEGER, SAVE :: iflag_cloudth_vert_noratqs=0 881 892 !$OMP THREADPRIVATE(iflag_cloudth_vert_noratqs) … … 888 899 REAL zqs(ngrid), qcloud(ngrid) 889 900 REAL erf 901 902 REAL rhodz(ngrid,klev) 903 REAL zrho(ngrid,klev) 904 REAL dz(ngrid,klev) 905 906 DO ind1 = 1, ngrid 907 !Layer calculation 908 rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg !kg/m2 909 zrho(ind1,ind2) = pplay(ind1,ind2)/t(ind1,ind2)/rd !kg/m3 910 dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2) !m : epaisseur de la couche en metre 911 END DO 912 890 913 891 914 !------------------------------------------------------------------------------ … … 930 953 CALL getin_p('cloudth_sigma1s_power',sigma1s_power) 931 954 WRITE(*,*) 'cloudth_sigma1s_power = ', sigma1s_power 955 ! Factor used in the calculation of sigma2s 956 CALL getin_p('cloudth_sigma2s_factor',sigma2s_factor) 957 WRITE(*,*) 'cloudth_sigma2s_factor = ', sigma2s_factor 958 ! Power used in the calculation of sigma2s 959 CALL getin_p('cloudth_sigma2s_power',sigma2s_power) 960 WRITE(*,*) 'cloudth_sigma2s_power = ', sigma2s_power 932 961 ! Minimum value for the environmental air subgrid water distrib 933 962 CALL getin_p('cloudth_ratqsmin',cloudth_ratqsmin) … … 998 1027 ENDIF 999 1028 sigma1s = sigma1s_fraca + sigma1s_ratqs 1000 sigma2s=( 0.09*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**0.5))+0.002*zqta(ind1,ind2)1029 sigma2s=(sigma2s_factor*(((sth-senv)**2)**0.5)/((fraca(ind1,ind2)+0.02)**sigma2s_power))+0.002*zqta(ind1,ind2) 1001 1030 ! tests 1002 1031 ! sigma1s=(0.92**0.5)*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+ratqs(ind1,ind2)*po(ind1) … … 1050 1079 1051 1080 ELSE IF (iflag_cloudth_vert >= 3) THEN 1052 1081 IF (iflag_cloudth_vert < 5) THEN 1053 1082 !------------------------------------------------------------------------------- 1054 1083 ! Version 3: Changes by J. Jouhaud; condensation for q > -delta s … … 1119 1148 endif 1120 1149 1121 1122 1150 qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2) 1123 1151 ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2) 1124 1152 1153 ELSE IF (iflag_cloudth_vert == 5) THEN 1154 sigma1s=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5)+ratqs(ind1,ind2)*po(ind1) !Environment 1155 sigma2s=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.02)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2) !Thermals 1156 !sigma1s=(1.1**0.5)*(fraca(ind1,ind2)**0.6)/(1-fraca(ind1,ind2))*((sth-senv)**2)**0.5+0.002*po(ind1) 1157 !sigma2s=0.11*((sth-senv)**2)**0.5/(fraca(ind1,ind2)+0.01)**0.4+0.002*zqta(ind1,ind2) 1158 xth=sth/(sqrt(2.)*sigma2s) 1159 xenv=senv/(sqrt(2.)*sigma1s) 1160 1161 !Volumique 1162 cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth)) 1163 cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 1164 ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2) 1165 !print *,'jeanjean_CV=',ctot_vol(ind1,ind2) 1166 1167 qlth(ind1,ind2)=sigma2s*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt(2.)*cth_vol(ind1,ind2)) 1168 qlenv(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv_vol(ind1,ind2)) 1169 qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2) 1170 1171 !Surfacique 1172 !Neggers 1173 !beta=0.0044 1174 !inverse_rho=1.+beta*dz(ind1,ind2) 1175 !print *,'jeanjean : beta=',beta 1176 !cth(ind1,ind2)=cth_vol(ind1,ind2)*inverse_rho 1177 !cenv(ind1,ind2)=cenv_vol(ind1,ind2)*inverse_rho 1178 !ctot(ind1,ind2)=fraca(ind1,ind2)*cth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv(ind1,ind2) 1179 1180 !Brooks 1181 a_Brooks=0.6694 1182 b_Brooks=0.1882 1183 A_Maj_Brooks=0.1635 !-- sans shear 1184 !A_Maj_Brooks=0.17 !-- ARM LES 1185 !A_Maj_Brooks=0.18 !-- RICO LES 1186 !A_Maj_Brooks=0.19 !-- BOMEX LES 1187 Dx_Brooks=200000. 1188 f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks)) 1189 !print *,'jeanjean_f=',f_Brooks 1190 1191 cth(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cth_vol(ind1,ind2),1.)))- 1.)) 1192 cenv(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(cenv_vol(ind1,ind2),1.)))- 1.)) 1193 ctot(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.)) 1194 !print *,'JJ_ctot_1',ctot(ind1,ind2) 1195 1196 1197 1198 1199 1200 ENDIF ! of if (iflag_cloudth_vert<5) 1125 1201 ENDIF ! of if (iflag_cloudth_vert==1 or 3 or 4) 1126 1202 1127 1203 ! if (ctot(ind1,ind2).lt.1.e-10) then 1128 1204 if (cenv(ind1,ind2).lt.1.e-10.or.cth(ind1,ind2).lt.1.e-10) then 1129 1205 ctot(ind1,ind2)=0. 1130 1206 ctot_vol(ind1,ind2)=0. 1131 qcloud(ind1)=zqsatenv(ind1,ind2) 1132 1133 else 1207 qcloud(ind1)=zqsatenv(ind1,ind2) 1208 1209 else 1134 1210 1135 1211 qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqs(ind1) … … 1139 1215 endif 1140 1216 1141 else ! Environment only1217 else ! gaussienne environnement seule 1142 1218 1143 1219 zqenv(ind1)=po(ind1) … … 1151 1227 1152 1228 1153 ! qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.)1229 ! qlbef=Max(po(ind1)-zqsatenv(ind1,ind2),0.) 1154 1230 zthl(ind1,ind2)=t(ind1,ind2)*(101325/paprs(ind1,ind2))**(rdd/cppd) 1155 alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) 1231 alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) 1156 1232 aenv=1./(1.+(alenv*Lv/cppd)) 1157 1233 senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) 1158 1234 sth=0. 1235 1159 1236 1160 1237 sigma1s=ratqs(ind1,ind2)*zqenv(ind1) 1161 1238 sigma2s=0. 1162 1239 1163 xenv=senv/(sqrt2*sigma1s) 1240 sqrt2pi=sqrt(2.*pi) 1241 xenv=senv/(sqrt(2.)*sigma1s) 1164 1242 ctot(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 1165 1243 ctot_vol(ind1,ind2)=ctot(ind1,ind2) 1166 qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt 2*cenv(ind1,ind2))1244 qltot(ind1,ind2)=sigma1s*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt(2.)*cenv(ind1,ind2)) 1167 1245 1168 1246 if (ctot(ind1,ind2).lt.1.e-3) then 1169 1247 ctot(ind1,ind2)=0. 1170 qcloud(ind1)=zqsatenv(ind1,ind2) 1248 qcloud(ind1)=zqsatenv(ind1,ind2) 1171 1249 1172 1250 else 1173 1251 1252 ! ctot(ind1,ind2)=ctot(ind1,ind2) 1174 1253 qcloud(ind1)=qltot(ind1,ind2)/ctot(ind1,ind2)+zqsatenv(ind1,ind2) 1175 1254 1176 endif 1177 1255 endif 1256 1257 1258 1259 1178 1260 endif ! From the separation (thermal/envrionnement) et (environnement) only, l.335 et l.492 1179 1261 ! Outputs used to check the PDFs … … 1184 1266 1185 1267 enddo ! from the loop on ngrid l.333 1186 1187 1268 return 1188 1269 ! end 1189 1270 END SUBROUTINE cloudth_vert_v3 1190 1271 ! 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 SUBROUTINE cloudth_v6(ngrid,klev,ind2, & 1284 & ztv,po,zqta,fraca, & 1285 & qcloud,ctot_surf,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 1286 & ratqs,zqs,T) 1287 1288 1289 USE ioipsl_getin_p_mod, ONLY : getin_p 1290 USE phys_output_var_mod, ONLY : cloudth_sth,cloudth_senv, & 1291 & cloudth_sigmath,cloudth_sigmaenv 1292 1293 IMPLICIT NONE 1294 1295 #include "YOMCST.h" 1296 #include "YOETHF.h" 1297 #include "FCTTRE.h" 1298 #include "thermcell.h" 1299 #include "nuage.h" 1300 1301 1302 !Domain variables 1303 INTEGER ngrid !indice Max lat-lon 1304 INTEGER klev !indice Max alt 1305 INTEGER ind1 !indice in [1:ngrid] 1306 INTEGER ind2 !indice in [1:klev] 1307 !thermal plume fraction 1308 REAL fraca(ngrid,klev+1) !thermal plumes fraction in the gridbox 1309 !temperatures 1310 REAL T(ngrid,klev) !temperature 1311 REAL zpspsk(ngrid,klev) !factor (p/p0)**kappa (used for potential variables) 1312 REAL ztv(ngrid,klev) !potential temperature (voir thermcell_env.F90) 1313 REAL ztla(ngrid,klev) !liquid temperature in the thermals (Tl_th) 1314 REAL zthl(ngrid,klev) !liquid temperature in the environment (Tl_env) 1315 !pressure 1316 REAL paprs(ngrid,klev+1) !pressure at the interface of levels 1317 REAL pplay(ngrid,klev) !pressure at the middle of the level 1318 !humidity 1319 REAL ratqs(ngrid,klev) !width of the total water subgrid-scale distribution 1320 REAL po(ngrid) !total water (qt) 1321 REAL zqenv(ngrid) !total water in the environment (qt_env) 1322 REAL zqta(ngrid,klev) !total water in the thermals (qt_th) 1323 REAL zqsatth(ngrid,klev) !water saturation level in the thermals (q_sat_th) 1324 REAL zqsatenv(ngrid,klev) !water saturation level in the environment (q_sat_env) 1325 REAL qlth(ngrid,klev) !condensed water in the thermals 1326 REAL qlenv(ngrid,klev) !condensed water in the environment 1327 REAL qltot(ngrid,klev) !condensed water in the gridbox 1328 !cloud fractions 1329 REAL cth_vol(ngrid,klev) !cloud fraction by volume in the thermals 1330 REAL cenv_vol(ngrid,klev) !cloud fraction by volume in the environment 1331 REAL ctot_vol(ngrid,klev) !cloud fraction by volume in the gridbox 1332 REAL cth_surf(ngrid,klev) !cloud fraction by surface in the thermals 1333 REAL cenv_surf(ngrid,klev) !cloud fraction by surface in the environment 1334 REAL ctot_surf(ngrid,klev) !cloud fraction by surface in the gridbox 1335 !PDF of saturation deficit variables 1336 REAL rdd,cppd,Lv 1337 REAL Tbef,zdelta,qsatbef,zcor 1338 REAL alth,alenv,ath,aenv 1339 REAL sth,senv !saturation deficits in the thermals and environment 1340 REAL sigma_env,sigma_th !standard deviations of the biGaussian PDF 1341 !cloud fraction variables 1342 REAL xth,xenv 1343 REAL inverse_rho,beta !Neggers et al. (2011) method 1344 REAL a_Brooks,b_Brooks,A_Maj_Brooks,Dx_Brooks,f_Brooks !Brooks et al. (2005) method 1345 !Incloud total water variables 1346 REAL zqs(ngrid) !q_sat 1347 REAL qcloud(ngrid) !eau totale dans le nuage 1348 !Some arithmetic variables 1349 REAL erf,pi,sqrt2,sqrt2pi 1350 !Depth of the layer 1351 REAL dz(ngrid,klev) !epaisseur de la couche en metre 1352 REAL rhodz(ngrid,klev) 1353 REAL zrho(ngrid,klev) 1354 DO ind1 = 1, ngrid 1355 rhodz(ind1,ind2) = (paprs(ind1,ind2)-paprs(ind1,ind2+1))/rg ![kg/m2] 1356 zrho(ind1,ind2) = pplay(ind1,ind2)/T(ind1,ind2)/rd ![kg/m3] 1357 dz(ind1,ind2) = rhodz(ind1,ind2)/zrho(ind1,ind2) ![m] 1358 END DO 1359 1360 !------------------------------------------------------------------------------ 1361 ! Initialization 1362 !------------------------------------------------------------------------------ 1363 qlth(:,:)=0. 1364 qlenv(:,:)=0. 1365 qltot(:,:)=0. 1366 cth_vol(:,:)=0. 1367 cenv_vol(:,:)=0. 1368 ctot_vol(:,:)=0. 1369 cth_surf(:,:)=0. 1370 cenv_surf(:,:)=0. 1371 ctot_surf(:,:)=0. 1372 qcloud(:)=0. 1373 rdd=287.04 1374 cppd=1005.7 1375 pi=3.14159 1376 Lv=2.5e6 1377 sqrt2=sqrt(2.) 1378 sqrt2pi=sqrt(2.*pi) 1379 1380 1381 DO ind1=1,ngrid 1382 !------------------------------------------------------------------------------- 1383 !Both thermal and environment in the gridbox 1384 !------------------------------------------------------------------------------- 1385 IF ((ztv(ind1,1).gt.ztv(ind1,2)).and.(fraca(ind1,ind2).gt.1.e-10)) THEN 1386 !-------------------------------------------- 1387 !calcul de qsat_env 1388 !-------------------------------------------- 1389 Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2) 1390 zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) 1391 qsatbef= R2ES*FOEEW(Tbef,zdelta)/paprs(ind1,ind2) 1392 qsatbef=MIN(0.5,qsatbef) 1393 zcor=1./(1.-retv*qsatbef) 1394 qsatbef=qsatbef*zcor 1395 zqsatenv(ind1,ind2)=qsatbef 1396 !-------------------------------------------- 1397 !calcul de s_env 1398 !-------------------------------------------- 1399 alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) !qsl, p84 these Arnaud Jam 1400 aenv=1./(1.+(alenv*Lv/cppd)) !al, p84 these Arnaud Jam 1401 senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) !s, p84 these Arnaud Jam 1402 !-------------------------------------------- 1403 !calcul de qsat_th 1404 !-------------------------------------------- 1405 Tbef=ztla(ind1,ind2)*zpspsk(ind1,ind2) 1406 zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) 1407 qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2) 1408 qsatbef=MIN(0.5,qsatbef) 1409 zcor=1./(1.-retv*qsatbef) 1410 qsatbef=qsatbef*zcor 1411 zqsatth(ind1,ind2)=qsatbef 1412 !-------------------------------------------- 1413 !calcul de s_th 1414 !-------------------------------------------- 1415 alth=(0.622*Lv*zqsatth(ind1,ind2))/(rdd*ztla(ind1,ind2)**2) !qsl, p84 these Arnaud Jam 1416 ath=1./(1.+(alth*Lv/cppd)) !al, p84 these Arnaud Jam 1417 sth=ath*(zqta(ind1,ind2)-zqsatth(ind1,ind2)) !s, p84 these Arnaud Jam 1418 !-------------------------------------------- 1419 !calcul standard deviations bi-Gaussian PDF 1420 !-------------------------------------------- 1421 sigma_th=(0.03218+0.000092655*dz(ind1,ind2))/((fraca(ind1,ind2)+0.01)**0.5)*(((sth-senv)**2)**0.5)+0.002*zqta(ind1,ind2) 1422 sigma_env=(0.71794+0.000498239*dz(ind1,ind2))*(fraca(ind1,ind2)**0.5)/(1-fraca(ind1,ind2))*(((sth-senv)**2)**0.5)+ratqs(ind1,ind2)*po(ind1) 1423 xth=sth/(sqrt2*sigma_th) 1424 xenv=senv/(sqrt2*sigma_env) 1425 !-------------------------------------------- 1426 !Cloud fraction by volume CF_vol 1427 !-------------------------------------------- 1428 cth_vol(ind1,ind2)=0.5*(1.+1.*erf(xth)) 1429 cenv_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 1430 ctot_vol(ind1,ind2)=fraca(ind1,ind2)*cth_vol(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*cenv_vol(ind1,ind2) 1431 !-------------------------------------------- 1432 !Condensed water qc 1433 !-------------------------------------------- 1434 qlth(ind1,ind2)=sigma_th*((exp(-1.*xth**2)/sqrt2pi)+xth*sqrt2*cth_vol(ind1,ind2)) 1435 qlenv(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*cenv_vol(ind1,ind2)) 1436 qltot(ind1,ind2)=fraca(ind1,ind2)*qlth(ind1,ind2)+(1.-1.*fraca(ind1,ind2))*qlenv(ind1,ind2) 1437 !-------------------------------------------- 1438 !Cloud fraction by surface CF_surf 1439 !-------------------------------------------- 1440 !Method Neggers et al. (2011) : ok for cumulus clouds only 1441 !beta=0.0044 (Jouhaud et al.2018) 1442 !inverse_rho=1.+beta*dz(ind1,ind2) 1443 !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho 1444 !Method Brooks et al. (2005) : ok for all types of clouds 1445 a_Brooks=0.6694 1446 b_Brooks=0.1882 1447 A_Maj_Brooks=0.1635 !-- sans dependence au cisaillement de vent 1448 Dx_Brooks=200000. !-- si l'on considere des mailles de 200km de cote 1449 f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks)) 1450 ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.)) 1451 !-------------------------------------------- 1452 !Incloud Condensed water qcloud 1453 !-------------------------------------------- 1454 if (ctot_surf(ind1,ind2) .lt. 1.e-10) then 1455 ctot_vol(ind1,ind2)=0. 1456 ctot_surf(ind1,ind2)=0. 1457 qcloud(ind1)=zqsatenv(ind1,ind2) 1458 else 1459 qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqs(ind1) 1460 endif 1461 1462 1463 1464 !------------------------------------------------------------------------------- 1465 !Environment only in the gridbox 1466 !------------------------------------------------------------------------------- 1467 ELSE 1468 !-------------------------------------------- 1469 !calcul de qsat_env 1470 !-------------------------------------------- 1471 Tbef=zthl(ind1,ind2)*zpspsk(ind1,ind2) 1472 zdelta=MAX(0.,SIGN(1.,RTT-Tbef)) 1473 qsatbef= R2ES * FOEEW(Tbef,zdelta)/paprs(ind1,ind2) 1474 qsatbef=MIN(0.5,qsatbef) 1475 zcor=1./(1.-retv*qsatbef) 1476 qsatbef=qsatbef*zcor 1477 zqsatenv(ind1,ind2)=qsatbef 1478 !-------------------------------------------- 1479 !calcul de s_env 1480 !-------------------------------------------- 1481 alenv=(0.622*Lv*zqsatenv(ind1,ind2))/(rdd*zthl(ind1,ind2)**2) !qsl, p84 these Arnaud Jam 1482 aenv=1./(1.+(alenv*Lv/cppd)) !al, p84 these Arnaud Jam 1483 senv=aenv*(po(ind1)-zqsatenv(ind1,ind2)) !s, p84 these Arnaud Jam 1484 !-------------------------------------------- 1485 !calcul standard deviations Gaussian PDF 1486 !-------------------------------------------- 1487 zqenv(ind1)=po(ind1) 1488 sigma_env=ratqs(ind1,ind2)*zqenv(ind1) 1489 xenv=senv/(sqrt2*sigma_env) 1490 !-------------------------------------------- 1491 !Cloud fraction by volume CF_vol 1492 !-------------------------------------------- 1493 ctot_vol(ind1,ind2)=0.5*(1.+1.*erf(xenv)) 1494 !-------------------------------------------- 1495 !Condensed water qc 1496 !-------------------------------------------- 1497 qltot(ind1,ind2)=sigma_env*((exp(-1.*xenv**2)/sqrt2pi)+xenv*sqrt2*ctot_vol(ind1,ind2)) 1498 !-------------------------------------------- 1499 !Cloud fraction by surface CF_surf 1500 !-------------------------------------------- 1501 !Method Neggers et al. (2011) : ok for cumulus clouds only 1502 !beta=0.0044 (Jouhaud et al.2018) 1503 !inverse_rho=1.+beta*dz(ind1,ind2) 1504 !ctot_surf(ind1,ind2)=ctot_vol(ind1,ind2)*inverse_rho 1505 !Method Brooks et al. (2005) : ok for all types of clouds 1506 a_Brooks=0.6694 1507 b_Brooks=0.1882 1508 A_Maj_Brooks=0.1635 !-- sans dependence au shear 1509 Dx_Brooks=200000. 1510 f_Brooks=A_Maj_Brooks*(dz(ind1,ind2)**(a_Brooks))*(Dx_Brooks**(-b_Brooks)) 1511 ctot_surf(ind1,ind2)=1./(1.+exp(-1.*f_Brooks)*((1./max(1.e-15,min(ctot_vol(ind1,ind2),1.)))- 1.)) 1512 !-------------------------------------------- 1513 !Incloud Condensed water qcloud 1514 !-------------------------------------------- 1515 if (ctot_surf(ind1,ind2) .lt. 1.e-8) then 1516 ctot_vol(ind1,ind2)=0. 1517 ctot_surf(ind1,ind2)=0. 1518 qcloud(ind1)=zqsatenv(ind1,ind2) 1519 else 1520 qcloud(ind1)=qltot(ind1,ind2)/ctot_vol(ind1,ind2)+zqsatenv(ind1,ind2) 1521 endif 1522 1523 1524 END IF ! From the separation (thermal/envrionnement) et (environnement only) 1525 1526 ! Outputs used to check the PDFs 1527 cloudth_senv(ind1,ind2) = senv 1528 cloudth_sth(ind1,ind2) = sth 1529 cloudth_sigmaenv(ind1,ind2) = sigma_env 1530 cloudth_sigmath(ind1,ind2) = sigma_th 1531 1532 END DO ! From the loop on ngrid 1533 return 1534 1535 END SUBROUTINE cloudth_v6 1191 1536 END MODULE cloudth_mod 1537 1538 1539 1540 -
LMDZ6/branches/Ocean_skin/libf/phylmd/coef_diff_turb_mod.F90
r3102 r3605 65 65 66 66 67 ykmm = 0 !ym missing init 68 ykmn = 0 !ym missing init 69 ykmq = 0 !ym missing init 70 71 67 72 !**************************************************************************************** 68 73 ! Calcul de coefficients de diffusion turbulent de l'atmosphere : … … 177 182 ycoefh(1:knon,2:klev)=ykmn(1:knon,2:klev) 178 183 184 ELSE 185 ! No TKE for Standard Physics 186 yq2=0. 179 187 ENDIF !(iflag_pbl.ge.3) 180 188 -
LMDZ6/branches/Ocean_skin/libf/phylmd/concvl.F90
r3197 r3605 13 13 !RomP >>> 14 14 !! . da,phi,mp,dd_t,dd_q,lalim_conv,wght_th) 15 da, phi, mp, phii, d1a, dam, sij, clw, elij, &! RomP15 da, phi, mp, phii, d1a, dam, sij, qta, clw, elij, &! RomP 16 16 dd_t, dd_q, lalim_conv, wght_th, & ! RomP 17 17 evap, ep, epmlmMm, eplaMm, & ! RomP 18 wdtrainA, wdtrain M, wght, qtc, sigt, &18 wdtrainA, wdtrainS, wdtrainM, wght, qtc, sigt, & 19 19 tau_cld_cv, coefw_cld_cv, & ! RomP+RL, AJ 20 20 !RomP <<< … … 80 80 ! eplaMm-----output-R 81 81 ! wdtrainA---output-R 82 ! wdtrainS---output-R 82 83 ! wdtrainM---output-R 83 84 ! wght-------output-R … … 134 135 REAL, DIMENSION(klon,klev), INTENT(OUT) :: d1a, dam 135 136 REAL, DIMENSION(klon,klev,klev),INTENT(OUT) :: sij, elij 137 REAL, DIMENSION(klon,klev), INTENT(OUT) :: qta 136 138 REAL, DIMENSION(klon,klev), INTENT(OUT) :: clw 137 139 REAL, DIMENSION(klon,klev), INTENT(OUT) :: dd_t, dd_q … … 139 141 REAL, DIMENSION(klon,klev), INTENT(OUT) :: eplaMm 140 142 REAL, DIMENSION(klon,klev,klev), INTENT(OUT) :: epmlmMm 141 REAL, DIMENSION(klon,klev), INTENT(OUT) :: wdtrainA, wdtrain M143 REAL, DIMENSION(klon,klev), INTENT(OUT) :: wdtrainA, wdtrainS, wdtrainM 142 144 ! RomP <<< 143 145 REAL, DIMENSION(klon,klev), INTENT(OUT) :: wght !RL … … 437 439 !! evap,ep,epmlmMm,eplaMm, ! RomP 438 440 da, phi, mp, phii, d1a, dam, sij, wght, & ! RomP+RL 439 clw, elij, evap, ep, epmlmMm, eplaMm, &! RomP+RL440 wdtrainA, wdtrain M, qtc, sigt, &441 qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP+RL 442 wdtrainA, wdtrainS, wdtrainM, qtc, sigt, & 441 443 tau_cld_cv, coefw_cld_cv, & ! RomP,AJ 442 444 !AC!+!RomP+jyg -
LMDZ6/branches/Ocean_skin/libf/phylmd/conf_phys_m.F90
r3432 r3605 17 17 iflag_cld_th, & 18 18 iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & 19 ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple, &19 ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, aerosol_couple, chemistry_couple, & 20 20 flag_aerosol, flag_aerosol_strat, flag_aer_feedback, new_aod, & 21 21 flag_bc_internal_mixture, bl95_b0, bl95_b1,& … … 26 26 USE surface_data 27 27 USE phys_cal_mod 28 USE carbon_cycle_mod, ONLY: carbon_cycle_tr, carbon_cycle_cpl, level_coupling_esm28 USE carbon_cycle_mod, ONLY: carbon_cycle_tr, carbon_cycle_cpl, carbon_cycle_rad, level_coupling_esm 29 29 USE mod_grid_phy_lmdz, ONLY: klon_glo 30 30 USE print_control_mod, ONLY: lunout 31 31 use config_ocean_skin_m, only: config_ocean_skin 32 USE phys_state_var_mod, ONLY: phys_tstep 32 33 33 34 INCLUDE "conema3.h" … … 63 64 ! flag_bc_internal_mixture : use BC internal mixture if true 64 65 ! bl95_b*: parameters in the formula to link CDNC to aerosol mass conc 66 ! ok_volcan: activate volcanic diags (SW heat & LW cool rate, SW & LW flux) 65 67 ! 66 68 … … 71 73 LOGICAL :: ok_LES 72 74 LOGICAL :: callstats 73 LOGICAL :: ok_ade, ok_aie, ok_alw, ok_cdnc 75 LOGICAL :: ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan 74 76 LOGICAL :: aerosol_couple, chemistry_couple 75 77 INTEGER :: flag_aerosol … … 93 95 LOGICAL, SAVE :: ok_LES_omp 94 96 LOGICAL, SAVE :: callstats_omp 95 LOGICAL, SAVE :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp 97 LOGICAL, SAVE :: ok_ade_omp, ok_aie_omp, ok_alw_omp, ok_cdnc_omp, ok_volcan_omp 96 98 LOGICAL, SAVE :: aerosol_couple_omp, chemistry_couple_omp 97 99 INTEGER, SAVE :: flag_aerosol_omp … … 151 153 152 154 REAL,SAVE :: R_ecc_omp,R_peri_omp,R_incl_omp,solaire_omp 153 REAL :: solaire_omp_init155 REAL,SAVE :: solaire_omp_init 154 156 LOGICAL,SAVE :: ok_suntime_rrtm_omp 155 157 REAL,SAVE :: co2_ppm_omp, RCO2_omp, co2_ppm_per_omp, RCO2_per_omp … … 231 233 LOGICAL, SAVE :: carbon_cycle_tr_omp 232 234 LOGICAL, SAVE :: carbon_cycle_cpl_omp 235 LOGICAL, SAVE :: carbon_cycle_rad_omp 233 236 INTEGER, SAVE :: level_coupling_esm_omp 234 237 LOGICAL, SAVE :: adjust_tropopause_omp … … 395 398 ok_cdnc_omp = .FALSE. 396 399 CALL getin('ok_cdnc', ok_cdnc_omp) 400 401 ! 402 !Config Key = ok_volcan 403 !Config Desc = ok to generate volcanic diags 404 !Config Def = .FALSE. 405 !Config Help = Used in radlwsw_m.F 406 ! 407 ok_volcan_omp = .FALSE. 408 CALL getin('ok_volcan', ok_volcan_omp) 409 397 410 ! 398 411 !Config Key = aerosol_couple … … 595 608 ! RCO2 = 5.286789092164308E-04 596 609 !ancienne valeur 597 RCO2_omp = co2_ppm_omp * 1.0e-06 * 44.011/28.97! pour co2_ppm=348.610 RCO2_omp = co2_ppm_omp * 1.0e-06 * RMCO2 / RMD ! pour co2_ppm=348. 598 611 599 612 ! CALL getin('RCO2', RCO2) … … 615 628 CALL getin('CH4_ppb', zzz) 616 629 CH4_ppb_omp = zzz 617 RCH4_omp = CH4_ppb_omp * 1.0E-09 * 16.043/28.97630 RCH4_omp = CH4_ppb_omp * 1.0E-09 * RMCH4 / RMD 618 631 ! 619 632 !Config Key = RN2O … … 633 646 CALL getin('N2O_ppb', zzz) 634 647 N2O_ppb_omp = zzz 635 RN2O_omp = N2O_ppb_omp * 1.0E-09 * 44.013/28.97648 RN2O_omp = N2O_ppb_omp * 1.0E-09 * RMN2O / RMD 636 649 ! 637 650 !Config Key = RCFC11 … … 645 658 CALL getin('CFC11_ppt',zzz) 646 659 CFC11_ppt_omp = zzz 647 RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * 137.3686/28.97660 RCFC11_omp=CFC11_ppt_omp* 1.0E-12 * RMCFC11 / RMD 648 661 ! RCFC11 = 1.327690990680013E-09 649 662 !OK CALL getin('RCFC11', RCFC11) … … 659 672 CALL getin('CFC12_ppt',zzz) 660 673 CFC12_ppt_omp = zzz 661 RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * 120.9140/28.97674 RCFC12_omp = CFC12_ppt_omp * 1.0E-12 * RMCFC12 / RMD 662 675 ! RCFC12 = 2.020102726958923E-09 663 676 !OK CALL getin('RCFC12', RCFC12) … … 679 692 !Config Help = 680 693 ! 681 RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * 44.011/28.97694 RCO2_per_omp = co2_ppm_per_omp * 1.0e-06 * RMCO2 / RMD 682 695 683 696 !Config Key = ok_4xCO2atm … … 694 707 CALL getin('CH4_ppb_per', zzz) 695 708 CH4_ppb_per_omp = zzz 696 RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * 16.043/28.97709 RCH4_per_omp = CH4_ppb_per_omp * 1.0E-09 * RMCH4 / RMD 697 710 ! 698 711 !Config Key = RN2O_per … … 704 717 CALL getin('N2O_ppb_per', zzz) 705 718 N2O_ppb_per_omp = zzz 706 RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * 44.013/28.97719 RN2O_per_omp = N2O_ppb_per_omp * 1.0E-09 * RMN2O / RMD 707 720 ! 708 721 !Config Key = RCFC11_per … … 714 727 CALL getin('CFC11_ppt_per',zzz) 715 728 CFC11_ppt_per_omp = zzz 716 RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * 137.3686/28.97729 RCFC11_per_omp=CFC11_ppt_per_omp* 1.0E-12 * RMCFC11 / RMD 717 730 ! 718 731 !Config Key = RCFC12_per … … 724 737 CALL getin('CFC12_ppt_per',zzz) 725 738 CFC12_ppt_per_omp = zzz 726 RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * 120.9140/28.97739 RCFC12_per_omp = CFC12_ppt_per_omp * 1.0E-12 * RMCFC12 / RMD 727 740 !ajout CFMIP end 728 741 … … 1031 1044 ! - 1 = stratospheric aerosols scaled from 550 nm AOD 1032 1045 ! - 2 = stratospheric aerosol properties from CMIP6 1033 !Option 2 is only available with RRTM, this is tested later on 1046 !Option 2 is only available with RRTM, this is tested later on 1034 1047 !Config Def = 0 1035 1048 !Config Help = Used in physiq.F … … 1724 1737 !Config Desc = freq_calNMC(2) = frequence de calcul fichiers histdayNMC 1725 1738 !Config Desc = freq_calNMC(3) = frequence de calcul fichiers histhfNMC 1726 !Config Def = p asphys1727 !Config Help = 1728 ! 1729 freq_calNMC_omp(1) = p asphys1730 freq_calNMC_omp(2) = p asphys1731 freq_calNMC_omp(3) = p asphys1739 !Config Def = phys_tstep 1740 !Config Help = 1741 ! 1742 freq_calNMC_omp(1) = phys_tstep 1743 freq_calNMC_omp(2) = phys_tstep 1744 freq_calNMC_omp(3) = phys_tstep 1732 1745 CALL getin('freq_calNMC',freq_calNMC_omp) 1733 1746 ! … … 2156 2169 carbon_cycle_cpl_omp=.FALSE. 2157 2170 CALL getin('carbon_cycle_cpl',carbon_cycle_cpl_omp) 2171 2172 carbon_cycle_rad_omp=.FALSE. 2173 CALL getin('carbon_cycle_rad',carbon_cycle_rad_omp) 2158 2174 2159 2175 ! >> PC … … 2306 2322 ok_alw = ok_alw_omp 2307 2323 ok_cdnc = ok_cdnc_omp 2324 ok_volcan = ok_volcan_omp 2308 2325 aerosol_couple = aerosol_couple_omp 2309 2326 chemistry_couple = chemistry_couple_omp … … 2428 2445 carbon_cycle_tr = carbon_cycle_tr_omp 2429 2446 carbon_cycle_cpl = carbon_cycle_cpl_omp 2447 carbon_cycle_rad = carbon_cycle_rad_omp 2430 2448 level_coupling_esm = level_coupling_esm_omp 2431 2449 … … 2529 2547 IF (flag_bc_internal_mixture .AND. flag_aerosol.NE.6) THEN 2530 2548 CALL abort_physic('conf_phys', 'flag_bc_internal_mixture can only be activated with flag_aerosol=6',1) 2549 ENDIF 2550 2551 ! Test on carbon cycle 2552 IF (carbon_cycle_tr .AND. .NOT. carbon_cycle_cpl) THEN 2553 CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_tr is on',1) 2554 ENDIF 2555 IF (carbon_cycle_rad .AND. .NOT. carbon_cycle_cpl) THEN 2556 CALL abort_physic('conf_phys', 'carbon_cycle_cpl has to be TRUE if carbon_cycle_rad is on',1) 2531 2557 ENDIF 2532 2558 … … 2643 2669 WRITE(lunout,*) ' pmagic = ',pmagic 2644 2670 WRITE(lunout,*) ' ok_ade = ',ok_ade 2671 WRITE(lunout,*) ' ok_volcan = ',ok_volcan 2645 2672 WRITE(lunout,*) ' ok_aie = ',ok_aie 2646 2673 WRITE(lunout,*) ' ok_alw = ',ok_alw … … 2742 2769 WRITE(lunout,*) ' carbon_cycle_tr = ', carbon_cycle_tr 2743 2770 WRITE(lunout,*) ' carbon_cycle_cpl = ', carbon_cycle_cpl 2771 WRITE(lunout,*) ' carbon_cycle_rad = ', carbon_cycle_rad 2744 2772 WRITE(lunout,*) ' level_coupling_esm = ', level_coupling_esm 2745 2773 -
LMDZ6/branches/Ocean_skin/libf/phylmd/cosp/phys_cosp.F90
r3403 r3605 354 354 !$OMP END MASTER 355 355 !$OMP BARRIER 356 debut_cosp=.false.357 356 endif ! debut_cosp 358 357 ! else … … 366 365 ! call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) 367 366 !#else 368 367 if (.NOT. debut_cosp) call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) 369 368 !#endif 370 369 !! … … 374 373 375 374 ! print *, 'Calling write output' 376 375 if (.NOT. debut_cosp) call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, & 377 376 cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, & 378 377 isccp, misr, modis) … … 400 399 ! call system_clock(t1,count_rate,count_max) 401 400 ! print *,(t1-t0)*1.0/count_rate 401 if (debut_cosp) then 402 debut_cosp=.false. 403 endif 402 404 403 405 CONTAINS -
LMDZ6/branches/Ocean_skin/libf/phylmd/cosp2/cosp_output_mod.F90
r3369 r3605 359 359 WRITE(lunout,*) 'wxios_add_vaxis cth16 numMISRHgtBins, misr_histHgtCenters ', & 360 360 numMISRHgtBins, misr_histHgtCenters 361 CALL wxios_add_vaxis("cth ", numMISRHgtBins, misr_histHgtCenters)361 CALL wxios_add_vaxis("cth16", numMISRHgtBins, misr_histHgtCenters) 362 362 363 363 WRITE(lunout,*) 'wxios_add_vaxis dbze DBZE_BINS, dbze_ax ', & -
LMDZ6/branches/Ocean_skin/libf/phylmd/cpl_mod.F90
r3102 r3605 97 97 !$OMP THREADPRIVATE(cpl_atm_co22D) 98 98 99 !!!!!!!!!! variable for calving 100 INTEGER, PARAMETER :: nb_zone_calving = 3 101 REAL,ALLOCATABLE, DIMENSION(:,:,:),SAVE :: area_calving 102 !$OMP THREADPRIVATE(area_calving) 103 REAL,ALLOCATABLE, DIMENSION(:,:),SAVE :: cell_area2D 104 !$OMP THREADPRIVATE(cell_area2D) 105 INTEGER, SAVE :: ind_calving(nb_zone_calving) 106 !$OMP THREADPRIVATE(ind_calving) 107 108 LOGICAL,SAVE :: cpl_old_calving 109 !$OMP THREADPRIVATE(cpl_old_calving) 110 99 111 CONTAINS 100 112 ! … … 105 117 USE surface_data 106 118 USE indice_sol_mod 107 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 119 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid1dTo2d_glo, klon_glo, grid_type, unstructured, regular_lonlat 108 120 USE time_phylmdz_mod, ONLY: annee_ref, day_ini, itau_phy, itaufin_phy 109 121 USE print_control_mod, ONLY: lunout 122 USE geometry_mod, ONLY : longitude_deg, latitude_deg, ind_cell_glo, cell_area 123 USE ioipsl_getin_p_mod, ONLY: getin_p 110 124 111 125 ! Input arguments … … 127 141 CHARACTER(len = 80) :: abort_message 128 142 CHARACTER(len=80) :: clintocplnam, clfromcplnam 143 REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi, cell_area_mpi 144 INTEGER, DIMENSION(klon_mpi) :: ind_cell_glo_mpi 145 REAL, DIMENSION(nbp_lon,jj_nb) :: lon2D, lat2D 146 INTEGER :: mask_calving(nbp_lon,jj_nb,nb_zone_calving) 147 REAL :: pos 148 149 !*************************************** 150 ! Use old calving or not (default new calving method) 151 ! New calving method should be used with DYNAMICO and when using new coupling 152 ! weights. 153 cpl_old_calving=.FALSE. 154 CALL getin_p("cpl_old_calving",cpl_old_calving) 155 129 156 130 157 !************************************************************************************* … … 204 231 205 232 ! Allocate variable in carbon_cycle_mod 206 ALLOCATE(fco2_ocn_day(klon), stat = error)233 IF (.NOT.ALLOCATED(fco2_ocn_day)) ALLOCATE(fco2_ocn_day(klon), stat = error) 207 234 sum_error = sum_error + error 208 END IF 209 235 ENDIF 236 237 ! calving initialization 238 ALLOCATE(area_calving(nbp_lon, jj_nb, nb_zone_calving), stat = error) 239 sum_error = sum_error + error 240 ALLOCATE(cell_area2D(nbp_lon, jj_nb), stat = error) 241 sum_error = sum_error + error 242 243 244 CALL gather_omp(longitude_deg,rlon_mpi) 245 CALL gather_omp(latitude_deg,rlat_mpi) 246 CALL gather_omp(ind_cell_glo,ind_cell_glo_mpi) 247 CALL gather_omp(cell_area,cell_area_mpi) 248 249 IF (is_omp_master) THEN 250 CALL Grid1DTo2D_mpi(rlon_mpi,lon2D) 251 CALL Grid1DTo2D_mpi(rlat_mpi,lat2D) 252 CALL Grid1DTo2D_mpi(cell_area_mpi,cell_area2D) 253 mask_calving(:,:,:) = 0 254 WHERE ( lat2D >= 40) mask_calving(:,:,1) = 1 255 WHERE ( lat2D < 40 .AND. lat2D > -50) mask_calving(:,:,2) = 1 256 WHERE ( lat2D <= -50) mask_calving(:,:,3) = 1 257 258 259 DO i=1,nb_zone_calving 260 area_calving(:,:,i)=mask_calving(:,:,i)*cell_area2D(:,:) 261 pos=1 262 IF (i>1) pos = 1 + ((nbp_lon*nbp_lat-1)*(i-1))/(nb_zone_calving-1) 263 264 ind_calving(i)=0 265 IF (grid_type==unstructured) THEN 266 267 DO ig=1,klon_mpi 268 IF (ind_cell_glo_mpi(ig)==pos) ind_calving(i)=ig 269 ENDDO 270 271 ELSE IF (grid_type==regular_lonlat) THEN 272 IF ((ij_begin<=pos .AND. ij_end>=pos) .OR. (ij_begin<=pos .AND. is_south_pole_dyn )) THEN 273 ind_calving(i)=pos-(jj_begin-1)*nbp_lon 274 ENDIF 275 ENDIF 276 277 ENDDO 278 ENDIF 279 280 210 281 IF (sum_error /= 0) THEN 211 282 abort_message='Pb allocation variables couplees' … … 236 307 idayref = day_ini 237 308 CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) 238 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)309 CALL grid1dTo2d_glo(rlon,zx_lon) 239 310 DO i = 1, nbp_lon 240 311 zx_lon(i,1) = rlon(i+1) 241 312 zx_lon(i,nbp_lat) = rlon(i+1) 242 313 ENDDO 243 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)314 CALL grid1dTo2d_glo(rlat,zx_lat) 244 315 clintocplnam="cpl_atm_tauflx" 245 316 CALL histbeg(clintocplnam,nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:),& … … 259 330 "-",nbp_lon,nbp_lat,nhoridct,1,1,1,-99,32,"inst",dtime,dtime) 260 331 ENDIF 261 END 332 ENDDO 262 333 CALL histend(nidct) 263 334 CALL histsync(nidct) … … 272 343 "-",nbp_lon,nbp_lat,nhoridcs,1,1,1,-99,32,"inst",dtime,dtime) 273 344 ENDIF 274 END 345 ENDDO 275 346 CALL histend(nidcs) 276 347 CALL histsync(nidcs) … … 286 357 abort_message='carbon_cycle_cpl does not work with opa8' 287 358 CALL abort_physic(modname,abort_message,1) 288 END 359 ENDIF 289 360 290 361 END SUBROUTINE cpl_init … … 356 427 CALL histwrite(nidcs,inforecv(i)%name,itau_w,tab_read_flds(:,:,i),nbp_lon*(nbp_lat),ndexcs) 357 428 ENDIF 358 END 429 ENDDO 359 430 ENDIF 360 431 … … 415 486 ENDDO 416 487 417 END 488 ENDIF ! if time to receive 418 489 419 490 END SUBROUTINE cpl_receive_frac … … 466 537 DO i=1,klon 467 538 index(i)=i 468 END 539 ENDDO 469 540 CALL cpl2gath(read_co2, fco2_ocn_day, klon, index) 470 END 541 ENDIF 471 542 472 543 !************************************************************************************* … … 477 548 DO i=1, knon 478 549 tsurf_new(i) = tsurf_new(i)/(1. - sic_new(i)) 479 END 550 ENDDO 480 551 481 552 END SUBROUTINE cpl_receive_ocean_fields … … 529 600 tsurf_new(i) = tsurf_new(i) / sic_new(i) 530 601 alb_new(i) = alb_new(i) / sic_new(i) 531 END 602 ENDDO 532 603 533 604 END SUBROUTINE cpl_receive_seaice_fields … … 637 708 cpl_atm_co2(ig,cpl_index) = cpl_atm_co2(ig,cpl_index) + & 638 709 co2_send(knindex(ig))/ REAL(nexca) 639 END IF 710 !!---OB: this is correct but why knindex ?? 711 ENDIF 640 712 ENDDO 641 713 … … 682 754 ALLOCATE(cpl_atm_co22D(nbp_lon,jj_nb), stat=error) 683 755 sum_error = sum_error + error 684 END 756 ENDIF 685 757 686 758 IF (sum_error /= 0) THEN … … 886 958 ALLOCATE(cpl_atm_co22D(nbp_lon,jj_nb), stat=error) 887 959 sum_error = sum_error + error 888 END 960 ENDIF 889 961 890 962 IF (sum_error /= 0) THEN … … 917 989 DO ig = 1, knon 918 990 cpl_fder_tmp(knindex(ig))=cpl_fder(ig,cpl_index) 919 END 991 ENDDO 920 992 CALL gath2cpl(cpl_fder_tmp(:), cpl_fder2D(:,:,cpl_index), & 921 993 klon, unity) … … 1085 1157 ! Local variables 1086 1158 !************************************************************************************* 1087 INTEGER :: error, sum_error, j1159 INTEGER :: error, sum_error, i,j,k 1088 1160 INTEGER :: itau_w 1089 1161 INTEGER :: time_sec … … 1102 1174 ! Table with all fields to send to coupler 1103 1175 REAL, DIMENSION(nbp_lon, jj_nb, maxsend) :: tab_flds 1104 REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi 1105 1176 REAL, DIMENSION(klon_mpi) :: rlon_mpi, rlat_mpi 1177 REAL :: calving(nb_zone_calving) 1178 REAL :: calving_glo(nb_zone_calving) 1179 1106 1180 #ifdef CPP_MPI 1107 1181 INCLUDE 'mpif.h' … … 1130 1204 1131 1205 IF (version_ocean=='nemo') THEN 1132 tab_flds(:,:,ids_liqrun) = cpl_rriv2D(:,:) + cpl_rcoa2D(:,:)1206 tab_flds(:,:,ids_liqrun) = (cpl_rriv2D(:,:) + cpl_rcoa2D(:,:)) 1133 1207 IF (carbon_cycle_cpl) tab_flds(:,:,ids_atmco2)=cpl_atm_co22D(:,:) 1134 1208 ELSE IF (version_ocean=='opa8') THEN … … 1139 1213 tab_flds(:,:,ids_runcoa) = cpl_rcoa2D(:,:) 1140 1214 tab_flds(:,:,ids_rivflu) = cpl_rriv2D(:,:) 1141 END 1215 ENDIF 1142 1216 1143 1217 !************************************************************************************* … … 1158 1232 IF (is_omp_root) THEN 1159 1233 1160 DO j = 1, jj_nb 1161 tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:nbp_lon,j), & 1162 pctsrf2D(1:nbp_lon,j,is_lic)) / REAL(nbp_lon) 1163 ENDDO 1164 1165 1166 IF (is_parallel) THEN 1167 IF (.NOT. is_north_pole_dyn) THEN 1234 IF (cpl_old_calving) THEN ! use old calving 1235 1236 DO j = 1, jj_nb 1237 tmp_calv(:,j) = DOT_PRODUCT (cpl_rlic2D(1:nbp_lon,j), & 1238 pctsrf2D(1:nbp_lon,j,is_lic)) / REAL(nbp_lon) 1239 ENDDO 1240 1241 1242 IF (is_parallel) THEN 1243 IF (.NOT. is_north_pole_dyn) THEN 1168 1244 #ifdef CPP_MPI 1169 CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error)1170 CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error)1245 CALL MPI_RECV(Up,1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,status,error) 1246 CALL MPI_SEND(tmp_calv(1,1),1,MPI_REAL_LMDZ,mpi_rank-1,1234,COMM_LMDZ_PHY,error) 1171 1247 #endif 1172 ENDIF1248 ENDIF 1173 1249 1174 IF (.NOT. is_south_pole_dyn) THEN1250 IF (.NOT. is_south_pole_dyn) THEN 1175 1251 #ifdef CPP_MPI 1176 CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error)1177 CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error)1252 CALL MPI_SEND(tmp_calv(1,jj_nb),1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,error) 1253 CALL MPI_RECV(down,1,MPI_REAL_LMDZ,mpi_rank+1,1234,COMM_LMDZ_PHY,status,error) 1178 1254 #endif 1179 ENDIF1255 ENDIF 1180 1256 1181 IF (.NOT. is_north_pole_dyn .AND. ii_begin /=1) THEN 1182 Up=Up+tmp_calv(nbp_lon,1) 1183 tmp_calv(:,1)=Up 1184 ENDIF 1257 IF (.NOT. is_north_pole_dyn .AND. ii_begin /=1) THEN 1258 Up=Up+tmp_calv(nbp_lon,1) 1259 tmp_calv(:,1)=Up 1260 ENDIF 1261 1262 IF (.NOT. is_south_pole_dyn .AND. ii_end /= nbp_lon) THEN 1263 Down=Down+tmp_calv(1,jj_nb) 1264 tmp_calv(:,jj_nb)=Down 1265 ENDIF 1266 ENDIF 1267 tab_flds(:,:,ids_calvin) = tmp_calv(:,:) 1268 1269 ELSE 1270 ! cpl_old_calving=FALSE 1271 ! To be used with new method for calculation of coupling weights 1272 DO k=1,nb_zone_calving 1273 calving(k)=0 1274 DO j = 1, jj_nb 1275 calving(k)= calving(k)+DOT_PRODUCT(cpl_rlic2D(:,j)*area_calving(:,j,k),pctsrf2D(:,j,is_lic)) 1276 ENDDO 1277 ENDDO 1185 1278 1186 IF (.NOT. is_south_pole_dyn .AND. ii_end /= nbp_lon) THEN 1187 Down=Down+tmp_calv(1,jj_nb) 1188 tmp_calv(:,jj_nb)=Down 1189 ENDIF 1279 #ifdef CPP_MPI 1280 CALL MPI_ALLREDUCE(calving, calving_glo, nb_zone_calving, MPI_REAL_LMDZ, MPI_SUM, COMM_LMDZ_PHY, error) 1281 #endif 1282 1283 tab_flds(:,:,ids_calvin) = 0 1284 DO k=1,nb_zone_calving 1285 IF (ind_calving(k)>0 ) THEN 1286 j=(ind_calving(k)-1)/nbp_lon + 1 1287 i=MOD(ind_calving(k)-1,nbp_lon)+1 1288 tab_flds(i,j,ids_calvin) = calving_glo(k) 1289 ENDIF 1290 ENDDO 1291 1190 1292 ENDIF 1191 1293 1192 tab_flds(:,:,ids_calvin) = tmp_calv(:,:)1193 1194 1294 !************************************************************************************* 1195 1295 ! Calculate total flux for snow, rain and wind with weighted addition using the … … 1252 1352 cpl_tauy2D(:,:,2) * pctsrf2D(:,:,is_sic) / deno(:,:) 1253 1353 ENDWHERE 1254 END 1354 ENDIF 1255 1355 1256 1356 ENDIF ! is_omp_root … … 1336 1436 DEALLOCATE(cpl_atm_co22D, stat=error ) 1337 1437 sum_error = sum_error + error 1338 END 1438 ENDIF 1339 1439 1340 1440 IF (sum_error /= 0) THEN -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv30_routines.F90
r2520 r3605 3050 3050 ! variables pour tracer dans precip de l'AA et des mel 3051 3051 ! local variables: 3052 INTEGER i, j, k 3052 INTEGER i, j, k, nam1 3053 3053 REAL epm(nloc, na, na) 3054 3054 3055 nam1=na-1 ! Introduced because ep is not defined for j=na 3055 3056 ! variables d'Emanuel : du second indice au troisieme 3056 3057 ! ---> tab(i,k,j) -> de l origine k a l arrivee j … … 3082 3083 ! fraction deau condensee dans les melanges convertie en precip : epm 3083 3084 ! et eau condensée précipitée dans masse d'air saturé : l_m*dM_m/dzdz.dzdz 3084 DO j = 1, na 3085 DO j = 1, nam1 3085 3086 DO k = 1, j - 1 3086 3087 DO i = 1, ncum … … 3095 3096 END DO 3096 3097 3097 DO j = 1, na 3098 DO k = 1, na 3098 DO j = 1, nam1 3099 DO k = 1, nam1 3099 3100 DO i = 1, ncum 3100 3101 IF (k>=icb(i) .AND. k<=inb(i)) THEN … … 3106 3107 END DO 3107 3108 3108 DO j = 1, na 3109 DO j = 1, nam1 3109 3110 DO k = 1, j - 1 3110 3111 DO i = 1, ncum … … 3117 3118 3118 3119 ! matrices pour calculer la tendance des concentrations dans cvltr.F90 3119 DO j = 1, na 3120 DO k = 1, na 3120 DO j = 1, nam1 3121 DO k = 1, nam1 3121 3122 DO i = 1, ncum 3122 3123 da(i, j) = da(i, j) + (1.-sij(i,k,j))*ment(i, k, j) … … 3127 3128 END DO 3128 3129 3129 DO j = 1, na 3130 DO j = 1, nam1 3130 3131 DO k = 1, j - 1 3131 3132 DO i = 1, ncum … … 3298 3299 integer i,k 3299 3300 real hp_bak(nloc,nd) 3301 CHARACTER (LEN=20) :: modname='cv30_epmax_fn_cape' 3302 CHARACTER (LEN=80) :: abort_message 3300 3303 3301 3304 ! on recalcule ep et hp … … 3346 3349 write(*,*) 'clw(i,k)=',clw(i,k) 3347 3350 write(*,*) 'cpd,cpv=',cpd,cpv 3348 stop3351 CALL abort_physic(modname,abort_message,0) 3349 3352 endif 3350 3353 enddo !do k=1,nl -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3_mixscale.F90
r1992 r3605 13 13 include "cv3param.h" 14 14 15 INTEGER nloc, ncum, na 15 !inputs: 16 INTEGER, INTENT (IN) :: ncum, na, nloc 17 REAL, DIMENSION (nloc, na), INTENT (IN) :: m 18 !input/outputs: 19 REAL, DIMENSION (nloc, na, na), INTENT (INOUT) :: ment 20 21 !local variables: 16 22 INTEGER i, j, il 17 REAL ment(nloc, na, na), m(nloc, na)18 23 19 DO j = 1, nl 20 DO i = 1, nl 21 DO il = 1, ncum 22 ment(il, i, j) = m(il, i)*ment(il, i, j) 24 DO j = 1, nl 25 DO i = 1, nl 26 DO il = 1, ncum 27 ment(il, i, j) = m(il, i)*ment(il, i, j) 28 END DO 23 29 END DO 24 30 END DO 25 END DO26 31 27 32 -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3_routines.F90
r3345 r3605 35 35 36 36 include "cv3param.h" 37 include "cvflag.h" 37 38 include "conema3.h" 38 39 … … 125 126 tlcrit=-55.0 126 127 CALL getin_p('tlcrit',tlcrit) 128 ejectliq=0. 129 CALL getin_p('ejectliq',ejectliq) 130 ejectice=0. 131 CALL getin_p('ejectice',ejectice) 132 cvflag_prec_eject = .FALSE. 133 CALL getin_p('cvflag_prec_eject',cvflag_prec_eject) 134 qsat_depends_on_qt = .FALSE. 135 CALL getin_p('qsat_depends_on_qt',qsat_depends_on_qt) 136 adiab_ascent_mass_flux_depends_on_ejectliq = .FALSE. 137 CALL getin_p('adiab_ascent_mass_flux_depends_on_ejectliq',adiab_ascent_mass_flux_depends_on_ejectliq) 138 keepbug_ice_frac = .TRUE. 139 CALL getin_p('keepbug_ice_frac', keepbug_ice_frac) 127 140 128 141 WRITE (*, *) 't_top_max=', t_top_max … … 144 157 WRITE (*, *) 'elcrit=', elcrit 145 158 WRITE (*, *) 'tlcrit=', tlcrit 159 WRITE (*, *) 'ejectliq=', ejectliq 160 WRITE (*, *) 'ejectice=', ejectice 161 WRITE (*, *) 'cvflag_prec_eject =', cvflag_prec_eject 162 WRITE (*, *) 'qsat_depends_on_qt =', qsat_depends_on_qt 163 WRITE (*, *) 'adiab_ascent_mass_flux_depends_on_ejectliq =', adiab_ascent_mass_flux_depends_on_ejectliq 164 WRITE (*, *) 'keepbug_ice_frac =', keepbug_ice_frac 165 146 166 first = .FALSE. 147 167 END IF ! (first) … … 170 190 171 191 include "cv3param.h" 192 include "cvflag.h" 172 193 173 194 !inputs: … … 236 257 ! debug lv(i,k)= lv0-clmcpv*(t(i,k)-t0) 237 258 lv(i, k) = lv0 - clmcpv*(t(i,k)-273.15) 238 lf(i, k) = lf0 - clmci*(t(i,k)-273.15) 259 !! lf(i, k) = lf0 - clmci*(t(i,k)-273.15) ! erreur de signe !! 260 lf(i, k) = lf0 + clmci*(t(i,k)-273.15) 239 261 cpn(i, k) = cpd*(1.0-q(i,k)) + cpv*q(i, k) 240 262 cpx(i, k) = cpd*(1.0-q(i,k)) + cl*q(i, k) … … 289 311 USE mod_phys_lmdz_transfert_para, ONLY : bcast 290 312 USE add_phys_tend_mod, ONLY: fl_cor_ebil 313 USE print_control_mod, ONLY: prt_level 291 314 IMPLICIT NONE 292 315 … … 516 539 END DO 517 540 ENDIF 541 IF (prt_level .GE. 10) THEN 542 print *,'cv3_feed : iflag(1), pfeed(1), plcl(1), wghti(1,k) ', & 543 iflag(1), pfeed(1), plcl(1), (wghti(1,k),k=1,10) 544 ENDIF 518 545 519 546 ! ------------------------------------------------------------------- … … 1105 1132 tnk, qnk, gznk, hnk, t, q, qs, gz, & 1106 1133 p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & 1107 inb, tp, tvp, clw, hp, ep, sigp, buoy, frac) 1134 inb, tp, tvp, clw, hp, ep, sigp, buoy, & 1135 frac_a, frac_s, qpreca, qta) 1108 1136 USE print_control_mod, ONLY: prt_level 1109 1137 IMPLICIT NONE … … 1153 1181 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: ep, sigp, hp 1154 1182 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: buoy 1155 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: frac 1183 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: frac_a, frac_s 1184 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qpreca 1185 REAL, DIMENSION (nloc, nd), INTENT (OUT) :: qta 1156 1186 1157 1187 !local variables: 1158 1188 INTEGER i, j, k 1159 REAL tg, qg, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit 1189 REAL smallestreal 1190 REAL tg, qg, dqgdT, ahg, alv, alf, s, tc, es, esi, denom, rg, tca, elacrit 1191 REAL :: phinu2p 1160 1192 REAL als 1161 REAL qsat_new, snew, qi(nloc, nd) 1162 REAL by, defrac, pden, tbis 1163 REAL ah0(nloc), cape(nloc), capem(nloc), byp(nloc) 1164 LOGICAL lcape(nloc) 1165 INTEGER iposit(nloc) 1166 REAL fracg 1167 REAL deltap 1193 REAL :: qsat_new, snew 1194 REAL, DIMENSION (nloc,nd) :: qi 1195 REAL, DIMENSION (nloc,nd) :: ha ! moist static energy of adiabatic ascents 1196 ! taking into account precip ejection 1197 REAL, DIMENSION (nloc,nd) :: hla ! liquid water static energy of adiabatic ascents 1198 ! taking into account precip ejection 1199 REAL, DIMENSION (nloc,nd) :: qcld ! specific cloud water 1200 REAL, DIMENSION (nloc,nd) :: qhsat ! specific humidity at saturation 1201 REAL, DIMENSION (nloc,nd) :: dqhsatdT ! dqhsat/dT 1202 REAL, DIMENSION (nloc,nd) :: frac ! ice fraction function of envt temperature 1203 REAL, DIMENSION (nloc,nd) :: qps ! specific solid precipitation 1204 REAL, DIMENSION (nloc,nd) :: qpl ! specific liquid precipitation 1205 REAL, DIMENSION (nloc) :: ah0, cape, capem, byp 1206 LOGICAL, DIMENSION (nloc) :: lcape 1207 INTEGER, DIMENSION (nloc) :: iposit 1208 REAL :: denomm1 1209 REAL :: by, defrac, pden, tbis 1210 REAL :: fracg 1211 REAL :: deltap 1212 REAL, SAVE :: Tx, Tm 1213 DATA Tx/263.15/, Tm/243.15/ 1214 !$OMP THREADPRIVATE(Tx, Tm) 1215 REAL :: aa, bb, dd, ddelta, discr 1216 REAL :: ff, fp 1217 REAL :: coefx, coefm, Zx, Zm, Ux, U, Um 1168 1218 1169 1219 IF (prt_level >= 10) THEN 1170 print *,'cv3_undilute2.0. t(1,k), q(1,k), qs(1,k) ', &1171 (k, t(1,k), q(1,k), qs(1,k), k = 1,nl)1220 print *,'cv3_undilute2.0. icvflag_Tpa, t(1,k), q(1,k), qs(1,k) ', & 1221 icvflag_Tpa, (k, t(1,k), q(1,k), qs(1,k), k = 1,nl) 1172 1222 ENDIF 1223 smallestreal=tiny(smallestreal) 1173 1224 1174 1225 ! ===================================================================== … … 1181 1232 END DO 1182 1233 END DO 1234 1183 1235 1184 1236 ! ===================================================================== … … 1197 1249 qnk(i)*(lv0-clmcpv*(tnk(i)-273.15)) + gznk(i) 1198 1250 END DO 1199 1251 ! 1252 ! Ice fraction 1253 ! 1254 IF (cvflag_ice) THEN 1255 DO k = minorig, nl 1256 DO i = 1, ncum 1257 frac(i, k) = (Tx - t(i,k))/(Tx - Tm) 1258 frac(i, k) = min(max(frac(i,k),0.0), 1.0) 1259 END DO 1260 END DO 1261 ! Below cloud base, set ice fraction to cloud base value 1262 DO k = 1, nl 1263 DO i = 1, ncum 1264 IF (k<icb(i)) THEN 1265 frac(i,k) = frac(i,icb(i)) 1266 END IF 1267 END DO 1268 END DO 1269 ELSE 1270 DO k = 1, nl 1271 DO i = 1, ncum 1272 frac(i,k) = 0. 1273 END DO 1274 END DO 1275 ENDIF ! (cvflag_ice) 1276 1277 1278 DO k = minorig, nl 1279 DO i = 1,ncum 1280 ha(i,k) = ah0(i) 1281 hla(i,k) = hnk(i) 1282 qta(i,k) = qnk(i) 1283 qpreca(i,k) = 0. 1284 frac_a(i,k) = 0. 1285 frac_s(i,k) = frac(i,k) 1286 qpl(i,k) = 0. 1287 qps(i,k) = 0. 1288 qhsat(i,k) = qs(i,k) 1289 qcld(i,k) = max(qta(i,k)-qhsat(i,k),0.) 1290 IF (k <= icb(i)+1) THEN 1291 qhsat(i,k) = qnk(i)-clw(i,k) 1292 qcld(i,k) = clw(i,k) 1293 ENDIF 1294 ENDDO 1295 ENDDO 1296 1297 !jyg< 1298 ! ===================================================================== 1299 ! --- SET THE THE FRACTION OF PRECIPITATION FALLING OUTSIDE OF CLOUD 1300 ! ===================================================================== 1301 DO k = 1, nl 1302 DO i = 1, ncum 1303 ep(i, k) = 0.0 1304 sigp(i, k) = spfac 1305 END DO 1306 END DO 1307 !>jyg 1308 ! 1200 1309 1201 1310 ! *** Find lifted parcel quantities above cloud base *** 1202 1311 1203 1312 !---------------------------------------------------------------------------- 1313 ! 1314 IF (icvflag_Tpa == 2) THEN 1315 ! 1316 !---------------------------------------------------------------------------- 1317 ! 1318 DO k = minorig + 1, nl 1319 DO i = 1,ncum 1320 tp(i,k) = t(i,k) 1321 ENDDO 1322 !! alv = lv0 - clmcpv*(t(i,k)-273.15) 1323 !! alf = lf0 + clmci*(t(i,k)-273.15) 1324 !! als = alf + alv 1325 DO j = 1,4 1326 DO i = 1, ncum 1327 ! ori if(k.ge.(icb(i)+1))then 1328 IF (k>=(icbs(i)+1)) THEN ! convect3 1329 tg = tp(i, k) 1330 IF (tg .gt. Tx) THEN 1331 es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) 1332 qg = eps*es/(p(i,k)-es*(1.-eps)) 1333 ELSE 1334 esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) 1335 qg = eps*esi/(p(i,k)-esi*(1.-eps)) 1336 ENDIF 1337 ! Ice fraction 1338 ff = 0. 1339 fp = 1./(Tx - Tm) 1340 IF (tg < Tx) THEN 1341 IF (tg > Tm) THEN 1342 ff = (Tx - tg)*fp 1343 ELSE 1344 ff = 1. 1345 ENDIF ! (tg > Tm) 1346 ENDIF ! (tg < Tx) 1347 ! Intermediate variables 1348 aa = cpd + (cl-cpd)*qnk(i) + lv(i,k)*lv(i,k)*qg/(rrv*tg*tg) 1349 ahg = (cpd + (cl-cpd)*qnk(i))*tg + lv(i,k)*qg - & 1350 lf(i,k)*ff*(qnk(i) - qg) + gz(i,k) 1351 dd = lf(i,k)*lv(i,k)*qg/(rrv*tg*tg) 1352 ddelta = lf(i,k)*(qnk(i) - qg) 1353 bb = aa + ddelta*fp + dd*fp*(Tx-tg) 1354 ! Compute Zx and Zm 1355 coefx = aa 1356 coefm = aa + dd 1357 IF (tg .gt. Tx) THEN 1358 Zx = ahg + coefx*(Tx - tg) 1359 Zm = ahg - ddelta + coefm*(Tm - tg) 1360 ELSE 1361 IF (tg .gt. Tm) THEN 1362 Zx = ahg + (coefx +fp*ddelta)*(Tx - Tg) 1363 Zm = ahg + (coefm +fp*ddelta)*(Tm - Tg) 1364 ELSE 1365 Zx = ahg + ddelta + coefx*(Tx - tg) 1366 Zm = ahg + coefm*(Tm - tg) 1367 ENDIF ! (tg .gt. Tm) 1368 ENDIF ! (tg .gt. Tx) 1369 ! Compute the masks Um, U, Ux 1370 Um = (sign(1., Zm-ah0(i))+1.)/2. 1371 Ux = (sign(1., ah0(i)-Zx)+1.)/2. 1372 U = (1. - Um)*(1. - Ux) 1373 ! Compute the updated parcell temperature Tp : 3 cases depending on tg value 1374 IF (tg .gt. Tx) THEN 1375 discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tx-tg)) 1376 Tp(i,k) = tg + & 1377 Um* (ah0(i) - ahg + ddelta) /(aa + dd) + & 1378 U *2*(ah0(i) - ahg + ddelta*fp*(Tx-tg))/(bb + sqrt(discr)) + & 1379 Ux* (ah0(i) - ahg) /aa 1380 ELSEIF (tg .gt. Tm) THEN 1381 discr = bb*bb - 4*dd*fp*(ah0(i) - ahg) 1382 Tp(i,k) = tg + & 1383 Um* (ah0(i) - ahg + ddelta*fp*(tg-Tm))/(aa + dd) + & 1384 U *2*(ah0(i) - ahg) /(bb + sqrt(discr)) + & 1385 Ux* (ah0(i) - ahg + ddelta*fp*(tg-Tx))/aa 1386 ELSE 1387 discr = bb*bb - 4*dd*fp*(ah0(i) - ahg + ddelta*fp*(Tm-tg)) 1388 Tp(i,k) = tg + & 1389 Um* (ah0(i) - ahg) /(aa + dd) + & 1390 U *2*(ah0(i) - ahg + ddelta*fp*(Tm-tg))/(bb + sqrt(discr)) + & 1391 Ux* (ah0(i) - ahg - ddelta) /aa 1392 ENDIF ! (tg .gt. Tx) 1393 ! 1394 !! print *,' j, k, Um, U, Ux, aa, bb, discr, dd, ddelta ', j, k, Um, U, Ux, aa, bb, discr, dd, ddelta 1395 !! print *,' j, k, ah0(i), ahg, tg, qg, tp(i,k), ff ', j, k, ah0(i), ahg, tg, qg, tp(i,k), ff 1396 END IF ! (k>=(icbs(i)+1)) 1397 END DO ! i = 1, ncum 1398 END DO ! j = 1,4 1399 DO i = 1, ncum 1400 IF (k>=(icbs(i)+1)) THEN ! convect3 1401 tg = tp(i, k) 1402 IF (tg .gt. Tx) THEN 1403 es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) 1404 qg = eps*es/(p(i,k)-es*(1.-eps)) 1405 ELSE 1406 esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) 1407 qg = eps*esi/(p(i,k)-esi*(1.-eps)) 1408 ENDIF 1409 clw(i, k) = qnk(i) - qg 1410 clw(i, k) = max(0.0, clw(i,k)) 1411 tvp(i, k) = max(0., tp(i,k)*(1.+qg/eps-qnk(i))) 1412 ! print*,tvp(i,k),'tvp' 1413 IF (clw(i,k)<1.E-11) THEN 1414 tp(i, k) = tv(i, k) 1415 tvp(i, k) = tv(i, k) 1416 END IF ! (clw(i,k)<1.E-11) 1417 END IF ! (k>=(icbs(i)+1)) 1418 END DO ! i = 1, ncum 1419 END DO ! k = minorig + 1, nl 1420 !---------------------------------------------------------------------------- 1421 ! 1422 ELSE IF (icvflag_Tpa == 1) THEN ! (icvflag_Tpa == 2) 1423 ! 1424 !---------------------------------------------------------------------------- 1425 ! 1426 DO k = minorig + 1, nl 1427 DO i = 1,ncum 1428 tp(i,k) = t(i,k) 1429 ENDDO 1430 !! alv = lv0 - clmcpv*(t(i,k)-273.15) 1431 !! alf = lf0 + clmci*(t(i,k)-273.15) 1432 !! als = alf + alv 1433 DO j = 1,4 1434 DO i = 1, ncum 1435 ! ori if(k.ge.(icb(i)+1))then 1436 IF (k>=(icbs(i)+1)) THEN ! convect3 1437 tg = tp(i, k) 1438 IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN 1439 es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) 1440 qg = eps*es/(p(i,k)-es*(1.-eps)) 1441 dqgdT = lv(i,k)*qg/(rrv*tg*tg) 1442 ELSE 1443 esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) 1444 qg = eps*esi/(p(i,k)-esi*(1.-eps)) 1445 dqgdT = (lv(i,k)+lf(i,k))*qg/(rrv*tg*tg) 1446 ENDIF 1447 IF (qsat_depends_on_qt) THEN 1448 dqgdT = dqgdT*(1.-qta(i,k-1))/(1.-qg)**2 1449 qg = qg*(1.-qta(i,k-1))/(1.-qg) 1450 ENDIF 1451 ahg = (cpd + (cl-cpd)*qta(i,k-1))*tg + lv(i,k)*qg - & 1452 lf(i,k)*frac(i,k)*(qta(i,k-1) - qg) + gz(i,k) 1453 Tp(i,k) = tg + (ah0(i) - ahg)/ & 1454 (cpd + (cl-cpd)*qta(i,k-1) + (lv(i,k)+frac(i,k)*lf(i,k))*dqgdT) 1455 !! print *,'undilute2 iterations k, Tp(i,k), ah0(i), ahg ', & 1456 !! k, Tp(i,k), ah0(i), ahg 1457 END IF ! (k>=(icbs(i)+1)) 1458 END DO ! i = 1, ncum 1459 END DO ! j = 1,4 1460 DO i = 1, ncum 1461 IF (k>=(icbs(i)+1)) THEN ! convect3 1462 tg = tp(i, k) 1463 IF (tg .gt. Tx .OR. .NOT.cvflag_ice) THEN 1464 es = 6.112*exp(17.67*(tg - 273.15)/(tg + 243.5 - 273.15)) 1465 qg = eps*es/(p(i,k)-es*(1.-eps)) 1466 ELSE 1467 esi = exp(23.33086-(6111.72784/tg)+0.15215*log(tg)) 1468 qg = eps*esi/(p(i,k)-esi*(1.-eps)) 1469 ENDIF 1470 IF (qsat_depends_on_qt) THEN 1471 qg = qg*(1.-qta(i,k-1))/(1.-qg) 1472 ENDIF 1473 qhsat(i,k) = qg 1474 END IF ! (k>=(icbs(i)+1)) 1475 END DO ! i = 1, ncum 1476 DO i = 1, ncum 1477 IF (k>=(icbs(i)+1)) THEN ! convect3 1478 clw(i, k) = qta(i,k-1) - qhsat(i,k) 1479 clw(i, k) = max(0.0, clw(i,k)) 1480 tvp(i, k) = max(0., tp(i,k)*(1.+qhsat(i,k)/eps-qta(i,k-1))) 1481 ! print*,tvp(i,k),'tvp' 1482 IF (clw(i,k)<1.E-11) THEN 1483 tp(i, k) = tv(i, k) 1484 tvp(i, k) = tv(i, k) 1485 END IF ! (clw(i,k)<1.E-11) 1486 END IF ! (k>=(icbs(i)+1)) 1487 END DO ! i = 1, ncum 1488 ! 1489 IF (cvflag_prec_eject) THEN 1490 DO i = 1, ncum 1491 IF (k>=(icbs(i)+1)) THEN ! convect3 1492 ! Specific precipitation (liquid and solid) and ice content 1493 ! before ejection of precipitation !!jygprl 1494 elacrit = elcrit*min(max(1.-(tp(i,k)-T0)/Tlcrit, 0.), 1.) !!jygprl 1495 !!!! qcld(i,k) = min(clw(i,k), elacrit) !!jygprl 1496 qcld(i,k) = min(clw(i,k), elacrit*(1.-qta(i,k-1))/(1.-elacrit)) !!jygprl 1497 phinu2p = qhsat(i,k-1) + qcld(i,k-1) - (qhsat(i,k) + qcld(i,k)) !!jygprl 1498 qpl(i,k) = qpl(i,k-1) + (1.-frac(i,k))*phinu2p !!jygprl 1499 qps(i,k) = qps(i,k-1) + frac(i,k) *phinu2p !!jygprl 1500 qi(i,k) = (1.-ejectliq)*clw(i,k)*frac(i,k) + & !!jygprl 1501 ejectliq*(qps(i,k-1) + frac(i,k)*(phinu2p+qcld(i,k))) !!jygprl 1502 !! 1503 ! ===================================================================================== 1504 ! Ejection of precipitation from adiabatic ascents if requested (cvflag_prec_eject=True): 1505 ! Compute the steps of total water (qta), of moist static energy (ha), of specific 1506 ! precipitation (qpl and qps) and of specific cloud water (qcld) associated with precipitation 1507 ! ejection. 1508 ! ===================================================================================== 1509 ! 1510 ! Verif 1511 qpreca(i,k) = ejectliq*qpl(i,k) + ejectice*qps(i,k) !!jygprl 1512 frac_a(i,k) = ejectice*qps(i,k)/max(qpreca(i,k),smallestreal) !!jygprl 1513 frac_s(i,k) = (1.-ejectliq)*frac(i,k) + & !!jygprl 1514 ejectliq*(1. - (qpl(i,k)+(1.-frac(i,k))*qcld(i,k))/max(clw(i,k),smallestreal)) !!jygprl 1515 ! 1516 denomm1 = 1./(1. - qpreca(i,k)) 1517 ! 1518 qta(i,k) = qta(i,k-1) - & 1519 qpreca(i,k)*(1.-qta(i,k-1))*denomm1 1520 ha(i,k) = ha(i,k-1) + & 1521 ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cl-cpd)*tp(i,k) + & 1522 lv(i,k)*qhsat(i,k) - lf(i,k)*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & 1523 lf(i,k)*ejectice*qps(i,k))*denomm1 1524 hla(i,k) = hla(i,k-1) + & 1525 ( qpreca(i,k)*(-(1.-qta(i,k-1))*(cpv-cpd)*tp(i,k) - & 1526 lv(i,k)*((1.-frac_s(i,k))*qcld(i,k)+qpl(i,k)) - & 1527 (lv(i,k)+lf(i,k))*(frac_s(i,k)*qcld(i,k)+qps(i,k))) + & 1528 lv(i,k)*ejectliq*qpl(i,k) + (lv(i,k)+lf(i,k))*ejectice*qps(i,k))*denomm1 1529 qpl(i,k) = qpl(i,k)*(1.-ejectliq)*denomm1 1530 qps(i,k) = qps(i,k)*(1.-ejectice)*denomm1 1531 qcld(i,k) = qcld(i,k)*denomm1 1532 qhsat(i,k) = qhsat(i,k)*(1.-qta(i,k))/(1.-qta(i,k-1)) 1533 END IF ! (k>=(icbs(i)+1)) 1534 END DO ! i = 1, ncum 1535 ENDIF ! (cvflag_prec_eject) 1536 ! 1537 END DO ! k = minorig + 1, nl 1538 ! 1539 !---------------------------------------------------------------------------- 1540 ! 1541 ELSE IF (icvflag_Tpa == 0) THEN! (icvflag_Tpa == 2) ELSE IF(icvflag_Tpa == 1) 1542 ! 1543 !---------------------------------------------------------------------------- 1544 ! 1204 1545 DO k = minorig + 1, nl 1205 1546 DO i = 1, ncum … … 1358 1699 END DO 1359 1700 1360 IF (prt_level >= 10) THEN 1361 print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', & 1362 (k, tp(1,k), tvp(1,k), k = 1,nl) 1363 ENDIF 1364 1701 !---------------------------------------------------------------------------- 1702 ! 1703 ENDIF ! (icvflag_Tpa == 2) ELSEIF (icvflag_Tpa == 1) ELSE (icvflag_Tpa == 0) 1704 ! 1705 !---------------------------------------------------------------------------- 1706 ! 1365 1707 ! ===================================================================== 1366 ! --- SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF 1367 ! --- PRECIPITATION FALLING OUTSIDE OF CLOUD 1708 ! --- SET THE PRECIPITATION EFFICIENCIES 1368 1709 ! --- THESE MAY BE FUNCTIONS OF TP(I), P(I) AND CLW(I) 1369 1710 ! ===================================================================== 1370 !1371 !jyg<1372 DO k = 1, nl1373 DO i = 1, ncum1374 ep(i, k) = 0.01375 sigp(i, k) = spfac1376 END DO1377 END DO1378 !>jyg1379 1711 ! 1380 1712 IF (flag_epkeorig/=1) THEN … … 1413 1745 END DO 1414 1746 END IF 1747 ! 1748 ! ========================================================================= 1749 IF (prt_level >= 10) THEN 1750 print *,'cv3_undilute2.1. tp(1,k), tvp(1,k) ', & 1751 (k, tp(1,k), tvp(1,k), k = 1,nl) 1752 ENDIF 1415 1753 ! 1416 1754 ! ===================================================================== … … 1648 1986 IF (cvflag_ice) THEN 1649 1987 ! 1988 IF (cvflag_prec_eject) THEN 1989 !! DO k = minorig + 1, nl 1990 !! DO i = 1, ncum 1991 !! IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN 1992 !! frac_s(i,k) = qi(i,k)/max(clw(i,k),smallestreal) 1993 !! frac_s(i,k) = 1. - (qpl(i,k)+(1.-frac_s(i,k))*qcld(i,k))/max(clw(i,k),smallestreal) 1994 !! END IF 1995 !! END DO 1996 !! END DO 1997 ELSE ! (cvflag_prec_eject) 1650 1998 DO k = minorig + 1, nl 1651 1999 DO i = 1, ncum 1652 2000 IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN 1653 frac(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15) 1654 frac(i, k) = min(max(frac(i,k),0.0), 1.0) 1655 hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac(i,k)*lf(i,k))* &1656 ep(i, k)*clw(i, k)2001 !jyg< frac computation moved to beginning of cv3_undilute2. 2002 ! kept here for compatibility test with CMip6 version 2003 frac_s(i, k) = 1. - (t(i,k)-243.15)/(263.15-243.15) 2004 frac_s(i, k) = min(max(frac_s(i,k),0.0), 1.0) 1657 2005 END IF 1658 2006 END DO 1659 2007 END DO 1660 ! Below cloud base, set ice fraction to cloud base value 1661 DO k = 1, nl2008 ENDIF ! (cvflag_prec_eject) ELSE 2009 DO k = minorig + 1, nl 1662 2010 DO i = 1, ncum 1663 IF (k<icb(i)) THEN 1664 frac(i,k) = frac(i,icb(i)) 2011 IF ((k>=icb(i)) .AND. (k<=inb(i))) THEN 2012 !! hp(i, k) = hnk(i) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl 2013 !! ep(i, k)*clw(i, k) !!jygprl 2014 hp(i, k) = hla(i,k-1) + (lv(i,k)+(cpd-cpv)*t(i,k)+frac_s(i,k)*lf(i,k))* & !!jygprl 2015 ep(i, k)*clw(i, k) !!jygprl 1665 2016 END IF 1666 2017 END DO 1667 2018 END DO 1668 2019 ! 1669 ELSE 2020 ELSE ! (cvflag_ice) 1670 2021 ! 1671 2022 DO k = minorig + 1, nl … … 2350 2701 SUBROUTINE cv3_unsat(nloc, ncum, nd, na, ntra, icb, inb, iflag, & 2351 2702 t, rr, rs, gz, u, v, tra, p, ph, & 2352 th, tv, lv, lf, cpn, ep, sigp, clw, &2703 th, tv, lv, lf, cpn, ep, sigp, clw, frac_s, qpreca, frac_a, qta , & !!jygprl 2353 2704 m, ment, elij, delt, plcl, coef_clos, & 2354 2705 mp, rp, up, vp, trap, wt, water, evap, fondue, ice, & 2355 2706 faci, b, sigd, & 2356 wdtrainA, wdtrain M) ! RomP2707 wdtrainA, wdtrainS, wdtrainM) ! RomP 2357 2708 USE print_control_mod, ONLY: prt_level, lunout 2358 2709 IMPLICIT NONE … … 2372 2723 REAL, DIMENSION (nloc, na), INTENT (IN) :: gz 2373 2724 REAL, DIMENSION (nloc, nd), INTENT (IN) :: u, v 2374 REAL tra(nloc, nd, ntra) 2375 REAL p(nloc, nd), ph(nloc, nd+1) 2376 REAL, DIMENSION (nloc, na), INTENT (IN) :: ep, sigp, clw 2725 REAL, DIMENSION (nloc, nd, ntra), INTENT(IN) :: tra 2726 REAL, DIMENSION (nloc, nd), INTENT (IN) :: p 2727 REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph 2728 REAL, DIMENSION (nloc, na), INTENT (IN) :: ep, sigp, clw !adiab ascent shedding 2729 REAL, DIMENSION (nloc, na), INTENT (IN) :: frac_s !ice fraction in adiab ascent shedding !!jygprl 2730 REAL, DIMENSION (nloc, na), INTENT (IN) :: qpreca !adiab ascent precip !!jygprl 2731 REAL, DIMENSION (nloc, na), INTENT (IN) :: frac_a !ice fraction in adiab ascent precip !!jygprl 2732 REAL, DIMENSION (nloc, na), INTENT (IN) :: qta !adiab ascent specific total water !!jygprl 2377 2733 REAL, DIMENSION (nloc, na), INTENT (IN) :: th, tv, lv, cpn 2378 2734 REAL, DIMENSION (nloc, na), INTENT (IN) :: lf … … 2387 2743 REAL, DIMENSION (nloc, na), INTENT (OUT) :: mp, rp, up, vp 2388 2744 REAL, DIMENSION (nloc, na), INTENT (OUT) :: water, evap, wt 2389 REAL, DIMENSION (nloc, na), INTENT (OUT) :: ice, fondue, faci 2745 REAL, DIMENSION (nloc, na), INTENT (OUT) :: ice, fondue 2746 REAL, DIMENSION (nloc, na), INTENT (OUT) :: faci ! ice fraction in precipitation 2390 2747 REAL, DIMENSION (nloc, na, ntra), INTENT (OUT) :: trap 2391 2748 REAL, DIMENSION (nloc, na), INTENT (OUT) :: b … … 2395 2752 ! Distinction des wdtrain 2396 2753 ! Pa = wdtrainA Pm = wdtrainM 2397 REAL, DIMENSION (nloc, na), INTENT (OUT) :: wdtrainA, wdtrain M2754 REAL, DIMENSION (nloc, na), INTENT (OUT) :: wdtrainA, wdtrainS, wdtrainM 2398 2755 2399 2756 !local variables 2400 2757 INTEGER i, j, k, il, num1, ndp1 2758 REAL smallestreal 2401 2759 REAL tinv, delti, coef 2402 2760 REAL awat, afac, afac1, afac2, bfac … … 2405 2763 REAL ampmax, thaw 2406 2764 REAL tevap(nloc) 2407 REAL lvcp(nloc, na), lfcp(nloc, na) 2408 REAL h(nloc, na), hm(nloc, na) 2409 REAL frac(nloc, na) 2410 REAL fraci(nloc, na), prec(nloc, na) 2765 REAL, DIMENSION (nloc, na) :: lvcp, lfcp 2766 REAL, DIMENSION (nloc, na) :: h, hm 2767 REAL, DIMENSION (nloc, na) :: ma 2768 REAL, DIMENSION (nloc, na) :: frac ! ice fraction in precipitation source 2769 REAL, DIMENSION (nloc, na) :: fraci ! provisionnal ice fraction in precipitation 2770 REAL, DIMENSION (nloc, na) :: prec 2411 2771 REAL wdtrain(nloc) 2412 2772 LOGICAL lwork(nloc), mplus(nloc) … … 2415 2775 ! ------------------------------------------------------ 2416 2776 IF (prt_level .GE. 10) print *,' ->cv3_unsat, iflag(1) ', iflag(1) 2777 2778 smallestreal=tiny(smallestreal) 2417 2779 2418 2780 ! ============================= … … 2434 2796 !! RomP >>> 2435 2797 wdtrainA(:,:) = 0. 2798 wdtrainS(:,:) = 0. 2436 2799 wdtrainM(:,:) = 0. 2437 2800 !! RomP <<< … … 2489 2852 END DO 2490 2853 2854 ! 2855 ! Get adiabatic ascent mass flux 2856 ! 2857 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2858 IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN 2859 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2860 !!! Warning : this option leads to water conservation violation 2861 !!! Expert only 2862 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2863 DO il = 1, ncum 2864 ma(il, nlp) = 0. 2865 ma(il, 1) = 0. 2866 END DO 2867 2868 DO i = nl, 2, -1 2869 DO il = 1, ncum 2870 ma(il, i) = ma(il, i+1)*(1.-qta(il,i))/(1.-qta(il,i-1)) + m(il, i) 2871 END DO 2872 END DO 2873 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2874 ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) 2875 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2876 DO il = 1, ncum 2877 ma(il, nlp) = 0. 2878 ma(il, 1) = 0. 2879 END DO 2880 2881 DO i = nl, 2, -1 2882 DO il = 1, ncum 2883 ma(il, i) = ma(il, i+1) + m(il, i) 2884 END DO 2885 END DO 2886 2887 ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE 2888 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2491 2889 2492 2890 ! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ … … 2513 2911 ! *** calculate detrained precipitation *** 2514 2912 2515 DO il = 1, ncum 2516 IF (i<=inb(il) .AND. lwork(il)) THEN 2517 IF (cvflag_grav) THEN 2518 wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i) 2519 wdtrainA(il, i) = wdtrain(il)/grav ! Pa RomP 2520 ELSE 2521 wdtrain(il) = 10.0*ep(il, i)*m(il, i)*clw(il, i) 2522 wdtrainA(il, i) = wdtrain(il)/10. ! Pa RomP 2523 END IF 2524 END IF 2525 END DO 2913 2914 DO il = 1, ncum 2915 IF (i<=inb(il) .AND. lwork(il)) THEN 2916 wdtrain(il) = grav*ep(il, i)*m(il, i)*clw(il, i) 2917 wdtrainS(il, i) = wdtrain(il)/grav ! Ps jyg 2918 !! wdtrainA(il, i) = wdtrain(il)/grav ! Ps RomP 2919 END IF 2920 END DO 2526 2921 2527 2922 IF (i>1) THEN … … 2531 2926 awat = elij(il, j, i) - (1.-ep(il,i))*clw(il, i) 2532 2927 awat = max(awat, 0.0) 2533 IF (cvflag_grav) THEN 2534 wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i) 2535 wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i) ! Pm RomP 2536 ELSE 2537 wdtrain(il) = wdtrain(il) + 10.0*awat*ment(il, j, i) 2538 wdtrainM(il, i) = wdtrain(il)/10. - wdtrainA(il, i) ! Pm RomP 2539 END IF 2928 wdtrain(il) = wdtrain(il) + grav*awat*ment(il, j, i) 2929 wdtrainM(il, i) = wdtrain(il)/grav - wdtrainS(il, i) ! Pm jyg 2930 !! wdtrainM(il, i) = wdtrain(il)/grav - wdtrainA(il, i) ! Pm RomP 2540 2931 END IF 2541 2932 END DO … … 2543 2934 END IF 2544 2935 2936 IF (cvflag_prec_eject) THEN 2937 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2938 IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN 2939 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2940 !!! Warning : this option leads to water conservation violation 2941 !!! Expert only 2942 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2943 IF ( i > 1) THEN 2944 DO il = 1, ncum 2945 IF (i<=inb(il) .AND. lwork(il)) THEN 2946 wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i))/(1. - qta(il, i-1)) ! Pa jygprl 2947 wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i) 2948 END IF 2949 END DO 2950 ENDIF ! ( i > 1) 2951 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2952 ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) 2953 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2954 IF ( i > 1) THEN 2955 DO il = 1, ncum 2956 IF (i<=inb(il) .AND. lwork(il)) THEN 2957 wdtrainA(il,i) = ma(il, i+1)*(qta(il, i-1)-qta(il,i)) ! Pa jygprl 2958 wdtrain(il) = wdtrain(il) + grav*wdtrainA(il,i) 2959 END IF 2960 END DO 2961 ENDIF ! ( i > 1) 2962 2963 ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE 2964 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2965 ENDIF ! (cvflag_prec_eject) 2966 2545 2967 2546 2968 ! *** find rain water and evaporation using provisional *** … … 2548 2970 2549 2971 2972 IF (cvflag_ice) THEN !!jygprl 2973 IF (cvflag_prec_eject) THEN 2974 DO il = 1, ncum !!jygprl 2975 IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl 2976 frac(il, i) = (frac_a(il,i)*wdtrainA(il,i)+frac_s(il,i)*(wdtrainS(il,i)+wdtrainM(il,i))) / & !!jygprl 2977 max(wdtrainA(il,i)+wdtrainS(il,i)+wdtrainM(il,i),smallestreal) !!jygprl 2978 fraci(il, i) = frac(il, i) !!jygprl 2979 END IF !!jygprl 2980 END DO !!jygprl 2981 ELSE ! (cvflag_prec_eject) 2982 DO il = 1, ncum !!jygprl 2983 IF (i<=inb(il) .AND. lwork(il)) THEN !!jygprl 2984 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2985 IF (keepbug_ice_frac) THEN 2986 frac(il, i) = frac_s(il, i) 2987 ! Ice fraction computed again here as a function of the temperature seen by unsaturated downdraughts 2988 ! (i.e. the cold pool temperature) for compatibility with earlier versions. 2989 fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15) 2990 fraci(il, i) = min(max(fraci(il,i),0.0), 1.0) 2991 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2992 ELSE ! (keepbug_ice_frac) 2993 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2994 frac(il, i) = frac_s(il, i) 2995 fraci(il, i) = frac(il, i) !!jygprl 2996 ENDIF ! (keepbug_ice_frac) 2997 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2998 END IF !!jygprl 2999 END DO !!jygprl 3000 ENDIF ! (cvflag_prec_eject) 3001 END IF !!jygprl 3002 3003 2550 3004 DO il = 1, ncum 2551 3005 IF (i<=inb(il) .AND. lwork(il)) THEN … … 2553 3007 wt(il, i) = 45.0 2554 3008 2555 IF (cvflag_ice) THEN2556 frac(il, inb(il)) = 1. - (t(il,inb(il))-243.15)/(263.15-243.15)2557 frac(il, inb(il)) = min(max(frac(il,inb(il)),0.), 1.)2558 fraci(il, inb(il)) = frac(il, inb(il))2559 ELSE2560 CONTINUE2561 END IF2562 2563 3009 IF (i<inb(il)) THEN 2564 2565 IF (cvflag_ice) THEN2566 !CR:tmax_fonte_cv: T for which ice is totally melted (used to be 275.15)2567 thaw = (t(il,i)-273.15)/(tmax_fonte_cv-273.15)2568 thaw = min(max(thaw,0.0), 1.0)2569 frac(il, i) = frac(il, i)*(1.-thaw)2570 ELSE2571 CONTINUE2572 END IF2573 2574 3010 rp(il, i) = rp(il, i+1) + & 2575 3011 (cpd*(t(il,i+1)-t(il,i))+gz(il,i+1)-gz(il,i))/lv(il, i) 2576 3012 rp(il, i) = 0.5*(rp(il,i)+rr(il,i)) 2577 3013 END IF 2578 fraci(il, i) = 1. - (t(il,i)-243.15)/(263.15-243.15)2579 fraci(il, i) = min(max(fraci(il,i),0.0), 1.0)2580 3014 rp(il, i) = max(rp(il,i), 0.0) 2581 3015 rp(il, i) = amin1(rp(il,i), rs(il,i)) … … 2998 3432 2999 3433 RETURN 3434 3000 3435 END SUBROUTINE cv3_unsat 3001 3436 … … 3004 3439 t, rr, t_wake, rr_wake, s_wake, u, v, tra, & 3005 3440 gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & 3006 ep, clw, m, tp, mp, rp, up, vp, trap, &3441 ep, clw, qpreca, m, tp, mp, rp, up, vp, trap, & 3007 3442 wt, water, ice, evap, fondue, faci, b, sigd, & 3008 3443 ment, qent, hent, iflag_mix, uent, vent, & … … 3014 3449 !! tls, tps, ! useless . jyg 3015 3450 qcondc, wd, & 3016 ftd, fqd, q nk, qtc, sigt, tau_cld_cv, coefw_cld_cv)3451 ftd, fqd, qta, qtc, sigt, tau_cld_cv, coefw_cld_cv) 3017 3452 3018 3453 USE print_control_mod, ONLY: lunout, prt_level … … 3054 3489 REAL, DIMENSION (nloc, na, na, ntra), INTENT (IN) :: traent 3055 3490 REAL, DIMENSION (nloc, nd), INTENT (IN) :: tv, tvp, wghti 3056 REAL,INTENT(IN) :: tau_cld_cv, coefw_cld_cv 3491 REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta 3492 REAL, DIMENSION (nloc, na),INTENT(IN) :: qpreca 3493 REAL, INTENT(IN) :: tau_cld_cv, coefw_cld_cv 3057 3494 ! 3058 3495 !input/output: … … 3083 3520 REAL :: ax, bx, cx, dx, ex 3084 3521 REAL :: cpinv, rdcp, dpinv 3522 REAL :: sigaq 3085 3523 REAL, DIMENSION (nloc) :: awat 3086 3524 REAL, DIMENSION (nloc, nd) :: lvcp, lfcp ! , mke ! unused . jyg … … 3100 3538 REAL, DIMENSION (nloc) :: sument 3101 3539 REAL, DIMENSION (nloc, nd) :: sigment, qtment ! cld 3102 REAL, DIMENSION (nloc) :: qnk3103 3540 REAL sumdq !jyg 3104 3541 ! … … 3211 3648 END DO 3212 3649 3650 ! - Adiabatic ascent mass flux "ma" and cloud base mass flux "cbmf" 3651 !----------------------------------------------------------------- 3652 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3653 IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN 3654 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3655 !!! Warning : this option leads to water conservation violation 3656 !!! Expert only 3657 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3658 DO il = 1, ncum 3659 ma(il, nlp) = 0. 3660 ma(il, 1) = 0. 3661 END DO 3662 DO k = nl, 2, -1 3663 DO il = 1, ncum 3664 ma(il, k) = ma(il, k+1)*(1.-qta(il, k))/(1.-qta(il, k-1)) + m(il, k) 3665 cbmf(il) = max(cbmf(il), ma(il,k)) 3666 END DO 3667 END DO 3668 DO k = 2,nl 3669 DO il = 1, ncum 3670 IF (k <icb(il)) THEN 3671 ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il) 3672 ENDIF 3673 END DO 3674 END DO 3675 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3676 ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) 3677 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3678 !! Line kept for compatibility with earlier versions 3213 3679 DO k = 2, nl 3214 3680 DO il = 1, ncum … … 3219 3685 END DO 3220 3686 3687 DO il = 1, ncum 3688 ma(il, nlp) = 0. 3689 ma(il, 1) = 0. 3690 END DO 3691 DO k = nl, 2, -1 3692 DO il = 1, ncum 3693 ma(il, k) = ma(il, k+1) + m(il, k) 3694 END DO 3695 END DO 3696 DO k = 2,nl 3697 DO il = 1, ncum 3698 IF (k <icb(il)) THEN 3699 ma(il, k) = ma(il, k-1) + wghti(il,k-1)*cbmf(il) 3700 ENDIF 3701 END DO 3702 END DO 3703 3704 ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE 3705 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3706 ! 3221 3707 ! print*,'cv3_yield avant ft' 3222 3708 ! am is the part of cbmf taken from the first level … … 3355 3841 !*** Compute convective mass fluxes upwd and dnwd *** 3356 3842 3843 ! 3844 ! ================================================= 3845 ! upward fluxes | 3846 ! ------------------------------------------------ 3847 ! 3357 3848 upwd(:,:) = 0. 3358 3849 up_to(:,:) = 0. 3359 3850 up_from(:,:) = 0. 3360 dnwd(:,:) = 0. 3361 dn_to(:,:) = 0. 3362 dn_from(:,:) = 0. 3363 ! 3364 ! ================================================= 3365 ! upward fluxes | 3366 ! ------------------------------------------------ 3851 ! 3852 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3853 IF (adiab_ascent_mass_flux_depends_on_ejectliq) THEN 3854 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3855 !! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 3856 !! is taken into account. 3857 !! WARNING : in the present version, taking into account the mass-flux decrease due to 3858 !! precipitation ejection leads to water conservation violation. 3859 ! 3860 ! - Upward mass flux of mixed draughts 3861 !--------------------------------------- 3862 DO i = 2, nl 3863 DO j = 1, i-1 3864 DO il = 1, ncum 3865 IF (i<=inb(il)) THEN 3866 up_to(il,i) = up_to(il,i) + ment(il,j,i) 3867 ENDIF 3868 ENDDO 3869 ENDDO 3870 ENDDO 3871 ! 3872 DO j = 3, nl 3873 DO i = 2, j-1 3874 DO il = 1, ncum 3875 IF (j<=inb(il)) THEN 3876 up_from(il,i) = up_from(il,i) + ment(il,i,j) 3877 ENDIF 3878 ENDDO 3879 ENDDO 3880 ENDDO 3881 ! 3882 ! The difference between upwd(il,i) and upwd(il,i-1) is due to updrafts ending in layer 3883 !(i-1) (theses drafts cross interface (i-1) but not interface(i)) and to updrafts starting 3884 !from layer (i-1) (theses drafts cross interface (i) but not interface(i-1)): 3885 ! 3886 DO i = 2, nlp 3887 DO il = 1, ncum 3888 IF (i<=inb(il)+1) THEN 3889 upwd(il,i) = max(0., upwd(il,i-1) - up_to(il,i-1) + up_from(il,i-1)) 3890 ENDIF 3891 ENDDO 3892 ENDDO 3893 ! 3894 ! - Total upward mass flux 3895 !--------------------------- 3896 DO i = 2, nlp 3897 DO il = 1, ncum 3898 IF (i<=inb(il)+1) THEN 3899 upwd(il,i) = upwd(il,i) + ma(il,i) 3900 ENDIF 3901 ENDDO 3902 ENDDO 3903 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3904 ELSE ! (adiab_ascent_mass_flux_depends_on_ejectliq) 3905 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3906 !! The decrease of the adiabatic ascent mass flux due to ejection of precipitation 3907 !! is not taken into account. 3908 ! 3909 ! - Upward mass flux 3910 !------------------- 3367 3911 DO i = 2, nl 3368 3912 DO il = 1, ncum … … 3387 3931 ENDDO 3388 3932 ENDDO 3389 !!DO i = 2, nl 3390 !! DO j = i+1, nl !! Permuter les boucles i et j 3933 ! 3391 3934 DO j = 3, nl 3392 3935 DO i = 2, j-1 … … 3410 3953 ENDDO 3411 3954 ENDDO 3955 3956 3957 ENDIF ! (adiab_ascent_mass_flux_depends_on_ejectliq) ELSE 3958 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 3959 3412 3960 ! 3413 3961 ! ================================================= 3414 3962 ! downward fluxes | 3415 3963 ! ------------------------------------------------ 3964 dnwd(:,:) = 0. 3965 dn_to(:,:) = 0. 3966 dn_from(:,:) = 0. 3416 3967 DO i = 1, nl 3417 3968 DO j = i+1, nl … … 3424 3975 ENDDO 3425 3976 ! 3426 !!DO i = 2, nl3427 !! DO j = 1, i-1 !! Permuter les boucles i et j3428 3977 DO j = 1, nl 3429 3978 DO i = j+1, nl … … 3749 4298 END DO ! cld 3750 4299 4300 !ym BIG Warning : it seems that the k loop is missing !!! 4301 !ym Strong advice to check this 4302 !ym add a k loop temporary 4303 3751 4304 ! (particular case: no detraining level is found) ! cld 4305 ! Verif merge Dynamico<<<<<<< .working 3752 4306 DO il = 1, ncum ! cld 3753 4307 IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld … … 3761 4315 END IF ! cld 3762 4316 END DO ! cld 4317 ! Verif merge Dynamico ======= 4318 ! Verif merge Dynamico DO k = i + 1, nl 4319 ! Verif merge Dynamico DO il = 1, ncum !ym k loop added ! cld 4320 ! Verif merge Dynamico IF (i<=inb(il) .AND. nent(il,i)==0 .AND. iflag(il)<=1) THEN ! cld 4321 ! Verif merge Dynamico qcond(il, i) = qcond(il, i) + (1.-ep(il,i))*clw(il, i) ! cld 4322 ! Verif merge Dynamico qtment(il, i) = qent(il,k,i) + qtment(il,i) ! cld 4323 ! Verif merge Dynamico nqcond(il, i) = nqcond(il, i) + 1. ! cld 4324 ! Verif merge Dynamico END IF ! cld 4325 ! Verif merge Dynamico END DO 4326 ! Verif merge Dynamico ENDDO ! cld 4327 ! Verif merge Dynamico >>>>>>> .merge-right.r3413 3763 4328 3764 4329 DO il = 1, ncum ! cld … … 4181 4746 !!!! 4182 4747 !!!! ENDDO 4748 4749 !! DO i = 1, nlp 4750 !! DO il = 1, ncum 4751 !! ma(il, i) = 0 4752 !! END DO 4753 !! END DO 4754 !! 4755 !! DO i = 1, nl 4756 !! DO j = i, nl 4757 !! DO il = 1, ncum 4758 !! ma(il, i) = ma(il, i) + m(il, j) 4759 !! END DO 4760 !! END DO 4761 !! END DO 4762 4763 !jyg< (loops stop at nl) 4764 !! DO i = nl + 1, nd 4765 !! DO il = 1, ncum 4766 !! ma(il, i) = 0. 4767 !! END DO 4768 !! END DO 4769 !>jyg 4770 4771 !! DO i = 1, nl 4772 !! DO il = 1, ncum 4773 !! IF (i<=(icb(il)-1)) THEN 4774 !! ma(il, i) = 0 4775 !! END IF 4776 !! END DO 4777 !! END DO 4778 4183 4779 !----------------------------------------------------------- 4184 4780 ENDIF !(.NOT.ok_optim_yield) !| … … 4205 4801 !>jyg 4206 4802 4207 DO i = 1, nlp4208 DO il = 1, ncum4209 ma(il, i) = 04210 END DO4211 END DO4212 4213 DO i = 1, nl4214 DO j = i, nl4215 DO il = 1, ncum4216 ma(il, i) = ma(il, i) + m(il, j)4217 END DO4218 END DO4219 END DO4220 4221 !jyg< (loops stop at nl)4222 !! DO i = nl + 1, nd4223 !! DO il = 1, ncum4224 !! ma(il, i) = 0.4225 !! END DO4226 !! END DO4227 !>jyg4228 4229 DO i = 1, nl4230 DO il = 1, ncum4231 IF (i<=(icb(il)-1)) THEN4232 ma(il, i) = 04233 END IF4234 END DO4235 END DO4236 4803 4237 4804 ! cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc … … 4320 4887 ! 14/01/15 AJ delta n'a rien à faire là... 4321 4888 DO il = 1, ncum ! cld 4322 IF (wa(il,i)>0.0 .AND. iflag(il)<=1) & ! cld 4889 !! IF (wa(il,i)>0.0 .AND. iflag(il)<=1) & ! cld 4890 !! siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld 4891 !! *rrd*tvp(il, i)/p(il, i)/100. ! cld 4892 !! 4893 !! siga(il, i) = min(siga(il,i), 1.0) ! cld 4894 sigaq = 0. 4895 IF (wa(il,i)>0.0 .AND. iflag(il)<=1) THEN ! cld 4323 4896 siga(il, i) = mac(il, i)/(coefw_cld_cv*wa(il, i)) & ! cld 4324 *rrd*tvp(il, i)/p(il, i)/100. ! cld 4325 4326 siga(il, i) = min(siga(il,i), 1.0) ! cld 4897 *rrd*tvp(il, i)/p(il, i)/100. ! cld 4898 siga(il, i) = min(siga(il,i), 1.0) ! cld 4899 sigaq = siga(il,i)*qta(il,i-1) ! cld 4900 ENDIF 4327 4901 4328 4902 ! IM cf. FH … … 4336 4910 sigment(il,i)=sument(il)*tau_cld_cv/(ph(il,i)-ph(il,i+1)) ! cld 4337 4911 sigment(il, i) = min(1.e-4+sigment(il,i), 1.0 - siga(il,i)) ! cld 4338 qtc(il, i) = (siga(il,i)*qnk(il)+sigment(il,i)*qtment(il,i)) & ! cld 4912 !! qtc(il, i) = (siga(il,i)*qta(il,i-1)+sigment(il,i)*qtment(il,i)) & ! cld 4913 qtc(il, i) = (sigaq+sigment(il,i)*qtment(il,i)) & ! cld 4339 4914 /(siga(il,i)+sigment(il,i)) ! cld 4340 4915 sigt(il,i) = sigment(il, i) + siga(il, i) 4341 4916 4342 ! qtc(il, i) = siga(il,i)*q nk(il)+(1.-siga(il,i))*qtment(il,i) ! cld4917 ! qtc(il, i) = siga(il,i)*qta(il,i-1)+(1.-siga(il,i))*qtment(il,i) ! cld 4343 4918 ! print*,'BIGAUSSIAN CONV',siga(il,i),sigment(il,i),qtc(il,i) 4344 4919 … … 4629 5204 do k=1,nl 4630 5205 do i=1,ncum 4631 4632 5206 hp(i,k)=h(i,k) 5207 enddo 4633 5208 enddo 4634 5209 -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3a_uncompress.F90
r2481 r3605 10 10 asupmaxmin, & 11 11 da, phi, mp, phi2, d1a, dam, sigij, & ! RomP+AC+jyg 12 clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP13 wdtrainA, wdtrain M, &! RomP12 qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP+jyg 13 wdtrainA, wdtrainS, wdtrainM, & ! RomP 14 14 qtc, sigt, & 15 15 epmax_diag, & ! epmax_cape … … 24 24 asupmaxmin1, & 25 25 da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP+AC+jyg 26 clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP27 wdtrainA1, wdtrain M1, &! RomP26 qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP+jyg 27 wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP 28 28 qtc1, sigt1, & 29 29 epmax_diag1) ! epmax_cape … … 75 75 REAL, DIMENSION (nloc, nd), INTENT (IN) :: d1a, dam !RomP 76 76 REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: sigij !RomP 77 REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta !jyg 77 78 REAL, DIMENSION (nloc, nd), INTENT (IN) :: clw !RomP 78 79 REAL, DIMENSION (nloc, nd, nd), INTENT (IN) :: elij !RomP … … 81 82 REAL, DIMENSION (nloc, nd), INTENT (IN) :: eplamM !RomP+jyg 82 83 REAL, DIMENSION (nloc, nd), INTENT (IN) :: qtc, sigt !RomP 83 REAL, DIMENSION (nloc, nd), INTENT (IN) :: wdtrainA, wdtrain M !RomP84 REAL, DIMENSION (nloc, nd), INTENT (IN) :: wdtrainA, wdtrainS, wdtrainM !RomP 84 85 85 86 ! outputs: … … 111 112 REAL, DIMENSION (len, nd), INTENT (OUT) :: d1a1, dam1 !RomP !RomP 112 113 REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 !RomP 114 REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 !jyg 113 115 REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 !RomP 114 116 REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1 !RomP … … 117 119 REAL, DIMENSION (len, nd), INTENT (OUT) :: eplamM1 !RomP+jyg 118 120 REAL, DIMENSION (len, nd), INTENT (OUT) :: qtc1, sigt1 !RomP 119 REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrain M1 !RomP121 REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 !RomP 120 122 121 123 … … 175 177 d1a1(idcum(i), k) = d1a(i, k) !RomP 176 178 dam1(idcum(i), k) = dam(i, k) !RomP 179 qta1(idcum(i), k) = qta(i, k) !jyg 177 180 clw1(idcum(i), k) = clw(i, k) !RomP 178 181 evap1(idcum(i), k) = evap(i, k) !RomP … … 180 183 eplamM1(idcum(i), k) = eplamM(i, k) !RomP+jyg 181 184 wdtrainA1(idcum(i), k) = wdtrainA(i, k) !RomP 185 wdtrainS1(idcum(i), k) = wdtrainS(i, k) !RomP 182 186 wdtrainM1(idcum(i), k) = wdtrainM(i, k) !RomP 183 187 qtc1(idcum(i), k) = qtc(i, k) … … 300 304 d1a1(:, 1:nl) = d1a(:, 1:nl) !RomP 301 305 dam1(:, 1:nl) = dam(:, 1:nl) !RomP 306 qta1(:, 1:nl) = qta(:, 1:nl) !jyg 302 307 clw1(:, 1:nl) = clw(:, 1:nl) !RomP 303 308 evap1(:, 1:nl) = evap(:, 1:nl) !RomP … … 305 310 eplamM1(:, 1:nl) = eplamM(:, 1:nl) !RomP+jyg 306 311 wdtrainA1(:, 1:nl) = wdtrainA(:, 1:nl) !RomP 312 wdtrainS1(:, 1:nl) = wdtrainS(:, 1:nl) !RomP 307 313 wdtrainM1(:, 1:nl) = wdtrainM(:, 1:nl) !RomP 308 314 qtc1(:, 1:nl) = qtc(:, 1:nl) -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p1_closure.F90
r2826 r3605 537 537 ELSE 538 538 ! Calculate wbeff 539 IF ( flag_wb==0) THEN539 IF (NINT(flag_wb)==0) THEN 540 540 wbeff(il) = wbmax 541 ELSE IF ( flag_wb==1) THEN541 ELSE IF (NINT(flag_wb)==1) THEN 542 542 wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) 543 ELSE IF ( flag_wb==2) THEN543 ELSE IF (NINT(flag_wb)==2) THEN 544 544 wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 545 545 ELSE ! Option provisoire ou le iflag_wb/10 est considere comme une vitesse -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p2_closure.F90
r2502 r3605 23 23 include "cvthermo.h" 24 24 include "cv3param.h" 25 include "cvflag.h" 25 26 include "YOMCST2.h" 26 27 include "YOMCST.h" … … 608 609 ELSE 609 610 ! Calculate wbeff 610 IF ( flag_wb==0) THEN611 IF (NINT(flag_wb)==0) THEN 611 612 wbeff(il) = wbmax 612 ELSE IF ( flag_wb==1) THEN613 ELSE IF (NINT(flag_wb)==1) THEN 613 614 wbeff(il) = wbmax/(1.+500./(ph(il,1)-plfc(il))) 614 ELSE IF ( flag_wb==2) THEN615 ELSE IF (NINT(flag_wb)==2) THEN 615 616 wbeff(il) = wbmax*(0.01*(ph(il,1)-plfc(il)))**2 616 617 END IF -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3p_mixing.F90
r2905 r3605 1 1 SUBROUTINE cv3p_mixing(nloc, ncum, nd, na, ntra, icb, nk, inb, & 2 ph, t, rr, rs, u, v, tra, h, lv, lf, frac, q nk, &2 ph, t, rr, rs, u, v, tra, h, lv, lf, frac, qta, & 3 3 unk, vnk, hp, tv, tvp, ep, clw, sig, & 4 4 Ment, Qent, hent, uent, vent, nent, & … … 29 29 INTEGER, DIMENSION (nloc), INTENT (IN) :: icb, inb, nk 30 30 REAL, DIMENSION (nloc, nd), INTENT (IN) :: sig 31 REAL, DIMENSION (nloc), INTENT (IN) :: qnk, unk, vnk 31 REAL, DIMENSION (nloc), INTENT (IN) :: unk, vnk 32 REAL, DIMENSION (nloc, nd), INTENT (IN) :: qta 32 33 REAL, DIMENSION (nloc, nd+1), INTENT (IN) :: ph 33 34 REAL, DIMENSION (nloc, nd), INTENT (IN) :: t, rr, rs … … 173 174 .AND. (j<=inb(il))) THEN 174 175 175 rti = qnk(il) - ep(il, i)*clw(il, i) 176 !! rti = qnk(il) - ep(il, i)*clw(il, i) 177 rti = qta(il,i-1) - ep(il, i)*clw(il, i) 176 178 bf2 = 1. + lv(il, j)*lv(il, j)*rs(il, j)/(rrv*t(il,j)*t(il,j)*cpd) 177 179 !jyg(from aj)< … … 219 221 Sij(il, i, j) = amax1(0.0, Sij(il,i,j)) 220 222 Sij(il, i, j) = amin1(1.0, Sij(il,i,j)) 223 ELSE IF (j > i) THEN 224 IF (prt_level >= 10) THEN 225 print *,'cv3p_mixing i, j, Sij given by the no-precip eq. ', i, j, Sij(il,i,j) 226 ENDIF 221 227 END IF ! new 222 228 END DO … … 248 254 !!! Ment(il,i,i)=m(il,i) 249 255 Ment(il, i, i) = 1. 250 Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) 256 !! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) 257 Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) 251 258 uent(il, i, i) = unk(il) 252 259 vent(il, i, i) = vnk(il) … … 332 339 IF (i>=icb(il) .AND. i<=inb(il)) THEN 333 340 lwork(il) = (nent(il,i)/=0) 334 rti = qnk(il) - ep(il, i)*clw(il, i) 341 !! rti = qnk(il) - ep(il, i)*clw(il, i) 342 rti = qta(il,i-1) - ep(il, i)*clw(il, i) 335 343 !jyg< 336 344 IF (cvflag_ice) THEN … … 462 470 lwork(il)) THEN 463 471 IF (Sij(il,i,j)>0.0) THEN 464 rti = qnk(il) - ep(il, i)*clw(il, i) 472 !! rti = qnk(il) - ep(il, i)*clw(il, i) 473 rti = qta(il,i-1) - ep(il, i)*clw(il, i) 465 474 Qmixmax(il) = Qmix(Sjmax(il)) 466 475 Qmixmin(il) = Qmix(Sjmin(il)) … … 590 599 lwork(il)) THEN 591 600 IF (Sij(il,i,j)>0.0) THEN 592 rti = qnk(il) - ep(il, i)*clw(il, i) 601 !! rti = qnk(il) - ep(il, i)*clw(il, i) 602 rti = qta(il,i-1) - ep(il, i)*clw(il, i) 593 603 !!! Ment(il,i,i) = m(il,i)*abs(Qmixmax(il)*(1.-Sjmax(il)) 594 604 Ment(il, i, i) = abs(Qmixmax(il)*(1.-Sjmax(il))+Rmixmax(il) - & … … 659 669 ! cc Ment(il,i,i)=m(il,i) 660 670 Ment(il, i, i) = 1. 661 Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) 671 !! Qent(il, i, i) = qnk(il) - ep(il, i)*clw(il, i) 672 Qent(il, i, i) = qta(il,i-1) - ep(il, i)*clw(il, i) 662 673 uent(il, i, i) = unk(il) 663 674 vent(il, i, i) = vnk(il) -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv3param.h
r2905 r3605 7 7 !------------------------------------------------------------ 8 8 9 logical ok_homo_tend 10 logical ok_optim_yield 11 logical ok_entrain 12 logical ok_convstop 13 logical ok_intermittent 9 integer flag_epKEorig 10 real flag_wb 11 integer cv_flag_feed 14 12 integer noff, minorig, nl, nlp, nlm 15 integer cv_flag_feed16 integer flag_epKEorig,flag_wb17 13 real sigdz, spfac 18 14 real pbcrit, ptcrit … … 27 23 real delta 28 24 real betad 25 real ejectliq 26 real ejectice 29 27 30 28 COMMON /cv3param/ sigdz, spfac & … … 39 37 ,wbmax & 40 38 ,delta, betad & 39 ,ejectliq, ejectice & 41 40 ,flag_epKEorig & 42 41 ,flag_wb, cv_flag_feed & 43 ,noff, minorig, nl, nlp, nlm & 44 ,ok_convstop, ok_intermittent & 45 ,ok_optim_yield & 46 ,ok_entrain & 47 ,ok_homo_tend 42 ,noff, minorig, nl, nlp, nlm 48 43 !$OMP THREADPRIVATE(/cv3param/) 49 44 -
LMDZ6/branches/Ocean_skin/libf/phylmd/cv_driver.F90
r3409 r3605 568 568 ,cape,ep,hp,icb,inb,clw,nk,t,h,lv & 569 569 ,epmax_diag) 570 ! on écrase ep et recalcule hp570 ! on écrase ep et recalcule hp 571 571 END IF 572 572 … … 681 681 ! ================================================================== 682 682 SUBROUTINE cv_flag(iflag_ice_thermo) 683 684 USE ioipsl_getin_p_mod, ONLY : getin_p 685 683 686 IMPLICIT NONE 684 687 … … 693 696 cvflag_grav = .TRUE. 694 697 cvflag_ice = iflag_ice_thermo >= 1 698 ! 699 ! si icvflag_Tpa=0, alors la fraction de glace dans l'ascendance adiabatique est 700 ! fonction de la temperature de l'environnement et la temperature de l'ascendance est 701 ! calculee en deux itérations, une en supposant qu'il n'y a pas de glace et l'autre 702 ! en ajoutant la glace (ancien schéma d'Arnaud Jam). 703 ! si icvflag_Tpa=1, alors la fraction de glace dans l'ascendance adiabatique est 704 ! fonction de la temperature de l'environnement et la temperature de l'ascendance est 705 ! calculee en une seule iteration. 706 ! si icvflag_Tpa=2, alors la fraction de glace dans l'ascendance adiabatique est 707 ! fonction de la temperature de l'ascendance et la temperature de l'ascendance est 708 ! calculee en une seule iteration. 709 icvflag_Tpa=0 710 call getin_p('icvflag_Tpa', icvflag_Tpa) 695 711 696 712 RETURN -
LMDZ6/branches/Ocean_skin/libf/phylmd/cva_driver.F90
r3197 r3605 25 25 !! elij1,evap1,ep1,epmlmMm1,eplaMm1, & ! RomP 26 26 da1, phi1, mp1, phi21, d1a1, dam1, sigij1, wghti1, & ! RomP, RL 27 clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, &! RomP, RL28 wdtrainA1, wdtrain M1, qtc1, sigt1, tau_cld_cv, &27 qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP, RL 28 wdtrainA1, wdtrainS1, wdtrainM1, qtc1, sigt1, tau_cld_cv, & !!jygprl 29 29 coefw_cld_cv, & ! RomP, AJ 30 30 epmax_diag1) ! epmax_cape … … 124 124 ! of dimension ND, defined at same grid levels as T, Q, QS and P. 125 125 126 ! wdtrainA1 Real Output precipitation detrained from adiabatic draught; 126 ! wdtrainA1 Real Output precipitation ejected from adiabatic draught; 127 ! should be used in tracer transport (cvltr) 128 ! wdtrainS1 Real Output precipitation detrained from shedding of adiabatic draught; 127 129 ! used in tracer transport (cvltr) 128 130 ! wdtrainM1 Real Output precipitation detrained from mixed draughts; … … 248 250 249 251 ! RomP >>> 250 REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrain M1 ! precipitation sources (extensive)252 REAL, DIMENSION (len, nd), INTENT (OUT) :: wdtrainA1, wdtrainS1, wdtrainM1 ! precipitation sources (extensive) 251 253 REAL, DIMENSION (len, nd), INTENT (OUT) :: mp1 ! unsat. mass flux (staggered grid) 252 254 REAL, DIMENSION (len, nd), INTENT (OUT) :: da1 ! detrained mass flux of adiab. asc. air (extensive) … … 258 260 REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: sigij1 ! mass fraction of env. air in mixed draughts (intensive) 259 261 REAL, DIMENSION (len, nd, nd), INTENT (OUT) :: elij1! cond. water per unit mass of mixed draughts (intensive) 262 REAL, DIMENSION (len, nd), INTENT (OUT) :: qta1 ! total water per unit mass of the adiab. asc. (intensive) 260 263 REAL, DIMENSION (len, nd), INTENT (OUT) :: clw1 ! cond. water per unit mass of the adiab. asc. (intensive) 261 264 !JYG,RL … … 467 470 REAL tv_wake(nloc, nd) 468 471 REAL clw(nloc, nd) 472 REAL, DIMENSION(nloc, nd) :: qta, qpreca !!jygprl 469 473 REAL dph(nloc, nd) 470 474 REAL pbase(nloc), buoybase(nloc), th(nloc, nd) … … 477 481 REAL cin(nloc) 478 482 REAL m(nloc, nd) 483 REAL mm(nloc, nd) 479 484 REAL ment(nloc, nd, nd), sigij(nloc, nd, nd) 480 485 REAL qent(nloc, nd, nd) … … 494 499 REAL, DIMENSION(len,nd) :: wt, water, evap 495 500 REAL, DIMENSION(len,nd) :: ice, fondue, b 496 REAL, DIMENSION(len,nd) :: frac , faci501 REAL, DIMENSION(len,nd) :: frac_a, frac_s, faci !!jygprl 497 502 REAL ft(nloc, nd), fq(nloc, nd) 498 503 REAL ftd(nloc, nd), fqd(nloc, nd) … … 523 528 524 529 ! RomP >>> 525 REAL wdtrainA(nloc, nd), wdtrain M(nloc, nd)530 REAL wdtrainA(nloc, nd), wdtrainS(nloc, nd), wdtrainM(nloc, nd) !!jygprl 526 531 REAL da(len, nd), phi(len, nd, nd) 527 532 REAL epmlmMm(nloc, nd, nd), eplaMm(nloc, nd) … … 613 618 asupmaxmin1(:) = 0. 614 619 620 tvp(:, :) = 0. !ym missing init, need to have a look by developpers 621 tv(:, :) = 0. !ym missing init, need to have a look by developpers 622 615 623 DO il = 1, len 616 624 cin1(il) = -100000. … … 633 641 qtc1(:, :) = 0. 634 642 wdtrainA1(:, :) = 0. 643 wdtrainS1(:, :) = 0. 635 644 wdtrainM1(:, :) = 0. 636 645 da1(:, :) = 0. … … 643 652 sigij1(:, :, :) = 0. 644 653 elij1(:, :, :) = 0. 654 qta1(:,:) = 0. 645 655 clw1(:,:) = 0. 646 656 wghti1(:,:) = 0. … … 903 913 p, ph, h, tv, lv, lf, pbase, buoybase, plcl, & 904 914 inb, tp, tvp, clw, hp, ep, sigp, buoy, & 905 frac )915 frac_a, frac_s, qpreca, qta) !!jygprl 906 916 END IF 907 917 … … 912 922 tnk, qnk, gznk, t, q, qs, gz, & 913 923 p, dph, h, tv, lv, & 914 inb, inbis, tp, tvp, clw, hp, ep, sigp, frac )924 inb, inbis, tp, tvp, clw, hp, ep, sigp, frac_s) 915 925 END IF 916 926 … … 920 930 PRINT *, 'cva_driver -> cv3_epmax_cape' 921 931 call cv3_epmax_fn_cape(nloc,ncum,nd & 922 , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac &932 , ep,hp,icb,inb,clw,nk,t,h,hnk,lv,lf,frac_s & 923 933 , pbase, p, ph, tv, buoy, sig, w0,iflag & 924 934 , epmax_diag) … … 938 948 PRINT *, 'cva_driver -> cv3p_mixing' 939 949 CALL cv3p_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd 940 ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, & 950 !! ph, t, q, qs, u, v, tra, h, lv, lf, frac, qnk, & 951 ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qta, & !!jygprl 941 952 unk, vnk, hp, tv, tvp, ep, clw, sig, & 942 953 ment, qent, hent, uent, vent, nent, & … … 1018 1029 PRINT *, 'cva_driver -> cv3_mixing' 1019 1030 CALL cv3_mixing(nloc, ncum, nd, nd, ntra, icb, nk, inb, & ! na->nd 1020 ph, t, q, qs, u, v, tra, h, lv, lf, frac , qnk, &1031 ph, t, q, qs, u, v, tra, h, lv, lf, frac_s, qnk, & 1021 1032 unk, vnk, hp, tv, tvp, ep, clw, m, sig, & 1022 1033 ment, qent, uent, vent, nent, sigij, elij, ments, qents, traent) 1023 1034 CALL zilch(hent, nloc*nd*nd) 1024 1035 ELSE 1025 CALL cv3_mixscale(nloc, ncum, nd, ment, m) 1036 !!jyg: Essais absurde pour voir 1037 !! mm(:,1) = 0. 1038 !! DO i = 2,nd 1039 !! mm(:,i) = m(:,i)*(1.-qta(:,i-1)) 1040 !! ENDDO 1041 mm(:,:) = m(:,:) 1042 CALL cv3_mixscale(nloc, ncum, nd, ment, mm) 1026 1043 IF (debut) THEN 1027 1044 PRINT *, ' cv3_mixscale-> ' … … 1059 1076 t_wake, q_wake, qs_wake, gz, u, v, tra, p, ph, & 1060 1077 th_wake, tv_wake, lv_wake, lf_wake, cpn_wake, & 1061 ep, sigp, clw, &1078 ep, sigp, clw, frac_s, qpreca, frac_a, qta, & !!jygprl 1062 1079 m, ment, elij, delt, plcl, coef_clos, & 1063 1080 mp, qp, up, vp, trap, wt, water, evap, fondue, ice, & 1064 1081 faci, b, sigd, & 1065 wdtrainA, wdtrainM) ! RomP 1082 !! wdtrainA, wdtrainM) ! RomP 1083 wdtrainA, wdtrainS, wdtrainM) !!jygprl 1066 1084 ! 1067 1085 IF (prt_level >= 10) THEN … … 1072 1090 evap(igout,k), fondue(igout,k) 1073 1091 ENDDO 1074 Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrain M '1092 Print *, 'cva_driver after cv3_unsat: wdtrainA, wdtrainS, wdtrainM ' !!jygprl 1075 1093 DO k = 1,nd 1076 write (6, '(i4, 2(1x,e13.6))'), &1077 k, wdtrainA(igout,k), wdtrain M(igout,k)1094 write (6, '(i4,3(1x,e13.6))'), & 1095 k, wdtrainA(igout,k), wdtrainS(igout,k), wdtrainM(igout,k) !!jygprl 1078 1096 ENDDO 1079 1097 ENDIF … … 1109 1127 t, q, t_wake, q_wake, s_wake, u, v, tra, & 1110 1128 gz, p, ph, h, hp, lv, lf, cpn, th, th_wake, & 1111 ep, clw, m, tp, mp, qp, up, vp, trap, &1129 ep, clw, qpreca, m, tp, mp, qp, up, vp, trap, & 1112 1130 wt, water, ice, evap, fondue, faci, b, sigd, & 1113 1131 ment, qent, hent, iflag_mix, uent, vent, & … … 1118 1136 !! tls, tps, & ! useless . jyg 1119 1137 qcondc, wd, & 1120 ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv) 1138 !! ftd, fqd, qnk, qtc, sigt, tau_cld_cv, coefw_cld_cv) 1139 ftd, fqd, qta, qtc, sigt, tau_cld_cv, coefw_cld_cv) !!jygprl 1140 ! 1141 ! Test conseravtion de l'eau 1121 1142 ! 1122 1143 IF (debut) THEN … … 1139 1160 t, q, u, v, & 1140 1161 gz, p, ph, h, hp, lv, cpn, & 1141 ep, clw, frac , m, mp, qp, up, vp, &1162 ep, clw, frac_s, m, mp, qp, up, vp, & 1142 1163 wt, water, evap, & 1143 1164 ment, qent, uent, vent, nent, elij, & … … 1184 1205 asupmaxmin, & 1185 1206 da, phi, mp, phi2, d1a, dam, sigij, & ! RomP 1186 clw, elij, evap, ep, epmlmMm, eplaMm, &! RomP1187 wdtrainA, wdtrain M, & ! RomP1207 qta, clw, elij, evap, ep, epmlmMm, eplaMm, & ! RomP 1208 wdtrainA, wdtrainS, wdtrainM, & ! RomP 1188 1209 qtc, sigt, epmax_diag, & ! epmax_cape 1189 1210 iflag1, kbas1, ktop1, & … … 1196 1217 Plim11, plim21, asupmax1, supmax01, & 1197 1218 asupmaxmin1, & 1198 da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP1199 clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP1200 wdtrainA1, wdtrain M1,& ! RomP1219 da1, phi1, mp1, phi21, d1a1, dam1, sigij1, & ! RomP 1220 qta1, clw1, elij1, evap1, ep1, epmlmMm1, eplaMm1, & ! RomP 1221 wdtrainA1, wdtrainS1, wdtrainM1, & ! RomP 1201 1222 qtc1, sigt1, epmax_diag1) ! epmax_cape 1202 1223 ! -
LMDZ6/branches/Ocean_skin/libf/phylmd/cvflag.h
r1992 r3605 4 4 logical cvflag_grav 5 5 logical cvflag_ice 6 logical ok_optim_yield 7 logical ok_entrain 8 logical ok_homo_tend 9 logical ok_convstop 10 logical ok_intermittent 11 logical cvflag_prec_eject 12 logical qsat_depends_on_qt 13 logical adiab_ascent_mass_flux_depends_on_ejectliq 14 logical keepbug_ice_frac 15 integer icvflag_Tpa 6 16 7 COMMON /cvflag/ cvflag_grav, cvflag_ice 17 COMMON /cvflag/ icvflag_Tpa, & 18 cvflag_grav, cvflag_ice, & 19 ok_optim_yield, & 20 ok_entrain, & 21 ok_homo_tend, & 22 ok_convstop, ok_intermittent, & 23 cvflag_prec_eject, & 24 qsat_depends_on_qt, & 25 adiab_ascent_mass_flux_depends_on_ejectliq, & 26 keepbug_ice_frac 8 27 !$OMP THREADPRIVATE(/cvflag/) -
LMDZ6/branches/Ocean_skin/libf/phylmd/dimphy.F90
-
Property
svn:keywords
changed from
Author Date Id Revision
toId
r2656 r3605 1 MODULE dimphy 1 ! 2 ! $Id$ 3 ! 4 MODULE dimphy 2 5 3 6 INTEGER,SAVE :: klon … … 33 36 !$OMP END MASTER 34 37 ALLOCATE(zmasq(klon)) 38 zmasq=0. 35 39 36 40 END SUBROUTINE Init_dimphy 37 41 42 SUBROUTINE Init_dimphy1D(klon0,klev0) 43 ! 1D special version of dimphy without ALLOCATE(zmasq) 44 ! which will be allocated in iniphysiq 45 IMPLICIT NONE 46 47 INTEGER, INTENT(in) :: klon0 48 INTEGER, INTENT(in) :: klev0 49 50 klon=klon0 51 kdlon=klon 52 kidia=1 53 kfdia=klon 54 klev=klev0 55 klevp1=klev+1 56 klevm1=klev-1 57 kflev=klev 58 59 END SUBROUTINE Init_dimphy1D 60 38 61 39 62 END MODULE dimphy -
Property
svn:keywords
changed from
-
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1DUTILS.h
-
Property
svn:keywords
set to
Id
r3316 r3605 2 2 3 3 ! 4 ! $Id : conf_unicol.F 1279 2010-08-04 17:20:56Z lahellec$4 ! $Id$ 5 5 ! 6 6 ! … … 540 540 CALL getin('nudging_w',nudging_w) 541 541 542 ! RELIQUE ANCIENS FORMAT. ECRASE PAR LE SUIVANT 542 543 !Config Key = nudging_q 543 544 !Config Desc = forcage ou non par nudging sur q 544 545 !Config Def = false 545 546 !Config Help = forcage ou non par nudging sur q 546 nudging_q =0 547 CALL getin('nudging_q',nudging_q) 547 nudging_qv =0 548 CALL getin('nudging_q',nudging_qv) 549 CALL getin('nudging_qv',nudging_qv) 550 551 p_nudging_u=11000. 552 p_nudging_v=11000. 553 p_nudging_t=11000. 554 p_nudging_qv=11000. 555 CALL getin('p_nudging_u',p_nudging_u) 556 CALL getin('p_nudging_v',p_nudging_v) 557 CALL getin('p_nudging_t',p_nudging_t) 558 CALL getin('p_nudging_qv',p_nudging_qv) 548 559 549 560 !Config Key = nudging_t … … 599 610 write(lunout,*)' nudging_v = ', nudging_v 600 611 write(lunout,*)' nudging_t = ', nudging_t 601 write(lunout,*)' nudging_q = ', nudging_q612 write(lunout,*)' nudging_qv = ', nudging_qv 602 613 IF (forcing_type .eq.40) THEN 603 614 write(lunout,*) '--- Forcing type GCSS Old --- with:' … … 814 825 character*80 abort_message 815 826 ! 816 INTEGER nb 817 SAVE nb 818 DATA nb / 0 / 827 INTEGER pass 819 828 820 829 CALL open_restartphy(fichnom) … … 828 837 ENDDO 829 838 830 831 832 833 834 835 839 ! modname = 'dyn1dredem' 840 ! ierr = NF_OPEN(fichnom, NF_WRITE, nid) 841 ! IF (ierr .NE. NF_NOERR) THEN 842 ! abort_message="Pb. d ouverture "//fichnom 843 ! CALL abort_gcm('Modele 1D',abort_message,1) 844 ! ENDIF 836 845 837 846 DO l=1,length … … 885 894 tab_cntrl(31) = FLOAT(itau_dyn + itaufin) 886 895 ! 887 CALL put_var("controle","Param. de controle Dyn1D",tab_cntrl) 896 DO pass=1,2 897 CALL put_var(pass,"controle","Param. de controle Dyn1D",tab_cntrl) 888 898 ! 889 899 890 900 ! Ecriture/extension de la coordonnee temps 891 901 892 nb = nb + 1893 902 894 903 ! Ecriture des champs 895 904 ! 896 CALL put_field( "plev","p interfaces sauf la nulle",plev)897 CALL put_field( "play","",play)898 CALL put_field( "phi","geopotentielle",phi)899 CALL put_field( "phis","geopotentiell de surface",phis)900 CALL put_field( "presnivs","",presnivs)901 CALL put_field( "ucov","",ucov)902 CALL put_field( "vcov","",vcov)903 CALL put_field( "temp","",temp)904 CALL put_field( "omega2","",omega2)905 CALL put_field(pass,"plev","p interfaces sauf la nulle",plev) 906 CALL put_field(pass,"play","",play) 907 CALL put_field(pass,"phi","geopotentielle",phi) 908 CALL put_field(pass,"phis","geopotentiell de surface",phis) 909 CALL put_field(pass,"presnivs","",presnivs) 910 CALL put_field(pass,"ucov","",ucov) 911 CALL put_field(pass,"vcov","",vcov) 912 CALL put_field(pass,"temp","",temp) 913 CALL put_field(pass,"omega2","",omega2) 905 914 906 915 Do iq=1,nqtot 907 CALL put_field( "q"//nmq(iq),"eau vap ou condens et traceurs", &916 CALL put_field(pass,"q"//nmq(iq),"eau vap ou condens et traceurs", & 908 917 & q(:,:,iq)) 909 918 EndDo 910 CALL close_restartphy 919 IF (pass==1) CALL enddef_restartphy 920 IF (pass==2) CALL close_restartphy 921 922 923 ENDDO 911 924 912 925 ! … … 1458 1471 1459 1472 !====================================================================== 1460 SUBROUTINE read_togacoare(fich_toga,nlev_toga,nt_toga &1461 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga &1462 & ,ht_toga,vt_toga,hq_toga,vq_toga)1463 implicit none1464 1465 !-------------------------------------------------------------------------1466 ! Read TOGA-COARE forcing data1467 !-------------------------------------------------------------------------1468 1469 integer nlev_toga,nt_toga1470 real ts_toga(nt_toga),plev_toga(nlev_toga,nt_toga)1471 real t_toga(nlev_toga,nt_toga),q_toga(nlev_toga,nt_toga)1472 real u_toga(nlev_toga,nt_toga),v_toga(nlev_toga,nt_toga)1473 real w_toga(nlev_toga,nt_toga)1474 real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)1475 real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)1476 character*80 fich_toga1477 1478 integer k,ip1479 real bid1480 1481 integer iy,im,id,ih1482 1483 real plev_min1484 1485 plev_min = 55. ! pas de tendance de vap. d eau au-dessus de 55 hPa1486 1487 open(21,file=trim(fich_toga),form='formatted')1488 read(21,'(a)')1489 do ip = 1, nt_toga1490 read(21,'(a)')1491 read(21,'(a)')1492 read(21,223) iy, im, id, ih, bid, ts_toga(ip), bid,bid,bid,bid1493 read(21,'(a)')1494 read(21,'(a)')1495 1496 do k = 1, nlev_toga1497 read(21,230) plev_toga(k,ip), t_toga(k,ip), q_toga(k,ip) &1498 & ,u_toga(k,ip), v_toga(k,ip), w_toga(k,ip) &1499 & ,ht_toga(k,ip), vt_toga(k,ip), hq_toga(k,ip), vq_toga(k,ip)1500 1501 ! conversion in SI units:1502 t_toga(k,ip)=t_toga(k,ip)+273.15 ! K1503 q_toga(k,ip)=q_toga(k,ip)*0.001 ! kg/kg1504 w_toga(k,ip)=w_toga(k,ip)*100./3600. ! Pa/s1505 ! no water vapour tendency above 55 hPa1506 if (plev_toga(k,ip) .lt. plev_min) then1507 q_toga(k,ip) = 0.1508 hq_toga(k,ip) = 0.1509 vq_toga(k,ip) =0.1510 endif1511 enddo1512 1513 ts_toga(ip)=ts_toga(ip)+273.15 ! K1514 enddo1515 close(21)1516 1517 223 format(4i3,6f8.2)1518 230 format(6f9.3,4e11.3)1519 1520 return1521 end1522 1523 !-------------------------------------------------------------------------1524 SUBROUTINE read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu)1525 implicit none1526 1527 !-------------------------------------------------------------------------1528 ! Read I.SANDU case forcing data1529 !-------------------------------------------------------------------------1530 1531 integer nlev_sandu,nt_sandu1532 real ts_sandu(nt_sandu)1533 character*80 fich_sandu1534 1535 integer ip1536 integer iy,im,id,ih1537 1538 real plev_min1539 1540 print*,'nlev_sandu',nlev_sandu1541 plev_min = 55000. ! pas de tendance de vap. d eau au-dessus de 55 hPa1542 1543 open(21,file=trim(fich_sandu),form='formatted')1544 read(21,'(a)')1545 do ip = 1, nt_sandu1546 read(21,'(a)')1547 read(21,'(a)')1548 read(21,223) iy, im, id, ih, ts_sandu(ip)1549 print *,'ts=',iy,im,id,ih,ip,ts_sandu(ip)1550 enddo1551 close(21)1552 1553 223 format(4i3,f8.2)1554 1555 return1556 end1557 1558 !=====================================================================1559 !-------------------------------------------------------------------------1560 SUBROUTINE read_astex(fich_astex,nlev_astex,nt_astex,div_astex, &1561 & ts_astex,ug_astex,vg_astex,ufa_astex,vfa_astex)1562 implicit none1563 1564 !-------------------------------------------------------------------------1565 ! Read Astex case forcing data1566 !-------------------------------------------------------------------------1567 1568 integer nlev_astex,nt_astex1569 real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)1570 real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)1571 character*80 fich_astex1572 1573 integer ip1574 integer iy,im,id,ih1575 1576 real plev_min1577 1578 print*,'nlev_astex',nlev_astex1579 plev_min = 55000. ! pas de tendance de vap. d eau au-dessus de 55 hPa1580 1581 open(21,file=trim(fich_astex),form='formatted')1582 read(21,'(a)')1583 read(21,'(a)')1584 do ip = 1, nt_astex1585 read(21,'(a)')1586 read(21,'(a)')1587 read(21,223) iy, im, id, ih, div_astex(ip),ts_astex(ip), &1588 &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vfa_astex(ip)1589 ts_astex(ip)=ts_astex(ip)+273.151590 print *,'ts=',iy,im,id,ih,ip,div_astex(ip),ts_astex(ip), &1591 &ug_astex(ip),vg_astex(ip),ufa_astex(ip),vg_astex(ip)1592 enddo1593 close(21)1594 1595 223 format(4i3,e13.2,f7.2,f7.3,f7.2,f7.3,f7.2)1596 1597 return1598 end1599 !=====================================================================1600 subroutine read_twpice(fich_twpice,nlevel,ntime &1601 & ,T_srf,plev,T,q,u,v,omega &1602 & ,T_adv_h,T_adv_v,q_adv_h,q_adv_v)1603 1604 !program reading forcings of the TWP-ICE experiment1605 1606 ! use netcdf1607 1608 implicit none1609 1610 #include "netcdf.inc"1611 1612 integer ntime,nlevel1613 integer l,k1614 character*80 :: fich_twpice1615 real*8 time(ntime)1616 real*8 lat, lon, alt, phis1617 real*8 lev(nlevel)1618 real*8 plev(nlevel,ntime)1619 1620 real*8 T(nlevel,ntime)1621 real*8 q(nlevel,ntime),u(nlevel,ntime)1622 real*8 v(nlevel,ntime)1623 real*8 omega(nlevel,ntime), div(nlevel,ntime)1624 real*8 T_adv_h(nlevel,ntime)1625 real*8 T_adv_v(nlevel,ntime), q_adv_h(nlevel,ntime)1626 real*8 q_adv_v(nlevel,ntime)1627 real*8 s(nlevel,ntime), s_adv_h(nlevel,ntime)1628 real*8 s_adv_v(nlevel,ntime)1629 real*8 p_srf_aver(ntime), p_srf_center(ntime)1630 real*8 T_srf(ntime)1631 1632 integer nid, ierr1633 integer nbvar3d1634 parameter(nbvar3d=20)1635 integer var3didin(nbvar3d)1636 1637 ierr = NF_OPEN(fich_twpice,NF_NOWRITE,nid)1638 if (ierr.NE.NF_NOERR) then1639 write(*,*) 'ERROR: Pb opening forcings cdf file '1640 write(*,*) NF_STRERROR(ierr)1641 stop ""1642 endif1643 1644 ierr=NF_INQ_VARID(nid,"lat",var3didin(1))1645 if(ierr/=NF_NOERR) then1646 write(*,*) NF_STRERROR(ierr)1647 stop 'lat'1648 endif1649 1650 ierr=NF_INQ_VARID(nid,"lon",var3didin(2))1651 if(ierr/=NF_NOERR) then1652 write(*,*) NF_STRERROR(ierr)1653 stop 'lon'1654 endif1655 1656 ierr=NF_INQ_VARID(nid,"alt",var3didin(3))1657 if(ierr/=NF_NOERR) then1658 write(*,*) NF_STRERROR(ierr)1659 stop 'alt'1660 endif1661 1662 ierr=NF_INQ_VARID(nid,"phis",var3didin(4))1663 if(ierr/=NF_NOERR) then1664 write(*,*) NF_STRERROR(ierr)1665 stop 'phis'1666 endif1667 1668 ierr=NF_INQ_VARID(nid,"T",var3didin(5))1669 if(ierr/=NF_NOERR) then1670 write(*,*) NF_STRERROR(ierr)1671 stop 'T'1672 endif1673 1674 ierr=NF_INQ_VARID(nid,"q",var3didin(6))1675 if(ierr/=NF_NOERR) then1676 write(*,*) NF_STRERROR(ierr)1677 stop 'q'1678 endif1679 1680 ierr=NF_INQ_VARID(nid,"u",var3didin(7))1681 if(ierr/=NF_NOERR) then1682 write(*,*) NF_STRERROR(ierr)1683 stop 'u'1684 endif1685 1686 ierr=NF_INQ_VARID(nid,"v",var3didin(8))1687 if(ierr/=NF_NOERR) then1688 write(*,*) NF_STRERROR(ierr)1689 stop 'v'1690 endif1691 1692 ierr=NF_INQ_VARID(nid,"omega",var3didin(9))1693 if(ierr/=NF_NOERR) then1694 write(*,*) NF_STRERROR(ierr)1695 stop 'omega'1696 endif1697 1698 ierr=NF_INQ_VARID(nid,"div",var3didin(10))1699 if(ierr/=NF_NOERR) then1700 write(*,*) NF_STRERROR(ierr)1701 stop 'div'1702 endif1703 1704 ierr=NF_INQ_VARID(nid,"T_adv_h",var3didin(11))1705 if(ierr/=NF_NOERR) then1706 write(*,*) NF_STRERROR(ierr)1707 stop 'T_adv_h'1708 endif1709 1710 ierr=NF_INQ_VARID(nid,"T_adv_v",var3didin(12))1711 if(ierr/=NF_NOERR) then1712 write(*,*) NF_STRERROR(ierr)1713 stop 'T_adv_v'1714 endif1715 1716 ierr=NF_INQ_VARID(nid,"q_adv_h",var3didin(13))1717 if(ierr/=NF_NOERR) then1718 write(*,*) NF_STRERROR(ierr)1719 stop 'q_adv_h'1720 endif1721 1722 ierr=NF_INQ_VARID(nid,"q_adv_v",var3didin(14))1723 if(ierr/=NF_NOERR) then1724 write(*,*) NF_STRERROR(ierr)1725 stop 'q_adv_v'1726 endif1727 1728 ierr=NF_INQ_VARID(nid,"s",var3didin(15))1729 if(ierr/=NF_NOERR) then1730 write(*,*) NF_STRERROR(ierr)1731 stop 's'1732 endif1733 1734 ierr=NF_INQ_VARID(nid,"s_adv_h",var3didin(16))1735 if(ierr/=NF_NOERR) then1736 write(*,*) NF_STRERROR(ierr)1737 stop 's_adv_h'1738 endif1739 1740 ierr=NF_INQ_VARID(nid,"s_adv_v",var3didin(17))1741 if(ierr/=NF_NOERR) then1742 write(*,*) NF_STRERROR(ierr)1743 stop 's_adv_v'1744 endif1745 1746 ierr=NF_INQ_VARID(nid,"p_srf_aver",var3didin(18))1747 if(ierr/=NF_NOERR) then1748 write(*,*) NF_STRERROR(ierr)1749 stop 'p_srf_aver'1750 endif1751 1752 ierr=NF_INQ_VARID(nid,"p_srf_center",var3didin(19))1753 if(ierr/=NF_NOERR) then1754 write(*,*) NF_STRERROR(ierr)1755 stop 'p_srf_center'1756 endif1757 1758 ierr=NF_INQ_VARID(nid,"T_srf",var3didin(20))1759 if(ierr/=NF_NOERR) then1760 write(*,*) NF_STRERROR(ierr)1761 stop 'T_srf'1762 endif1763 1764 !dimensions lecture1765 call catchaxis(nid,ntime,nlevel,time,lev,ierr)1766 1767 !pressure1768 do l=1,ntime1769 do k=1,nlevel1770 plev(k,l)=lev(k)1771 enddo1772 enddo1773 1774 #ifdef NC_DOUBLE1775 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),lat)1776 #else1777 ierr = NF_GET_VAR_REAL(nid,var3didin(1),lat)1778 #endif1779 if(ierr/=NF_NOERR) then1780 write(*,*) NF_STRERROR(ierr)1781 stop "getvarup"1782 endif1783 ! write(*,*)'lecture lat ok',lat1784 1785 #ifdef NC_DOUBLE1786 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),lon)1787 #else1788 ierr = NF_GET_VAR_REAL(nid,var3didin(2),lon)1789 #endif1790 if(ierr/=NF_NOERR) then1791 write(*,*) NF_STRERROR(ierr)1792 stop "getvarup"1793 endif1794 ! write(*,*)'lecture lon ok',lon1795 1796 #ifdef NC_DOUBLE1797 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),alt)1798 #else1799 ierr = NF_GET_VAR_REAL(nid,var3didin(3),alt)1800 #endif1801 if(ierr/=NF_NOERR) then1802 write(*,*) NF_STRERROR(ierr)1803 stop "getvarup"1804 endif1805 ! write(*,*)'lecture alt ok',alt1806 1807 #ifdef NC_DOUBLE1808 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),phis)1809 #else1810 ierr = NF_GET_VAR_REAL(nid,var3didin(4),phis)1811 #endif1812 if(ierr/=NF_NOERR) then1813 write(*,*) NF_STRERROR(ierr)1814 stop "getvarup"1815 endif1816 ! write(*,*)'lecture phis ok',phis1817 1818 #ifdef NC_DOUBLE1819 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),T)1820 #else1821 ierr = NF_GET_VAR_REAL(nid,var3didin(5),T)1822 #endif1823 if(ierr/=NF_NOERR) then1824 write(*,*) NF_STRERROR(ierr)1825 stop "getvarup"1826 endif1827 ! write(*,*)'lecture T ok'1828 1829 #ifdef NC_DOUBLE1830 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),q)1831 #else1832 ierr = NF_GET_VAR_REAL(nid,var3didin(6),q)1833 #endif1834 if(ierr/=NF_NOERR) then1835 write(*,*) NF_STRERROR(ierr)1836 stop "getvarup"1837 endif1838 ! write(*,*)'lecture q ok'1839 !q in kg/kg1840 do l=1,ntime1841 do k=1,nlevel1842 q(k,l)=q(k,l)/1000.1843 enddo1844 enddo1845 #ifdef NC_DOUBLE1846 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),u)1847 #else1848 ierr = NF_GET_VAR_REAL(nid,var3didin(7),u)1849 #endif1850 if(ierr/=NF_NOERR) then1851 write(*,*) NF_STRERROR(ierr)1852 stop "getvarup"1853 endif1854 ! write(*,*)'lecture u ok'1855 1856 #ifdef NC_DOUBLE1857 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),v)1858 #else1859 ierr = NF_GET_VAR_REAL(nid,var3didin(8),v)1860 #endif1861 if(ierr/=NF_NOERR) then1862 write(*,*) NF_STRERROR(ierr)1863 stop "getvarup"1864 endif1865 ! write(*,*)'lecture v ok'1866 1867 #ifdef NC_DOUBLE1868 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),omega)1869 #else1870 ierr = NF_GET_VAR_REAL(nid,var3didin(9),omega)1871 #endif1872 if(ierr/=NF_NOERR) then1873 write(*,*) NF_STRERROR(ierr)1874 stop "getvarup"1875 endif1876 ! write(*,*)'lecture omega ok'1877 !omega in mb/hour1878 do l=1,ntime1879 do k=1,nlevel1880 omega(k,l)=omega(k,l)*100./3600.1881 enddo1882 enddo1883 1884 #ifdef NC_DOUBLE1885 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),div)1886 #else1887 ierr = NF_GET_VAR_REAL(nid,var3didin(10),div)1888 #endif1889 if(ierr/=NF_NOERR) then1890 write(*,*) NF_STRERROR(ierr)1891 stop "getvarup"1892 endif1893 ! write(*,*)'lecture div ok'1894 1895 #ifdef NC_DOUBLE1896 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),T_adv_h)1897 #else1898 ierr = NF_GET_VAR_REAL(nid,var3didin(11),T_adv_h)1899 #endif1900 if(ierr/=NF_NOERR) then1901 write(*,*) NF_STRERROR(ierr)1902 stop "getvarup"1903 endif1904 ! write(*,*)'lecture T_adv_h ok'1905 !T adv in K/s1906 do l=1,ntime1907 do k=1,nlevel1908 T_adv_h(k,l)=T_adv_h(k,l)/3600.1909 enddo1910 enddo1911 1912 1913 #ifdef NC_DOUBLE1914 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),T_adv_v)1915 #else1916 ierr = NF_GET_VAR_REAL(nid,var3didin(12),T_adv_v)1917 #endif1918 if(ierr/=NF_NOERR) then1919 write(*,*) NF_STRERROR(ierr)1920 stop "getvarup"1921 endif1922 ! write(*,*)'lecture T_adv_v ok'1923 !T adv in K/s1924 do l=1,ntime1925 do k=1,nlevel1926 T_adv_v(k,l)=T_adv_v(k,l)/3600.1927 enddo1928 enddo1929 1930 #ifdef NC_DOUBLE1931 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),q_adv_h)1932 #else1933 ierr = NF_GET_VAR_REAL(nid,var3didin(13),q_adv_h)1934 #endif1935 if(ierr/=NF_NOERR) then1936 write(*,*) NF_STRERROR(ierr)1937 stop "getvarup"1938 endif1939 ! write(*,*)'lecture q_adv_h ok'1940 !q adv in kg/kg/s1941 do l=1,ntime1942 do k=1,nlevel1943 q_adv_h(k,l)=q_adv_h(k,l)/1000./3600.1944 enddo1945 enddo1946 1947 1948 #ifdef NC_DOUBLE1949 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),q_adv_v)1950 #else1951 ierr = NF_GET_VAR_REAL(nid,var3didin(14),q_adv_v)1952 #endif1953 if(ierr/=NF_NOERR) then1954 write(*,*) NF_STRERROR(ierr)1955 stop "getvarup"1956 endif1957 ! write(*,*)'lecture q_adv_v ok'1958 !q adv in kg/kg/s1959 do l=1,ntime1960 do k=1,nlevel1961 q_adv_v(k,l)=q_adv_v(k,l)/1000./3600.1962 enddo1963 enddo1964 1965 1966 #ifdef NC_DOUBLE1967 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),s)1968 #else1969 ierr = NF_GET_VAR_REAL(nid,var3didin(15),s)1970 #endif1971 if(ierr/=NF_NOERR) then1972 write(*,*) NF_STRERROR(ierr)1973 stop "getvarup"1974 endif1975 1976 #ifdef NC_DOUBLE1977 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),s_adv_h)1978 #else1979 ierr = NF_GET_VAR_REAL(nid,var3didin(16),s_adv_h)1980 #endif1981 if(ierr/=NF_NOERR) then1982 write(*,*) NF_STRERROR(ierr)1983 stop "getvarup"1984 endif1985 1986 #ifdef NC_DOUBLE1987 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),s_adv_v)1988 #else1989 ierr = NF_GET_VAR_REAL(nid,var3didin(17),s_adv_v)1990 #endif1991 if(ierr/=NF_NOERR) then1992 write(*,*) NF_STRERROR(ierr)1993 stop "getvarup"1994 endif1995 1996 #ifdef NC_DOUBLE1997 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),p_srf_aver)1998 #else1999 ierr = NF_GET_VAR_REAL(nid,var3didin(18),p_srf_aver)2000 #endif2001 if(ierr/=NF_NOERR) then2002 write(*,*) NF_STRERROR(ierr)2003 stop "getvarup"2004 endif2005 2006 #ifdef NC_DOUBLE2007 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),p_srf_center)2008 #else2009 ierr = NF_GET_VAR_REAL(nid,var3didin(19),p_srf_center)2010 #endif2011 if(ierr/=NF_NOERR) then2012 write(*,*) NF_STRERROR(ierr)2013 stop "getvarup"2014 endif2015 2016 #ifdef NC_DOUBLE2017 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),T_srf)2018 #else2019 ierr = NF_GET_VAR_REAL(nid,var3didin(20),T_srf)2020 #endif2021 if(ierr/=NF_NOERR) then2022 write(*,*) NF_STRERROR(ierr)2023 stop "getvarup"2024 endif2025 ! write(*,*)'lecture T_srf ok', T_srf2026 2027 return2028 end subroutine read_twpice2029 !=====================================================================2030 subroutine catchaxis(nid,ttm,llm,time,lev,ierr)2031 2032 ! use netcdf2033 2034 implicit none2035 #include "netcdf.inc"2036 integer nid,ttm,llm2037 real*8 time(ttm)2038 real*8 lev(llm)2039 integer ierr2040 2041 integer timevar,levvar2042 integer timelen,levlen2043 integer timedimin,levdimin2044 2045 ! Control & lecture on dimensions2046 ! ===============================2047 ierr=NF_INQ_DIMID(nid,"time",timedimin)2048 ierr=NF_INQ_VARID(nid,"time",timevar)2049 if (ierr.NE.NF_NOERR) then2050 write(*,*) 'ERROR: Field <time> is missing'2051 stop ""2052 endif2053 ierr=NF_INQ_DIMLEN(nid,timedimin,timelen)2054 2055 ierr=NF_INQ_DIMID(nid,"lev",levdimin)2056 ierr=NF_INQ_VARID(nid,"lev",levvar)2057 if (ierr.NE.NF_NOERR) then2058 write(*,*) 'ERROR: Field <lev> is lacking'2059 stop ""2060 endif2061 ierr=NF_INQ_DIMLEN(nid,levdimin,levlen)2062 2063 if((timelen/=ttm).or.(levlen/=llm)) then2064 write(*,*) 'ERROR: Not the good lenght for axis'2065 write(*,*) 'longitude: ',timelen,ttm+12066 write(*,*) 'latitude: ',levlen,llm2067 stop ""2068 endif2069 2070 !#ifdef NC_DOUBLE2071 ierr = NF_GET_VAR_DOUBLE(nid,timevar,time)2072 ierr = NF_GET_VAR_DOUBLE(nid,levvar,lev)2073 !#else2074 ! ierr = NF_GET_VAR_REAL(nid,timevar,time)2075 ! ierr = NF_GET_VAR_REAL(nid,levvar,lev)2076 !#endif2077 2078 return2079 end2080 !=====================================================================2081 2082 SUBROUTINE interp_sandu_vertical(play,nlev_sandu,plev_prof &2083 & ,t_prof,thl_prof,q_prof,u_prof,v_prof,w_prof &2084 & ,omega_prof,o3mmr_prof &2085 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod &2086 & ,omega_mod,o3mmr_mod,mxcalc)2087 2088 implicit none2089 2090 #include "dimensions.h"2091 2092 !-------------------------------------------------------------------------2093 ! Vertical interpolation of SANDUREF forcing data onto model levels2094 !-------------------------------------------------------------------------2095 2096 integer nlevmax2097 parameter (nlevmax=41)2098 integer nlev_sandu,mxcalc2099 ! real play(llm), plev_prof(nlevmax)2100 ! real t_prof(nlevmax),q_prof(nlevmax)2101 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2102 ! real ht_prof(nlevmax),vt_prof(nlevmax)2103 ! real hq_prof(nlevmax),vq_prof(nlevmax)2104 2105 real play(llm), plev_prof(nlev_sandu)2106 real t_prof(nlev_sandu),thl_prof(nlev_sandu),q_prof(nlev_sandu)2107 real u_prof(nlev_sandu),v_prof(nlev_sandu), w_prof(nlev_sandu)2108 real omega_prof(nlev_sandu),o3mmr_prof(nlev_sandu)2109 2110 real t_mod(llm),thl_mod(llm),q_mod(llm)2111 real u_mod(llm),v_mod(llm), w_mod(llm)2112 real omega_mod(llm),o3mmr_mod(llm)2113 2114 integer l,k,k1,k22115 real frac,frac1,frac2,fact2116 2117 do l = 1, llm2118 2119 if (play(l).ge.plev_prof(nlev_sandu)) then2120 2121 mxcalc=l2122 k1=02123 k2=02124 2125 if (play(l).le.plev_prof(1)) then2126 2127 do k = 1, nlev_sandu-12128 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2129 k1=k2130 k2=k+12131 endif2132 enddo2133 2134 if (k1.eq.0 .or. k2.eq.0) then2135 write(*,*) 'PB! k1, k2 = ',k1,k22136 write(*,*) 'l,play(l) = ',l,play(l)/1002137 do k = 1, nlev_sandu-12138 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002139 enddo2140 endif2141 2142 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2143 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2144 thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))2145 q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))2146 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2147 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2148 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2149 omega_mod(l)=omega_prof(k2)-frac*(omega_prof(k2)-omega_prof(k1))2150 o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))2151 2152 else !play>plev_prof(1)2153 2154 k1=12155 k2=22156 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2157 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2158 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2159 thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)2160 q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)2161 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2162 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2163 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2164 omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)2165 o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)2166 2167 endif ! play.le.plev_prof(1)2168 2169 else ! above max altitude of forcing file2170 2171 !jyg2172 fact=20.*(plev_prof(nlev_sandu)-play(l))/plev_prof(nlev_sandu) !jyg2173 fact = max(fact,0.) !jyg2174 fact = exp(-fact) !jyg2175 t_mod(l)= t_prof(nlev_sandu) !jyg2176 thl_mod(l)= thl_prof(nlev_sandu) !jyg2177 q_mod(l)= q_prof(nlev_sandu)*fact !jyg2178 u_mod(l)= u_prof(nlev_sandu)*fact !jyg2179 v_mod(l)= v_prof(nlev_sandu)*fact !jyg2180 w_mod(l)= w_prof(nlev_sandu)*fact !jyg2181 omega_mod(l)= omega_prof(nlev_sandu)*fact !jyg2182 o3mmr_mod(l)= o3mmr_prof(nlev_sandu)*fact !jyg2183 2184 endif ! play2185 2186 enddo ! l2187 2188 do l = 1,llm2189 ! print *,'t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l) ',2190 ! $ l,t_mod(l),thl_mod(l),q_mod(l),u_mod(l),v_mod(l)2191 enddo2192 2193 return2194 end2195 !=====================================================================2196 SUBROUTINE interp_astex_vertical(play,nlev_astex,plev_prof &2197 & ,t_prof,thl_prof,qv_prof,ql_prof,qt_prof,u_prof,v_prof &2198 & ,w_prof,tke_prof,o3mmr_prof &2199 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod &2200 & ,tke_mod,o3mmr_mod,mxcalc)2201 2202 implicit none2203 2204 #include "dimensions.h"2205 2206 !-------------------------------------------------------------------------2207 ! Vertical interpolation of Astex forcing data onto model levels2208 !-------------------------------------------------------------------------2209 2210 integer nlevmax2211 parameter (nlevmax=41)2212 integer nlev_astex,mxcalc2213 ! real play(llm), plev_prof(nlevmax)2214 ! real t_prof(nlevmax),qv_prof(nlevmax)2215 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2216 ! real ht_prof(nlevmax),vt_prof(nlevmax)2217 ! real hq_prof(nlevmax),vq_prof(nlevmax)2218 2219 real play(llm), plev_prof(nlev_astex)2220 real t_prof(nlev_astex),thl_prof(nlev_astex),qv_prof(nlev_astex)2221 real u_prof(nlev_astex),v_prof(nlev_astex), w_prof(nlev_astex)2222 real o3mmr_prof(nlev_astex),ql_prof(nlev_astex)2223 real qt_prof(nlev_astex),tke_prof(nlev_astex)2224 2225 real t_mod(llm),thl_mod(llm),qv_mod(llm)2226 real u_mod(llm),v_mod(llm), w_mod(llm),tke_mod(llm)2227 real o3mmr_mod(llm),ql_mod(llm),qt_mod(llm)2228 2229 integer l,k,k1,k22230 real frac,frac1,frac2,fact2231 2232 do l = 1, llm2233 2234 if (play(l).ge.plev_prof(nlev_astex)) then2235 2236 mxcalc=l2237 k1=02238 k2=02239 2240 if (play(l).le.plev_prof(1)) then2241 2242 do k = 1, nlev_astex-12243 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2244 k1=k2245 k2=k+12246 endif2247 enddo2248 2249 if (k1.eq.0 .or. k2.eq.0) then2250 write(*,*) 'PB! k1, k2 = ',k1,k22251 write(*,*) 'l,play(l) = ',l,play(l)/1002252 do k = 1, nlev_astex-12253 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002254 enddo2255 endif2256 2257 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2258 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2259 thl_mod(l)= thl_prof(k2) - frac*(thl_prof(k2)-thl_prof(k1))2260 qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))2261 ql_mod(l)= ql_prof(k2) - frac*(ql_prof(k2)-ql_prof(k1))2262 qt_mod(l)= qt_prof(k2) - frac*(qt_prof(k2)-qt_prof(k1))2263 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2264 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2265 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2266 tke_mod(l)= tke_prof(k2) - frac*(tke_prof(k2)-tke_prof(k1))2267 o3mmr_mod(l)=o3mmr_prof(k2)-frac*(o3mmr_prof(k2)-o3mmr_prof(k1))2268 2269 else !play>plev_prof(1)2270 2271 k1=12272 k2=22273 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2274 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2275 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2276 thl_mod(l)= frac1*thl_prof(k1) - frac2*thl_prof(k2)2277 qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)2278 ql_mod(l)= frac1*ql_prof(k1) - frac2*ql_prof(k2)2279 qt_mod(l)= frac1*qt_prof(k1) - frac2*qt_prof(k2)2280 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2281 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2282 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2283 tke_mod(l)= frac1*tke_prof(k1) - frac2*tke_prof(k2)2284 o3mmr_mod(l)= frac1*o3mmr_prof(k1) - frac2*o3mmr_prof(k2)2285 2286 endif ! play.le.plev_prof(1)2287 2288 else ! above max altitude of forcing file2289 2290 !jyg2291 fact=20.*(plev_prof(nlev_astex)-play(l))/plev_prof(nlev_astex) !jyg2292 fact = max(fact,0.) !jyg2293 fact = exp(-fact) !jyg2294 t_mod(l)= t_prof(nlev_astex) !jyg2295 thl_mod(l)= thl_prof(nlev_astex) !jyg2296 qv_mod(l)= qv_prof(nlev_astex)*fact !jyg2297 ql_mod(l)= ql_prof(nlev_astex)*fact !jyg2298 qt_mod(l)= qt_prof(nlev_astex)*fact !jyg2299 u_mod(l)= u_prof(nlev_astex)*fact !jyg2300 v_mod(l)= v_prof(nlev_astex)*fact !jyg2301 w_mod(l)= w_prof(nlev_astex)*fact !jyg2302 tke_mod(l)= tke_prof(nlev_astex)*fact !jyg2303 o3mmr_mod(l)= o3mmr_prof(nlev_astex)*fact !jyg2304 2305 endif ! play2306 2307 enddo ! l2308 2309 do l = 1,llm2310 ! print *,'t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l) ',2311 ! $ l,t_mod(l),thl_mod(l),qv_mod(l),u_mod(l),v_mod(l)2312 enddo2313 2314 return2315 end2316 2317 !======================================================================2318 SUBROUTINE read_rico(fich_rico,nlev_rico,ps_rico,play &2319 & ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico &2320 & ,dth_dyn,dqh_dyn)2321 implicit none2322 2323 !-------------------------------------------------------------------------2324 ! Read RICO forcing data2325 !-------------------------------------------------------------------------2326 #include "dimensions.h"2327 2328 2329 integer nlev_rico2330 real ts_rico,ps_rico2331 real t_rico(llm),q_rico(llm)2332 real u_rico(llm),v_rico(llm)2333 real w_rico(llm)2334 real dth_dyn(llm)2335 real dqh_dyn(llm)2336 2337 2338 real play(llm),zlay(llm)2339 2340 2341 real prico(nlev_rico),zrico(nlev_rico)2342 2343 character*80 fich_rico2344 2345 integer k,l2346 2347 2348 print*,fich_rico2349 open(21,file=trim(fich_rico),form='formatted')2350 do k=1,llm2351 zlay(k)=0.2352 enddo2353 2354 read(21,*) ps_rico,ts_rico2355 prico(1)=ps_rico2356 zrico(1)=0.02357 do l=2,nlev_rico2358 read(21,*) k,prico(l),zrico(l)2359 enddo2360 close(21)2361 2362 do k=1,llm2363 do l=1,802364 if(prico(l)>play(k)) then2365 if(play(k)>prico(l+1)) then2366 zlay(k)=zrico(l)+(play(k)-prico(l)) * &2367 & (zrico(l+1)-zrico(l))/(prico(l+1)-prico(l))2368 else2369 zlay(k)=zrico(l)+(play(k)-prico(80))* &2370 & (zrico(81)-zrico(80))/(prico(81)-prico(80))2371 endif2372 endif2373 enddo2374 print*,k,zlay(k)2375 ! U2376 if(0 < zlay(k) .and. zlay(k) < 4000) then2377 u_rico(k)=-9.9 + (-1.9 + 9.9)*zlay(k)/40002378 elseif(4000 < zlay(k) .and. zlay(k) < 12000) then2379 u_rico(k)= -1.9 + (30.0 + 1.9) / &2380 & (12000 - 4000) * (zlay(k) - 4000)2381 elseif(12000 < zlay(k) .and. zlay(k) < 13000) then2382 u_rico(k)=30.02383 elseif(13000 < zlay(k) .and. zlay(k) < 20000) then2384 u_rico(k)=30.0 - (30.0) / &2385 & (20000 - 13000) * (zlay(k) - 13000)2386 else2387 u_rico(k)=0.02388 endif2389 2390 !Q_v2391 if(0 < zlay(k) .and. zlay(k) < 740) then2392 q_rico(k)=16.0 + (13.8 - 16.0) / (740) * zlay(k)2393 elseif(740 < zlay(k) .and. zlay(k) < 3260) then2394 q_rico(k)=13.8 + (2.4 - 13.8) / &2395 & (3260 - 740) * (zlay(k) - 740)2396 elseif(3260 < zlay(k) .and. zlay(k) < 4000) then2397 q_rico(k)=2.4 + (1.8 - 2.4) / &2398 & (4000 - 3260) * (zlay(k) - 3260)2399 elseif(4000 < zlay(k) .and. zlay(k) < 9000) then2400 q_rico(k)=1.8 + (0 - 1.8) / &2401 & (9000 - 4000) * (zlay(k) - 4000)2402 else2403 q_rico(k)=0.02404 endif2405 2406 !T2407 if(0 < zlay(k) .and. zlay(k) < 740) then2408 t_rico(k)=299.2 + (292.0 - 299.2) / (740) * zlay(k)2409 elseif(740 < zlay(k) .and. zlay(k) < 4000) then2410 t_rico(k)=292.0 + (278.0 - 292.0) / &2411 & (4000 - 740) * (zlay(k) - 740)2412 elseif(4000 < zlay(k) .and. zlay(k) < 15000) then2413 t_rico(k)=278.0 + (203.0 - 278.0) / &2414 & (15000 - 4000) * (zlay(k) - 4000)2415 elseif(15000 < zlay(k) .and. zlay(k) < 17500) then2416 t_rico(k)=203.0 + (194.0 - 203.0) / &2417 & (17500 - 15000)* (zlay(k) - 15000)2418 elseif(17500 < zlay(k) .and. zlay(k) < 20000) then2419 t_rico(k)=194.0 + (206.0 - 194.0) / &2420 & (20000 - 17500)* (zlay(k) - 17500)2421 elseif(20000 < zlay(k) .and. zlay(k) < 60000) then2422 t_rico(k)=206.0 + (270.0 - 206.0) / &2423 & (60000 - 20000)* (zlay(k) - 20000)2424 endif2425 2426 ! W2427 if(0 < zlay(k) .and. zlay(k) < 2260 ) then2428 w_rico(k)=- (0.005/2260) * zlay(k)2429 elseif(2260 < zlay(k) .and. zlay(k) < 4000 ) then2430 w_rico(k)=- 0.0052431 elseif(4000 < zlay(k) .and. zlay(k) < 5000 ) then2432 w_rico(k)=- 0.005 + (0.005/ (5000 - 4000)) * (zlay(k) - 4000)2433 else2434 w_rico(k)=0.02435 endif2436 2437 ! dThrz+dTsw0+dTlw02438 if(0 < zlay(k) .and. zlay(k) < 4000) then2439 dth_dyn(k)=- 2.51 / 86400 + (-2.18 + 2.51 )/ &2440 & (86400*4000) * zlay(k)2441 elseif(4000 < zlay(k) .and. zlay(k) < 5000) then2442 dth_dyn(k)=- 2.18 / 86400 + ( 2.18 ) / &2443 & (86400*(5000 - 4000)) * (zlay(k) - 4000)2444 else2445 dth_dyn(k)=0.02446 endif2447 ! dQhrz2448 if(0 < zlay(k) .and. zlay(k) < 3000) then2449 dqh_dyn(k)=-1.0 / 86400 + (0.345 + 1.0)/ &2450 & (86400*3000) * (zlay(k))2451 elseif(3000 < zlay(k) .and. zlay(k) < 4000) then2452 dqh_dyn(k)=0.345 / 864002453 elseif(4000 < zlay(k) .and. zlay(k) < 5000) then2454 dqh_dyn(k)=0.345 / 86400 + &2455 & (-0.345)/(86400 * (5000 - 4000)) * (zlay(k)-4000)2456 else2457 dqh_dyn(k)=0.02458 endif2459 2460 !? if(play(k)>6e4) then2461 !? ratqs0(1,k)=ratqsbas*(plev(1)-play(k))/(plev(1)-6e4)2462 !? elseif((play(k)>3e4).and.(play(k)<6e4)) then2463 !? ratqs0(1,k)=ratqsbas+(ratqshaut-ratqsbas)&2464 !? *(6e4-play(k))/(6e4-3e4)2465 !? else2466 !? ratqs0(1,k)=ratqshaut2467 !? endif2468 2469 enddo2470 2471 do k=1,llm2472 q_rico(k)=q_rico(k)/1e32473 dqh_dyn(k)=dqh_dyn(k)/1e32474 v_rico(k)=-3.82475 enddo2476 2477 return2478 end2479 2480 !======================================================================2481 SUBROUTINE interp_sandu_time(day,day1,annee_ref &2482 & ,year_ini_sandu,day_ini_sandu,nt_sandu,dt_sandu &2483 & ,nlev_sandu,ts_sandu,ts_prof)2484 implicit none2485 2486 !---------------------------------------------------------------------------------------2487 ! Time interpolation of a 2D field to the timestep corresponding to day2488 !2489 ! day: current julian day (e.g. 717538.2)2490 ! day1: first day of the simulation2491 ! nt_sandu: total nb of data in the forcing (e.g. 13 for Sanduref)2492 ! dt_sandu: total time interval (in sec) between 2 forcing data (e.g. 6h for Sanduref)2493 !---------------------------------------------------------------------------------------2494 ! inputs:2495 integer annee_ref2496 integer nt_sandu,nlev_sandu2497 integer year_ini_sandu2498 real day, day1,day_ini_sandu,dt_sandu2499 real ts_sandu(nt_sandu)2500 ! outputs:2501 real ts_prof2502 ! local:2503 integer it_sandu1, it_sandu22504 real timeit,time_sandu1,time_sandu2,frac2505 ! Check that initial day of the simulation consistent with SANDU period:2506 if (annee_ref.ne.2006 ) then2507 print*,'Pour SANDUREF, annee_ref doit etre 2006 '2508 print*,'Changer annee_ref dans run.def'2509 stop2510 endif2511 ! if (annee_ref.eq.2006 .and. day1.lt.day_ini_sandu) then2512 ! print*,'SANDUREF debute le 15 Juillet 2006 (jour julien=196)'2513 ! print*,'Changer dayref dans run.def'2514 ! stop2515 ! endif2516 2517 ! Determine timestep relative to the 1st day of TOGA-COARE:2518 ! timeit=(day-day1)*86400.2519 ! if (annee_ref.eq.1992) then2520 ! timeit=(day-day_ini_sandu)*86400.2521 ! else2522 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19922523 ! endif2524 timeit=(day-day_ini_sandu)*864002525 2526 ! Determine the closest observation times:2527 it_sandu1=INT(timeit/dt_sandu)+12528 it_sandu2=it_sandu1 + 12529 time_sandu1=(it_sandu1-1)*dt_sandu2530 time_sandu2=(it_sandu2-1)*dt_sandu2531 print *,'timeit day day_ini_sandu',timeit,day,day_ini_sandu2532 print *,'it_sandu1,it_sandu2,time_sandu1,time_sandu2', &2533 & it_sandu1,it_sandu2,time_sandu1,time_sandu22534 2535 if (it_sandu1 .ge. nt_sandu) then2536 write(*,*) 'PB-stop: day, it_sandu1, it_sandu2, timeit: ' &2537 & ,day,it_sandu1,it_sandu2,timeit/86400.2538 stop2539 endif2540 2541 ! time interpolation:2542 frac=(time_sandu2-timeit)/(time_sandu2-time_sandu1)2543 frac=max(frac,0.0)2544 2545 ts_prof = ts_sandu(it_sandu2) &2546 & -frac*(ts_sandu(it_sandu2)-ts_sandu(it_sandu1))2547 2548 print*, &2549 &'day,annee_ref,day_ini_sandu,timeit,it_sandu1,it_sandu2,SST:', &2550 &day,annee_ref,day_ini_sandu,timeit/86400.,it_sandu1, &2551 &it_sandu2,ts_prof2552 2553 return2554 END2555 !=====================================================================2556 !-------------------------------------------------------------------------2557 SUBROUTINE read_armcu(fich_armcu,nlev_armcu,nt_armcu, &2558 & sens,flat,adv_theta,rad_theta,adv_qt)2559 implicit none2560 2561 !-------------------------------------------------------------------------2562 ! Read ARM_CU case forcing data2563 !-------------------------------------------------------------------------2564 2565 integer nlev_armcu,nt_armcu2566 real sens(nt_armcu),flat(nt_armcu)2567 real adv_theta(nt_armcu),rad_theta(nt_armcu),adv_qt(nt_armcu)2568 character*80 fich_armcu2569 2570 integer ip2571 2572 integer iy,im,id,ih,in2573 2574 print*,'nlev_armcu',nlev_armcu2575 2576 open(21,file=trim(fich_armcu),form='formatted')2577 read(21,'(a)')2578 do ip = 1, nt_armcu2579 read(21,'(a)')2580 read(21,'(a)')2581 read(21,223) iy, im, id, ih, in, sens(ip),flat(ip), &2582 & adv_theta(ip),rad_theta(ip),adv_qt(ip)2583 print *,'forcages=',iy,im,id,ih,in, sens(ip),flat(ip), &2584 & adv_theta(ip),rad_theta(ip),adv_qt(ip)2585 enddo2586 close(21)2587 2588 223 format(5i3,5f8.3)2589 2590 return2591 end2592 2593 !=====================================================================2594 SUBROUTINE interp_toga_vertical(play,nlev_toga,plev_prof &2595 & ,t_prof,q_prof,u_prof,v_prof,w_prof &2596 & ,ht_prof,vt_prof,hq_prof,vq_prof &2597 & ,t_mod,q_mod,u_mod,v_mod,w_mod &2598 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc)2599 2600 implicit none2601 2602 #include "dimensions.h"2603 2604 !-------------------------------------------------------------------------2605 ! Vertical interpolation of TOGA-COARE forcing data onto model levels2606 !-------------------------------------------------------------------------2607 2608 integer nlevmax2609 parameter (nlevmax=41)2610 integer nlev_toga,mxcalc2611 ! real play(llm), plev_prof(nlevmax)2612 ! real t_prof(nlevmax),q_prof(nlevmax)2613 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2614 ! real ht_prof(nlevmax),vt_prof(nlevmax)2615 ! real hq_prof(nlevmax),vq_prof(nlevmax)2616 2617 real play(llm), plev_prof(nlev_toga)2618 real t_prof(nlev_toga),q_prof(nlev_toga)2619 real u_prof(nlev_toga),v_prof(nlev_toga), w_prof(nlev_toga)2620 real ht_prof(nlev_toga),vt_prof(nlev_toga)2621 real hq_prof(nlev_toga),vq_prof(nlev_toga)2622 2623 real t_mod(llm),q_mod(llm)2624 real u_mod(llm),v_mod(llm), w_mod(llm)2625 real ht_mod(llm),vt_mod(llm)2626 real hq_mod(llm),vq_mod(llm)2627 2628 integer l,k,k1,k22629 real frac,frac1,frac2,fact2630 2631 do l = 1, llm2632 2633 if (play(l).ge.plev_prof(nlev_toga)) then2634 2635 mxcalc=l2636 k1=02637 k2=02638 2639 if (play(l).le.plev_prof(1)) then2640 2641 do k = 1, nlev_toga-12642 if (play(l).le.plev_prof(k).and. play(l).gt.plev_prof(k+1)) then2643 k1=k2644 k2=k+12645 endif2646 enddo2647 2648 if (k1.eq.0 .or. k2.eq.0) then2649 write(*,*) 'PB! k1, k2 = ',k1,k22650 write(*,*) 'l,play(l) = ',l,play(l)/1002651 do k = 1, nlev_toga-12652 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002653 enddo2654 endif2655 2656 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2657 t_mod(l)= t_prof(k2) - frac*(t_prof(k2)-t_prof(k1))2658 q_mod(l)= q_prof(k2) - frac*(q_prof(k2)-q_prof(k1))2659 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2660 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2661 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2662 ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))2663 vt_mod(l)= vt_prof(k2) - frac*(vt_prof(k2)-vt_prof(k1))2664 hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))2665 vq_mod(l)= vq_prof(k2) - frac*(vq_prof(k2)-vq_prof(k1))2666 2667 else !play>plev_prof(1)2668 2669 k1=12670 k2=22671 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2672 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2673 t_mod(l)= frac1*t_prof(k1) - frac2*t_prof(k2)2674 q_mod(l)= frac1*q_prof(k1) - frac2*q_prof(k2)2675 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2676 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2677 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2678 ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)2679 vt_mod(l)= frac1*vt_prof(k1) - frac2*vt_prof(k2)2680 hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)2681 vq_mod(l)= frac1*vq_prof(k1) - frac2*vq_prof(k2)2682 2683 endif ! play.le.plev_prof(1)2684 2685 else ! above max altitude of forcing file2686 2687 !jyg2688 fact=20.*(plev_prof(nlev_toga)-play(l))/plev_prof(nlev_toga) !jyg2689 fact = max(fact,0.) !jyg2690 fact = exp(-fact) !jyg2691 t_mod(l)= t_prof(nlev_toga) !jyg2692 q_mod(l)= q_prof(nlev_toga)*fact !jyg2693 u_mod(l)= u_prof(nlev_toga)*fact !jyg2694 v_mod(l)= v_prof(nlev_toga)*fact !jyg2695 w_mod(l)= 0.0 !jyg2696 ht_mod(l)= ht_prof(nlev_toga) !jyg2697 vt_mod(l)= vt_prof(nlev_toga) !jyg2698 hq_mod(l)= hq_prof(nlev_toga)*fact !jyg2699 vq_mod(l)= vq_prof(nlev_toga)*fact !jyg2700 2701 endif ! play2702 2703 enddo ! l2704 2705 ! do l = 1,llm2706 ! print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',2707 ! $ l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)2708 ! enddo2709 2710 return2711 end2712 2713 !=====================================================================2714 SUBROUTINE interp_case_vertical(play,nlev_cas,plev_prof_cas &2715 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas &2716 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas &2717 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas &2718 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas &2719 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas &2720 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc)2721 2722 implicit none2723 2724 #include "dimensions.h"2725 2726 !-------------------------------------------------------------------------2727 ! Vertical interpolation of TOGA-COARE forcing data onto mod_casel levels2728 !-------------------------------------------------------------------------2729 2730 integer nlevmax2731 parameter (nlevmax=41)2732 integer nlev_cas,mxcalc2733 ! real play(llm), plev_prof(nlevmax)2734 ! real t_prof(nlevmax),q_prof(nlevmax)2735 ! real u_prof(nlevmax),v_prof(nlevmax), w_prof(nlevmax)2736 ! real ht_prof(nlevmax),vt_prof(nlevmax)2737 ! real hq_prof(nlevmax),vq_prof(nlevmax)2738 2739 real play(llm), plev_prof_cas(nlev_cas)2740 real t_prof_cas(nlev_cas),q_prof_cas(nlev_cas)2741 real u_prof_cas(nlev_cas),v_prof_cas(nlev_cas)2742 real ug_prof_cas(nlev_cas),vg_prof_cas(nlev_cas), vitw_prof_cas(nlev_cas)2743 real du_prof_cas(nlev_cas),hu_prof_cas(nlev_cas),vu_prof_cas(nlev_cas)2744 real dv_prof_cas(nlev_cas),hv_prof_cas(nlev_cas),vv_prof_cas(nlev_cas)2745 real dt_prof_cas(nlev_cas),ht_prof_cas(nlev_cas),vt_prof_cas(nlev_cas),dtrad_prof_cas(nlev_cas)2746 real dq_prof_cas(nlev_cas),hq_prof_cas(nlev_cas),vq_prof_cas(nlev_cas)2747 2748 real t_mod_cas(llm),q_mod_cas(llm)2749 real u_mod_cas(llm),v_mod_cas(llm)2750 real ug_mod_cas(llm),vg_mod_cas(llm), w_mod_cas(llm)2751 real du_mod_cas(llm),hu_mod_cas(llm),vu_mod_cas(llm)2752 real dv_mod_cas(llm),hv_mod_cas(llm),vv_mod_cas(llm)2753 real dt_mod_cas(llm),ht_mod_cas(llm),vt_mod_cas(llm),dtrad_mod_cas(llm)2754 real dq_mod_cas(llm),hq_mod_cas(llm),vq_mod_cas(llm)2755 2756 integer l,k,k1,k22757 real frac,frac1,frac2,fact2758 2759 do l = 1, llm2760 2761 if (play(l).ge.plev_prof_cas(nlev_cas)) then2762 2763 mxcalc=l2764 k1=02765 k2=02766 2767 if (play(l).le.plev_prof_cas(1)) then2768 2769 do k = 1, nlev_cas-12770 if (play(l).le.plev_prof_cas(k).and. play(l).gt.plev_prof_cas(k+1)) then2771 k1=k2772 k2=k+12773 endif2774 enddo2775 2776 if (k1.eq.0 .or. k2.eq.0) then2777 write(*,*) 'PB! k1, k2 = ',k1,k22778 write(*,*) 'l,play(l) = ',l,play(l)/1002779 do k = 1, nlev_cas-12780 write(*,*) 'k,plev_prof_cas(k) = ',k,plev_prof_cas(k)/1002781 enddo2782 endif2783 2784 frac = (plev_prof_cas(k2)-play(l))/(plev_prof_cas(k2)-plev_prof_cas(k1))2785 t_mod_cas(l)= t_prof_cas(k2) - frac*(t_prof_cas(k2)-t_prof_cas(k1))2786 q_mod_cas(l)= q_prof_cas(k2) - frac*(q_prof_cas(k2)-q_prof_cas(k1))2787 u_mod_cas(l)= u_prof_cas(k2) - frac*(u_prof_cas(k2)-u_prof_cas(k1))2788 v_mod_cas(l)= v_prof_cas(k2) - frac*(v_prof_cas(k2)-v_prof_cas(k1))2789 ug_mod_cas(l)= ug_prof_cas(k2) - frac*(ug_prof_cas(k2)-ug_prof_cas(k1))2790 vg_mod_cas(l)= vg_prof_cas(k2) - frac*(vg_prof_cas(k2)-vg_prof_cas(k1))2791 w_mod_cas(l)= vitw_prof_cas(k2) - frac*(vitw_prof_cas(k2)-vitw_prof_cas(k1))2792 du_mod_cas(l)= du_prof_cas(k2) - frac*(du_prof_cas(k2)-du_prof_cas(k1))2793 hu_mod_cas(l)= hu_prof_cas(k2) - frac*(hu_prof_cas(k2)-hu_prof_cas(k1))2794 vu_mod_cas(l)= vu_prof_cas(k2) - frac*(vu_prof_cas(k2)-vu_prof_cas(k1))2795 dv_mod_cas(l)= dv_prof_cas(k2) - frac*(dv_prof_cas(k2)-dv_prof_cas(k1))2796 hv_mod_cas(l)= hv_prof_cas(k2) - frac*(hv_prof_cas(k2)-hv_prof_cas(k1))2797 vv_mod_cas(l)= vv_prof_cas(k2) - frac*(vv_prof_cas(k2)-vv_prof_cas(k1))2798 dt_mod_cas(l)= dt_prof_cas(k2) - frac*(dt_prof_cas(k2)-dt_prof_cas(k1))2799 ht_mod_cas(l)= ht_prof_cas(k2) - frac*(ht_prof_cas(k2)-ht_prof_cas(k1))2800 vt_mod_cas(l)= vt_prof_cas(k2) - frac*(vt_prof_cas(k2)-vt_prof_cas(k1))2801 dq_mod_cas(l)= dq_prof_cas(k2) - frac*(dq_prof_cas(k2)-dq_prof_cas(k1))2802 hq_mod_cas(l)= hq_prof_cas(k2) - frac*(hq_prof_cas(k2)-hq_prof_cas(k1))2803 vq_mod_cas(l)= vq_prof_cas(k2) - frac*(vq_prof_cas(k2)-vq_prof_cas(k1))2804 dtrad_mod_cas(l)= dtrad_prof_cas(k2) - frac*(dtrad_prof_cas(k2)-dtrad_prof_cas(k1))2805 2806 else !play>plev_prof_cas(1)2807 2808 k1=12809 k2=22810 frac1 = (play(l)-plev_prof_cas(k2))/(plev_prof_cas(k1)-plev_prof_cas(k2))2811 frac2 = (play(l)-plev_prof_cas(k1))/(plev_prof_cas(k1)-plev_prof_cas(k2))2812 t_mod_cas(l)= frac1*t_prof_cas(k1) - frac2*t_prof_cas(k2)2813 q_mod_cas(l)= frac1*q_prof_cas(k1) - frac2*q_prof_cas(k2)2814 u_mod_cas(l)= frac1*u_prof_cas(k1) - frac2*u_prof_cas(k2)2815 v_mod_cas(l)= frac1*v_prof_cas(k1) - frac2*v_prof_cas(k2)2816 ug_mod_cas(l)= frac1*ug_prof_cas(k1) - frac2*ug_prof_cas(k2)2817 vg_mod_cas(l)= frac1*vg_prof_cas(k1) - frac2*vg_prof_cas(k2)2818 w_mod_cas(l)= frac1*vitw_prof_cas(k1) - frac2*vitw_prof_cas(k2)2819 du_mod_cas(l)= frac1*du_prof_cas(k1) - frac2*du_prof_cas(k2)2820 hu_mod_cas(l)= frac1*hu_prof_cas(k1) - frac2*hu_prof_cas(k2)2821 vu_mod_cas(l)= frac1*vu_prof_cas(k1) - frac2*vu_prof_cas(k2)2822 dv_mod_cas(l)= frac1*dv_prof_cas(k1) - frac2*dv_prof_cas(k2)2823 hv_mod_cas(l)= frac1*hv_prof_cas(k1) - frac2*hv_prof_cas(k2)2824 vv_mod_cas(l)= frac1*vv_prof_cas(k1) - frac2*vv_prof_cas(k2)2825 dt_mod_cas(l)= frac1*dt_prof_cas(k1) - frac2*dt_prof_cas(k2)2826 ht_mod_cas(l)= frac1*ht_prof_cas(k1) - frac2*ht_prof_cas(k2)2827 vt_mod_cas(l)= frac1*vt_prof_cas(k1) - frac2*vt_prof_cas(k2)2828 dq_mod_cas(l)= frac1*dq_prof_cas(k1) - frac2*dq_prof_cas(k2)2829 hq_mod_cas(l)= frac1*hq_prof_cas(k1) - frac2*hq_prof_cas(k2)2830 vq_mod_cas(l)= frac1*vq_prof_cas(k1) - frac2*vq_prof_cas(k2)2831 dtrad_mod_cas(l)= frac1*dtrad_prof_cas(k1) - frac2*dtrad_prof_cas(k2)2832 2833 endif ! play.le.plev_prof_cas(1)2834 2835 else ! above max altitude of forcing file2836 2837 !jyg2838 fact=20.*(plev_prof_cas(nlev_cas)-play(l))/plev_prof_cas(nlev_cas) !jyg2839 fact = max(fact,0.) !jyg2840 fact = exp(-fact) !jyg2841 t_mod_cas(l)= t_prof_cas(nlev_cas) !jyg2842 q_mod_cas(l)= q_prof_cas(nlev_cas)*fact !jyg2843 u_mod_cas(l)= u_prof_cas(nlev_cas)*fact !jyg2844 v_mod_cas(l)= v_prof_cas(nlev_cas)*fact !jyg2845 ug_mod_cas(l)= ug_prof_cas(nlev_cas)*fact !jyg2846 vg_mod_cas(l)= vg_prof_cas(nlev_cas)*fact !jyg2847 w_mod_cas(l)= 0.0 !jyg2848 du_mod_cas(l)= du_prof_cas(nlev_cas)*fact2849 hu_mod_cas(l)= hu_prof_cas(nlev_cas)*fact !jyg2850 vu_mod_cas(l)= vu_prof_cas(nlev_cas)*fact !jyg2851 dv_mod_cas(l)= dv_prof_cas(nlev_cas)*fact2852 hv_mod_cas(l)= hv_prof_cas(nlev_cas)*fact !jyg2853 vv_mod_cas(l)= vv_prof_cas(nlev_cas)*fact !jyg2854 dt_mod_cas(l)= dt_prof_cas(nlev_cas)2855 ht_mod_cas(l)= ht_prof_cas(nlev_cas) !jyg2856 vt_mod_cas(l)= vt_prof_cas(nlev_cas) !jyg2857 dq_mod_cas(l)= dq_prof_cas(nlev_cas)*fact2858 hq_mod_cas(l)= hq_prof_cas(nlev_cas)*fact !jyg2859 vq_mod_cas(l)= vq_prof_cas(nlev_cas)*fact !jyg2860 dtrad_mod_cas(l)= dtrad_prof_cas(nlev_cas)*fact !jyg2861 2862 endif ! play2863 2864 enddo ! l2865 2866 ! do l = 1,llm2867 ! print *,'t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l) ',2868 ! $ l,t_mod_cas(l),q_mod_cas(l),ht_mod_cas(l),hq_mod_cas(l)2869 ! enddo2870 2871 return2872 end2873 !*****************************************************************************2874 !=====================================================================2875 SUBROUTINE interp_dice_vertical(play,nlev_dice,nt_dice,plev_prof &2876 & ,th_prof,qv_prof,u_prof,v_prof,o3_prof &2877 & ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof &2878 & ,th_mod,qv_mod,u_mod,v_mod,o3_mod &2879 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc)2880 2881 implicit none2882 2883 #include "dimensions.h"2884 2885 !-------------------------------------------------------------------------2886 ! Vertical interpolation of Dice forcing data onto model levels2887 !-------------------------------------------------------------------------2888 2889 integer nlevmax2890 parameter (nlevmax=41)2891 integer nlev_dice,mxcalc,nt_dice2892 2893 real play(llm), plev_prof(nlev_dice)2894 real th_prof(nlev_dice),qv_prof(nlev_dice)2895 real u_prof(nlev_dice),v_prof(nlev_dice)2896 real o3_prof(nlev_dice)2897 real ht_prof(nlev_dice),hq_prof(nlev_dice)2898 real hu_prof(nlev_dice),hv_prof(nlev_dice)2899 real w_prof(nlev_dice),omega_prof(nlev_dice)2900 2901 real th_mod(llm),qv_mod(llm)2902 real u_mod(llm),v_mod(llm), o3_mod(llm)2903 real ht_mod(llm),hq_mod(llm)2904 real hu_mod(llm),hv_mod(llm),w_mod(llm),omega_mod(llm)2905 2906 integer l,k,k1,k2,kp2907 real aa,frac,frac1,frac2,fact2908 2909 do l = 1, llm2910 2911 if (play(l).ge.plev_prof(nlev_dice)) then2912 2913 mxcalc=l2914 k1=02915 k2=02916 2917 if (play(l).le.plev_prof(1)) then2918 2919 do k = 1, nlev_dice-12920 if (play(l).le.plev_prof(k) .and. play(l).gt.plev_prof(k+1)) then2921 k1=k2922 k2=k+12923 endif2924 enddo2925 2926 if (k1.eq.0 .or. k2.eq.0) then2927 write(*,*) 'PB! k1, k2 = ',k1,k22928 write(*,*) 'l,play(l) = ',l,play(l)/1002929 do k = 1, nlev_dice-12930 write(*,*) 'k,plev_prof(k) = ',k,plev_prof(k)/1002931 enddo2932 endif2933 2934 frac = (plev_prof(k2)-play(l))/(plev_prof(k2)-plev_prof(k1))2935 th_mod(l)= th_prof(k2) - frac*(th_prof(k2)-th_prof(k1))2936 qv_mod(l)= qv_prof(k2) - frac*(qv_prof(k2)-qv_prof(k1))2937 u_mod(l)= u_prof(k2) - frac*(u_prof(k2)-u_prof(k1))2938 v_mod(l)= v_prof(k2) - frac*(v_prof(k2)-v_prof(k1))2939 o3_mod(l)= o3_prof(k2) - frac*(o3_prof(k2)-o3_prof(k1))2940 ht_mod(l)= ht_prof(k2) - frac*(ht_prof(k2)-ht_prof(k1))2941 hq_mod(l)= hq_prof(k2) - frac*(hq_prof(k2)-hq_prof(k1))2942 hu_mod(l)= hu_prof(k2) - frac*(hu_prof(k2)-hu_prof(k1))2943 hv_mod(l)= hv_prof(k2) - frac*(hv_prof(k2)-hv_prof(k1))2944 w_mod(l)= w_prof(k2) - frac*(w_prof(k2)-w_prof(k1))2945 omega_mod(l)= omega_prof(k2) - frac*(omega_prof(k2)-omega_prof(k1))2946 2947 else !play>plev_prof(1)2948 2949 k1=12950 k2=22951 frac1 = (play(l)-plev_prof(k2))/(plev_prof(k1)-plev_prof(k2))2952 frac2 = (play(l)-plev_prof(k1))/(plev_prof(k1)-plev_prof(k2))2953 th_mod(l)= frac1*th_prof(k1) - frac2*th_prof(k2)2954 qv_mod(l)= frac1*qv_prof(k1) - frac2*qv_prof(k2)2955 u_mod(l)= frac1*u_prof(k1) - frac2*u_prof(k2)2956 v_mod(l)= frac1*v_prof(k1) - frac2*v_prof(k2)2957 o3_mod(l)= frac1*o3_prof(k1) - frac2*o3_prof(k2)2958 ht_mod(l)= frac1*ht_prof(k1) - frac2*ht_prof(k2)2959 hq_mod(l)= frac1*hq_prof(k1) - frac2*hq_prof(k2)2960 hu_mod(l)= frac1*hu_prof(k1) - frac2*hu_prof(k2)2961 hv_mod(l)= frac1*hv_prof(k1) - frac2*hv_prof(k2)2962 w_mod(l)= frac1*w_prof(k1) - frac2*w_prof(k2)2963 omega_mod(l)= frac1*omega_prof(k1) - frac2*omega_prof(k2)2964 2965 endif ! play.le.plev_prof(1)2966 2967 else ! above max altitude of forcing file2968 2969 !jyg2970 fact=20.*(plev_prof(nlev_dice)-play(l))/plev_prof(nlev_dice) !jyg2971 fact = max(fact,0.) !jyg2972 fact = exp(-fact) !jyg2973 th_mod(l)= th_prof(nlev_dice) !jyg2974 qv_mod(l)= qv_prof(nlev_dice)*fact !jyg2975 u_mod(l)= u_prof(nlev_dice)*fact !jyg2976 v_mod(l)= v_prof(nlev_dice)*fact !jyg2977 o3_mod(l)= o3_prof(nlev_dice)*fact !jyg2978 ht_mod(l)= ht_prof(nlev_dice) !jyg2979 hq_mod(l)= hq_prof(nlev_dice)*fact !jyg2980 hu_mod(l)= hu_prof(nlev_dice) !jyg2981 hv_mod(l)= hv_prof(nlev_dice) !jyg2982 w_mod(l)= 0. !jyg2983 omega_mod(l)= 0. !jyg2984 2985 endif ! play2986 2987 enddo ! l2988 2989 ! do l = 1,llm2990 ! print *,'t_mod(l),q_mod(l),ht_mod(l),hq_mod(l) ',2991 ! $ l,t_mod(l),q_mod(l),ht_mod(l),hq_mod(l)2992 ! enddo2993 2994 return2995 end2996 2997 !======================================================================2998 SUBROUTINE interp_astex_time(day,day1,annee_ref &2999 & ,year_ini_astex,day_ini_astex,nt_astex,dt_astex &3000 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex &3001 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof &3002 & ,ufa_prof,vfa_prof)3003 implicit none3004 3005 !---------------------------------------------------------------------------------------3006 ! Time interpolation of a 2D field to the timestep corresponding to day3007 !3008 ! day: current julian day (e.g. 717538.2)3009 ! day1: first day of the simulation3010 ! nt_astex: total nb of data in the forcing (e.g. 41 for Astex)3011 ! dt_astex: total time interval (in sec) between 2 forcing data (e.g. 1h for Astex)3012 !---------------------------------------------------------------------------------------3013 3014 ! inputs:3015 integer annee_ref3016 integer nt_astex,nlev_astex3017 integer year_ini_astex3018 real day, day1,day_ini_astex,dt_astex3019 real div_astex(nt_astex),ts_astex(nt_astex),ug_astex(nt_astex)3020 real vg_astex(nt_astex),ufa_astex(nt_astex),vfa_astex(nt_astex)3021 ! outputs:3022 real div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof3023 ! local:3024 integer it_astex1, it_astex23025 real timeit,time_astex1,time_astex2,frac3026 3027 ! Check that initial day of the simulation consistent with ASTEX period:3028 if (annee_ref.ne.1992 ) then3029 print*,'Pour Astex, annee_ref doit etre 1992 '3030 print*,'Changer annee_ref dans run.def'3031 stop3032 endif3033 if (annee_ref.eq.1992 .and. day1.lt.day_ini_astex) then3034 print*,'Astex debute le 13 Juin 1992 (jour julien=165)'3035 print*,'Changer dayref dans run.def'3036 stop3037 endif3038 3039 ! Determine timestep relative to the 1st day of TOGA-COARE:3040 ! timeit=(day-day1)*86400.3041 ! if (annee_ref.eq.1992) then3042 ! timeit=(day-day_ini_astex)*86400.3043 ! else3044 ! timeit=(day+2.-1.)*86400. ! 2 days between Jun13 and Jun15 19923045 ! endif3046 timeit=(day-day_ini_astex)*864003047 3048 ! Determine the closest observation times:3049 it_astex1=INT(timeit/dt_astex)+13050 it_astex2=it_astex1 + 13051 time_astex1=(it_astex1-1)*dt_astex3052 time_astex2=(it_astex2-1)*dt_astex3053 print *,'timeit day day_ini_astex',timeit,day,day_ini_astex3054 print *,'it_astex1,it_astex2,time_astex1,time_astex2', &3055 & it_astex1,it_astex2,time_astex1,time_astex23056 3057 if (it_astex1 .ge. nt_astex) then3058 write(*,*) 'PB-stop: day, it_astex1, it_astex2, timeit: ' &3059 & ,day,it_astex1,it_astex2,timeit/86400.3060 stop3061 endif3062 3063 ! time interpolation:3064 frac=(time_astex2-timeit)/(time_astex2-time_astex1)3065 frac=max(frac,0.0)3066 3067 div_prof = div_astex(it_astex2) &3068 & -frac*(div_astex(it_astex2)-div_astex(it_astex1))3069 ts_prof = ts_astex(it_astex2) &3070 & -frac*(ts_astex(it_astex2)-ts_astex(it_astex1))3071 ug_prof = ug_astex(it_astex2) &3072 & -frac*(ug_astex(it_astex2)-ug_astex(it_astex1))3073 vg_prof = vg_astex(it_astex2) &3074 & -frac*(vg_astex(it_astex2)-vg_astex(it_astex1))3075 ufa_prof = ufa_astex(it_astex2) &3076 & -frac*(ufa_astex(it_astex2)-ufa_astex(it_astex1))3077 vfa_prof = vfa_astex(it_astex2) &3078 & -frac*(vfa_astex(it_astex2)-vfa_astex(it_astex1))3079 3080 print*, &3081 &'day,annee_ref,day_ini_astex,timeit,it_astex1,it_astex2,SST:', &3082 &day,annee_ref,day_ini_astex,timeit/86400.,it_astex1, &3083 &it_astex2,div_prof,ts_prof,ug_prof,vg_prof,ufa_prof,vfa_prof3084 3085 return3086 END3087 3088 !======================================================================3089 SUBROUTINE interp_toga_time(day,day1,annee_ref &3090 & ,year_ini_toga,day_ini_toga,nt_toga,dt_toga,nlev_toga &3091 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga &3092 & ,ht_toga,vt_toga,hq_toga,vq_toga &3093 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof &3094 & ,ht_prof,vt_prof,hq_prof,vq_prof)3095 implicit none3096 3097 !---------------------------------------------------------------------------------------3098 ! Time interpolation of a 2D field to the timestep corresponding to day3099 !3100 ! day: current julian day (e.g. 717538.2)3101 ! day1: first day of the simulation3102 ! nt_toga: total nb of data in the forcing (e.g. 480 for TOGA-COARE)3103 ! dt_toga: total time interval (in sec) between 2 forcing data (e.g. 6h for TOGA-COARE)3104 !---------------------------------------------------------------------------------------3105 3106 #include "compar1d.h"3107 3108 ! inputs:3109 integer annee_ref3110 integer nt_toga,nlev_toga3111 integer year_ini_toga3112 real day, day1,day_ini_toga,dt_toga3113 real ts_toga(nt_toga)3114 real plev_toga(nlev_toga,nt_toga),t_toga(nlev_toga,nt_toga)3115 real q_toga(nlev_toga,nt_toga),u_toga(nlev_toga,nt_toga)3116 real v_toga(nlev_toga,nt_toga),w_toga(nlev_toga,nt_toga)3117 real ht_toga(nlev_toga,nt_toga),vt_toga(nlev_toga,nt_toga)3118 real hq_toga(nlev_toga,nt_toga),vq_toga(nlev_toga,nt_toga)3119 ! outputs:3120 real ts_prof3121 real plev_prof(nlev_toga),t_prof(nlev_toga)3122 real q_prof(nlev_toga),u_prof(nlev_toga)3123 real v_prof(nlev_toga),w_prof(nlev_toga)3124 real ht_prof(nlev_toga),vt_prof(nlev_toga)3125 real hq_prof(nlev_toga),vq_prof(nlev_toga)3126 ! local:3127 integer it_toga1, it_toga2,k3128 real timeit,time_toga1,time_toga2,frac3129 3130 3131 if (forcing_type.eq.2) then3132 ! Check that initial day of the simulation consistent with TOGA-COARE period:3133 if (annee_ref.ne.1992 .and. annee_ref.ne.1993) then3134 print*,'Pour TOGA-COARE, annee_ref doit etre 1992 ou 1993'3135 print*,'Changer annee_ref dans run.def'3136 stop3137 endif3138 if (annee_ref.eq.1992 .and. day1.lt.day_ini_toga) then3139 print*,'TOGA-COARE a debute le 1er Nov 1992 (jour julien=306)'3140 print*,'Changer dayref dans run.def'3141 stop3142 endif3143 if (annee_ref.eq.1993 .and. day1.gt.day_ini_toga+119) then3144 print*,'TOGA-COARE a fini le 28 Feb 1993 (jour julien=59)'3145 print*,'Changer dayref ou nday dans run.def'3146 stop3147 endif3148 3149 else if (forcing_type.eq.4) then3150 3151 ! Check that initial day of the simulation consistent with TWP-ICE period:3152 if (annee_ref.ne.2006) then3153 print*,'Pour TWP-ICE, annee_ref doit etre 2006'3154 print*,'Changer annee_ref dans run.def'3155 stop3156 endif3157 if (annee_ref.eq.2006 .and. day1.lt.day_ini_toga) then3158 print*,'TWP-ICE a debute le 17 Jan 2006 (jour julien=17)'3159 print*,'Changer dayref dans run.def'3160 stop3161 endif3162 if (annee_ref.eq.2006 .and. day1.gt.day_ini_toga+26) then3163 print*,'TWP-ICE a fini le 12 Feb 2006 (jour julien=43)'3164 print*,'Changer dayref ou nday dans run.def'3165 stop3166 endif3167 3168 endif3169 3170 ! Determine timestep relative to the 1st day of TOGA-COARE:3171 ! timeit=(day-day1)*86400.3172 ! if (annee_ref.eq.1992) then3173 ! timeit=(day-day_ini_toga)*86400.3174 ! else3175 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19923176 ! endif3177 timeit=(day-day_ini_toga)*864003178 3179 ! Determine the closest observation times:3180 it_toga1=INT(timeit/dt_toga)+13181 it_toga2=it_toga1 + 13182 time_toga1=(it_toga1-1)*dt_toga3183 time_toga2=(it_toga2-1)*dt_toga3184 3185 if (it_toga1 .ge. nt_toga) then3186 write(*,*) 'PB-stop: day, it_toga1, it_toga2, timeit: ' &3187 & ,day,it_toga1,it_toga2,timeit/86400.3188 stop3189 endif3190 3191 ! time interpolation:3192 frac=(time_toga2-timeit)/(time_toga2-time_toga1)3193 frac=max(frac,0.0)3194 3195 ts_prof = ts_toga(it_toga2) &3196 & -frac*(ts_toga(it_toga2)-ts_toga(it_toga1))3197 3198 ! print*,3199 ! :'day,annee_ref,day_ini_toga,timeit,it_toga1,it_toga2,SST:',3200 ! :day,annee_ref,day_ini_toga,timeit/86400.,it_toga1,it_toga2,ts_prof3201 3202 do k=1,nlev_toga3203 plev_prof(k) = 100.*(plev_toga(k,it_toga2) &3204 & -frac*(plev_toga(k,it_toga2)-plev_toga(k,it_toga1)))3205 t_prof(k) = t_toga(k,it_toga2) &3206 & -frac*(t_toga(k,it_toga2)-t_toga(k,it_toga1))3207 q_prof(k) = q_toga(k,it_toga2) &3208 & -frac*(q_toga(k,it_toga2)-q_toga(k,it_toga1))3209 u_prof(k) = u_toga(k,it_toga2) &3210 & -frac*(u_toga(k,it_toga2)-u_toga(k,it_toga1))3211 v_prof(k) = v_toga(k,it_toga2) &3212 & -frac*(v_toga(k,it_toga2)-v_toga(k,it_toga1))3213 w_prof(k) = w_toga(k,it_toga2) &3214 & -frac*(w_toga(k,it_toga2)-w_toga(k,it_toga1))3215 ht_prof(k) = ht_toga(k,it_toga2) &3216 & -frac*(ht_toga(k,it_toga2)-ht_toga(k,it_toga1))3217 vt_prof(k) = vt_toga(k,it_toga2) &3218 & -frac*(vt_toga(k,it_toga2)-vt_toga(k,it_toga1))3219 hq_prof(k) = hq_toga(k,it_toga2) &3220 & -frac*(hq_toga(k,it_toga2)-hq_toga(k,it_toga1))3221 vq_prof(k) = vq_toga(k,it_toga2) &3222 & -frac*(vq_toga(k,it_toga2)-vq_toga(k,it_toga1))3223 enddo3224 3225 return3226 END3227 3228 !======================================================================3229 SUBROUTINE interp_dice_time(day,day1,annee_ref &3230 & ,year_ini_dice,day_ini_dice,nt_dice,dt_dice &3231 & ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice &3232 & ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice &3233 & ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice &3234 & ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof &3235 & ,ustar_prof,psurf_prof,ug_prof,vg_prof &3236 & ,ht_prof,hq_prof,hu_prof,hv_prof,w_prof,omega_prof)3237 implicit none3238 3239 !---------------------------------------------------------------------------------------3240 ! Time interpolation of a 2D field to the timestep corresponding to day3241 !3242 ! day: current julian day (e.g. 717538.2)3243 ! day1: first day of the simulation3244 ! nt_dice: total nb of data in the forcing (e.g. 145 for Dice)3245 ! dt_dice: total time interval (in sec) between 2 forcing data (e.g. 30min. for Dice)3246 !---------------------------------------------------------------------------------------3247 3248 #include "compar1d.h"3249 3250 ! inputs:3251 integer annee_ref3252 integer nt_dice,nlev_dice3253 integer year_ini_dice3254 real day, day1,day_ini_dice,dt_dice3255 real shf_dice(nt_dice),lhf_dice(nt_dice),lwup_dice(nt_dice)3256 real swup_dice(nt_dice),tg_dice(nt_dice),ustar_dice(nt_dice)3257 real psurf_dice(nt_dice),ug_dice(nt_dice),vg_dice(nt_dice)3258 real ht_dice(nlev_dice,nt_dice),hq_dice(nlev_dice,nt_dice)3259 real hu_dice(nlev_dice,nt_dice),hv_dice(nlev_dice,nt_dice)3260 real w_dice(nlev_dice,nt_dice),omega_dice(nlev_dice,nt_dice)3261 ! outputs:3262 real tg_prof,shf_prof,lhf_prof,lwup_prof,swup_prof3263 real ustar_prof,psurf_prof,ug_prof,vg_prof3264 real ht_prof(nlev_dice),hq_prof(nlev_dice)3265 real hu_prof(nlev_dice),hv_prof(nlev_dice)3266 real w_prof(nlev_dice),omega_prof(nlev_dice)3267 ! local:3268 integer it_dice1, it_dice2,k3269 real timeit,time_dice1,time_dice2,frac3270 3271 3272 if (forcing_type.eq.7) then3273 ! Check that initial day of the simulation consistent with Dice period:3274 print *,'annee_ref=',annee_ref3275 print *,'day1=',day13276 print *,'day_ini_dice=',day_ini_dice3277 if (annee_ref.ne.1999) then3278 print*,'Pour Dice, annee_ref doit etre 1999'3279 print*,'Changer annee_ref dans run.def'3280 stop3281 endif3282 if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice) then3283 print*,'Dice a debute le 23 Oct 1999 (jour julien=296)'3284 print*,'Changer dayref dans run.def',day1,day_ini_dice3285 stop3286 endif3287 if (annee_ref.eq.1999 .and. day1.gt.day_ini_dice+2) then3288 print*,'Dice a fini le 25 Oct 1999 (jour julien=298)'3289 print*,'Changer dayref ou nday dans run.def',day1,day_ini_dice3290 stop3291 endif3292 3293 endif3294 3295 ! Determine timestep relative to the 1st day of TOGA-COARE:3296 ! timeit=(day-day1)*86400.3297 ! if (annee_ref.eq.1992) then3298 ! timeit=(day-day_ini_dice)*86400.3299 ! else3300 ! timeit=(day+61.-1.)*86400. ! 61 days between Nov01 and Dec31 19923301 ! endif3302 timeit=(day-day_ini_dice)*864003303 3304 ! Determine the closest observation times:3305 it_dice1=INT(timeit/dt_dice)+13306 it_dice2=it_dice1 + 13307 time_dice1=(it_dice1-1)*dt_dice3308 time_dice2=(it_dice2-1)*dt_dice3309 3310 if (it_dice1 .ge. nt_dice) then3311 write(*,*) 'PB-stop: day, it_dice1, it_dice2, timeit: ',day,it_dice1,it_dice2,timeit/86400.3312 stop3313 endif3314 3315 ! time interpolation:3316 frac=(time_dice2-timeit)/(time_dice2-time_dice1)3317 frac=max(frac,0.0)3318 3319 shf_prof = shf_dice(it_dice2)-frac*(shf_dice(it_dice2)-shf_dice(it_dice1))3320 lhf_prof = lhf_dice(it_dice2)-frac*(lhf_dice(it_dice2)-lhf_dice(it_dice1))3321 lwup_prof = lwup_dice(it_dice2)-frac*(lwup_dice(it_dice2)-lwup_dice(it_dice1))3322 swup_prof = swup_dice(it_dice2)-frac*(swup_dice(it_dice2)-swup_dice(it_dice1))3323 tg_prof = tg_dice(it_dice2)-frac*(tg_dice(it_dice2)-tg_dice(it_dice1))3324 ustar_prof = ustar_dice(it_dice2)-frac*(ustar_dice(it_dice2)-ustar_dice(it_dice1))3325 psurf_prof = psurf_dice(it_dice2)-frac*(psurf_dice(it_dice2)-psurf_dice(it_dice1))3326 ug_prof = ug_dice(it_dice2)-frac*(ug_dice(it_dice2)-ug_dice(it_dice1))3327 vg_prof = vg_dice(it_dice2)-frac*(vg_dice(it_dice2)-vg_dice(it_dice1))3328 3329 ! print*,3330 ! :'day,annee_ref,day_ini_dice,timeit,it_dice1,it_dice2,SST:',3331 ! :day,annee_ref,day_ini_dice,timeit/86400.,it_dice1,it_dice2,ts_prof3332 3333 do k=1,nlev_dice3334 ht_prof(k) = ht_dice(k,it_dice2)-frac*(ht_dice(k,it_dice2)-ht_dice(k,it_dice1))3335 hq_prof(k) = hq_dice(k,it_dice2)-frac*(hq_dice(k,it_dice2)-hq_dice(k,it_dice1))3336 hu_prof(k) = hu_dice(k,it_dice2)-frac*(hu_dice(k,it_dice2)-hu_dice(k,it_dice1))3337 hv_prof(k) = hv_dice(k,it_dice2)-frac*(hv_dice(k,it_dice2)-hv_dice(k,it_dice1))3338 w_prof(k) = w_dice(k,it_dice2)-frac*(w_dice(k,it_dice2)-w_dice(k,it_dice1))3339 omega_prof(k) = omega_dice(k,it_dice2)-frac*(omega_dice(k,it_dice2)-omega_dice(k,it_dice1))3340 enddo3341 3342 return3343 END3344 3345 !======================================================================3346 SUBROUTINE interp_gabls4_time(day,day1,annee_ref &3347 & ,year_ini_gabls4,day_ini_gabls4,nt_gabls4,dt_gabls4,nlev_gabls4 &3348 & ,ug_gabls4,vg_gabls4,ht_gabls4,hq_gabls4,tg_gabls4 &3349 & ,ug_prof,vg_prof,ht_prof,hq_prof,tg_prof)3350 implicit none3351 3352 !---------------------------------------------------------------------------------------3353 ! Time interpolation of a 2D field to the timestep corresponding to day3354 !3355 ! day: current julian day3356 ! day1: first day of the simulation3357 ! nt_gabls4: total nb of data in the forcing (e.g. 37 for gabls4)3358 ! dt_gabls4: total time interval (in sec) between 2 forcing data (e.g. 60min. for gabls4)3359 !---------------------------------------------------------------------------------------3360 3361 #include "compar1d.h"3362 3363 ! inputs:3364 integer annee_ref3365 integer nt_gabls4,nlev_gabls43366 integer year_ini_gabls43367 real day, day1,day_ini_gabls4,dt_gabls43368 real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4)3369 real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4)3370 real tg_gabls4(nt_gabls4), tg_prof3371 ! outputs:3372 real ug_prof(nlev_gabls4),vg_prof(nlev_gabls4)3373 real ht_prof(nlev_gabls4),hq_prof(nlev_gabls4)3374 ! local:3375 integer it_gabls41, it_gabls42,k3376 real timeit,time_gabls41,time_gabls42,frac3377 3378 3379 3380 ! Check that initial day of the simulation consistent with gabls4 period:3381 if (forcing_type.eq.8 ) then3382 print *,'annee_ref=',annee_ref3383 print *,'day1=',day13384 print *,'day_ini_gabls4=',day_ini_gabls43385 if (annee_ref.ne.2009) then3386 print*,'Pour gabls4, annee_ref doit etre 2009'3387 print*,'Changer annee_ref dans run.def'3388 stop3389 endif3390 if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4) then3391 print*,'gabls4 a debute le 11 dec 2009 (jour julien=345)'3392 print*,'Changer dayref dans run.def',day1,day_ini_gabls43393 stop3394 endif3395 if (annee_ref.eq.2009 .and. day1.gt.day_ini_gabls4+2) then3396 print*,'gabls4 a fini le 12 dec 2009 (jour julien=346)'3397 print*,'Changer dayref ou nday dans run.def',day1,day_ini_gabls43398 stop3399 endif3400 endif3401 3402 timeit=(day-day_ini_gabls4)*864003403 print *,'day,day_ini_gabls4=',day,day_ini_gabls43404 print *,'nt_gabls4,dt,timeit=',nt_gabls4,dt_gabls4,timeit3405 3406 ! Determine the closest observation times:3407 it_gabls41=INT(timeit/dt_gabls4)+13408 it_gabls42=it_gabls41 + 13409 time_gabls41=(it_gabls41-1)*dt_gabls43410 time_gabls42=(it_gabls42-1)*dt_gabls43411 3412 if (it_gabls41 .ge. nt_gabls4) then3413 write(*,*) 'PB-stop: day, it_gabls41, it_gabls42, timeit: ',day,it_gabls41,it_gabls42,timeit/86400.3414 stop3415 endif3416 3417 ! time interpolation:3418 frac=(time_gabls42-timeit)/(time_gabls42-time_gabls41)3419 frac=max(frac,0.0)3420 3421 3422 do k=1,nlev_gabls43423 ug_prof(k) = ug_gabls4(k,it_gabls42)-frac*(ug_gabls4(k,it_gabls42)-ug_gabls4(k,it_gabls41))3424 vg_prof(k) = vg_gabls4(k,it_gabls42)-frac*(vg_gabls4(k,it_gabls42)-vg_gabls4(k,it_gabls41))3425 ht_prof(k) = ht_gabls4(k,it_gabls42)-frac*(ht_gabls4(k,it_gabls42)-ht_gabls4(k,it_gabls41))3426 hq_prof(k) = hq_gabls4(k,it_gabls42)-frac*(hq_gabls4(k,it_gabls42)-hq_gabls4(k,it_gabls41))3427 enddo3428 tg_prof=tg_gabls4(it_gabls42)-frac*(tg_gabls4(it_gabls42)-tg_gabls4(it_gabls41))3429 return3430 END3431 3432 !======================================================================3433 SUBROUTINE interp_armcu_time(day,day1,annee_ref &3434 & ,year_ini_armcu,day_ini_armcu,nt_armcu,dt_armcu &3435 & ,nlev_armcu,fs_armcu,fl_armcu,at_armcu,rt_armcu &3436 & ,aqt_armcu,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof)3437 implicit none3438 3439 !---------------------------------------------------------------------------------------3440 ! Time interpolation of a 2D field to the timestep corresponding to day3441 !3442 ! day: current julian day (e.g. 717538.2)3443 ! day1: first day of the simulation3444 ! nt_armcu: total nb of data in the forcing (e.g. 31 for armcu)3445 ! dt_armcu: total time interval (in sec) between 2 forcing data (e.g. 1/2h for armcu)3446 ! fs= sensible flux3447 ! fl= latent flux3448 ! at,rt,aqt= advective and radiative tendencies3449 !---------------------------------------------------------------------------------------3450 3451 ! inputs:3452 integer annee_ref3453 integer nt_armcu,nlev_armcu3454 integer year_ini_armcu3455 real day, day1,day_ini_armcu,dt_armcu3456 real fs_armcu(nt_armcu),fl_armcu(nt_armcu),at_armcu(nt_armcu)3457 real rt_armcu(nt_armcu),aqt_armcu(nt_armcu)3458 ! outputs:3459 real fs_prof,fl_prof,at_prof,rt_prof,aqt_prof3460 ! local:3461 integer it_armcu1, it_armcu2,k3462 real timeit,time_armcu1,time_armcu2,frac3463 3464 ! Check that initial day of the simulation consistent with ARMCU period:3465 if (annee_ref.ne.1997 ) then3466 print*,'Pour ARMCU, annee_ref doit etre 1997 '3467 print*,'Changer annee_ref dans run.def'3468 stop3469 endif3470 3471 timeit=(day-day_ini_armcu)*864003472 3473 ! Determine the closest observation times:3474 it_armcu1=INT(timeit/dt_armcu)+13475 it_armcu2=it_armcu1 + 13476 time_armcu1=(it_armcu1-1)*dt_armcu3477 time_armcu2=(it_armcu2-1)*dt_armcu3478 print *,'timeit day day_ini_armcu',timeit,day,day_ini_armcu3479 print *,'it_armcu1,it_armcu2,time_armcu1,time_armcu2', &3480 & it_armcu1,it_armcu2,time_armcu1,time_armcu23481 3482 if (it_armcu1 .ge. nt_armcu) then3483 write(*,*) 'PB-stop: day, it_armcu1, it_armcu2, timeit: ' &3484 & ,day,it_armcu1,it_armcu2,timeit/86400.3485 stop3486 endif3487 3488 ! time interpolation:3489 frac=(time_armcu2-timeit)/(time_armcu2-time_armcu1)3490 frac=max(frac,0.0)3491 3492 fs_prof = fs_armcu(it_armcu2) &3493 & -frac*(fs_armcu(it_armcu2)-fs_armcu(it_armcu1))3494 fl_prof = fl_armcu(it_armcu2) &3495 & -frac*(fl_armcu(it_armcu2)-fl_armcu(it_armcu1))3496 at_prof = at_armcu(it_armcu2) &3497 & -frac*(at_armcu(it_armcu2)-at_armcu(it_armcu1))3498 rt_prof = rt_armcu(it_armcu2) &3499 & -frac*(rt_armcu(it_armcu2)-rt_armcu(it_armcu1))3500 aqt_prof = aqt_armcu(it_armcu2) &3501 & -frac*(aqt_armcu(it_armcu2)-aqt_armcu(it_armcu1))3502 3503 print*, &3504 &'day,annee_ref,day_ini_armcu,timeit,it_armcu1,it_armcu2,SST:', &3505 &day,annee_ref,day_ini_armcu,timeit/86400.,it_armcu1, &3506 &it_armcu2,fs_prof,fl_prof,at_prof,rt_prof,aqt_prof3507 3508 return3509 END3510 3511 !=====================================================================3512 subroutine readprofiles(nlev_max,kmax,ntrac,height, &3513 & thlprof,qtprof,uprof, &3514 & vprof,e12prof,ugprof,vgprof, &3515 & wfls,dqtdxls,dqtdyls,dqtdtls, &3516 & thlpcar,tracer,nt1,nt2)3517 implicit none3518 3519 integer nlev_max,kmax,kmax2,ntrac3520 logical :: llesread = .true.3521 3522 real height(nlev_max),thlprof(nlev_max),qtprof(nlev_max), &3523 & uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max), &3524 & ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max), &3525 & dqtdxls(nlev_max),dqtdyls(nlev_max),dqtdtls(nlev_max), &3526 & thlpcar(nlev_max),tracer(nlev_max,ntrac)3527 3528 real height1(nlev_max)3529 3530 integer, parameter :: ilesfile=13531 integer :: ierr,k,itrac,nt1,nt23532 3533 if(.not.(llesread)) return3534 3535 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3536 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3537 read (ilesfile,*) kmax3538 do k=1,kmax3539 read (ilesfile,*) height1(k),thlprof(k),qtprof (k), &3540 & uprof (k),vprof (k),e12prof(k)3541 enddo3542 close(ilesfile)3543 3544 open(ilesfile,file='lscale.inp.001',status='old',iostat=ierr)3545 if (ierr /= 0) stop 'ERROR:Lscale.inp does not exist'3546 read (ilesfile,*) kmax23547 if (kmax .ne. kmax2) then3548 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3549 print *, 'nbre de niveaux : ',kmax,' et ',kmax23550 stop 'lecture profiles'3551 endif3552 do k=1,kmax3553 read (ilesfile,*) height(k),ugprof(k),vgprof(k),wfls(k), &3554 & dqtdxls(k),dqtdyls(k),dqtdtls(k),thlpcar(k)3555 end do3556 do k=1,kmax3557 if (height(k) .ne. height1(k)) then3558 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3559 print *, 'les niveaux different : ',k,height1(k), height(k)3560 stop3561 endif3562 end do3563 close(ilesfile)3564 3565 open(ilesfile,file='trac.inp.001',status='old',iostat=ierr)3566 if (ierr /= 0) then3567 print*,'WARNING : trac.inp does not exist'3568 else3569 read (ilesfile,*) kmax2,nt1,nt23570 if (nt2>ntrac) then3571 stop 'Augmenter le nombre de traceurs dans traceur.def'3572 endif3573 if (kmax .ne. kmax2) then3574 print *, 'fichiers prof.inp et lscale.inp incompatibles :'3575 print *, 'nbre de niveaux : ',kmax,' et ',kmax23576 stop 'lecture profiles'3577 endif3578 do k=1,kmax3579 read (ilesfile,*) height(k),(tracer(k,itrac),itrac=nt1,nt2)3580 end do3581 close(ilesfile)3582 endif3583 3584 return3585 end3586 !======================================================================3587 subroutine readprofile_sandu(nlev_max,kmax,height,pprof,tprof, &3588 & thlprof,qprof,uprof,vprof,wprof,omega,o3mmr)3589 !======================================================================3590 implicit none3591 3592 integer nlev_max,kmax3593 logical :: llesread = .true.3594 3595 real height(nlev_max),pprof(nlev_max),tprof(nlev_max)3596 real thlprof(nlev_max)3597 real qprof(nlev_max),uprof(nlev_max),vprof(nlev_max)3598 real wprof(nlev_max),omega(nlev_max),o3mmr(nlev_max)3599 3600 integer, parameter :: ilesfile=13601 integer :: k,ierr3602 3603 if(.not.(llesread)) return3604 3605 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3606 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3607 read (ilesfile,*) kmax3608 do k=1,kmax3609 read (ilesfile,*) height(k),pprof(k), tprof(k),thlprof(k), &3610 & qprof (k),uprof(k), vprof(k), wprof(k), &3611 & omega (k),o3mmr(k)3612 enddo3613 close(ilesfile)3614 3615 return3616 end3617 3618 !======================================================================3619 subroutine readprofile_astex(nlev_max,kmax,height,pprof,tprof, &3620 & thlprof,qvprof,qlprof,qtprof,uprof,vprof,wprof,tkeprof,o3mmr)3621 !======================================================================3622 implicit none3623 3624 integer nlev_max,kmax3625 logical :: llesread = .true.3626 3627 real height(nlev_max),pprof(nlev_max),tprof(nlev_max), &3628 & thlprof(nlev_max),qlprof(nlev_max),qtprof(nlev_max), &3629 & qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max), &3630 & wprof(nlev_max),tkeprof(nlev_max),o3mmr(nlev_max)3631 3632 integer, parameter :: ilesfile=13633 integer :: ierr,k3634 3635 if(.not.(llesread)) return3636 3637 open (ilesfile,file='prof.inp.001',status='old',iostat=ierr)3638 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3639 read (ilesfile,*) kmax3640 do k=1,kmax3641 read (ilesfile,*) height(k),pprof(k), tprof(k),thlprof(k), &3642 & qvprof (k),qlprof (k),qtprof (k), &3643 & uprof(k), vprof(k), wprof(k),tkeprof(k),o3mmr(k)3644 enddo3645 close(ilesfile)3646 3647 return3648 end3649 3650 3651 3652 !======================================================================3653 subroutine readprofile_armcu(nlev_max,kmax,height,pprof,uprof, &3654 & vprof,thetaprof,tprof,qvprof,rvprof,aprof,bprof)3655 !======================================================================3656 implicit none3657 3658 integer nlev_max,kmax3659 logical :: llesread = .true.3660 3661 real height(nlev_max),pprof(nlev_max),tprof(nlev_max)3662 real thetaprof(nlev_max),rvprof(nlev_max)3663 real qvprof(nlev_max),uprof(nlev_max),vprof(nlev_max)3664 real aprof(nlev_max+1),bprof(nlev_max+1)3665 3666 integer, parameter :: ilesfile=13667 integer, parameter :: ifile=23668 integer :: ierr,jtot,k3669 3670 if(.not.(llesread)) return3671 3672 ! Read profiles at full levels3673 IF(nlev_max.EQ.19) THEN3674 open (ilesfile,file='prof.inp.19',status='old',iostat=ierr)3675 print *,'On ouvre prof.inp.19'3676 ELSE3677 open (ilesfile,file='prof.inp.40',status='old',iostat=ierr)3678 print *,'On ouvre prof.inp.40'3679 ENDIF3680 if (ierr /= 0) stop 'ERROR:Prof.inp does not exist'3681 read (ilesfile,*) kmax3682 do k=1,kmax3683 read (ilesfile,*) height(k) ,pprof(k), uprof(k), vprof(k), &3684 & thetaprof(k) ,tprof(k), qvprof(k),rvprof(k)3685 enddo3686 close(ilesfile)3687 3688 ! Vertical coordinates half levels for eta-coordinates (plev = alpha + beta * psurf)3689 IF(nlev_max.EQ.19) THEN3690 open (ifile,file='proh.inp.19',status='old',iostat=ierr)3691 print *,'On ouvre proh.inp.19'3692 if (ierr /= 0) stop 'ERROR:Proh.inp.19 does not exist'3693 ELSE3694 open (ifile,file='proh.inp.40',status='old',iostat=ierr)3695 print *,'On ouvre proh.inp.40'3696 if (ierr /= 0) stop 'ERROR:Proh.inp.40 does not exist'3697 ENDIF3698 read (ifile,*) kmax3699 do k=1,kmax3700 read (ifile,*) jtot,aprof(k),bprof(k)3701 enddo3702 close(ifile)3703 3704 return3705 end3706 3707 !=====================================================================3708 subroutine read_fire(fich_fire,nlevel,ntime &3709 & ,zz,thl,qt,u,v,tke &3710 & ,ug,vg,wls,dqtdx,dqtdy,dqtdt,thl_rad)3711 3712 !program reading forcings of the FIRE case study3713 3714 3715 implicit none3716 3717 #include "netcdf.inc"3718 3719 integer ntime,nlevel3720 character*80 :: fich_fire3721 real*8 zz(nlevel)3722 3723 real*8 thl(nlevel)3724 real*8 qt(nlevel),u(nlevel)3725 real*8 v(nlevel),tke(nlevel)3726 real*8 ug(nlevel,ntime),vg(nlevel,ntime),wls(nlevel,ntime)3727 real*8 dqtdx(nlevel,ntime),dqtdy(nlevel,ntime)3728 real*8 dqtdt(nlevel,ntime),thl_rad(nlevel,ntime)3729 3730 integer nid, ierr3731 integer nbvar3d3732 parameter(nbvar3d=30)3733 integer var3didin(nbvar3d)3734 3735 ierr = NF_OPEN(fich_fire,NF_NOWRITE,nid)3736 if (ierr.NE.NF_NOERR) then3737 write(*,*) 'ERROR: Pb opening forcings nc file '3738 write(*,*) NF_STRERROR(ierr)3739 stop ""3740 endif3741 3742 3743 ierr=NF_INQ_VARID(nid,"zz",var3didin(1))3744 if(ierr/=NF_NOERR) then3745 write(*,*) NF_STRERROR(ierr)3746 stop 'lev'3747 endif3748 3749 3750 ierr=NF_INQ_VARID(nid,"thetal",var3didin(2))3751 if(ierr/=NF_NOERR) then3752 write(*,*) NF_STRERROR(ierr)3753 stop 'temp'3754 endif3755 3756 ierr=NF_INQ_VARID(nid,"qt",var3didin(3))3757 if(ierr/=NF_NOERR) then3758 write(*,*) NF_STRERROR(ierr)3759 stop 'qv'3760 endif3761 3762 ierr=NF_INQ_VARID(nid,"u",var3didin(4))3763 if(ierr/=NF_NOERR) then3764 write(*,*) NF_STRERROR(ierr)3765 stop 'u'3766 endif3767 3768 ierr=NF_INQ_VARID(nid,"v",var3didin(5))3769 if(ierr/=NF_NOERR) then3770 write(*,*) NF_STRERROR(ierr)3771 stop 'v'3772 endif3773 3774 ierr=NF_INQ_VARID(nid,"tke",var3didin(6))3775 if(ierr/=NF_NOERR) then3776 write(*,*) NF_STRERROR(ierr)3777 stop 'tke'3778 endif3779 3780 ierr=NF_INQ_VARID(nid,"ugeo",var3didin(7))3781 if(ierr/=NF_NOERR) then3782 write(*,*) NF_STRERROR(ierr)3783 stop 'ug'3784 endif3785 3786 ierr=NF_INQ_VARID(nid,"vgeo",var3didin(8))3787 if(ierr/=NF_NOERR) then3788 write(*,*) NF_STRERROR(ierr)3789 stop 'vg'3790 endif3791 3792 ierr=NF_INQ_VARID(nid,"wls",var3didin(9))3793 if(ierr/=NF_NOERR) then3794 write(*,*) NF_STRERROR(ierr)3795 stop 'wls'3796 endif3797 3798 ierr=NF_INQ_VARID(nid,"dqtdx",var3didin(10))3799 if(ierr/=NF_NOERR) then3800 write(*,*) NF_STRERROR(ierr)3801 stop 'dqtdx'3802 endif3803 3804 ierr=NF_INQ_VARID(nid,"dqtdy",var3didin(11))3805 if(ierr/=NF_NOERR) then3806 write(*,*) NF_STRERROR(ierr)3807 stop 'dqtdy'3808 endif3809 3810 ierr=NF_INQ_VARID(nid,"dqtdt",var3didin(12))3811 if(ierr/=NF_NOERR) then3812 write(*,*) NF_STRERROR(ierr)3813 stop 'dqtdt'3814 endif3815 3816 ierr=NF_INQ_VARID(nid,"thl_rad",var3didin(13))3817 if(ierr/=NF_NOERR) then3818 write(*,*) NF_STRERROR(ierr)3819 stop 'thl_rad'3820 endif3821 !dimensions lecture3822 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)3823 3824 #ifdef NC_DOUBLE3825 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)3826 #else3827 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)3828 #endif3829 if(ierr/=NF_NOERR) then3830 write(*,*) NF_STRERROR(ierr)3831 stop "getvarup"3832 endif3833 ! write(*,*)'lecture z ok',zz3834 3835 #ifdef NC_DOUBLE3836 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),thl)3837 #else3838 ierr = NF_GET_VAR_REAL(nid,var3didin(2),thl)3839 #endif3840 if(ierr/=NF_NOERR) then3841 write(*,*) NF_STRERROR(ierr)3842 stop "getvarup"3843 endif3844 ! write(*,*)'lecture thl ok',thl3845 3846 #ifdef NC_DOUBLE3847 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),qt)3848 #else3849 ierr = NF_GET_VAR_REAL(nid,var3didin(3),qt)3850 #endif3851 if(ierr/=NF_NOERR) then3852 write(*,*) NF_STRERROR(ierr)3853 stop "getvarup"3854 endif3855 ! write(*,*)'lecture qt ok',qt3856 3857 #ifdef NC_DOUBLE3858 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),u)3859 #else3860 ierr = NF_GET_VAR_REAL(nid,var3didin(4),u)3861 #endif3862 if(ierr/=NF_NOERR) then3863 write(*,*) NF_STRERROR(ierr)3864 stop "getvarup"3865 endif3866 ! write(*,*)'lecture u ok',u3867 3868 #ifdef NC_DOUBLE3869 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),v)3870 #else3871 ierr = NF_GET_VAR_REAL(nid,var3didin(5),v)3872 #endif3873 if(ierr/=NF_NOERR) then3874 write(*,*) NF_STRERROR(ierr)3875 stop "getvarup"3876 endif3877 ! write(*,*)'lecture v ok',v3878 3879 #ifdef NC_DOUBLE3880 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tke)3881 #else3882 ierr = NF_GET_VAR_REAL(nid,var3didin(6),tke)3883 #endif3884 if(ierr/=NF_NOERR) then3885 write(*,*) NF_STRERROR(ierr)3886 stop "getvarup"3887 endif3888 ! write(*,*)'lecture tke ok',tke3889 3890 #ifdef NC_DOUBLE3891 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ug)3892 #else3893 ierr = NF_GET_VAR_REAL(nid,var3didin(7),ug)3894 #endif3895 if(ierr/=NF_NOERR) then3896 write(*,*) NF_STRERROR(ierr)3897 stop "getvarup"3898 endif3899 ! write(*,*)'lecture ug ok',ug3900 3901 #ifdef NC_DOUBLE3902 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),vg)3903 #else3904 ierr = NF_GET_VAR_REAL(nid,var3didin(8),vg)3905 #endif3906 if(ierr/=NF_NOERR) then3907 write(*,*) NF_STRERROR(ierr)3908 stop "getvarup"3909 endif3910 ! write(*,*)'lecture vg ok',vg3911 3912 #ifdef NC_DOUBLE3913 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),wls)3914 #else3915 ierr = NF_GET_VAR_REAL(nid,var3didin(9),wls)3916 #endif3917 if(ierr/=NF_NOERR) then3918 write(*,*) NF_STRERROR(ierr)3919 stop "getvarup"3920 endif3921 ! write(*,*)'lecture wls ok',wls3922 3923 #ifdef NC_DOUBLE3924 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),dqtdx)3925 #else3926 ierr = NF_GET_VAR_REAL(nid,var3didin(10),dqtdx)3927 #endif3928 if(ierr/=NF_NOERR) then3929 write(*,*) NF_STRERROR(ierr)3930 stop "getvarup"3931 endif3932 ! write(*,*)'lecture dqtdx ok',dqtdx3933 3934 #ifdef NC_DOUBLE3935 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),dqtdy)3936 #else3937 ierr = NF_GET_VAR_REAL(nid,var3didin(11),dqtdy)3938 #endif3939 if(ierr/=NF_NOERR) then3940 write(*,*) NF_STRERROR(ierr)3941 stop "getvarup"3942 endif3943 ! write(*,*)'lecture dqtdy ok',dqtdy3944 3945 #ifdef NC_DOUBLE3946 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),dqtdt)3947 #else3948 ierr = NF_GET_VAR_REAL(nid,var3didin(12),dqtdt)3949 #endif3950 if(ierr/=NF_NOERR) then3951 write(*,*) NF_STRERROR(ierr)3952 stop "getvarup"3953 endif3954 ! write(*,*)'lecture dqtdt ok',dqtdt3955 3956 #ifdef NC_DOUBLE3957 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),thl_rad)3958 #else3959 ierr = NF_GET_VAR_REAL(nid,var3didin(13),thl_rad)3960 #endif3961 if(ierr/=NF_NOERR) then3962 write(*,*) NF_STRERROR(ierr)3963 stop "getvarup"3964 endif3965 ! write(*,*)'lecture thl_rad ok',thl_rad3966 3967 return3968 end subroutine read_fire3969 !=====================================================================3970 subroutine read_dice(fich_dice,nlevel,ntime &3971 & ,zz,pres,t,qv,u,v,o3 &3972 & ,shf,lhf,lwup,swup,tg,ustar,psurf,ug,vg &3973 & ,hadvt,hadvq,hadvu,hadvv,w,omega)3974 3975 !program reading initial profils and forcings of the Dice case study3976 3977 3978 implicit none3979 3980 #include "netcdf.inc"3981 #include "YOMCST.h"3982 3983 integer ntime,nlevel3984 integer l,k3985 character*80 :: fich_dice3986 real*8 time(ntime)3987 real*8 zz(nlevel)3988 3989 real*8 th(nlevel),pres(nlevel),t(nlevel)3990 real*8 qv(nlevel),u(nlevel),v(nlevel),o3(nlevel)3991 real*8 shf(ntime),lhf(ntime),lwup(ntime),swup(ntime),tg(ntime)3992 real*8 ustar(ntime),psurf(ntime),ug(ntime),vg(ntime)3993 real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime),hadvu(nlevel,ntime)3994 real*8 hadvv(nlevel,ntime),w(nlevel,ntime),omega(nlevel,ntime)3995 real*8 pzero3996 3997 integer nid, ierr3998 integer nbvar3d3999 parameter(nbvar3d=30)4000 integer var3didin(nbvar3d)4001 4002 pzero=100000.4003 ierr = NF_OPEN(fich_dice,NF_NOWRITE,nid)4004 if (ierr.NE.NF_NOERR) then4005 write(*,*) 'ERROR: Pb opening forcings nc file '4006 write(*,*) NF_STRERROR(ierr)4007 stop ""4008 endif4009 4010 4011 ierr=NF_INQ_VARID(nid,"height",var3didin(1))4012 if(ierr/=NF_NOERR) then4013 write(*,*) NF_STRERROR(ierr)4014 stop 'height'4015 endif4016 4017 ierr=NF_INQ_VARID(nid,"pf",var3didin(11))4018 if(ierr/=NF_NOERR) then4019 write(*,*) NF_STRERROR(ierr)4020 stop 'pf'4021 endif4022 4023 ierr=NF_INQ_VARID(nid,"theta",var3didin(12))4024 if(ierr/=NF_NOERR) then4025 write(*,*) NF_STRERROR(ierr)4026 stop 'theta'4027 endif4028 4029 ierr=NF_INQ_VARID(nid,"qv",var3didin(13))4030 if(ierr/=NF_NOERR) then4031 write(*,*) NF_STRERROR(ierr)4032 stop 'qv'4033 endif4034 4035 ierr=NF_INQ_VARID(nid,"u",var3didin(14))4036 if(ierr/=NF_NOERR) then4037 write(*,*) NF_STRERROR(ierr)4038 stop 'u'4039 endif4040 4041 ierr=NF_INQ_VARID(nid,"v",var3didin(15))4042 if(ierr/=NF_NOERR) then4043 write(*,*) NF_STRERROR(ierr)4044 stop 'v'4045 endif4046 4047 ierr=NF_INQ_VARID(nid,"o3mmr",var3didin(16))4048 if(ierr/=NF_NOERR) then4049 write(*,*) NF_STRERROR(ierr)4050 stop 'o3'4051 endif4052 4053 ierr=NF_INQ_VARID(nid,"shf",var3didin(2))4054 if(ierr/=NF_NOERR) then4055 write(*,*) NF_STRERROR(ierr)4056 stop 'shf'4057 endif4058 4059 ierr=NF_INQ_VARID(nid,"lhf",var3didin(3))4060 if(ierr/=NF_NOERR) then4061 write(*,*) NF_STRERROR(ierr)4062 stop 'lhf'4063 endif4064 4065 ierr=NF_INQ_VARID(nid,"lwup",var3didin(4))4066 if(ierr/=NF_NOERR) then4067 write(*,*) NF_STRERROR(ierr)4068 stop 'lwup'4069 endif4070 4071 ierr=NF_INQ_VARID(nid,"swup",var3didin(5))4072 if(ierr/=NF_NOERR) then4073 write(*,*) NF_STRERROR(ierr)4074 stop 'dqtdx'4075 endif4076 4077 ierr=NF_INQ_VARID(nid,"Tg",var3didin(6))4078 if(ierr/=NF_NOERR) then4079 write(*,*) NF_STRERROR(ierr)4080 stop 'Tg'4081 endif4082 4083 ierr=NF_INQ_VARID(nid,"ustar",var3didin(7))4084 if(ierr/=NF_NOERR) then4085 write(*,*) NF_STRERROR(ierr)4086 stop 'ustar'4087 endif4088 4089 ierr=NF_INQ_VARID(nid,"psurf",var3didin(8))4090 if(ierr/=NF_NOERR) then4091 write(*,*) NF_STRERROR(ierr)4092 stop 'psurf'4093 endif4094 4095 ierr=NF_INQ_VARID(nid,"Ug",var3didin(9))4096 if(ierr/=NF_NOERR) then4097 write(*,*) NF_STRERROR(ierr)4098 stop 'Ug'4099 endif4100 4101 ierr=NF_INQ_VARID(nid,"Vg",var3didin(10))4102 if(ierr/=NF_NOERR) then4103 write(*,*) NF_STRERROR(ierr)4104 stop 'Vg'4105 endif4106 4107 ierr=NF_INQ_VARID(nid,"hadvT",var3didin(17))4108 if(ierr/=NF_NOERR) then4109 write(*,*) NF_STRERROR(ierr)4110 stop 'hadvT'4111 endif4112 4113 ierr=NF_INQ_VARID(nid,"hadvq",var3didin(18))4114 if(ierr/=NF_NOERR) then4115 write(*,*) NF_STRERROR(ierr)4116 stop 'hadvq'4117 endif4118 4119 ierr=NF_INQ_VARID(nid,"hadvu",var3didin(19))4120 if(ierr/=NF_NOERR) then4121 write(*,*) NF_STRERROR(ierr)4122 stop 'hadvu'4123 endif4124 4125 ierr=NF_INQ_VARID(nid,"hadvv",var3didin(20))4126 if(ierr/=NF_NOERR) then4127 write(*,*) NF_STRERROR(ierr)4128 stop 'hadvv'4129 endif4130 4131 ierr=NF_INQ_VARID(nid,"w",var3didin(21))4132 if(ierr/=NF_NOERR) then4133 write(*,*) NF_STRERROR(ierr)4134 stop 'w'4135 endif4136 4137 ierr=NF_INQ_VARID(nid,"omega",var3didin(22))4138 if(ierr/=NF_NOERR) then4139 write(*,*) NF_STRERROR(ierr)4140 stop 'omega'4141 endif4142 !dimensions lecture4143 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)4144 4145 #ifdef NC_DOUBLE4146 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz)4147 #else4148 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz)4149 #endif4150 if(ierr/=NF_NOERR) then4151 write(*,*) NF_STRERROR(ierr)4152 stop "getvarup"4153 endif4154 ! write(*,*)'lecture zz ok',zz4155 4156 #ifdef NC_DOUBLE4157 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),pres)4158 #else4159 ierr = NF_GET_VAR_REAL(nid,var3didin(11),pres)4160 #endif4161 if(ierr/=NF_NOERR) then4162 write(*,*) NF_STRERROR(ierr)4163 stop "getvarup"4164 endif4165 ! write(*,*)'lecture pres ok',pres4166 4167 #ifdef NC_DOUBLE4168 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),th)4169 #else4170 ierr = NF_GET_VAR_REAL(nid,var3didin(12),th)4171 #endif4172 if(ierr/=NF_NOERR) then4173 write(*,*) NF_STRERROR(ierr)4174 stop "getvarup"4175 endif4176 ! write(*,*)'lecture th ok',th4177 do k=1,nlevel4178 t(k)=th(k)*(pres(k)/pzero)**rkappa4179 enddo4180 4181 #ifdef NC_DOUBLE4182 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(13),qv)4183 #else4184 ierr = NF_GET_VAR_REAL(nid,var3didin(13),qv)4185 #endif4186 if(ierr/=NF_NOERR) then4187 write(*,*) NF_STRERROR(ierr)4188 stop "getvarup"4189 endif4190 ! write(*,*)'lecture qv ok',qv4191 4192 #ifdef NC_DOUBLE4193 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),u)4194 #else4195 ierr = NF_GET_VAR_REAL(nid,var3didin(14),u)4196 #endif4197 if(ierr/=NF_NOERR) then4198 write(*,*) NF_STRERROR(ierr)4199 stop "getvarup"4200 endif4201 ! write(*,*)'lecture u ok',u4202 4203 #ifdef NC_DOUBLE4204 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),v)4205 #else4206 ierr = NF_GET_VAR_REAL(nid,var3didin(15),v)4207 #endif4208 if(ierr/=NF_NOERR) then4209 write(*,*) NF_STRERROR(ierr)4210 stop "getvarup"4211 endif4212 ! write(*,*)'lecture v ok',v4213 4214 #ifdef NC_DOUBLE4215 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),o3)4216 #else4217 ierr = NF_GET_VAR_REAL(nid,var3didin(16),o3)4218 #endif4219 if(ierr/=NF_NOERR) then4220 write(*,*) NF_STRERROR(ierr)4221 stop "getvarup"4222 endif4223 ! write(*,*)'lecture o3 ok',o34224 4225 #ifdef NC_DOUBLE4226 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),shf)4227 #else4228 ierr = NF_GET_VAR_REAL(nid,var3didin(2),shf)4229 #endif4230 if(ierr/=NF_NOERR) then4231 write(*,*) NF_STRERROR(ierr)4232 stop "getvarup"4233 endif4234 ! write(*,*)'lecture shf ok',shf4235 4236 #ifdef NC_DOUBLE4237 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),lhf)4238 #else4239 ierr = NF_GET_VAR_REAL(nid,var3didin(3),lhf)4240 #endif4241 if(ierr/=NF_NOERR) then4242 write(*,*) NF_STRERROR(ierr)4243 stop "getvarup"4244 endif4245 ! write(*,*)'lecture lhf ok',lhf4246 4247 #ifdef NC_DOUBLE4248 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),lwup)4249 #else4250 ierr = NF_GET_VAR_REAL(nid,var3didin(4),lwup)4251 #endif4252 if(ierr/=NF_NOERR) then4253 write(*,*) NF_STRERROR(ierr)4254 stop "getvarup"4255 endif4256 ! write(*,*)'lecture lwup ok',lwup4257 4258 #ifdef NC_DOUBLE4259 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),swup)4260 #else4261 ierr = NF_GET_VAR_REAL(nid,var3didin(5),swup)4262 #endif4263 if(ierr/=NF_NOERR) then4264 write(*,*) NF_STRERROR(ierr)4265 stop "getvarup"4266 endif4267 ! write(*,*)'lecture swup ok',swup4268 4269 #ifdef NC_DOUBLE4270 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),tg)4271 #else4272 ierr = NF_GET_VAR_REAL(nid,var3didin(6),tg)4273 #endif4274 if(ierr/=NF_NOERR) then4275 write(*,*) NF_STRERROR(ierr)4276 stop "getvarup"4277 endif4278 ! write(*,*)'lecture tg ok',tg4279 4280 #ifdef NC_DOUBLE4281 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),ustar)4282 #else4283 ierr = NF_GET_VAR_REAL(nid,var3didin(7),ustar)4284 #endif4285 if(ierr/=NF_NOERR) then4286 write(*,*) NF_STRERROR(ierr)4287 stop "getvarup"4288 endif4289 ! write(*,*)'lecture ustar ok',ustar4290 4291 #ifdef NC_DOUBLE4292 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),psurf)4293 #else4294 ierr = NF_GET_VAR_REAL(nid,var3didin(8),psurf)4295 #endif4296 if(ierr/=NF_NOERR) then4297 write(*,*) NF_STRERROR(ierr)4298 stop "getvarup"4299 endif4300 ! write(*,*)'lecture psurf ok',psurf4301 4302 #ifdef NC_DOUBLE4303 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),ug)4304 #else4305 ierr = NF_GET_VAR_REAL(nid,var3didin(9),ug)4306 #endif4307 if(ierr/=NF_NOERR) then4308 write(*,*) NF_STRERROR(ierr)4309 stop "getvarup"4310 endif4311 ! write(*,*)'lecture ug ok',ug4312 4313 #ifdef NC_DOUBLE4314 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),vg)4315 #else4316 ierr = NF_GET_VAR_REAL(nid,var3didin(10),vg)4317 #endif4318 if(ierr/=NF_NOERR) then4319 write(*,*) NF_STRERROR(ierr)4320 stop "getvarup"4321 endif4322 ! write(*,*)'lecture vg ok',vg4323 4324 #ifdef NC_DOUBLE4325 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(17),hadvt)4326 #else4327 ierr = NF_GET_VAR_REAL(nid,var3didin(17),hadvt)4328 #endif4329 if(ierr/=NF_NOERR) then4330 write(*,*) NF_STRERROR(ierr)4331 stop "getvarup"4332 endif4333 ! write(*,*)'lecture hadvt ok',hadvt4334 4335 #ifdef NC_DOUBLE4336 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(18),hadvq)4337 #else4338 ierr = NF_GET_VAR_REAL(nid,var3didin(18),hadvq)4339 #endif4340 if(ierr/=NF_NOERR) then4341 write(*,*) NF_STRERROR(ierr)4342 stop "getvarup"4343 endif4344 ! write(*,*)'lecture hadvq ok',hadvq4345 4346 #ifdef NC_DOUBLE4347 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(19),hadvu)4348 #else4349 ierr = NF_GET_VAR_REAL(nid,var3didin(19),hadvu)4350 #endif4351 if(ierr/=NF_NOERR) then4352 write(*,*) NF_STRERROR(ierr)4353 stop "getvarup"4354 endif4355 ! write(*,*)'lecture hadvu ok',hadvu4356 4357 #ifdef NC_DOUBLE4358 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(20),hadvv)4359 #else4360 ierr = NF_GET_VAR_REAL(nid,var3didin(20),hadvv)4361 #endif4362 if(ierr/=NF_NOERR) then4363 write(*,*) NF_STRERROR(ierr)4364 stop "getvarup"4365 endif4366 ! write(*,*)'lecture hadvv ok',hadvv4367 4368 #ifdef NC_DOUBLE4369 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(21),w)4370 #else4371 ierr = NF_GET_VAR_REAL(nid,var3didin(21),w)4372 #endif4373 if(ierr/=NF_NOERR) then4374 write(*,*) NF_STRERROR(ierr)4375 stop "getvarup"4376 endif4377 ! write(*,*)'lecture w ok',w4378 4379 #ifdef NC_DOUBLE4380 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(22),omega)4381 #else4382 ierr = NF_GET_VAR_REAL(nid,var3didin(22),omega)4383 #endif4384 if(ierr/=NF_NOERR) then4385 write(*,*) NF_STRERROR(ierr)4386 stop "getvarup"4387 endif4388 ! write(*,*)'lecture omega ok',omega4389 4390 return4391 end subroutine read_dice4392 !=====================================================================4393 subroutine read_gabls4(fich_gabls4,nlevel,ntime,nsol &4394 & ,zz,depth_sn,ug,vg,pf,th,t,qv,u,v,hadvt,hadvq,tg,tsnow,snow_dens)4395 4396 !program reading initial profils and forcings of the Gabls4 case study4397 4398 4399 implicit none4400 4401 #include "netcdf.inc"4402 4403 integer ntime,nlevel,nsol4404 integer l,k4405 character*80 :: fich_gabls44406 real*8 time(ntime)4407 4408 ! ATTENTION: visiblement quand on lit gabls4_driver.nc on recupere les donnees4409 ! dans un ordre inverse par rapport a la convention LMDZ4410 ! ==> il faut tout inverser (MPL 20141024)4411 ! les variables indexees "_i" sont celles qui sont lues dans gabls4_driver.nc4412 real*8 zz_i(nlevel),th_i(nlevel),pf_i(nlevel),t_i(nlevel)4413 real*8 qv_i(nlevel),u_i(nlevel),v_i(nlevel),ug_i(nlevel,ntime),vg_i(nlevel,ntime)4414 real*8 hadvt_i(nlevel,ntime),hadvq_i(nlevel,ntime)4415 4416 real*8 zz(nlevel),th(nlevel),pf(nlevel),t(nlevel)4417 real*8 qv(nlevel),u(nlevel),v(nlevel),ug(nlevel,ntime),vg(nlevel,ntime)4418 real*8 hadvt(nlevel,ntime),hadvq(nlevel,ntime)4419 4420 real*8 depth_sn(nsol),tsnow(nsol),snow_dens(nsol)4421 real*8 tg(ntime)4422 integer nid, ierr4423 integer nbvar3d4424 parameter(nbvar3d=30)4425 integer var3didin(nbvar3d)4426 4427 ierr = NF_OPEN(fich_gabls4,NF_NOWRITE,nid)4428 if (ierr.NE.NF_NOERR) then4429 write(*,*) 'ERROR: Pb opening forcings nc file '4430 write(*,*) NF_STRERROR(ierr)4431 stop ""4432 endif4433 4434 4435 ierr=NF_INQ_VARID(nid,"height",var3didin(1))4436 if(ierr/=NF_NOERR) then4437 write(*,*) NF_STRERROR(ierr)4438 stop 'height'4439 endif4440 4441 ierr=NF_INQ_VARID(nid,"depth_sn",var3didin(2))4442 if(ierr/=NF_NOERR) then4443 write(*,*) NF_STRERROR(ierr)4444 stop 'depth_sn'4445 endif4446 4447 ierr=NF_INQ_VARID(nid,"Ug",var3didin(3))4448 if(ierr/=NF_NOERR) then4449 write(*,*) NF_STRERROR(ierr)4450 stop 'Ug'4451 endif4452 4453 ierr=NF_INQ_VARID(nid,"Vg",var3didin(4))4454 if(ierr/=NF_NOERR) then4455 write(*,*) NF_STRERROR(ierr)4456 stop 'Vg'4457 endif4458 ierr=NF_INQ_VARID(nid,"pf",var3didin(5))4459 if(ierr/=NF_NOERR) then4460 write(*,*) NF_STRERROR(ierr)4461 stop 'pf'4462 endif4463 4464 ierr=NF_INQ_VARID(nid,"theta",var3didin(6))4465 if(ierr/=NF_NOERR) then4466 write(*,*) NF_STRERROR(ierr)4467 stop 'theta'4468 endif4469 4470 ierr=NF_INQ_VARID(nid,"tempe",var3didin(7))4471 if(ierr/=NF_NOERR) then4472 write(*,*) NF_STRERROR(ierr)4473 stop 'tempe'4474 endif4475 4476 ierr=NF_INQ_VARID(nid,"qv",var3didin(8))4477 if(ierr/=NF_NOERR) then4478 write(*,*) NF_STRERROR(ierr)4479 stop 'qv'4480 endif4481 4482 ierr=NF_INQ_VARID(nid,"u",var3didin(9))4483 if(ierr/=NF_NOERR) then4484 write(*,*) NF_STRERROR(ierr)4485 stop 'u'4486 endif4487 4488 ierr=NF_INQ_VARID(nid,"v",var3didin(10))4489 if(ierr/=NF_NOERR) then4490 write(*,*) NF_STRERROR(ierr)4491 stop 'v'4492 endif4493 4494 ierr=NF_INQ_VARID(nid,"hadvT",var3didin(11))4495 if(ierr/=NF_NOERR) then4496 write(*,*) NF_STRERROR(ierr)4497 stop 'hadvt'4498 endif4499 4500 ierr=NF_INQ_VARID(nid,"hadvQ",var3didin(12))4501 if(ierr/=NF_NOERR) then4502 write(*,*) NF_STRERROR(ierr)4503 stop 'hadvq'4504 endif4505 4506 ierr=NF_INQ_VARID(nid,"Tsnow",var3didin(14))4507 if(ierr/=NF_NOERR) then4508 write(*,*) NF_STRERROR(ierr)4509 stop 'tsnow'4510 endif4511 4512 ierr=NF_INQ_VARID(nid,"snow_density",var3didin(15))4513 if(ierr/=NF_NOERR) then4514 write(*,*) NF_STRERROR(ierr)4515 stop 'snow_density'4516 endif4517 4518 ierr=NF_INQ_VARID(nid,"Tg",var3didin(16))4519 if(ierr/=NF_NOERR) then4520 write(*,*) NF_STRERROR(ierr)4521 stop 'Tg'4522 endif4523 4524 4525 !dimensions lecture4526 ! call catchaxis(nid,ntime,nlevel,time,z,ierr)4527 4528 #ifdef NC_DOUBLE4529 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(1),zz_i)4530 #else4531 ierr = NF_GET_VAR_REAL(nid,var3didin(1),zz_i)4532 #endif4533 if(ierr/=NF_NOERR) then4534 write(*,*) NF_STRERROR(ierr)4535 stop "getvarup"4536 endif4537 4538 #ifdef NC_DOUBLE4539 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(2),depth_sn)4540 #else4541 ierr = NF_GET_VAR_REAL(nid,var3didin(2),depth_sn)4542 #endif4543 if(ierr/=NF_NOERR) then4544 write(*,*) NF_STRERROR(ierr)4545 stop "getvarup"4546 endif4547 4548 #ifdef NC_DOUBLE4549 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(3),ug_i)4550 #else4551 ierr = NF_GET_VAR_REAL(nid,var3didin(3),ug_i)4552 #endif4553 if(ierr/=NF_NOERR) then4554 write(*,*) NF_STRERROR(ierr)4555 stop "getvarup"4556 endif4557 4558 #ifdef NC_DOUBLE4559 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(4),vg_i)4560 #else4561 ierr = NF_GET_VAR_REAL(nid,var3didin(4),vg_i)4562 #endif4563 if(ierr/=NF_NOERR) then4564 write(*,*) NF_STRERROR(ierr)4565 stop "getvarup"4566 endif4567 4568 #ifdef NC_DOUBLE4569 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(5),pf_i)4570 #else4571 ierr = NF_GET_VAR_REAL(nid,var3didin(5),pf_i)4572 #endif4573 if(ierr/=NF_NOERR) then4574 write(*,*) NF_STRERROR(ierr)4575 stop "getvarup"4576 endif4577 4578 #ifdef NC_DOUBLE4579 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(6),th_i)4580 #else4581 ierr = NF_GET_VAR_REAL(nid,var3didin(6),th_i)4582 #endif4583 if(ierr/=NF_NOERR) then4584 write(*,*) NF_STRERROR(ierr)4585 stop "getvarup"4586 endif4587 4588 #ifdef NC_DOUBLE4589 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(7),t_i)4590 #else4591 ierr = NF_GET_VAR_REAL(nid,var3didin(7),t_i)4592 #endif4593 if(ierr/=NF_NOERR) then4594 write(*,*) NF_STRERROR(ierr)4595 stop "getvarup"4596 endif4597 4598 #ifdef NC_DOUBLE4599 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(8),qv_i)4600 #else4601 ierr = NF_GET_VAR_REAL(nid,var3didin(8),qv_i)4602 #endif4603 if(ierr/=NF_NOERR) then4604 write(*,*) NF_STRERROR(ierr)4605 stop "getvarup"4606 endif4607 4608 #ifdef NC_DOUBLE4609 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(9),u_i)4610 #else4611 ierr = NF_GET_VAR_REAL(nid,var3didin(9),u_i)4612 #endif4613 if(ierr/=NF_NOERR) then4614 write(*,*) NF_STRERROR(ierr)4615 stop "getvarup"4616 endif4617 4618 #ifdef NC_DOUBLE4619 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(10),v_i)4620 #else4621 ierr = NF_GET_VAR_REAL(nid,var3didin(10),v_i)4622 #endif4623 if(ierr/=NF_NOERR) then4624 write(*,*) NF_STRERROR(ierr)4625 stop "getvarup"4626 endif4627 4628 #ifdef NC_DOUBLE4629 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(11),hadvt_i)4630 #else4631 ierr = NF_GET_VAR_REAL(nid,var3didin(11),hadvt_i)4632 #endif4633 if(ierr/=NF_NOERR) then4634 write(*,*) NF_STRERROR(ierr)4635 stop "getvarup"4636 endif4637 4638 #ifdef NC_DOUBLE4639 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(12),hadvq_i)4640 #else4641 ierr = NF_GET_VAR_REAL(nid,var3didin(12),hadvq_i)4642 #endif4643 if(ierr/=NF_NOERR) then4644 write(*,*) NF_STRERROR(ierr)4645 stop "getvarup"4646 endif4647 4648 #ifdef NC_DOUBLE4649 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(14),tsnow)4650 #else4651 ierr = NF_GET_VAR_REAL(nid,var3didin(14),tsnow)4652 #endif4653 if(ierr/=NF_NOERR) then4654 write(*,*) NF_STRERROR(ierr)4655 stop "getvarup"4656 endif4657 4658 #ifdef NC_DOUBLE4659 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(15),snow_dens)4660 #else4661 ierr = NF_GET_VAR_REAL(nid,var3didin(15),snow_dens)4662 #endif4663 if(ierr/=NF_NOERR) then4664 write(*,*) NF_STRERROR(ierr)4665 stop "getvarup"4666 endif4667 4668 #ifdef NC_DOUBLE4669 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(16),tg)4670 #else4671 ierr = NF_GET_VAR_REAL(nid,var3didin(16),tg)4672 #endif4673 if(ierr/=NF_NOERR) then4674 write(*,*) NF_STRERROR(ierr)4675 stop "getvarup"4676 endif4677 4678 ! On remet les variables lues dans le bon ordre des niveaux (MPL 20141024)4679 do k=1,nlevel4680 zz(k)=zz_i(nlevel+1-k)4681 ug(k,:)=ug_i(nlevel+1-k,:)4682 vg(k,:)=vg_i(nlevel+1-k,:)4683 pf(k)=pf_i(nlevel+1-k)4684 print *,'pf=',pf(k)4685 th(k)=th_i(nlevel+1-k)4686 t(k)=t_i(nlevel+1-k)4687 qv(k)=qv_i(nlevel+1-k)4688 u(k)=u_i(nlevel+1-k)4689 v(k)=v_i(nlevel+1-k)4690 hadvt(k,:)=hadvt_i(nlevel+1-k,:)4691 hadvq(k,:)=hadvq_i(nlevel+1-k,:)4692 enddo4693 return4694 end subroutine read_gabls44695 !=====================================================================4696 4697 ! Reads CIRC input files4698 4699 SUBROUTINE read_circ(nlev_circ,cf,lwp,iwp,reliq,reice,t,z,p,pm,h2o,o3,sza)4700 4701 parameter (ncm_1=49180)4702 #include "YOMCST.h"4703 4704 real albsfc(ncm_1), albsfc_w(ncm_1)4705 real cf(nlev_circ), icefra(nlev_circ), deice(nlev_circ), &4706 reliq(nlev_circ), reice(nlev_circ), lwp(nlev_circ), iwp(nlev_circ)4707 real t(nlev_circ+1), z(nlev_circ+1), dz(nlev_circ), p(nlev_circ+1)4708 real aer_beta(nlev_circ), waer(nlev_circ), gaer(nlev_circ)4709 real pm(nlev_circ), tm(nlev_circ), h2o(nlev_circ), o3(nlev_circ)4710 real co2(nlev_circ), n2o(nlev_circ), co(nlev_circ), ch4(nlev_circ), &4711 o2(nlev_circ), ccl4(nlev_circ), f11(nlev_circ), f12(nlev_circ)4712 ! za= zenital angle4713 ! sza= cosinus angle zenital4714 real wavn(ncm_1), ssf(ncm_1),za,sza4715 integer nlev4716 4717 4718 ! Open the files4719 4720 open (11, file='Tsfc_sza_nlev_case.txt', status='old')4721 open (12, file='level_input_case.txt', status='old')4722 open (13, file='layer_input_case.txt', status='old')4723 open (14, file='aerosol_input_case.txt', status='old')4724 open (15, file='cloud_input_case.txt', status='old')4725 open (16, file='sfcalbedo_input_case.txt', status='old')4726 4727 ! Read scalar information4728 do iskip=1,54729 read (11, *)4730 enddo4731 read (11, '(i8)') nlev4732 read (11, '(f10.2)') tsfc4733 read (11, '(f10.2)') za4734 read (11, '(f10.4)') sw_dn_toa4735 sza=cos(za/180.*RPI)4736 print *,'nlev,tsfc,sza,sw_dn_toa,RPI',nlev,tsfc,sza,sw_dn_toa,RPI4737 close(11)4738 4739 ! Read level information4740 read (12, *)4741 do il=1,nlev4742 read (12, 302) ilev, z(il), p(il), t(il)4743 z(il)=z(il)*1000. ! z donne en km4744 p(il)=p(il)*100. ! p donne en mb4745 enddo4746 302 format (i8, f8.3, 2f9.2)4747 close(12)4748 4749 ! Read layer information (midpoint values)4750 do iskip=1,34751 read (13, *)4752 enddo4753 do il=1,nlev-14754 read (13, 303) ilev,pm(il),tm(il),h2o(il),co2(il),o3(il), &4755 n2o(il),co(il),ch4(il),o2(il),ccl4(il), &4756 f11(il),f12(il)4757 pm(il)=pm(il)*100.4758 enddo4759 303 format (i8, 2f9.2, 10(2x,e13.7))4760 close(13)4761 4762 ! Read aerosol layer information4763 do iskip=1,34764 read (14, *)4765 enddo4766 read (14, '(f10.2)') aer_alpha4767 read (14, *)4768 read (14, *)4769 do il=1,nlev-14770 read (14, 304) ilev, aer_beta(il), waer(il), gaer(il)4771 enddo4772 304 format (i8, f9.5, 2f8.3)4773 close(14)4774 4775 ! Read cloud information4776 do iskip=1,34777 read (15, *)4778 enddo4779 do il=1,nlev-14780 read (15, 305) ilev, cf(il), lwp(il), iwp(il), reliq(il), reice(il)4781 lwp(il)=lwp(il)/1000. ! lwp donne en g/kg4782 iwp(il)=iwp(il)/1000. ! iwp donne en g/kg4783 reliq(il)=reliq(il)/1000000. ! reliq donne en microns4784 reice(il)=reice(il)/1000000. ! reice donne en microns4785 enddo4786 305 format (i8, f8.3, 4f9.2)4787 close(15)4788 4789 ! Read surface albedo (weighted & unweighted) and spectral solar irradiance4790 do iskip=1,64791 read (16, *)4792 enddo4793 do icm_1=1,ncm_14794 read (16, 306) wavn(icm_1), albsfc(icm_1), albsfc_w(icm_1), ssf(icm_1)4795 enddo4796 306 format(f10.1, 2f12.5, f14.8)4797 close(16)4798 4799 return4800 end subroutine read_circ4801 !=====================================================================4802 ! Reads RTMIP input files4803 4804 SUBROUTINE read_rtmip(nlev_rtmip,play,plev,t,h2o,o3)4805 4806 #include "YOMCST.h"4807 4808 real t(nlev_rtmip), pt(nlev_rtmip),pb(nlev_rtmip),h2o(nlev_rtmip), o3(nlev_rtmip)4809 real temp(nlev_rtmip), play(nlev_rtmip),ovap(nlev_rtmip), oz(nlev_rtmip),plev(nlev_rtmip+1)4810 integer nlev4811 4812 4813 ! Open the files4814 4815 open (11, file='low_resolution_profile.txt', status='old')4816 4817 ! Read level information4818 read (11, *)4819 do il=1,nlev_rtmip4820 read (11, 302) pt(il), pb(il), t(il),h2o(il),o3(il)4821 enddo4822 do il=1,nlev_rtmip4823 play(il)=pt(nlev_rtmip-il+1)*100. ! p donne en mb4824 temp(il)=t(nlev_rtmip-il+1)4825 ovap(il)=h2o(nlev_rtmip-il+1)4826 oz(il)=o3(nlev_rtmip-il+1)4827 enddo4828 do il=1,394829 plev(il)=play(il)+(play(il+1)-play(il))/2.4830 print *,'il p t ovap oz=',il,plev(il),temp(il),ovap(il),oz(il)4831 enddo4832 plev(41)=101300.4833 302 format (e16.10,3x,e16.10,3x,e16.10,3x,e12.6,3x,e12.6)4834 close(12)4835 4836 return4837 end subroutine read_rtmip4838 !=====================================================================4839 1473 4840 1474 ! Subroutines for nudging … … 5125 1759 real frac,frac1,frac2,fact 5126 1760 5127 do l = 1, llm5128 print *,'debut interp2, play=',l,play(l)5129 enddo1761 ! do l = 1, llm 1762 ! print *,'debut interp2, play=',l,play(l) 1763 ! enddo 5130 1764 ! do l = 1, nlev_cas 5131 1765 ! print *,'debut interp2, plev_prof_cas=',l,play(l),plev_prof_cas(l) … … 5137 1771 5138 1772 mxcalc=l 5139 print *,'debut interp2, mxcalc=',mxcalc1773 ! print *,'debut interp2, mxcalc=',mxcalc 5140 1774 k1=0 5141 1775 k2=0 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_decl_cases.h
r3223 r3605 34 34 real w_mod(llm), t_mod(llm),q_mod(llm) 35 35 real u_mod(llm),v_mod(llm), ht_mod(llm),vt_mod(llm),ug_mod(llm),vg_mod(llm) 36 real temp_nudg_mod(llm),qv_nudg_mod(llm),u_nudg_mod(llm),v_nudg_mod(llm) 36 37 real hq_mod(llm),vq_mod(llm),qv_mod(llm),ql_mod(llm),qt_mod(llm) 37 38 real th_mod(llm) … … 95 96 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 96 97 !Declarations specifiques au cas GABLS4 (MPL 20141023) 97 character*80 :: fich_gabls4 98 integer nlev_gabls4, nt_gabls4, nsol_gabls4 99 parameter (nlev_gabls4=90, nt_gabls4=37, nsol_gabls4=19) 100 integer year_ini_gabls4, day_ini_gabls4, mth_ini_gabls4 101 real heure_ini_gabls4 102 real day_ju_ini_gabls4 ! Julian day of gabls4 first day 103 parameter (year_ini_gabls4=2009) 104 parameter (mth_ini_gabls4=12) 105 parameter (day_ini_gabls4=11) ! 11 = 11 decembre 2009 106 parameter (heure_ini_gabls4=0.) !0UTC en secondes 107 real dt_gabls4 108 parameter (dt_gabls4=3600.) ! 1 forcage ttes les heures 109 98 !FHADETRUIRE 99 ! character*80 :: fich_gabls4 100 ! integer nlev_gabls4, nt_gabls4, nsol_gabls4 101 ! parameter (nlev_gabls4=90, nt_gabls4=37, nsol_gabls4=19) 102 ! integer year_ini_gabls4, day_ini_gabls4, mth_ini_gabls4 103 ! real heure_ini_gabls4 104 ! real day_ju_ini_gabls4 ! Julian day of gabls4 first day 105 ! parameter (year_ini_gabls4=2009) 106 ! parameter (mth_ini_gabls4=12) 107 ! parameter (day_ini_gabls4=11) ! 11 = 11 decembre 2009 108 ! parameter (heure_ini_gabls4=0.) !0UTC en secondes 109 ! real dt_gabls4 110 ! parameter (dt_gabls4=3600.) ! 1 forcage ttes les heures 111 ! 110 112 !profils initiaux: 111 112 113 114 115 116 117 118 119 113 ! real plev_gabls4(nlev_gabls4) 114 ! real zz_gabls4(nlev_gabls4) 115 ! real th_gabls4(nlev_gabls4),t_gabls4(nlev_gabls4),qv_gabls4(nlev_gabls4) 116 ! real u_gabls4(nlev_gabls4), v_gabls4(nlev_gabls4) 117 ! real depth_sn_gabls4(nsol_gabls4),tsnow_gabls4(nsol_gabls4),snow_dens_gabls4(nsol_gabls4) 118 ! real t_gabi(nlev_gabls4),qv_gabi(nlev_gabls4) 119 ! real u_gabi(nlev_gabls4), v_gabi(nlev_gabls4),ug_gabi(nlev_gabls4), vg_gabi(nlev_gabls4) 120 ! real ht_gabi(nlev_gabls4),hq_gabi(nlev_gabls4),poub(nlev_gabls4) 121 ! 120 122 !forcings 121 real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4) 122 real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4) 123 real tg_gabls4(nt_gabls4) 124 real ht_profg(nlev_gabls4),hq_profg(nlev_gabls4) 125 real ug_profg(nlev_gabls4),vg_profg(nlev_gabls4) 126 real tg_profg 127 123 ! Lignes a detruire ... 124 ! real ht_gabls4(nlev_gabls4,nt_gabls4),hq_gabls4(nlev_gabls4,nt_gabls4) 125 ! real ug_gabls4(nlev_gabls4,nt_gabls4),vg_gabls4(nlev_gabls4,nt_gabls4) 126 ! real tg_gabls4(nt_gabls4) 127 ! real ht_profg(nlev_gabls4),hq_profg(nlev_gabls4) 128 ! real ug_profg(nlev_gabls4),vg_profg(nlev_gabls4) 129 ! real tg_profg 130 ! 128 131 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 129 132 … … 281 284 real qv_mod_cas(llm),ql_mod_cas(llm),qi_mod_cas(llm) 282 285 real ug_mod_cas(llm),vg_mod_cas(llm) 286 real temp_nudg_mod_cas(llm),qv_nudg_mod_cas(llm),v_nudg_mod_cas(llm),u_nudg_mod_cas(llm) 283 287 real u_mod_cas(llm),v_mod_cas(llm) 284 288 real omega_mod_cas(llm) -
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_interp_cases.h
r2920 r3605 1 !2 ! $Id$3 !4 !---------------------------------------------------------------------5 ! Forcing_LES case: constant dq_dyn6 !---------------------------------------------------------------------7 if (forcing_LES) then8 DO l = 1,llm9 d_q_adv(l,1) = dq_dyn(l,1)10 ENDDO11 endif ! forcing_LES12 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!13 !---------------------------------------------------------------------14 ! Interpolation forcing in time and onto model levels15 !---------------------------------------------------------------------16 if (forcing_GCSSold) then17 1 18 call get_uvd(it,timestep,fich_gcssold_ctl,fich_gcssold_dat, & 19 & ht_gcssold,hq_gcssold,hw_gcssold, & 20 & hu_gcssold,hv_gcssold, & 21 & hthturb_gcssold,hqturb_gcssold,Ts_gcssold, & 22 & imp_fcg_gcssold,ts_fcg_gcssold, & 23 & Tp_fcg_gcssold,Turb_fcg_gcssold) 24 if (prt_level.ge.1) then 25 print *,' get_uvd -> hqturb_gcssold ',it,hqturb_gcssold 26 endif 27 ! large-scale forcing : 28 !!! tsurf = ts_gcssold 29 do l = 1, llm 30 ! u(l) = hu_gcssold(l) ! on prescrit le vent 31 ! v(l) = hv_gcssold(l) ! on prescrit le vent 32 ! omega(l) = hw_gcssold(l) 33 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 34 ! omega2(l)=-rho(l)*omega(l) 35 omega(l) = hw_gcssold(l) 36 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 37 38 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 39 d_t_adv(l) = ht_gcssold(l) 40 d_q_adv(l,1) = hq_gcssold(l) 41 dt_cooling(l) = 0.0 42 enddo 43 44 endif ! forcing_GCSSold 45 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 46 !--------------------------------------------------------------------- 47 ! Interpolation Toga forcing 48 !--------------------------------------------------------------------- 49 if (forcing_toga) then 50 51 if (prt_level.ge.1) then 52 print*, & 53 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_toga=', & 54 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_toga 55 endif 2 print*,'FORCING CASE forcing_case2' 3 ! print*, & 4 ! & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=', & 5 ! & daytime,day1,(daytime-day1)*86400., & 6 ! & (daytime-day1)*86400/pdt_cas 56 7 57 8 ! time interpolation: 58 CALL interp_toga_time(daytime,day1,annee_ref & 59 & ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga & 60 & ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga & 61 & ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga & 62 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof & 63 & ,ht_prof,vt_prof,hq_prof,vq_prof) 64 65 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 66 67 ! vertical interpolation: 68 CALL interp_toga_vertical(play,nlev_toga,plev_prof & 69 & ,t_prof,q_prof,u_prof,v_prof,w_prof & 70 & ,ht_prof,vt_prof,hq_prof,vq_prof & 71 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 72 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 73 74 ! large-scale forcing : 75 tsurf = ts_prof 76 do l = 1, llm 77 u(l) = u_mod(l) ! sb: on prescrit le vent 78 v(l) = v_mod(l) ! sb: on prescrit le vent 79 ! omega(l) = w_prof(l) 80 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 81 ! omega2(l)=-rho(l)*omega(l) 82 omega(l) = w_mod(l) 83 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 84 85 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 86 d_t_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l)) 87 d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l)) 88 dt_cooling(l) = 0.0 89 enddo 90 91 endif ! forcing_toga 92 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 93 ! Interpolation DICE forcing 94 !--------------------------------------------------------------------- 95 if (forcing_dice) then 96 97 if (prt_level.ge.1) then 98 print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_dice=',& 99 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_dice 100 endif 101 102 ! time interpolation: 103 CALL interp_dice_time(daytime,day1,annee_ref & 104 & ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice & 105 & ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice & 106 & ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice & 107 & ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice & 108 & ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof & 109 & ,ustar_prof,psurf_prof,ug_profd,vg_profd & 110 & ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd & 111 & ,omega_profd) 112 ! do l = 1, llm 113 ! print *,'llm l omega_profd',llm,l,omega_profd(l) 114 ! enddo 115 116 if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d 117 118 ! vertical interpolation: 119 CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice & 120 & ,t_dice,qv_dice,u_dice,v_dice,o3_dice & 121 & ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd,omega_profd & 122 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 123 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc) 124 ! do l = 1, llm 125 ! print *,'llm l omega_mod',llm,l,omega_mod(l) 126 ! enddo 127 128 ! Les forcages DICE sont donnes /jour et non /seconde ! 129 ht_mod(:)=ht_mod(:)/86400. 130 hq_mod(:)=hq_mod(:)/86400. 131 hu_mod(:)=hu_mod(:)/86400. 132 hv_mod(:)=hv_mod(:)/86400. 133 134 !calcul de l'advection verticale a partir du omega (repris cas TWPICE, MPL 05082013) 135 !Calcul des gradients verticaux 136 !initialisation 137 d_t_z(:)=0. 138 d_q_z(:)=0. 139 d_u_z(:)=0. 140 d_v_z(:)=0. 141 DO l=2,llm-1 142 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 143 d_q_z(l)=(q(l+1,1)-q(l-1,1)) /(play(l+1)-play(l-1)) 144 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 145 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 146 ENDDO 147 d_t_z(1)=d_t_z(2) 148 d_q_z(1)=d_q_z(2) 149 ! d_u_z(1)=u(2)/(play(2)-psurf)/5. 150 ! d_v_z(1)=v(2)/(play(2)-psurf)/5. 151 d_u_z(1)=0. 152 d_v_z(1)=0. 153 d_t_z(llm)=d_t_z(llm-1) 154 d_q_z(llm)=d_q_z(llm-1) 155 d_u_z(llm)=d_u_z(llm-1) 156 d_v_z(llm)=d_v_z(llm-1) 157 158 !Calcul de l advection verticale: 159 ! utiliser omega (Pa/s) et non w (m/s) !! MP 20131108 160 d_t_dyn_z(:)=omega_mod(:)*d_t_z(:) 161 d_q_dyn_z(:)=omega_mod(:)*d_q_z(:) 162 d_u_dyn_z(:)=omega_mod(:)*d_u_z(:) 163 d_v_dyn_z(:)=omega_mod(:)*d_v_z(:) 164 165 ! large-scale forcing : 166 ! tsurf = tg_prof MPL 20130925 commente 167 psurf = psurf_prof 168 ! For this case, fluxes are imposed 169 fsens=-1*shf_prof 170 flat=-1*lhf_prof 171 ust=ustar_prof 172 tg=tg_prof 173 print *,'ust= ',ust 174 do l = 1, llm 175 ug(l)= ug_profd 176 vg(l)= vg_profd 177 ! omega(l) = w_prof(l) 178 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 179 ! omega2(l)=-rho(l)*omega(l) 180 ! omega(l) = w_mod(l)*(-rg*rho(l)) 181 omega(l) = omega_mod(l) 182 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 183 184 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 185 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l) 186 d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l) 187 d_u_adv(l) = hu_mod(l)-d_u_dyn_z(l) 188 d_v_adv(l) = hv_mod(l)-d_v_dyn_z(l) 189 dt_cooling(l) = 0.0 190 enddo 191 192 endif ! forcing_dice 193 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 194 ! Interpolation gabls4 forcing 195 !--------------------------------------------------------------------- 196 if (forcing_gabls4 ) then 197 198 if (prt_level.ge.1) then 199 print*,'#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_gabls4=',& 200 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_gabls4 201 endif 202 203 ! time interpolation: 204 CALL interp_gabls4_time(daytime,day1,annee_ref & 205 & ,year_ini_gabls4,day_ju_ini_gabls4,nt_gabls4,dt_gabls4,nlev_gabls4 & 206 & ,ug_gabls4,vg_gabls4,ht_gabls4,hq_gabls4,tg_gabls4 & 207 & ,ug_profg,vg_profg,ht_profg,hq_profg,tg_profg) 208 209 if (type_ts_forcing.eq.1) ts_cur = tg_prof ! SST used in read_tsurf1d 210 211 ! vertical interpolation: 212 ! on re-utilise le programme interp_dice_vertical: les transformations sur 213 ! plev_gabls4,th_gabls4,qv_gabls4,u_gabls4,v_gabls4 ne sont pas prises en compte. 214 ! seules celles sur ht_profg,hq_profg,ug_profg,vg_profg sont prises en compte. 215 216 CALL interp_dice_vertical(play,nlev_gabls4,nt_gabls4,plev_gabls4 & 217 ! & ,t_gabls4,qv_gabls4,u_gabls4,v_gabls4,poub & 218 & ,poub,poub,poub,poub,poub & 219 & ,ht_profg,hq_profg,ug_profg,vg_profg,poub,poub & 220 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 221 & ,ht_mod,hq_mod,ug_mod,vg_mod,w_mod,omega_mod,mxcalc) 222 223 do l = 1, llm 224 ug(l)= ug_mod(l) 225 vg(l)= vg_mod(l) 226 d_t_adv(l)=ht_mod(l) 227 d_q_adv(l,1)=hq_mod(l) 228 enddo 229 230 endif ! forcing_gabls4 231 !--------------------------------------------------------------------- 232 233 !--------------------------------------------------------------------- 234 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 235 !--------------------------------------------------------------------- 236 ! Interpolation forcing TWPice 237 !--------------------------------------------------------------------- 238 if (forcing_twpice) then 239 240 print*, & 241 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_twpi=', & 242 & daytime,day1,(daytime-day1)*86400., & 243 & (daytime-day1)*86400/dt_twpi 244 245 ! time interpolation: 246 CALL interp_toga_time(daytime,day1,annee_ref & 247 & ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi & 248 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 249 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi & 250 & ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp,u_proftwp & 251 & ,v_proftwp,w_proftwp & 252 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp) 253 254 ! vertical interpolation: 255 CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp & 256 & ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp & 257 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp & 258 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 259 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 260 261 262 !calcul de l'advection verticale a partir du omega 263 !Calcul des gradients verticaux 264 !initialisation 265 d_t_z(:)=0. 266 d_q_z(:)=0. 267 d_t_dyn_z(:)=0. 268 d_q_dyn_z(:)=0. 269 DO l=2,llm-1 270 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 271 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 272 ENDDO 273 d_t_z(1)=d_t_z(2) 274 d_q_z(1)=d_q_z(2) 275 d_t_z(llm)=d_t_z(llm-1) 276 d_q_z(llm)=d_q_z(llm-1) 277 278 !Calcul de l advection verticale 279 d_t_dyn_z(:)=w_mod(:)*d_t_z(:) 280 d_q_dyn_z(:)=w_mod(:)*d_q_z(:) 281 282 !wind nudging above 500m with a 2h time scale 283 do l=1,llm 284 if (nudge_wind) then 285 ! if (phi(l).gt.5000.) then 286 if (phi(l).gt.0.) then 287 u(l)=u(l)+timestep*(u_mod(l)-u(l))/(2.*3600.) 288 v(l)=v(l)+timestep*(v_mod(l)-v(l))/(2.*3600.) 289 endif 290 else 291 u(l) = u_mod(l) 292 v(l) = v_mod(l) 293 endif 294 enddo 295 296 !CR:nudging of q and theta with a 6h time scale above 15km 297 if (nudge_thermo) then 298 do l=1,llm 299 zz(l)=phi(l)/9.8 300 if ((zz(l).le.16000.).and.(zz(l).gt.15000.)) then 301 zfact=(zz(l)-15000.)/1000. 302 q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.)*zfact 303 temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.)*zfact 304 else if (zz(l).gt.16000.) then 305 q(l,1)=q(l,1)+timestep*(q_mod(l)-q(l,1))/(6.*3600.) 306 temp(l)=temp(l)+timestep*(t_mod(l)-temp(l))/(6.*3600.) 307 endif 308 enddo 309 endif 310 311 do l = 1, llm 312 omega(l) = w_mod(l) 313 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 314 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 315 !calcul de l'advection totale 316 if (cptadvw) then 317 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-d_t_dyn_z(l) 318 ! print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l) 319 d_q_adv(l,1) = hq_mod(l)-d_q_dyn_z(l) 320 ! print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l) 321 else 322 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l)) 323 d_q_adv(l,1) = (hq_mod(l)+vq_mod(l)) 324 endif 325 dt_cooling(l) = 0.0 326 enddo 327 328 endif ! forcing_twpice 329 330 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 331 !--------------------------------------------------------------------- 332 ! Interpolation forcing AMMA 333 !--------------------------------------------------------------------- 334 335 if (forcing_amma) then 336 337 print*, & 338 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_amma=', & 339 & daytime,day1,(daytime-day1)*86400., & 340 & (daytime-day1)*86400/dt_amma 341 342 ! time interpolation using TOGA interpolation routine 343 CALL interp_amma_time(daytime,day1,annee_ref & 344 & ,year_ini_amma,day_ju_ini_amma,nt_amma,dt_amma,nlev_amma & 345 & ,vitw_amma,ht_amma,hq_amma,lat_amma,sens_amma & 346 & ,vitw_profamma,ht_profamma,hq_profamma,lat_profamma & 347 & ,sens_profamma) 348 349 print*,'apres interpolation temporelle AMMA' 350 351 do k=1,nlev_amma 352 th_profamma(k)=0. 353 q_profamma(k)=0. 354 u_profamma(k)=0. 355 v_profamma(k)=0. 356 vt_profamma(k)=0. 357 vq_profamma(k)=0. 358 enddo 359 ! vertical interpolation using TOGA interpolation routine: 360 ! write(*,*)'avant interp vert', t_proftwp 361 CALL interp_toga_vertical(play,nlev_amma,plev_amma & 362 & ,th_profamma,q_profamma,u_profamma,v_profamma & 363 & ,vitw_profamma & 364 & ,ht_profamma,vt_profamma,hq_profamma,vq_profamma & 365 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 366 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 367 write(*,*) 'Profil initial forcing AMMA interpole' 368 369 370 !calcul de l'advection verticale a partir du omega 371 !Calcul des gradients verticaux 372 !initialisation 373 do l=1,llm 374 d_t_z(l)=0. 375 d_q_z(l)=0. 376 enddo 377 378 DO l=2,llm-1 379 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 380 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 381 ENDDO 382 d_t_z(1)=d_t_z(2) 383 d_q_z(1)=d_q_z(2) 384 d_t_z(llm)=d_t_z(llm-1) 385 d_q_z(llm)=d_q_z(llm-1) 386 387 388 do l = 1, llm 389 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 390 omega(l) = w_mod(l)*(-rg*rho(l)) 391 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 392 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 393 !calcul de l'advection totale 394 ! d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l)-omega(l)*d_t_z(l) 395 !attention: on impose dth 396 d_t_adv(l) = alpha*omega(l)/rcpd+ & 397 & ht_mod(l)*(play(l)/pzero)**rkappa-omega(l)*d_t_z(l) 398 ! d_t_adv(l) = 0. 399 ! print*,'temp vert adv',l,ht_mod(l),vt_mod(l),-d_t_dyn_z(l) 400 d_q_adv(l,1) = hq_mod(l)-omega(l)*d_q_z(l) 401 ! d_q_adv(l,1) = 0. 402 ! print*,'q vert adv',l,hq_mod(l),vq_mod(l),-d_q_dyn_z(l) 403 404 dt_cooling(l) = 0.0 405 enddo 406 407 408 ! ok_flux_surf=.false. 409 fsens=-1.*sens_profamma 410 flat=-1.*lat_profamma 411 412 endif ! forcing_amma 413 414 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 415 !--------------------------------------------------------------------- 416 ! Interpolation forcing Rico 417 !--------------------------------------------------------------------- 418 if (forcing_rico) then 419 ! call lstendH(llm,omega,dt_dyn,dq_dyn,du_dyn, dv_dyn,q,temp,u,v,play) 420 call lstendH(llm,nqtot,omega,dt_dyn,dq_dyn,q,temp,u,v,play) 421 422 do l=1,llm 423 d_t_adv(l) = (dth_rico(l) + dt_dyn(l)) 424 d_q_adv(l,1) = (dqh_rico(l) + dq_dyn(l,1)) 425 d_q_adv(l,2) = 0. 426 enddo 427 endif ! forcing_rico 428 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 429 !--------------------------------------------------------------------- 430 ! Interpolation forcing Arm_cu 431 !--------------------------------------------------------------------- 432 if (forcing_armcu) then 433 434 print*, & 435 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_armcu=', & 436 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_armcu 437 438 ! time interpolation: 439 ! ATTENTION, cet appel ne convient pas pour TOGA !! 440 ! revoir 1DUTILS.h et les arguments 441 CALL interp_armcu_time(daytime,day1,annee_ref & 442 & ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu & 443 & ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu & 444 & ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof & 445 & ,adv_theta_prof,rad_theta_prof,adv_qt_prof) 446 447 ! vertical interpolation: 448 ! No vertical interpolation if nlev imposed to 19 or 40 449 450 ! For this case, fluxes are imposed 451 fsens=-1*sens_prof 452 flat=-1*flat_prof 453 454 ! Advective forcings are given in K or g/kg ... BY HOUR 455 do l = 1, llm 456 ug(l)= u_mod(l) 457 vg(l)= v_mod(l) 458 IF((phi(l)/RG).LT.1000) THEN 459 d_t_adv(l) = (adv_theta_prof + rad_theta_prof)/3600. 460 d_q_adv(l,1) = adv_qt_prof/1000./3600. 461 d_q_adv(l,2) = 0.0 462 ! print *,'INF1000: phi dth dq1 dq2', 463 ! : phi(l)/RG,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 464 ELSEIF ((phi(l)/RG).GE.1000.AND.(phi(l)/RG).lt.3000) THEN 465 fact=((phi(l)/RG)-1000.)/2000. 466 fact=1-fact 467 d_t_adv(l) = (adv_theta_prof + rad_theta_prof)*fact/3600. 468 d_q_adv(l,1) = adv_qt_prof*fact/1000./3600. 469 d_q_adv(l,2) = 0.0 470 ! print *,'SUP1000: phi fact dth dq1 dq2', 471 ! : phi(l)/RG,fact,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 472 ELSE 473 d_t_adv(l) = 0.0 474 d_q_adv(l,1) = 0.0 475 d_q_adv(l,2) = 0.0 476 ! print *,'SUP3000: phi dth dq1 dq2', 477 ! : phi(l)/RG,d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 478 ENDIF 479 dt_cooling(l) = 0.0 480 ! print *,'Interp armcu: phi dth dq1 dq2', 481 ! : l,phi(l),d_t_adv(l),d_q_adv(l,1),d_q_adv(l,2) 482 enddo 483 endif ! forcing_armcu 484 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 485 !--------------------------------------------------------------------- 486 ! Interpolation forcing in time and onto model levels 487 !--------------------------------------------------------------------- 488 if (forcing_sandu) then 489 490 print*, & 491 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_sandu=', & 492 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_sandu 493 494 ! time interpolation: 495 ! ATTENTION, cet appel ne convient pas pour TOGA !! 496 ! revoir 1DUTILS.h et les arguments 497 CALL interp_sandu_time(daytime,day1,annee_ref & 498 & ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu & 499 & ,nlev_sandu & 500 & ,ts_sandu,ts_prof) 501 502 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 503 504 ! vertical interpolation: 505 CALL interp_sandu_vertical(play,nlev_sandu,plev_profs & 506 & ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs & 507 & ,omega_profs,o3mmr_profs & 508 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod & 509 & ,omega_mod,o3mmr_mod,mxcalc) 510 !calcul de l'advection verticale 511 !Calcul des gradients verticaux 512 !initialisation 513 d_t_z(:)=0. 514 d_q_z(:)=0. 515 d_t_dyn_z(:)=0. 516 d_q_dyn_z(:)=0. 517 ! schema centre 518 ! DO l=2,llm-1 519 ! d_t_z(l)=(temp(l+1)-temp(l-1)) 520 ! & /(play(l+1)-play(l-1)) 521 ! d_q_z(l)=(q(l+1,1)-q(l-1,1)) 522 ! & /(play(l+1)-play(l-1)) 523 ! schema amont 524 DO l=2,llm-1 525 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 526 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 527 ! print *,'l temp2 temp0 play2 play0 omega_mod', 528 ! & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l) 529 ENDDO 530 d_t_z(1)=d_t_z(2) 531 d_q_z(1)=d_q_z(2) 532 d_t_z(llm)=d_t_z(llm-1) 533 d_q_z(llm)=d_q_z(llm-1) 534 535 ! calcul de l advection verticale 536 ! Confusion w (m/s) et omega (Pa/s) !! 537 d_t_dyn_z(:)=omega_mod(:)*d_t_z(:) 538 d_q_dyn_z(:)=omega_mod(:)*d_q_z(:) 539 ! do l=1,llm 540 ! print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z', 541 ! :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l) 542 ! enddo 543 544 545 ! large-scale forcing : pour le cas Sandu ces forcages sont la SST 546 ! et une divergence constante -> profil de omega 547 tsurf = ts_prof 548 write(*,*) 'SST suivante: ',tsurf 549 do l = 1, llm 550 omega(l) = omega_mod(l) 551 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 552 553 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 554 ! 555 ! d_t_adv(l) = 0.0 556 ! d_q_adv(l,1) = 0.0 557 !CR:test advection=0 558 !calcul de l'advection verticale 559 d_t_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l) 560 ! print*,'temp adv',l,-d_t_dyn_z(l) 561 d_q_adv(l,1) = -d_q_dyn_z(l) 562 ! print*,'q adv',l,-d_q_dyn_z(l) 563 dt_cooling(l) = 0.0 564 enddo 565 endif ! forcing_sandu 566 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 567 !--------------------------------------------------------------------- 568 ! Interpolation forcing in time and onto model levels 569 !--------------------------------------------------------------------- 570 if (forcing_astex) then 571 572 print*, & 573 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/dt_astex=', & 574 & day,day1,(day-day1)*86400.,(day-day1)*86400/dt_astex 575 576 ! time interpolation: 577 ! ATTENTION, cet appel ne convient pas pour TOGA !! 578 ! revoir 1DUTILS.h et les arguments 579 CALL interp_astex_time(daytime,day1,annee_ref & 580 & ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex & 581 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex & 582 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof & 583 & ,ufa_prof,vfa_prof) 584 585 if (type_ts_forcing.eq.1) ts_cur = ts_prof ! SST used in read_tsurf1d 586 587 ! vertical interpolation: 588 CALL interp_astex_vertical(play,nlev_astex,plev_profa & 589 & ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa & 590 & ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa & 591 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod & 592 & ,tke_mod,o3mmr_mod,mxcalc) 593 !calcul de l'advection verticale 594 !Calcul des gradients verticaux 595 !initialisation 596 d_t_z(:)=0. 597 d_q_z(:)=0. 598 d_t_dyn_z(:)=0. 599 d_q_dyn_z(:)=0. 600 ! schema centre 601 ! DO l=2,llm-1 602 ! d_t_z(l)=(temp(l+1)-temp(l-1)) 603 ! & /(play(l+1)-play(l-1)) 604 ! d_q_z(l)=(q(l+1,1)-q(l-1,1)) 605 ! & /(play(l+1)-play(l-1)) 606 ! schema amont 607 DO l=2,llm-1 608 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 609 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 610 ! print *,'l temp2 temp0 play2 play0 omega_mod', 611 ! & temp(l+1),temp(l-1),play(l+1),play(l-1),omega_mod(l) 612 ENDDO 613 d_t_z(1)=d_t_z(2) 614 d_q_z(1)=d_q_z(2) 615 d_t_z(llm)=d_t_z(llm-1) 616 d_q_z(llm)=d_q_z(llm-1) 617 618 ! calcul de l advection verticale 619 ! Confusion w (m/s) et omega (Pa/s) !! 620 d_t_dyn_z(:)=w_mod(:)*d_t_z(:) 621 d_q_dyn_z(:)=w_mod(:)*d_q_z(:) 622 ! do l=1,llm 623 ! print *,'d_t_dyn omega_mod d_t_z d_q_dyn d_q_z', 624 ! :l,d_t_dyn_z(l),omega_mod(l),d_t_z(l),d_q_dyn_z(l),d_q_z(l) 625 ! enddo 626 627 628 ! large-scale forcing : pour le cas Astex ces forcages sont la SST 629 ! la divergence,ug,vg,ufa,vfa 630 tsurf = ts_prof 631 write(*,*) 'SST suivante: ',tsurf 632 do l = 1, llm 633 omega(l) = w_mod(l) 634 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 635 636 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 637 ! 638 ! d_t_adv(l) = 0.0 639 ! d_q_adv(l,1) = 0.0 640 !CR:test advection=0 641 !calcul de l'advection verticale 642 d_t_adv(l) = alpha*omega(l)/rcpd-d_t_dyn_z(l) 643 ! print*,'temp adv',l,-d_t_dyn_z(l) 644 d_q_adv(l,1) = -d_q_dyn_z(l) 645 ! print*,'q adv',l,-d_q_dyn_z(l) 646 dt_cooling(l) = 0.0 647 enddo 648 endif ! forcing_astex 649 650 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 651 !--------------------------------------------------------------------- 652 ! Interpolation forcing standard case 653 !--------------------------------------------------------------------- 654 if (forcing_case) then 655 656 print*, & 657 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=', & 658 & daytime,day1,(daytime-day1)*86400., & 659 & (daytime-day1)*86400/pdt_cas 660 661 ! time interpolation: 662 CALL interp_case_time(daytime,day1,annee_ref & 663 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 664 & ,nt_cas,nlev_cas & 665 & ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas,ug_cas,vg_cas & 666 & ,vitw_cas,du_cas,hu_cas,vu_cas & 667 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 668 & ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas & 669 & ,uw_cas,vw_cas,q1_cas,q2_cas & 670 & ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas & 671 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas & 672 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas & 673 & ,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas,lat_prof_cas & 674 & ,sens_prof_cas,ustar_prof_cas,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas) 675 676 ts_cur = ts_prof_cas 677 psurf=plev_prof_cas(1) 678 679 ! vertical interpolation: 680 CALL interp_case_vertical(play,nlev_cas,plev_prof_cas & 681 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas & 682 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 683 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 684 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas & 685 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 686 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc) 687 688 689 !calcul de l'advection verticale a partir du omega 690 !Calcul des gradients verticaux 691 !initialisation 692 d_t_z(:)=0. 693 d_q_z(:)=0. 694 d_u_z(:)=0. 695 d_v_z(:)=0. 696 d_t_dyn_z(:)=0. 697 d_q_dyn_z(:)=0. 698 d_u_dyn_z(:)=0. 699 d_v_dyn_z(:)=0. 700 DO l=2,llm-1 701 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 702 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 703 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 704 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 705 ENDDO 706 d_t_z(1)=d_t_z(2) 707 d_q_z(1)=d_q_z(2) 708 d_u_z(1)=d_u_z(2) 709 d_v_z(1)=d_v_z(2) 710 d_t_z(llm)=d_t_z(llm-1) 711 d_q_z(llm)=d_q_z(llm-1) 712 d_u_z(llm)=d_u_z(llm-1) 713 d_v_z(llm)=d_v_z(llm-1) 714 715 !Calcul de l advection verticale 716 717 d_t_dyn_z(:)=w_mod_cas(:)*d_t_z(:) 718 719 d_q_dyn_z(:)=w_mod_cas(:)*d_q_z(:) 720 d_u_dyn_z(:)=w_mod_cas(:)*d_u_z(:) 721 d_v_dyn_z(:)=w_mod_cas(:)*d_v_z(:) 722 723 !wind nudging 724 if (nudge_u.gt.0.) then 725 do l=1,llm 726 u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u) 727 enddo 728 else 729 do l=1,llm 730 u(l) = u_mod_cas(l) 731 enddo 732 endif 733 734 if (nudge_v.gt.0.) then 735 do l=1,llm 736 v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v) 737 enddo 738 else 739 do l=1,llm 740 v(l) = v_mod_cas(l) 741 enddo 742 endif 743 744 if (nudge_w.gt.0.) then 745 do l=1,llm 746 w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w) 747 enddo 748 else 749 do l=1,llm 750 w(l) = w_mod_cas(l) 751 enddo 752 endif 753 754 !nudging of q and temp 755 if (nudge_t.gt.0.) then 756 do l=1,llm 757 temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t) 758 enddo 759 endif 760 if (nudge_q.gt.0.) then 761 do l=1,llm 762 q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q) 763 enddo 764 endif 765 766 do l = 1, llm 767 omega(l) = w_mod_cas(l) ! juste car w_mod_cas en Pa/s (MPL 20170310) 768 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 769 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 770 771 !calcul advection 772 if ((tend_u.eq.1).and.(tend_w.eq.0)) then 773 d_u_adv(l)=du_mod_cas(l) 774 else if ((tend_u.eq.1).and.(tend_w.eq.1)) then 775 d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l) 776 endif 777 778 if ((tend_v.eq.1).and.(tend_w.eq.0)) then 779 d_v_adv(l)=dv_mod_cas(l) 780 else if ((tend_v.eq.1).and.(tend_w.eq.1)) then 781 d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l) 782 endif 783 784 if ((tend_t.eq.1).and.(tend_w.eq.0)) then 785 ! d_t_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l) 786 d_t_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l) 787 else if ((tend_t.eq.1).and.(tend_w.eq.1)) then 788 ! d_t_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l) 789 d_t_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l) 790 endif 791 792 if ((tend_q.eq.1).and.(tend_w.eq.0)) then 793 ! d_q_adv(l,1)=dq_mod_cas(l) 794 d_q_adv(l,1)=-1*dq_mod_cas(l) 795 else if ((tend_q.eq.1).and.(tend_w.eq.1)) then 796 ! d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l) 797 d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l) 798 endif 799 800 if (tend_rayo.eq.1) then 801 dt_cooling(l) = dtrad_mod_cas(l) 802 ! print *,'dt_cooling=',dt_cooling(l) 803 else 804 dt_cooling(l) = 0.0 805 endif 806 enddo 807 808 ! Faut-il multiplier par -1 ? (MPL 20160713) 809 IF(ok_flux_surf) THEN 810 fsens=sens_prof_cas 811 flat=lat_prof_cas 812 ENDIF 813 ! 814 IF (ok_prescr_ust) THEN 815 ust=ustar_prof_cas 816 print *,'ust=',ust 817 ENDIF 818 endif ! forcing_case 819 820 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 821 !--------------------------------------------------------------------- 822 ! Interpolation forcing standard case 823 !--------------------------------------------------------------------- 824 if (forcing_case2) then 825 826 print*, & 827 & '#### ITAP,day,day1,(day-day1)*86400,(day-day1)*86400/pdt_cas=', & 828 & daytime,day1,(daytime-day1)*86400., & 829 & (daytime-day1)*86400/pdt_cas 830 831 ! time interpolation: 832 CALL interp2_case_time(daytime,day1,annee_ref & 9 CALL interp_case_time_std(daytime,day1,annee_ref & 833 10 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 834 11 & ,nt_cas,nlev_cas & 835 12 & ,ts_cas,ps_cas,plev_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,ql_cas,qi_cas & 836 & ,u_cas,v_cas,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas & 13 & ,u_cas,v_cas,ug_cas,vg_cas & 14 & ,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas & 15 & ,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas & 837 16 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 838 17 & ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,lat_cas,sens_cas,ustar_cas & 839 18 & ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas & 840 19 ! 841 & ,ts_prof_cas,p lev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas &20 & ,ts_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas & 842 21 & ,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas & 843 & ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 22 & ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas & 23 & ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & 24 & ,vitw_prof_cas,omega_prof_cas & 844 25 & ,du_prof_cas,hu_prof_cas,vu_prof_cas & 845 26 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas & … … 853 34 854 35 ! vertical interpolation: 855 CALL interp2_case_vertical (play,nlev_cas,plev_prof_cas &856 & ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas 36 CALL interp2_case_vertical_std(play,nlev_cas,plev_prof_cas & 37 & ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas & 857 38 & ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas & 858 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 39 & ,ug_prof_cas,vg_prof_cas & 40 & ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & 41 & ,vitw_prof_cas,omega_prof_cas & 859 42 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 860 43 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & … … 862 45 ! 863 46 & ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas,qv_mod_cas,ql_mod_cas,qi_mod_cas & 864 & ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas,omega_mod_cas & 47 & ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas & 48 & ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas & 49 & ,w_mod_cas,omega_mod_cas & 865 50 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 866 51 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas & … … 884 69 d_u_dyn_z(:)=0. 885 70 d_v_dyn_z(:)=0. 886 DO l=2,llm-1 887 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 888 d_th_z(l)=(teta(l+1)-teta(l-1))/(play(l+1)-play(l-1)) 889 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 890 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 891 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 892 ENDDO 71 if (1==0) then 72 DO l=2,llm-1 73 d_t_z(l)=(temp(l+1)-temp(l-1))/(play(l+1)-play(l-1)) 74 d_th_z(l)=(teta(l+1)-teta(l-1))/(play(l+1)-play(l-1)) 75 d_q_z(l)=(q(l+1,1)-q(l-1,1))/(play(l+1)-play(l-1)) 76 d_u_z(l)=(u(l+1)-u(l-1))/(play(l+1)-play(l-1)) 77 d_v_z(l)=(v(l+1)-v(l-1))/(play(l+1)-play(l-1)) 78 ENDDO 79 else 80 DO l=2,llm-1 81 IF (omega(l)>0.) THEN 82 d_t_z(l)=(temp(l+1)-temp(l))/(play(l+1)-play(l)) 83 d_th_z(l)=(teta(l+1)-teta(l))/(play(l+1)-play(l)) 84 d_q_z(l)=(q(l+1,1)-q(l,1))/(play(l+1)-play(l)) 85 d_u_z(l)=(u(l+1)-u(l))/(play(l+1)-play(l)) 86 d_v_z(l)=(v(l+1)-v(l))/(play(l+1)-play(l)) 87 ELSE 88 d_t_z(l)=(temp(l-1)-temp(l))/(play(l-1)-play(l)) 89 d_th_z(l)=(teta(l-1)-teta(l))/(play(l-1)-play(l)) 90 d_q_z(l)=(q(l-1,1)-q(l,1))/(play(l-1)-play(l)) 91 d_u_z(l)=(u(l-1)-u(l))/(play(l-1)-play(l)) 92 d_v_z(l)=(v(l-1)-v(l))/(play(l-1)-play(l)) 93 ENDIF 94 ENDDO 95 endif 96 d_t_z(1)=d_t_z(2) 893 97 d_t_z(1)=d_t_z(2) 894 98 d_th_z(1)=d_th_z(2) … … 902 106 d_v_z(llm)=d_v_z(llm-1) 903 107 108 ! TRAVAIL : PRENDRE DES NOTATIONS COHERENTES POUR W 109 do l = 1, llm 110 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309) 111 omega(l) = -w_mod_cas(l)*play(l)*rg/(rd*temp(l)) 112 enddo 113 904 114 !Calcul de l advection verticale 905 115 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170310) 906 d_t_dyn_z(:)=omega _mod_cas(:)*d_t_z(:)907 d_th_dyn_z(:)=omega _mod_cas(:)*d_th_z(:)908 d_q_dyn_z(:)=omega _mod_cas(:)*d_q_z(:)909 d_u_dyn_z(:)=omega _mod_cas(:)*d_u_z(:)910 d_v_dyn_z(:)=omega _mod_cas(:)*d_v_z(:)116 d_t_dyn_z(:)=omega(:)*d_t_z(:) 117 d_th_dyn_z(:)=omega(:)*d_th_z(:) 118 d_q_dyn_z(:)=omega(:)*d_q_z(:) 119 d_u_dyn_z(:)=omega(:)*d_u_z(:) 120 d_v_dyn_z(:)=omega(:)*d_v_z(:) 911 121 912 122 !geostrophic wind … … 917 127 enddo 918 128 endif 919 !wind nudging920 if (nudging_u.gt.0.) then921 do l=1,llm922 u(l)=u(l)+timestep*(u_mod_cas(l)-u(l))/(nudge_u)923 enddo924 ! else925 ! do l=1,llm926 ! u(l) = u_mod_cas(l)927 ! enddo928 endif929 930 if (nudging_v.gt.0.) then931 do l=1,llm932 v(l)=v(l)+timestep*(v_mod_cas(l)-v(l))/(nudge_v)933 enddo934 ! else935 ! do l=1,llm936 ! v(l) = v_mod_cas(l)937 ! enddo938 endif939 940 if (nudging_w.gt.0.) then941 do l=1,llm942 w(l)=w(l)+timestep*(w_mod_cas(l)-w(l))/(nudge_w)943 enddo944 ! else945 ! do l=1,llm946 ! w(l) = w_mod_cas(l)947 ! enddo948 endif949 950 !nudging of q and temp951 if (nudging_t.gt.0.) then952 do l=1,llm953 temp(l)=temp(l)+timestep*(t_mod_cas(l)-temp(l))/(nudge_t)954 enddo955 endif956 if (nudging_q.gt.0.) then957 do l=1,llm958 q(l,1)=q(l,1)+timestep*(q_mod_cas(l)-q(l,1))/(nudge_q)959 enddo960 endif961 129 962 130 do l = 1, llm 131 132 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 963 133 ! Modif w_mod_cas -> omega_mod_cas (MM+MPL 20170309) 134 !!! omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 964 135 omega(l) = omega_mod_cas(l) 965 omega2(l)= omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 966 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 136 omega2(l)= omega_mod_cas(l)/rg*airefi ! flxmass_w calcule comme ds physiq 967 137 968 !calcul advections 969 if ((forc_u.eq.1).and.(forc_w.eq.0)) then 970 d_u_adv(l)=du_mod_cas(l) 971 else if ((forc_u.eq.1).and.(forc_w.eq.1)) then 972 d_u_adv(l)=hu_mod_cas(l)-d_u_dyn_z(l) 973 endif 138 ! On effectue la somme du forcage total et de la decomposition 139 ! horizontal/vertical en supposant que soit l'un soit l'autre 140 ! sont remplis mais jamais les deux 974 141 975 if ((forc_v.eq.1).and.(forc_w.eq.0)) then976 d_v_adv(l)=dv_mod_cas(l)977 else if ((forc_v.eq.1).and.(forc_w.eq.1)) then978 d_v_adv(l)=hv_mod_cas(l)-d_v_dyn_z(l)979 endif142 d_t_adv(l) = dt_mod_cas(l)+ht_mod_cas(l)+vt_mod_cas(l) 143 d_q_adv(l,1) = dq_mod_cas(l)+hq_mod_cas(l)+vq_mod_cas(l) 144 d_q_adv(l,2) = 0.0 145 d_u_adv(l) = du_mod_cas(l)+hu_mod_cas(l)+vu_mod_cas(l) 146 d_v_adv(l) = dv_mod_cas(l)+hv_mod_cas(l)+vv_mod_cas(l) 980 147 981 ! Puisque dth a ete converti en dt, on traite de la meme facon 982 ! les flags tadv et thadv 983 if ((tadv.eq.1.or.thadv.eq.1) .and. (forc_w.eq.0)) then 984 ! d_t_adv(l)=alpha*omega(l)/rcpd-dt_mod_cas(l) 985 d_t_adv(l)=alpha*omega(l)/rcpd+dt_mod_cas(l) 986 else if ((tadv.eq.1.or.thadv.eq.1) .and. (forc_w.eq.1)) then 987 ! d_t_adv(l)=alpha*omega(l)/rcpd-ht_mod_cas(l)-d_t_dyn_z(l) 988 d_t_adv(l)=alpha*omega(l)/rcpd+ht_mod_cas(l)-d_t_dyn_z(l) 989 endif 990 991 ! if ((thadv.eq.1) .and. (forc_w.eq.0)) then 992 ! d_t_adv(l)=alpha*omega(l)/rcpd-dth_mod_cas(l) 993 ! d_t_adv(l)=alpha*omega(l)/rcpd+dth_mod_cas(l) 994 ! else if ((thadv.eq.1) .and. (forc_w.eq.1)) then 995 ! d_t_adv(l)=alpha*omega(l)/rcpd-hth_mod_cas(l)-d_t_dyn_z(l) 996 ! d_t_adv(l)=alpha*omega(l)/rcpd+hth_mod_cas(l)-d_t_dyn_z(l) 148 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 149 !! CONSERVE EN ATTENDANT QUE LE CAS EN QUESTION FONCTIONNE EN STD !! 150 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 151 !if (forc_w==1) then 152 ! d_q_adv(l,1)=d_q_adv(l,1)-d_q_dyn_z(l) 153 ! d_t_adv(l)=d_t_adv(l)-d_t_dyn_z(l) 154 ! d_v_adv(l)=d_v_adv(l)-d_v_dyn_z(l) 155 ! d_u_adv(l)=d_u_adv(l)-d_u_dyn_z(l) 997 156 ! endif 998 999 if ((qadv.eq.1) .and. (forc_w.eq.0)) then 1000 d_q_adv(l,1)=dq_mod_cas(l) 1001 ! d_q_adv(l,1)=-1*dq_mod_cas(l) 1002 else if ((qadv.eq.1) .and. (forc_w.eq.1)) then 1003 d_q_adv(l,1)=hq_mod_cas(l)-d_q_dyn_z(l) 1004 ! d_q_adv(l,1)=-1*hq_mod_cas(l)-d_q_dyn_z(l) 1005 endif 157 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1006 158 1007 159 if (trad.eq.1) then … … 1025 177 print *,'ust=',ust 1026 178 ENDIF 1027 endif ! forcing_case21028 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1029 -
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_nudge_sandu_astex.h
r3223 r3605 33 33 34 34 35 print*,'OLDLMDZ1D IOPH' 36 CALL iophys_ecrit('relax_thl',klev,'relax_thl','m/s',relax_thl) 37 CALL iophys_ecrit('d_t_adv',klev,'d_t_adv','m/s',d_t_adv) 38 CALL iophys_ecrit('temp',klev,'temp','m/s',temp) 39 CALL iophys_ecrit('q',klev,'q','m/s',q(:,1)) 40 CALL iophys_ecrit('relax_q',klev,'relax_q','m/s',relax_q(:,1)) 41 CALL iophys_ecrit('d_q_adv',klev,'d_q_adv','m/s',d_q_adv(:,1)) 42 -
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/1D_read_forc_cases.h
r2920 r3605 11 11 nq2=0 12 12 13 if (forcing_les .or. forcing_radconv &14 & .or. forcing_GCSSold .or. forcing_fire) then13 print*,'FORCING ,forcing_SCM',forcing_SCM 14 if (forcing_SCM) then 15 15 16 if (forcing_fire) then 17 !---------------------------------------------------------------------- 18 !read fire forcings from fire.nc 19 !---------------------------------------------------------------------- 20 fich_fire='fire.nc' 21 call read_fire(fich_fire,nlev_fire,nt_fire & 22 & ,height,tttprof,qtprof,uprof,vprof,e12prof & 23 & ,ugprof,vgprof,wfls,dqtdxls & 24 & ,dqtdyls,dqtdtls,thlpcar) 25 write(*,*) 'Forcing FIRE lu' 26 kmax=120 ! nombre de niveaux dans les profils et forcages 27 else 28 !---------------------------------------------------------------------- 29 ! Read profiles from files: prof.inp.001 and lscale.inp.001 30 ! (repris de readlesfiles) 31 !---------------------------------------------------------------------- 32 33 call readprofiles(nlev_max,kmax,nqtot,height, & 34 & tttprof,qtprof,uprof,vprof, & 35 & e12prof,ugprof,vgprof, & 36 & wfls,dqtdxls,dqtdyls,dqtdtls, & 37 & thlpcar,qprof,nq1,nq2) 38 endif 39 40 ! compute altitudes of play levels. 41 zlay(1) =zsurf + rd*tsurf*(psurf-play(1))/(rg*psurf) 42 do l = 2,llm 43 zlay(l) = zlay(l-1)+rd*tsurf*(psurf-play(1))/(rg*psurf) 44 enddo 45 46 !---------------------------------------------------------------------- 47 ! Interpolation of the profiles given on the input file to 48 ! model levels 49 !---------------------------------------------------------------------- 50 zlay(1) = zsurf + rd*tsurf*(psurf-play(1))/(rg*psurf) 51 do l=1,llm 52 ! Above the max altutide of the input file 53 54 if (zlay(l)<height(kmax)) mxcalc=l 55 56 frac = (height(kmax)-zlay(l))/(height (kmax)-height(kmax-1)) 57 ttt =tttprof(kmax)-frac*(tttprof(kmax)-tttprof(kmax-1)) 58 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 59 temp(l) = ttt*(play(l)/pzero)**rkappa 60 teta(l) = ttt 61 else 62 temp(l) = ttt 63 teta(l) = ttt*(pzero/play(l))**rkappa 64 endif 65 print *,' temp,teta ',l,temp(l),teta(l) 66 q(l,1) = qtprof(kmax)-frac*( qtprof(kmax)- qtprof(kmax-1)) 67 u(l) = uprof(kmax)-frac*( uprof(kmax)- uprof(kmax-1)) 68 v(l) = vprof(kmax)-frac*( vprof(kmax)- vprof(kmax-1)) 69 ug(l) = ugprof(kmax)-frac*( ugprof(kmax)- ugprof(kmax-1)) 70 vg(l) = vgprof(kmax)-frac*( vgprof(kmax)- vgprof(kmax-1)) 71 IF (nq2>0) q(l,nq1:nq2)=qprof(kmax,nq1:nq2) & 72 & -frac*(qprof(kmax,nq1:nq2)-qprof(kmax-1,nq1:nq2)) 73 omega(l)= wfls(kmax)-frac*( wfls(kmax)- wfls(kmax-1)) 74 75 dq_dyn(l,1) = dqtdtls(kmax)-frac*(dqtdtls(kmax)-dqtdtls(kmax-1)) 76 dt_cooling(l)=thlpcar(kmax)-frac*(thlpcar(kmax)-thlpcar(kmax-1)) 77 do k=2,kmax 78 print *,'k l height(k) height(k-1) zlay(l) frac=',k,l,height(k),height(k-1),zlay(l),frac 79 frac = (height(k)-zlay(l))/(height(k)-height(k-1)) 80 if(l==1) print*,'k, height, tttprof',k,height(k),tttprof(k) 81 if(zlay(l)>height(k-1).and.zlay(l)<height(k)) then 82 ttt =tttprof(k)-frac*(tttprof(k)-tttprof(k-1)) 83 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 84 temp(l) = ttt*(play(l)/pzero)**rkappa 85 teta(l) = ttt 86 else 87 temp(l) = ttt 88 teta(l) = ttt*(pzero/play(l))**rkappa 89 endif 90 print *,' temp,teta ',l,temp(l),teta(l) 91 q(l,1) = qtprof(k)-frac*( qtprof(k)- qtprof(k-1)) 92 u(l) = uprof(k)-frac*( uprof(k)- uprof(k-1)) 93 v(l) = vprof(k)-frac*( vprof(k)- vprof(k-1)) 94 ug(l) = ugprof(k)-frac*( ugprof(k)- ugprof(k-1)) 95 vg(l) = vgprof(k)-frac*( vgprof(k)- vgprof(k-1)) 96 IF (nq2>0) q(l,nq1:nq2)=qprof(k,nq1:nq2) & 97 & -frac*(qprof(k,nq1:nq2)-qprof(k-1,nq1:nq2)) 98 omega(l)= wfls(k)-frac*( wfls(k)- wfls(k-1)) 99 dq_dyn(l,1)=dqtdtls(k)-frac*(dqtdtls(k)-dqtdtls(k-1)) 100 dt_cooling(l)=thlpcar(k)-frac*(thlpcar(k)-thlpcar(k-1)) 101 elseif(zlay(l)<height(1)) then ! profils uniformes pour z<height(1) 102 ttt =tttprof(1) 103 if ((forcing_GCSSold .AND. tp_ini_GCSSold) .OR. forcing_fire)then ! pot. temp. in initial profile 104 temp(l) = ttt*(play(l)/pzero)**rkappa 105 teta(l) = ttt 106 else 107 temp(l) = ttt 108 teta(l) = ttt*(pzero/play(l))**rkappa 109 endif 110 q(l,1) = qtprof(1) 111 u(l) = uprof(1) 112 v(l) = vprof(1) 113 ug(l) = ugprof(1) 114 vg(l) = vgprof(1) 115 omega(l)= wfls(1) 116 IF (nq2>0) q(l,nq1:nq2)=qprof(1,nq1:nq2) 117 dq_dyn(l,1) =dqtdtls(1) 118 dt_cooling(l)=thlpcar(1) 119 endif 120 enddo 121 122 temp(l)=max(min(temp(l),350.),150.) 123 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 124 if (l .lt. llm) then 125 zlay(l+1) = zlay(l) + (play(l)-play(l+1))/(rg*rho(l)) 126 endif 127 omega2(l)=-rho(l)*omega(l) 128 omega(l)= omega(l)*(-rg*rho(l)) !en Pa/s 129 if (l>1) then 130 if(zlay(l-1)>height(kmax)) then 131 omega(l)=0.0 132 omega2(l)=0.0 133 endif 134 endif 135 if(q(l,1)<0.) q(l,1)=0.0 136 q(l,2) = 0.0 137 enddo 138 139 endif ! forcing_les .or. forcing_GCSSold .or. forcing_fire 140 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 141 !--------------------------------------------------------------------- 142 ! Forcing for GCSSold: 143 !--------------------------------------------------------------------- 144 if (forcing_GCSSold) then 145 fich_gcssold_ctl = './forcing.ctl' 146 fich_gcssold_dat = './forcing8.dat' 147 call copie(llm,play,psurf,fich_gcssold_ctl) 148 call get_uvd2(it,timestep,fich_gcssold_ctl,fich_gcssold_dat, & 149 & ht_gcssold,hq_gcssold,hw_gcssold, & 150 & hu_gcssold,hv_gcssold, & 151 & hthturb_gcssold,hqturb_gcssold,Ts_gcssold, & 152 & imp_fcg_gcssold,ts_fcg_gcssold, & 153 & Tp_fcg_gcssold,Turb_fcg_gcssold) 154 print *,' get_uvd2 -> hqturb_gcssold ',hqturb_gcssold 155 endif ! forcing_GCSSold 156 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 157 !--------------------------------------------------------------------- 158 ! Forcing for RICO: 159 !--------------------------------------------------------------------- 160 if (forcing_rico) then 161 162 ! call writefield_phy('omega', omega,llm+1) 163 fich_rico = 'rico.txt' 164 call read_rico(fich_rico,nlev_rico,ps_rico,play & 165 & ,ts_rico,t_rico,q_rico,u_rico,v_rico,w_rico & 166 & ,dth_rico,dqh_rico) 167 print*, ' on a lu et prepare RICO' 168 169 mxcalc=llm 170 print *, airefi, ' airefi ' 171 do l = 1, llm 172 rho(l) = play(l)/(rd*t_rico(l)*(1.+(rv/rd-1.)*q_rico(l))) 173 temp(l) = t_rico(l) 174 q(l,1) = q_rico(l) 175 q(l,2) = 0.0 176 u(l) = u_rico(l) 177 v(l) = v_rico(l) 178 ug(l)=u_rico(l) 179 vg(l)=v_rico(l) 180 omega(l) = -w_rico(l)*rg 181 omega2(l) = omega(l)/rg*airefi 182 enddo 183 endif 184 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 185 !--------------------------------------------------------------------- 186 ! Forcing from TOGA-COARE experiment (Ciesielski et al. 2002) : 187 !--------------------------------------------------------------------- 188 189 if (forcing_toga) then 190 191 ! read TOGA-COARE forcing (native vertical grid, nt_toga timesteps): 192 fich_toga = './d_toga/ifa_toga_coare_v21_dime.txt' 193 CALL read_togacoare(fich_toga,nlev_toga,nt_toga & 194 & ,ts_toga,plev_toga,t_toga,q_toga,u_toga,v_toga,w_toga & 195 & ,ht_toga,vt_toga,hq_toga,vq_toga) 196 197 write(*,*) 'Forcing TOGA lu' 198 199 ! time interpolation for initial conditions: 200 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 201 CALL interp_toga_time(daytime,day1,annee_ref & 202 & ,year_ini_toga,day_ju_ini_toga,nt_toga,dt_toga & 203 & ,nlev_toga,ts_toga,plev_toga,t_toga,q_toga,u_toga & 204 & ,v_toga,w_toga,ht_toga,vt_toga,hq_toga,vq_toga & 205 & ,ts_prof,plev_prof,t_prof,q_prof,u_prof,v_prof,w_prof & 206 & ,ht_prof,vt_prof,hq_prof,vq_prof) 207 208 ! vertical interpolation: 209 CALL interp_toga_vertical(play,nlev_toga,plev_prof & 210 & ,t_prof,q_prof,u_prof,v_prof,w_prof & 211 & ,ht_prof,vt_prof,hq_prof,vq_prof & 212 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 213 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 214 write(*,*) 'Profil initial forcing TOGA interpole' 215 216 ! initial and boundary conditions : 217 tsurf = ts_prof 218 write(*,*) 'SST initiale: ',tsurf 219 do l = 1, llm 220 temp(l) = t_mod(l) 221 q(l,1) = q_mod(l) 222 q(l,2) = 0.0 223 u(l) = u_mod(l) 224 v(l) = v_mod(l) 225 omega(l) = w_mod(l) 226 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 227 !? rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 228 !? omega2(l)=-rho(l)*omega(l) 229 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 230 d_t_adv(l) = alpha*omega(l)/rcpd-(ht_mod(l)+vt_mod(l)) 231 d_q_adv(l,1) = -(hq_mod(l)+vq_mod(l)) 232 d_q_adv(l,2) = 0.0 233 enddo 234 235 endif ! forcing_toga 236 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 237 !--------------------------------------------------------------------- 238 ! Forcing from TWPICE experiment (Shaocheng et al. 2010) : 239 !--------------------------------------------------------------------- 240 241 if (forcing_twpice) then 242 !read TWP-ICE forcings 243 fich_twpice='d_twpi/twp180iopsndgvarana_v2.1_C3.c1.20060117.000000.cdf' 244 call read_twpice(fich_twpice,nlev_twpi,nt_twpi & 245 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 246 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi) 247 248 write(*,*) 'Forcing TWP-ICE lu' 249 !Time interpolation for initial conditions using TOGA interpolation routine 250 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 251 CALL interp_toga_time(daytime,day1,annee_ref & 252 & ,year_ini_twpi,day_ju_ini_twpi,nt_twpi,dt_twpi,nlev_twpi & 253 & ,ts_twpi,plev_twpi,t_twpi,q_twpi,u_twpi,v_twpi,w_twpi & 254 & ,ht_twpi,vt_twpi,hq_twpi,vq_twpi & 255 & ,ts_proftwp,plev_proftwp,t_proftwp,q_proftwp & 256 & ,u_proftwp,v_proftwp,w_proftwp & 257 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp) 258 259 ! vertical interpolation using TOGA interpolation routine: 260 ! write(*,*)'avant interp vert', t_proftwp 261 CALL interp_toga_vertical(play,nlev_twpi,plev_proftwp & 262 & ,t_proftwp,q_proftwp,u_proftwp,v_proftwp,w_proftwp & 263 & ,ht_proftwp,vt_proftwp,hq_proftwp,vq_proftwp & 264 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 265 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 266 ! write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod 267 268 ! initial and boundary conditions : 269 ! tsurf = ts_proftwp 270 write(*,*) 'SST initiale: ',tsurf 271 do l = 1, llm 272 temp(l) = t_mod(l) 273 q(l,1) = q_mod(l) 274 q(l,2) = 0.0 275 u(l) = u_mod(l) 276 v(l) = v_mod(l) 277 omega(l) = w_mod(l) 278 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 279 280 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 281 !on applique le forcage total au premier pas de temps 282 !attention: signe different de toga 283 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod(l)+vt_mod(l)) 284 d_q_adv(l,1) = (hq_mod(l)+vq_mod(l)) 285 d_q_adv(l,2) = 0.0 286 enddo 287 288 endif !forcing_twpice 289 290 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 291 !--------------------------------------------------------------------- 292 ! Forcing from AMMA experiment (Couvreux et al. 2010) : 293 !--------------------------------------------------------------------- 294 295 if (forcing_amma) then 296 297 call read_1D_cases 298 299 write(*,*) 'Forcing AMMA lu' 300 301 !champs initiaux: 302 do k=1,nlev_amma 303 th_ammai(k)=th_amma(k) 304 q_ammai(k)=q_amma(k) 305 u_ammai(k)=u_amma(k) 306 v_ammai(k)=v_amma(k) 307 vitw_ammai(k)=vitw_amma(k,12) 308 ht_ammai(k)=ht_amma(k,12) 309 hq_ammai(k)=hq_amma(k,12) 310 vt_ammai(k)=0. 311 vq_ammai(k)=0. 312 enddo 313 omega(:)=0. 314 omega2(:)=0. 315 rho(:)=0. 316 ! vertical interpolation using TOGA interpolation routine: 317 ! write(*,*)'avant interp vert', t_proftwp 318 CALL interp_toga_vertical(play,nlev_amma,plev_amma & 319 & ,th_ammai,q_ammai,u_ammai,v_ammai,vitw_ammai & 320 & ,ht_ammai,vt_ammai,hq_ammai,vq_ammai & 321 & ,t_mod,q_mod,u_mod,v_mod,w_mod & 322 & ,ht_mod,vt_mod,hq_mod,vq_mod,mxcalc) 323 ! write(*,*) 'Profil initial forcing TWP-ICE interpole',t_mod 324 325 ! initial and boundary conditions : 326 ! tsurf = ts_proftwp 327 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 328 do l = 1, llm 329 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 330 ! temp(l) = t_mod(l)*(play(l)/pzero)**rkappa 331 temp(l) = t_mod(l) 332 q(l,1) = q_mod(l) 333 q(l,2) = 0.0 334 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 335 u(l) = u_mod(l) 336 v(l) = v_mod(l) 337 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 338 omega(l) = w_mod(l)*(-rg*rho(l)) 339 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 340 341 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 342 !on applique le forcage total au premier pas de temps 343 !attention: signe different de toga 344 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 345 !forcage en th 346 ! d_t_adv(l) = ht_mod(l) 347 d_q_adv(l,1) = hq_mod(l) 348 d_q_adv(l,2) = 0.0 349 dt_cooling(l)=0. 350 enddo 351 write(*,*) 'Prof initeforcing AMMA interpole temp39',temp(39) 352 353 354 ! ok_flux_surf=.false. 355 fsens=-1.*sens_amma(12) 356 flat=-1.*lat_amma(12) 357 358 endif !forcing_amma 359 360 361 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 362 !--------------------------------------------------------------------- 363 ! Forcing from DICE experiment (see file DICE_protocol_vn2-3.pdf) 364 !--------------------------------------------------------------------- 365 366 if (forcing_dice) then 367 !read DICE forcings 368 fich_dice='dice_driver.nc' 369 call read_dice(fich_dice,nlev_dice,nt_dice & 370 & ,zz_dice,plev_dice,t_dice,qv_dice,u_dice,v_dice,o3_dice & 371 & ,shf_dice,lhf_dice,lwup_dice,swup_dice,tg_dice,ustar_dice& 372 & ,psurf_dice,ug_dice,vg_dice,ht_dice,hq_dice & 373 & ,hu_dice,hv_dice,w_dice,omega_dice) 374 375 write(*,*) 'Forcing DICE lu' 376 377 !champs initiaux: 378 do k=1,nlev_dice 379 t_dicei(k)=t_dice(k) 380 qv_dicei(k)=qv_dice(k) 381 u_dicei(k)=u_dice(k) 382 v_dicei(k)=v_dice(k) 383 o3_dicei(k)=o3_dice(k) 384 ht_dicei(k)=ht_dice(k,1) 385 hq_dicei(k)=hq_dice(k,1) 386 hu_dicei(k)=hu_dice(k,1) 387 hv_dicei(k)=hv_dice(k,1) 388 w_dicei(k)=w_dice(k,1) 389 omega_dicei(k)=omega_dice(k,1) 390 enddo 391 omega(:)=0. 392 omega2(:)=0. 393 rho(:)=0. 394 ! vertical interpolation using TOGA interpolation routine: 395 ! write(*,*)'avant interp vert', t_proftwp 396 ! 397 ! CALL interp_dice_time(daytime,day1,annee_ref 398 ! i ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice 399 ! i ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice 400 ! i ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice 401 ! i ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice 402 ! o ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof 403 ! o ,ustar_prof,psurf_prof,ug_profd,vg_profd 404 ! o ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd 405 ! o ,omega_profd) 406 407 CALL interp_dice_vertical(play,nlev_dice,nt_dice,plev_dice & 408 & ,t_dicei,qv_dicei,u_dicei,v_dicei,o3_dicei & 409 & ,ht_dicei,hq_dicei,hu_dicei,hv_dicei,w_dicei,omega_dicei& 410 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 411 & ,ht_mod,hq_mod,hu_mod,hv_mod,w_mod,omega_mod,mxcalc) 412 413 ! Pour tester les advections horizontales de T et Q, on met w_mod et omega_mod ?? zero (MPL 20131108) 414 ! w_mod(:,:)=0. 415 ! omega_mod(:,:)=0. 416 417 ! write(*,*) 'Profil initial forcing DICE interpole',t_mod 418 ! Les forcages DICE sont donnes /jour et non /seconde ! 419 ht_mod(:)=ht_mod(:)/86400. 420 hq_mod(:)=hq_mod(:)/86400. 421 hu_mod(:)=hu_mod(:)/86400. 422 hv_mod(:)=hv_mod(:)/86400. 423 424 ! initial and boundary conditions : 425 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 426 do l = 1, llm 427 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 428 ! temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 429 temp(l) = t_mod(l) 430 q(l,1) = qv_mod(l) 431 q(l,2) = 0.0 432 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 433 u(l) = u_mod(l) 434 v(l) = v_mod(l) 435 ug(l)=ug_dice(1) 436 vg(l)=vg_dice(1) 437 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 438 ! omega(l) = w_mod(l)*(-rg*rho(l)) 439 omega(l) = omega_mod(l) 440 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 441 442 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 443 !on applique le forcage total au premier pas de temps 444 !attention: signe different de toga 445 d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 446 !forcage en th 447 ! d_t_adv(l) = ht_mod(l) 448 d_q_adv(l,1) = hq_mod(l) 449 d_q_adv(l,2) = 0.0 450 dt_cooling(l)=0. 451 enddo 452 write(*,*) 'Profil initial forcing DICE interpole temp39',temp(39) 453 454 455 ! ok_flux_surf=.false. 456 fsens=-1.*shf_dice(1) 457 flat=-1.*lhf_dice(1) 458 ! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 459 ! le coefficient de trainee en surface cd**2=ustar*vent(k=1) 460 ! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface 461 ! MPL 05082013 462 ust=ustar_dice(1) 463 tg=tg_dice(1) 464 print *,'ust= ',ust 465 IF (tsurf .LE. 0.) THEN 466 tsurf= tg_dice(1) 467 ENDIF 468 psurf= psurf_dice(1) 469 solsw_in = (1.-albedo)/albedo*swup_dice(1) 470 sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1) 471 PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in 472 endif !forcing_dice 473 474 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 475 !--------------------------------------------------------------------- 476 ! Forcing from GABLS4 experiment 477 !--------------------------------------------------------------------- 478 479 !!!! Si la temperature de surface n'est pas impos??e: 480 481 if (forcing_gabls4) then 482 !read GABLS4 forcings 483 484 fich_gabls4='gabls4_driver.nc' 485 486 487 call read_gabls4(fich_gabls4,nlev_gabls4,nt_gabls4,nsol_gabls4,zz_gabls4,depth_sn_gabls4,ug_gabls4,vg_gabls4 & 488 & ,plev_gabls4,th_gabls4,t_gabls4,qv_gabls4,u_gabls4,v_gabls4,ht_gabls4,hq_gabls4,tg_gabls4,tsnow_gabls4,snow_dens_gabls4) 489 490 write(*,*) 'Forcing GABLS4 lu' 491 492 !champs initiaux: 493 do k=1,nlev_gabls4 494 t_gabi(k)=t_gabls4(k) 495 qv_gabi(k)=qv_gabls4(k) 496 u_gabi(k)=u_gabls4(k) 497 v_gabi(k)=v_gabls4(k) 498 poub(k)=0. 499 ht_gabi(k)=ht_gabls4(k,1) 500 hq_gabi(k)=hq_gabls4(k,1) 501 ug_gabi(k)=ug_gabls4(k,1) 502 vg_gabi(k)=vg_gabls4(k,1) 503 enddo 504 505 omega(:)=0. 506 omega2(:)=0. 507 rho(:)=0. 508 ! vertical interpolation using TOGA interpolation routine: 509 ! write(*,*)'avant interp vert', t_proftwp 510 ! 511 ! CALL interp_dice_time(daytime,day1,annee_ref 512 ! i ,year_ini_dice,day_ju_ini_dice,nt_dice,dt_dice 513 ! i ,nlev_dice,shf_dice,lhf_dice,lwup_dice,swup_dice 514 ! i ,tg_dice,ustar_dice,psurf_dice,ug_dice,vg_dice 515 ! i ,ht_dice,hq_dice,hu_dice,hv_dice,w_dice,omega_dice 516 ! o ,shf_prof,lhf_prof,lwup_prof,swup_prof,tg_prof 517 ! o ,ustar_prof,psurf_prof,ug_profd,vg_profd 518 ! o ,ht_profd,hq_profd,hu_profd,hv_profd,w_profd 519 ! o ,omega_profd) 520 521 CALL interp_dice_vertical(play,nlev_gabls4,nt_gabls4,plev_gabls4 & 522 & ,t_gabi,qv_gabi,u_gabi,v_gabi,poub & 523 & ,ht_gabi,hq_gabi,ug_gabi,vg_gabi,poub,poub & 524 & ,t_mod,qv_mod,u_mod,v_mod,o3_mod & 525 & ,ht_mod,hq_mod,ug_mod,vg_mod,w_mod,omega_mod,mxcalc) 526 527 ! Les forcages GABLS4 ont l air d etre en K/S quoiqu en dise le fichier gabls4_driver.nc !? MPL 20141024 528 ! ht_mod(:)=ht_mod(:)/86400. 529 ! hq_mod(:)=hq_mod(:)/86400. 530 531 ! initial and boundary conditions : 532 write(*,*) 'SST initiale mxcalc: ',tsurf,mxcalc 533 do l = 1, llm 534 ! Ligne du dessous ?? decommenter si on lit theta au lieu de temp 535 ! temp(l) = th_mod(l)*(play(l)/pzero)**rkappa 536 temp(l) = t_mod(l) 537 q(l,1) = qv_mod(l) 538 q(l,2) = 0.0 539 ! print *,'read_forc: l,temp,q=',l,temp(l),q(l,1) 540 u(l) = u_mod(l) 541 v(l) = v_mod(l) 542 ug(l)=ug_mod(l) 543 vg(l)=vg_mod(l) 544 545 ! 546 ! tg=tsurf 547 ! 548 549 print *,'***** tsurf=',tsurf 550 rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 551 ! omega(l) = w_mod(l)*(-rg*rho(l)) 552 omega(l) = omega_mod(l) 553 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 554 555 556 557 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 558 !on applique le forcage total au premier pas de temps 559 !attention: signe different de toga 560 ! d_t_adv(l) = alpha*omega(l)/rcpd+ht_mod(l) 561 !forcage en th 562 d_t_adv(l) = ht_mod(l) 563 d_q_adv(l,1) = hq_mod(l) 564 d_q_adv(l,2) = 0.0 565 dt_cooling(l)=0. 566 enddo 567 568 !--------------- Residus forcages du cas Dice (a supprimer) MPL 20141024--------------- 569 ! Le cas Dice doit etre force avec ustar mais on peut simplifier en forcant par 570 ! le coefficient de trainee en surface cd**2=ustar*vent(k=1) 571 ! On commence ici a stocker ustar dans cdrag puis on terminera le calcul dans pbl_surface 572 ! MPL 05082013 573 ! ust=ustar_dice(1) 574 ! tg=tg_dice(1) 575 ! print *,'ust= ',ust 576 ! IF (tsurf .LE. 0.) THEN 577 ! tsurf= tg_dice(1) 578 ! ENDIF 579 ! psurf= psurf_dice(1) 580 ! solsw_in = (1.-albedo)/albedo*swup_dice(1) 581 ! sollw_in = (0.7*RSIGMA*temp(1)**4)-lwup_dice(1) 582 ! PRINT *,'1D_READ_FORC : solsw, sollw',solsw_in,sollw_in 583 !-------------------------------------------------------------------------------------- 584 endif !forcing_gabls4 585 586 587 588 ! Forcing from Arm_Cu case 589 ! For this case, ifa_armcu.txt contains sensible, latent heat fluxes 590 ! large scale advective forcing,radiative forcing 591 ! and advective tendency of theta and qt to be applied 592 !--------------------------------------------------------------------- 593 594 if (forcing_armcu) then 595 ! read armcu forcing : 596 write(*,*) 'Avant lecture Forcing Arm_Cu' 597 fich_armcu = './ifa_armcu.txt' 598 CALL read_armcu(fich_armcu,nlev_armcu,nt_armcu, & 599 & sens_armcu,flat_armcu,adv_theta_armcu, & 600 & rad_theta_armcu,adv_qt_armcu) 601 write(*,*) 'Forcing Arm_Cu lu' 602 603 !---------------------------------------------------------------------- 604 ! Read profiles from file: prof.inp.19 or prof.inp.40 605 ! For this case, profiles are given for two vertical resolution 606 ! 19 or 40 levels 607 ! 608 ! Comment from: http://www.knmi.nl/samenw/eurocs/ARM/profiles.html 609 ! Note that the initial profiles contain no liquid water! 610 ! (so potential temperature can be interpreted as liquid water 611 ! potential temperature and water vapor as total water) 612 ! profiles are given at full levels 613 !---------------------------------------------------------------------- 614 615 call readprofile_armcu(nlev_max,kmax,height,play_mod,u_mod, & 616 & v_mod,theta_mod,t_mod,qv_mod,rv_mod,ap,bp) 617 618 ! time interpolation for initial conditions: 619 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 620 621 print *,'Avant interp_armcu_time' 622 print *,'daytime=',daytime 623 print *,'day1=',day1 624 print *,'annee_ref=',annee_ref 625 print *,'year_ini_armcu=',year_ini_armcu 626 print *,'day_ju_ini_armcu=',day_ju_ini_armcu 627 print *,'nt_armcu=',nt_armcu 628 print *,'dt_armcu=',dt_armcu 629 print *,'nlev_armcu=',nlev_armcu 630 CALL interp_armcu_time(daytime,day1,annee_ref & 631 & ,year_ini_armcu,day_ju_ini_armcu,nt_armcu,dt_armcu & 632 & ,nlev_armcu,sens_armcu,flat_armcu,adv_theta_armcu & 633 & ,rad_theta_armcu,adv_qt_armcu,sens_prof,flat_prof & 634 & ,adv_theta_prof,rad_theta_prof,adv_qt_prof) 635 write(*,*) 'Forcages interpoles dans temps' 636 637 ! No vertical interpolation if nlev imposed to 19 or 40 638 ! The vertical grid stops at 4000m # 600hPa 639 mxcalc=llm 640 641 ! initial and boundary conditions : 642 ! tsurf = ts_prof 643 ! tsurf read in lmdz1d.def 644 write(*,*) 'Tsurf initiale: ',tsurf 645 do l = 1, llm 646 play(l)=play_mod(l)*100. 647 presnivs(l)=play(l) 648 zlay(l)=height(l) 649 temp(l) = t_mod(l) 650 teta(l)=theta_mod(l) 651 q(l,1) = qv_mod(l)/1000. 652 ! No liquid water in the initial profil 653 q(l,2) = 0. 654 u(l) = u_mod(l) 655 ug(l)= u_mod(l) 656 v(l) = v_mod(l) 657 vg(l)= v_mod(l) 658 ! Advective forcings are given in K or g/kg ... per HOUR 659 ! IF(height(l).LT.1000) THEN 660 ! d_t_adv(l) = (adv_theta_prof + rad_theta_prof)/3600. 661 ! d_q_adv(l,1) = adv_qt_prof/1000./3600. 662 ! d_q_adv(l,2) = 0.0 663 ! ELSEIF (height(l).GE.1000.AND.height(l).LT.3000) THEN 664 ! d_t_adv(l) = (adv_theta_prof + rad_theta_prof)* 665 ! : (1-(height(l)-1000.)/2000.) 666 ! d_t_adv(l) = d_t_adv(l)/3600. 667 ! d_q_adv(l,1) = adv_qt_prof*(1-(height(l)-1000.)/2000.) 668 ! d_q_adv(l,1) = d_q_adv(l,1)/1000./3600. 669 ! d_q_adv(l,2) = 0.0 670 ! ELSE 671 ! d_t_adv(l) = 0.0 672 ! d_q_adv(l,1) = 0.0 673 ! d_q_adv(l,2) = 0.0 674 ! ENDIF 675 enddo 676 ! plev at half levels is given in proh.inp.19 or proh.inp.40 files 677 plev(1)= ap(llm+1)+bp(llm+1)*psurf 678 do l = 1, llm 679 plev(l+1) = ap(llm-l+1)+bp(llm-l+1)*psurf 680 print *,'Read_forc: l height play plev zlay temp', & 681 & l,height(l),play(l),plev(l),zlay(l),temp(l) 682 enddo 683 ! For this case, fluxes are imposed 684 fsens=-1*sens_prof 685 flat=-1*flat_prof 686 687 endif ! forcing_armcu 688 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 689 !--------------------------------------------------------------------- 690 ! Forcing from transition case of Irina Sandu 691 !--------------------------------------------------------------------- 692 693 if (forcing_sandu) then 694 write(*,*) 'Avant lecture Forcing SANDU' 695 696 ! read sanduref forcing : 697 fich_sandu = './ifa_sanduref.txt' 698 CALL read_sandu(fich_sandu,nlev_sandu,nt_sandu,ts_sandu) 699 700 write(*,*) 'Forcing SANDU lu' 701 702 !---------------------------------------------------------------------- 703 ! Read profiles from file: prof.inp.001 704 !---------------------------------------------------------------------- 705 706 call readprofile_sandu(nlev_max,kmax,height,plev_profs,t_profs, & 707 & thl_profs,q_profs,u_profs,v_profs, & 708 & w_profs,omega_profs,o3mmr_profs) 709 710 ! time interpolation for initial conditions: 711 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 712 ! ATTENTION, cet appel ne convient pas pour le cas SANDU !! 713 ! revoir 1DUTILS.h et les arguments 714 715 print *,'Avant interp_sandu_time' 716 print *,'daytime=',daytime 717 print *,'day1=',day1 718 print *,'annee_ref=',annee_ref 719 print *,'year_ini_sandu=',year_ini_sandu 720 print *,'day_ju_ini_sandu=',day_ju_ini_sandu 721 print *,'nt_sandu=',nt_sandu 722 print *,'dt_sandu=',dt_sandu 723 print *,'nlev_sandu=',nlev_sandu 724 CALL interp_sandu_time(daytime,day1,annee_ref & 725 & ,year_ini_sandu,day_ju_ini_sandu,nt_sandu,dt_sandu & 726 & ,nlev_sandu & 727 & ,ts_sandu,ts_prof) 728 729 ! vertical interpolation: 730 print *,'Avant interp_vertical: nlev_sandu=',nlev_sandu 731 CALL interp_sandu_vertical(play,nlev_sandu,plev_profs & 732 & ,t_profs,thl_profs,q_profs,u_profs,v_profs,w_profs & 733 & ,omega_profs,o3mmr_profs & 734 & ,t_mod,thl_mod,q_mod,u_mod,v_mod,w_mod & 735 & ,omega_mod,o3mmr_mod,mxcalc) 736 write(*,*) 'Profil initial forcing SANDU interpole' 737 738 ! initial and boundary conditions : 739 tsurf = ts_prof 740 write(*,*) 'SST initiale: ',tsurf 741 do l = 1, llm 742 temp(l) = t_mod(l) 743 tetal(l)=thl_mod(l) 744 q(l,1) = q_mod(l) 745 q(l,2) = 0.0 746 u(l) = u_mod(l) 747 v(l) = v_mod(l) 748 w(l) = w_mod(l) 749 omega(l) = omega_mod(l) 750 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 751 !? rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 752 !? omega2(l)=-rho(l)*omega(l) 753 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 754 ! d_t_adv(l) = alpha*omega(l)/rcpd+vt_mod(l) 755 ! d_q_adv(l,1) = vq_mod(l) 756 d_t_adv(l) = alpha*omega(l)/rcpd 757 d_q_adv(l,1) = 0.0 758 d_q_adv(l,2) = 0.0 759 enddo 760 761 endif ! forcing_sandu 762 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 763 !--------------------------------------------------------------------- 764 ! Forcing from Astex case 765 !--------------------------------------------------------------------- 766 767 if (forcing_astex) then 768 write(*,*) 'Avant lecture Forcing Astex' 769 770 ! read astex forcing : 771 fich_astex = './ifa_astex.txt' 772 CALL read_astex(fich_astex,nlev_astex,nt_astex,div_astex,ts_astex, & 773 & ug_astex,vg_astex,ufa_astex,vfa_astex) 774 775 write(*,*) 'Forcing Astex lu' 776 777 !---------------------------------------------------------------------- 778 ! Read profiles from file: prof.inp.001 779 !---------------------------------------------------------------------- 780 781 call readprofile_astex(nlev_max,kmax,height,plev_profa,t_profa, & 782 & thl_profa,qv_profa,ql_profa,qt_profa,u_profa,v_profa, & 783 & w_profa,tke_profa,o3mmr_profa) 784 785 ! time interpolation for initial conditions: 786 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',day,day1 787 ! ATTENTION, cet appel ne convient pas pour le cas SANDU !! 788 ! revoir 1DUTILS.h et les arguments 789 790 print *,'Avant interp_astex_time' 791 print *,'daytime=',daytime 792 print *,'day1=',day1 793 print *,'annee_ref=',annee_ref 794 print *,'year_ini_astex=',year_ini_astex 795 print *,'day_ju_ini_astex=',day_ju_ini_astex 796 print *,'nt_astex=',nt_astex 797 print *,'dt_astex=',dt_astex 798 print *,'nlev_astex=',nlev_astex 799 CALL interp_astex_time(daytime,day1,annee_ref & 800 & ,year_ini_astex,day_ju_ini_astex,nt_astex,dt_astex & 801 & ,nlev_astex,div_astex,ts_astex,ug_astex,vg_astex & 802 & ,ufa_astex,vfa_astex,div_prof,ts_prof,ug_prof,vg_prof & 803 & ,ufa_prof,vfa_prof) 804 805 ! vertical interpolation: 806 print *,'Avant interp_vertical: nlev_astex=',nlev_astex 807 CALL interp_astex_vertical(play,nlev_astex,plev_profa & 808 & ,t_profa,thl_profa,qv_profa,ql_profa,qt_profa & 809 & ,u_profa,v_profa,w_profa,tke_profa,o3mmr_profa & 810 & ,t_mod,thl_mod,qv_mod,ql_mod,qt_mod,u_mod,v_mod,w_mod & 811 & ,tke_mod,o3mmr_mod,mxcalc) 812 write(*,*) 'Profil initial forcing Astex interpole' 813 814 ! initial and boundary conditions : 815 tsurf = ts_prof 816 write(*,*) 'SST initiale: ',tsurf 817 do l = 1, llm 818 temp(l) = t_mod(l) 819 tetal(l)=thl_mod(l) 820 q(l,1) = qv_mod(l) 821 q(l,2) = ql_mod(l) 822 u(l) = u_mod(l) 823 v(l) = v_mod(l) 824 w(l) = w_mod(l) 825 omega(l) = w_mod(l) 826 ! omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 827 ! rho(l) = play(l)/(rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))) 828 ! omega2(l)=-rho(l)*omega(l) 829 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 830 ! d_t_adv(l) = alpha*omega(l)/rcpd+vt_mod(l) 831 ! d_q_adv(l,1) = vq_mod(l) 832 d_t_adv(l) = alpha*omega(l)/rcpd 833 d_q_adv(l,1) = 0.0 834 d_q_adv(l,2) = 0.0 835 enddo 836 837 endif ! forcing_astex 838 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 839 !--------------------------------------------------------------------- 840 ! Forcing from standard case : 841 !--------------------------------------------------------------------- 842 843 if (forcing_case) then 844 845 write(*,*),'avant call read_1D_cas' 846 call read_1D_cas 847 write(*,*) 'Forcing read' 848 849 !Time interpolation for initial conditions using TOGA interpolation routine 850 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 851 CALL interp_case_time(day,day1,annee_ref & 852 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 853 & ,nt_cas,nlev_cas & 854 & ,ts_cas,plev_cas,t_cas,q_cas,u_cas,v_cas & 855 & ,ug_cas,vg_cas,vitw_cas,du_cas,hu_cas,vu_cas & 856 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 857 & ,dq_cas,hq_cas,vq_cas,lat_cas,sens_cas,ustar_cas & 858 & ,uw_cas,vw_cas,q1_cas,q2_cas & 859 & ,ts_prof_cas,plev_prof_cas,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas & 860 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,du_prof_cas,hu_prof_cas,vu_prof_cas & 861 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas & 862 & ,dq_prof_cas,hq_prof_cas,vq_prof_cas,lat_prof_cas,sens_prof_cas,ustar_prof_cas & 863 & ,uw_prof_cas,vw_prof_cas,q1_prof_cas,q2_prof_cas) 864 865 ! vertical interpolation using TOGA interpolation routine: 866 ! write(*,*)'avant interp vert', t_prof 867 CALL interp_case_vertical(play,nlev_cas,plev_prof_cas & 868 & ,t_prof_cas,q_prof_cas,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas & 869 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 870 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & 871 & ,t_mod_cas,q_mod_cas,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas & 872 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 873 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas,mxcalc) 874 ! write(*,*) 'Profil initial forcing case interpole',t_mod 875 876 ! initial and boundary conditions : 877 ! tsurf = ts_prof_cas 878 ts_cur = ts_prof_cas 879 psurf=plev_prof_cas(1) 880 write(*,*) 'SST initiale: ',tsurf 881 do l = 1, llm 882 temp(l) = t_mod_cas(l) 883 q(l,1) = q_mod_cas(l) 884 q(l,2) = 0.0 885 u(l) = u_mod_cas(l) 886 v(l) = v_mod_cas(l) 887 omega(l) = w_mod_cas(l) 888 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 889 890 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 891 !on applique le forcage total au premier pas de temps 892 !attention: signe different de toga 893 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 894 d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l)) 895 d_q_adv(l,2) = 0.0 896 d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l)) 897 ! correction bug d_u -> d_v (MM+MPL 20170310) 898 d_v_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l)) 899 enddo 900 901 ! In case fluxes are imposed 902 IF (ok_flux_surf) THEN 903 fsens=sens_prof_cas 904 flat=lat_prof_cas 905 ENDIF 906 IF (ok_prescr_ust) THEN 907 ust=ustar_prof_cas 908 print *,'ust=',ust 909 ENDIF 910 911 endif !forcing_case 912 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 913 !--------------------------------------------------------------------- 914 ! Forcing from standard case : 915 !--------------------------------------------------------------------- 916 917 if (forcing_case2) then 918 919 write(*,*),'avant call read2_1D_cas' 920 call read2_1D_cas 921 write(*,*) 'Forcing read' 16 write(*,*),'avant call read_SCM' 17 call read_SCM_cas 18 write(*,*) 'Forcing read' 19 print*,'PS ps_cas',ps_cas 922 20 923 21 !Time interpolation for initial conditions using interpolation routine 924 22 write(*,*) 'AVT 1ere INTERPOLATION: day,day1 = ',daytime,day1 925 CALL interp 2_case_time(daytime,day1,annee_ref &23 CALL interp_case_time_std(daytime,day1,annee_ref & 926 24 ! & ,year_ini_cas,day_ju_ini_cas,nt_cas,pdt_cas,nlev_cas & 927 25 & ,nt_cas,nlev_cas & 928 26 & ,ts_cas,ps_cas,plev_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas,ql_cas,qi_cas & 929 & ,u_cas,v_cas,ug_cas,vg_cas,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas & 27 & ,u_cas,v_cas,ug_cas,vg_cas & 28 & ,temp_nudg_cas,qv_nudg_cas,u_nudg_cas,v_nudg_cas & 29 & ,vitw_cas,omega_cas,du_cas,hu_cas,vu_cas & 930 30 & ,dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dtrad_cas & 931 31 & ,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas,lat_cas,sens_cas,ustar_cas & 932 32 & ,uw_cas,vw_cas,q1_cas,q2_cas,tke_cas & 933 33 ! 934 & ,ts_prof_cas,p lev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas &34 & ,ts_prof_cas,ps_prof_cas,plev_prof_cas,t_prof_cas,theta_prof_cas,thv_prof_cas & 935 35 & ,thl_prof_cas,qv_prof_cas,ql_prof_cas,qi_prof_cas & 936 & ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 36 & ,u_prof_cas,v_prof_cas,ug_prof_cas,vg_prof_cas & 37 & ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & 38 & ,vitw_prof_cas,omega_prof_cas & 937 39 & ,du_prof_cas,hu_prof_cas,vu_prof_cas & 938 40 & ,dv_prof_cas,hv_prof_cas,vv_prof_cas,dt_prof_cas,ht_prof_cas,vt_prof_cas & … … 947 49 ! vertical interpolation using interpolation routine: 948 50 ! write(*,*)'avant interp vert', t_prof 949 CALL interp2_case_vertical (play,nlev_cas,plev_prof_cas &51 CALL interp2_case_vertical_std(play,nlev_cas,plev_prof_cas & 950 52 & ,t_prof_cas,theta_prof_cas,thv_prof_cas,thl_prof_cas & 951 53 & ,qv_prof_cas,ql_prof_cas,qi_prof_cas,u_prof_cas,v_prof_cas & 952 & ,ug_prof_cas,vg_prof_cas,vitw_prof_cas,omega_prof_cas & 54 & ,ug_prof_cas,vg_prof_cas & 55 & ,temp_nudg_prof_cas,qv_nudg_prof_cas,u_nudg_prof_cas,v_nudg_prof_cas & 56 57 & ,vitw_prof_cas,omega_prof_cas & 953 58 & ,du_prof_cas,hu_prof_cas,vu_prof_cas,dv_prof_cas,hv_prof_cas,vv_prof_cas & 954 59 & ,dt_prof_cas,ht_prof_cas,vt_prof_cas,dtrad_prof_cas,dq_prof_cas,hq_prof_cas,vq_prof_cas & … … 956 61 ! 957 62 & ,t_mod_cas,theta_mod_cas,thv_mod_cas,thl_mod_cas,qv_mod_cas,ql_mod_cas,qi_mod_cas & 958 & ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas,w_mod_cas,omega_mod_cas & 63 & ,u_mod_cas,v_mod_cas,ug_mod_cas,vg_mod_cas & 64 & ,temp_nudg_mod_cas,qv_nudg_mod_cas,u_nudg_mod_cas,v_nudg_mod_cas & 65 & ,w_mod_cas,omega_mod_cas & 959 66 & ,du_mod_cas,hu_mod_cas,vu_mod_cas,dv_mod_cas,hv_mod_cas,vv_mod_cas & 960 67 & ,dt_mod_cas,ht_mod_cas,vt_mod_cas,dtrad_mod_cas,dq_mod_cas,hq_mod_cas,vq_mod_cas & 961 68 & ,dth_mod_cas,hth_mod_cas,vth_mod_cas,mxcalc) 962 69 963 ! write(*,*) 'Profil initial forcing case interpole',t_mod964 70 965 71 ! initial and boundary conditions : 966 72 ! tsurf = ts_prof_cas 73 psurf = ps_prof_cas 967 74 ts_cur = ts_prof_cas 968 psurf=plev_prof_cas(1)969 write(*,*) 'SST initiale: ',tsurf970 75 do l = 1, llm 971 76 temp(l) = t_mod_cas(l) … … 980 85 omega2(l)=omega(l)/rg*airefi ! flxmass_w calcule comme ds physiq 981 86 982 alpha = rd*temp(l)*(1.+(rv/rd-1.)*q(l,1))/play(l) 983 ! on applique le forcage total au premier pas de temps984 ! attention: signe different de toga985 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 986 d_t_adv(l) = alpha*omega(l)/rcpd+(ht_mod_cas(l)+vt_mod_cas(l)) 987 ! d_q_adv(l,1) = (hq_mod_cas(l)+vq_mod_cas(l))988 d_q_adv(l,1) = dq_mod_cas(l) 87 88 ! On effectue la somme du forcage total et de la decomposition 89 ! horizontal/vertical en supposant que soit l'un soit l'autre 90 ! sont remplis mais jamais les deux 91 92 d_t_adv(l) = dt_mod_cas(l)+ht_mod_cas(l)+vt_mod_cas(l) 93 d_q_adv(l,1) = dq_mod_cas(l)+hq_mod_cas(l)+vq_mod_cas(l) 989 94 d_q_adv(l,2) = 0.0 990 ! d_u_adv(l) = (hu_mod_cas(l)+vu_mod_cas(l))991 d_ u_adv(l) = du_mod_cas(l)992 ! d_v_adv(l) = (hv_mod_cas(l)+vv_mod_cas(l)) 993 ! correction bug d_u -> d_v (MM+MPL 20170310)994 d_v_adv(l) = dv_mod_cas(l) 95 d_u_adv(l) = du_mod_cas(l)+hu_mod_cas(l)+vu_mod_cas(l) 96 d_v_adv(l) = dv_mod_cas(l)+hv_mod_cas(l)+vv_mod_cas(l) 97 98 !print*,'d_t_adv ',d_t_adv(1:20)*86400 99 995 100 enddo 996 101 … … 1006 111 ENDIF 1007 112 1008 endif !forcing_case2 1009 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1010 113 endif !forcing_SCM -
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/compar1d.h
r2921 r3605 42 42 integer :: tadv, tadvv, tadvh, qadv, qadvv, qadvh, thadv, thadvv, thadvh, trad 43 43 integer :: forc_omega, forc_u, forc_v, forc_w, forc_geo, forc_ustar 44 real :: nudging_u, nudging_v, nudging_w, nudging_t, nudging_q 44 real :: nudging_u, nudging_v, nudging_w, nudging_t, nudging_qv 45 real :: p_nudging_u, p_nudging_v, p_nudging_w, p_nudging_t, p_nudging_qv 45 46 common/com_par1d/ & 46 47 & nat_surf,tsurf,rugos,rugosh, & … … 52 53 & restart,ok_old_disvert, & 53 54 & tadv, tadvv, tadvh, qadv, qadvv, qadvh, thadv, thadvv, thadvh, & 54 & trad, forc_omega, forc_w, forc_geo, forc_ustar, & 55 & nudging_u, nudging_v, nudging_t, nudging_q 55 & trad, forc_omega, forc_u, forc_v, forc_w, forc_geo, forc_ustar, & 56 & nudging_u, nudging_v, nudging_t, nudging_qv, nudging_w, & 57 & p_nudging_u, p_nudging_v, p_nudging_t, p_nudging_qv, p_nudging_w 56 58 57 59 !$OMP THREADPRIVATE(/com_par1d/) -
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/lmdz1d.F90
-
Property
svn:keywords
set to
Id
r3316 r3605 1 ! 2 ! $Id$ 3 ! 1 4 !#ifdef CPP_1D 2 5 !#include "../dyn3d/mod_const_mpi.F90" … … 6 9 7 10 8 11 PROGRAM lmdz1d 9 12 10 USE ioipsl, only: ju2ymds, ymds2ju, ioconf_calendar 11 USE phys_state_var_mod, ONLY : phys_state_var_init, phys_state_var_end, & 12 clwcon, detr_therm, & 13 qsol, fevap, z0m, z0h, agesno, & 14 du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, & 15 falb_dir, falb_dif, & 16 ftsol, pbl_tke, pctsrf, radsol, rain_fall, snow_fall, ratqs, & 17 rnebcon, rugoro, sig1, w01, solaire_etat0, sollw, sollwdown, & 18 solsw, t_ancien, q_ancien, u_ancien, v_ancien, wake_cstar, & 19 wake_delta_pbl_TKE, delta_tsurf, wake_fip, wake_pe, & 20 wake_deltaq, wake_deltat, wake_s, wake_dens, & 21 zgam, zmax0, zmea, zpic, zsig, & 22 zstd, zthe, zval, ale_bl, ale_bl_trig, alp_bl, ql_ancien, qs_ancien, & 23 prlw_ancien, prsw_ancien, prw_ancien 24 25 USE dimphy 26 USE surface_data, only : type_ocean,ok_veget 27 USE pbl_surface_mod, only : ftsoil, pbl_surface_init, & 28 pbl_surface_final 29 USE fonte_neige_mod, only : fonte_neige_init, fonte_neige_final 13 USE ioipsl, only: getin 30 14 31 USE infotrac ! new 32 USE control_mod 33 USE indice_sol_mod 34 USE phyaqua_mod 35 ! USE mod_1D_cases_read 36 USE mod_1D_cases_read2 37 USE mod_1D_amma_read 38 USE print_control_mod, ONLY: lunout, prt_level 39 USE iniphysiq_mod, ONLY: iniphysiq 40 USE mod_const_mpi, ONLY: comm_lmdz 41 USE physiq_mod, ONLY: physiq 42 USE comvert_mod, ONLY: presnivs, ap, bp, dpres,nivsig, nivsigs, pa, & 43 preff, aps, bps, pseudoalt, scaleheight 44 USE temps_mod, ONLY: annee_ref, calend, day_end, day_ini, day_ref, & 45 itau_dyn, itau_phy, start_time 15 INTEGER forcing_type 46 16 47 implicit none 48 #include "dimensions.h" 49 #include "YOMCST.h" 50 !!#include "control.h" 51 #include "clesphys.h" 52 #include "dimsoil.h" 53 !#include "indicesol.h" 17 CALL getin('forcing_type',forcing_type) 54 18 55 #include "compar1d.h" 56 #include "flux_arp.h" 57 #include "date_cas.h" 58 #include "tsoilnudge.h" 59 #include "fcg_gcssold.h" 60 !!!#include "fbforcing.h" 61 #include "compbl.h" 19 IF (forcing_type==1000) THEN 20 CALL scm 21 ELSE 22 CALL old_lmdz1d 23 ENDIF 62 24 63 !===================================================================== 64 ! DECLARATIONS 65 !===================================================================== 25 END 66 26 67 !---------------------------------------------------------------------68 ! Externals69 !---------------------------------------------------------------------70 external fq_sat71 real fq_sat72 73 !---------------------------------------------------------------------74 ! Arguments d' initialisations de la physique (USER DEFINE)75 !---------------------------------------------------------------------76 77 integer, parameter :: ngrid=178 real :: zcufi = 1.79 real :: zcvfi = 1.80 81 !- real :: nat_surf82 !- logical :: ok_flux_surf83 !- real :: fsens84 !- real :: flat85 !- real :: tsurf86 !- real :: rugos87 !- real :: qsol(1:2)88 !- real :: qsurf89 !- real :: psurf90 !- real :: zsurf91 !- real :: albedo92 !-93 !- real :: time = 0.94 !- real :: time_ini95 !- real :: xlat96 !- real :: xlon97 !- real :: wtsurf98 !- real :: wqsurf99 !- real :: restart_runoff100 !- real :: xagesno101 !- real :: qsolinp102 !- real :: zpicinp103 !-104 real :: fnday105 real :: day, daytime106 real :: day1107 real :: heure108 integer :: jour109 integer :: mois110 integer :: an111 112 !---------------------------------------------------------------------113 ! Declarations related to forcing and initial profiles114 !---------------------------------------------------------------------115 116 integer :: kmax = llm117 integer llm700,nq1,nq2118 INTEGER, PARAMETER :: nlev_max=1000, nqmx=1000119 real timestep, frac120 real height(nlev_max),tttprof(nlev_max),qtprof(nlev_max)121 real uprof(nlev_max),vprof(nlev_max),e12prof(nlev_max)122 real ugprof(nlev_max),vgprof(nlev_max),wfls(nlev_max)123 real dqtdxls(nlev_max),dqtdyls(nlev_max)124 real dqtdtls(nlev_max),thlpcar(nlev_max)125 real qprof(nlev_max,nqmx)126 127 ! integer :: forcing_type128 logical :: forcing_les = .false.129 logical :: forcing_armcu = .false.130 logical :: forcing_rico = .false.131 logical :: forcing_radconv = .false.132 logical :: forcing_toga = .false.133 logical :: forcing_twpice = .false.134 logical :: forcing_amma = .false.135 logical :: forcing_dice = .false.136 logical :: forcing_gabls4 = .false.137 138 logical :: forcing_GCM2SCM = .false.139 logical :: forcing_GCSSold = .false.140 logical :: forcing_sandu = .false.141 logical :: forcing_astex = .false.142 logical :: forcing_fire = .false.143 logical :: forcing_case = .false.144 logical :: forcing_case2 = .false.145 integer :: type_ts_forcing ! 0 = SST constant; 1 = SST read from a file146 ! (cf read_tsurf1d.F)147 148 !vertical advection computation149 ! real d_t_z(llm), d_q_z(llm)150 ! real d_t_dyn_z(llm), dq_dyn_z(llm)151 ! real zz(llm)152 ! real zfact153 154 !flag forcings155 logical :: nudge_wind=.true.156 logical :: nudge_thermo=.false.157 logical :: cptadvw=.true.158 !=====================================================================159 ! DECLARATIONS FOR EACH CASE160 !=====================================================================161 !162 #include "1D_decl_cases.h"163 !164 !---------------------------------------------------------------------165 ! Declarations related to nudging166 !---------------------------------------------------------------------167 integer :: nudge_max168 parameter (nudge_max=9)169 integer :: inudge_RHT=1170 integer :: inudge_UV=2171 logical :: nudge(nudge_max)172 real :: t_targ(llm)173 real :: rh_targ(llm)174 real :: u_targ(llm)175 real :: v_targ(llm)176 !177 !---------------------------------------------------------------------178 ! Declarations related to vertical discretization:179 !---------------------------------------------------------------------180 real :: pzero=1.e5181 real :: play (llm),zlay (llm),sig_s(llm),plev(llm+1)182 real :: playd(llm),zlayd(llm),ap_amma(llm+1),bp_amma(llm+1)183 184 !---------------------------------------------------------------------185 ! Declarations related to variables186 !---------------------------------------------------------------------187 188 real :: phi(llm)189 real :: teta(llm),tetal(llm),temp(llm),u(llm),v(llm),w(llm)190 REAL rot(1, llm) ! relative vorticity, in s-1191 real :: rlat_rad(1),rlon_rad(1)192 real :: omega(llm+1),omega2(llm),rho(llm+1)193 real :: ug(llm),vg(llm),fcoriolis194 real :: sfdt, cfdt195 real :: du_phys(llm),dv_phys(llm),dt_phys(llm)196 real :: dt_dyn(llm)197 real :: dt_cooling(llm),d_t_adv(llm),d_t_nudge(llm)198 real :: d_u_nudge(llm),d_v_nudge(llm)199 real :: du_adv(llm),dv_adv(llm)200 real :: du_age(llm),dv_age(llm)201 real :: alpha202 real :: ttt203 204 REAL, ALLOCATABLE, DIMENSION(:,:):: q205 REAL, ALLOCATABLE, DIMENSION(:,:):: dq206 REAL, ALLOCATABLE, DIMENSION(:,:):: dq_dyn207 REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_adv208 REAL, ALLOCATABLE, DIMENSION(:,:):: d_q_nudge209 ! REAL, ALLOCATABLE, DIMENSION(:):: d_th_adv210 211 !---------------------------------------------------------------------212 ! Initialization of surface variables213 !---------------------------------------------------------------------214 real :: run_off_lic_0(1)215 real :: fder(1),snsrf(1,nbsrf),qsurfsrf(1,nbsrf)216 real :: tsoil(1,nsoilmx,nbsrf)217 ! real :: agesno(1,nbsrf)218 219 !---------------------------------------------------------------------220 ! Call to phyredem221 !---------------------------------------------------------------------222 logical :: ok_writedem =.true.223 real :: sollw_in = 0.224 real :: solsw_in = 0.225 226 !---------------------------------------------------------------------227 ! Call to physiq228 !---------------------------------------------------------------------229 logical :: firstcall=.true.230 logical :: lastcall=.false.231 real :: phis(1) = 0.0232 real :: dpsrf(1)233 234 !---------------------------------------------------------------------235 ! Initializations of boundary conditions236 !---------------------------------------------------------------------237 integer, parameter :: yd = 360238 real :: phy_nat (yd) = 0.0 ! 0=ocean libre,1=land,2=glacier,3=banquise239 real :: phy_alb (yd) ! Albedo land only (old value condsurf_jyg=0.3)240 real :: phy_sst (yd) ! SST (will not be used; cf read_tsurf1d.F)241 real :: phy_bil (yd) = 1.0 ! Ne sert que pour les slab_ocean242 real :: phy_rug (yd) ! Longueur rugosite utilisee sur land only243 real :: phy_ice (yd) = 0.0 ! Fraction de glace244 real :: phy_fter(yd) = 0.0 ! Fraction de terre245 real :: phy_foce(yd) = 0.0 ! Fraction de ocean246 real :: phy_fsic(yd) = 0.0 ! Fraction de glace247 real :: phy_flic(yd) = 0.0 ! Fraction de glace248 249 !---------------------------------------------------------------------250 ! Fichiers et d'autres variables251 !---------------------------------------------------------------------252 integer :: k,l,i,it=1,mxcalc253 integer :: nsrf254 integer jcode255 INTEGER read_climoz256 !257 integer :: it_end ! iteration number of the last call258 !Al1259 integer ecrit_slab_oc !1=ecrit,-1=lit,0=no file260 data ecrit_slab_oc/-1/261 !262 ! if flag_inhib_forcing = 0, tendencies of forcing are added263 ! <> 0, tendencies of forcing are not added264 INTEGER :: flag_inhib_forcing = 0265 266 !=====================================================================267 ! INITIALIZATIONS268 !=====================================================================269 du_phys(:)=0.270 dv_phys(:)=0.271 dt_phys(:)=0.272 dt_dyn(:)=0.273 dt_cooling(:)=0.274 d_t_adv(:)=0.275 d_t_nudge(:)=0.276 d_u_nudge(:)=0.277 d_v_nudge(:)=0.278 du_adv(:)=0.279 dv_adv(:)=0.280 du_age(:)=0.281 dv_age(:)=0.282 283 ! Initialization of Common turb_forcing284 dtime_frcg = 0.285 Turb_fcg_gcssold=.false.286 hthturb_gcssold = 0.287 hqturb_gcssold = 0.288 289 290 291 292 !---------------------------------------------------------------------293 ! OPTIONS OF THE 1D SIMULATION (lmdz1d.def => unicol.def)294 !---------------------------------------------------------------------295 !Al1296 call conf_unicol297 !Al1 moves this gcssold var from common fcg_gcssold to298 Turb_fcg_gcssold = xTurb_fcg_gcssold299 ! --------------------------------------------------------------------300 close(1)301 !Al1302 write(*,*) 'lmdz1d.def lu => unicol.def'303 304 ! forcing_type defines the way the SCM is forced:305 !forcing_type = 0 ==> forcing_les = .true.306 ! initial profiles from file prof.inp.001307 ! no forcing by LS convergence ;308 ! surface temperature imposed ;309 ! radiative cooling may be imposed (iflag_radia=0 in physiq.def)310 !forcing_type = 1 ==> forcing_radconv = .true.311 ! idem forcing_type = 0, but the imposed radiative cooling312 ! is set to 0 (hence, if iflag_radia=0 in physiq.def,313 ! then there is no radiative cooling at all)314 !forcing_type = 2 ==> forcing_toga = .true.315 ! initial profiles from TOGA-COARE IFA files316 ! LS convergence and SST imposed from TOGA-COARE IFA files317 !forcing_type = 3 ==> forcing_GCM2SCM = .true.318 ! initial profiles from the GCM output319 ! LS convergence imposed from the GCM output320 !forcing_type = 4 ==> forcing_twpice = .true.321 ! initial profiles from TWP-ICE cdf file322 ! LS convergence, omega and SST imposed from TWP-ICE files323 !forcing_type = 5 ==> forcing_rico = .true.324 ! initial profiles from RICO files325 ! LS convergence imposed from RICO files326 !forcing_type = 6 ==> forcing_amma = .true.327 ! initial profiles from AMMA nc file328 ! LS convergence, omega and surface fluxes imposed from AMMA file329 !forcing_type = 7 ==> forcing_dice = .true.330 ! initial profiles and large scale forcings in dice_driver.nc331 ! Different stages: soil model alone, atm. model alone332 ! then both models coupled333 !forcing_type = 8 ==> forcing_gabls4 = .true.334 ! initial profiles and large scale forcings in gabls4_driver.nc335 !forcing_type >= 100 ==> forcing_case = .true.336 ! initial profiles and large scale forcings in cas.nc337 ! LS convergence, omega and SST imposed from CINDY-DYNAMO files338 ! 101=cindynamo339 ! 102=bomex340 !forcing_type >= 100 ==> forcing_case2 = .true.341 ! temporary flag while all the 1D cases are not whith the same cas.nc forcing file342 ! 103=arm_cu2 ie arm_cu with new forcing format343 ! 104=rico2 ie rico with new forcing format344 !forcing_type = 40 ==> forcing_GCSSold = .true.345 ! initial profile from GCSS file346 ! LS convergence imposed from GCSS file347 !forcing_type = 50 ==> forcing_fire = .true.348 ! forcing from fire.nc349 !forcing_type = 59 ==> forcing_sandu = .true.350 ! initial profiles from sanduref file: see prof.inp.001351 ! SST varying with time and divergence constante: see ifa_sanduref.txt file352 ! Radiation has to be computed interactively353 !forcing_type = 60 ==> forcing_astex = .true.354 ! initial profiles from file: see prof.inp.001355 ! SST,divergence,ug,vg,ufa,vfa varying with time : see ifa_astex.txt file356 ! Radiation has to be computed interactively357 !forcing_type = 61 ==> forcing_armcu = .true.358 ! initial profiles from file: see prof.inp.001359 ! sensible and latent heat flux imposed: see ifa_arm_cu_1.txt360 ! large scale advective forcing & radiative tendencies applied below 1000m: see ifa_arm_cu_2.txt361 ! use geostrophic wind ug=10m/s vg=0m/s. Duration of the case 53100s362 ! Radiation to be switched off363 !364 if (forcing_type <=0) THEN365 forcing_les = .true.366 elseif (forcing_type .eq.1) THEN367 forcing_radconv = .true.368 elseif (forcing_type .eq.2) THEN369 forcing_toga = .true.370 elseif (forcing_type .eq.3) THEN371 forcing_GCM2SCM = .true.372 elseif (forcing_type .eq.4) THEN373 forcing_twpice = .true.374 elseif (forcing_type .eq.5) THEN375 forcing_rico = .true.376 elseif (forcing_type .eq.6) THEN377 forcing_amma = .true.378 elseif (forcing_type .eq.7) THEN379 forcing_dice = .true.380 elseif (forcing_type .eq.8) THEN381 forcing_gabls4 = .true.382 elseif (forcing_type .eq.101) THEN ! Cindynamo starts 1-10-2011 0h383 forcing_case = .true.384 year_ini_cas=2011385 mth_ini_cas=10386 day_deb=1387 heure_ini_cas=0.388 pdt_cas=3*3600. ! forcing frequency389 elseif (forcing_type .eq.102) THEN ! Bomex starts 24-6-1969 0h390 forcing_case = .true.391 year_ini_cas=1969392 mth_ini_cas=6393 day_deb=24394 heure_ini_cas=0.395 pdt_cas=1800. ! forcing frequency396 elseif (forcing_type .eq.103) THEN ! Arm_cu starts 21-6-1997 11h30397 forcing_case2 = .true.398 year_ini_cas=1997399 mth_ini_cas=6400 day_deb=21401 heure_ini_cas=11.5402 pdt_cas=1800. ! forcing frequency403 elseif (forcing_type .eq.104) THEN ! rico starts 16-12-2004 0h404 forcing_case2 = .true.405 year_ini_cas=2004406 mth_ini_cas=12407 day_deb=16408 heure_ini_cas=0.409 pdt_cas=1800. ! forcing frequency410 elseif (forcing_type .eq.105) THEN ! bomex starts 16-12-2004 0h411 forcing_case2 = .true.412 year_ini_cas=1969413 mth_ini_cas=6414 day_deb=24415 heure_ini_cas=0.416 pdt_cas=1800. ! forcing frequency417 elseif (forcing_type .eq.106) THEN ! ayotte_24SC starts 6-11-1992 0h418 forcing_case2 = .true.419 year_ini_cas=1992420 mth_ini_cas=11421 day_deb=6422 heure_ini_cas=10.423 pdt_cas=86400. ! forcing frequency424 elseif (forcing_type .eq.40) THEN425 forcing_GCSSold = .true.426 elseif (forcing_type .eq.50) THEN427 forcing_fire = .true.428 elseif (forcing_type .eq.59) THEN429 forcing_sandu = .true.430 elseif (forcing_type .eq.60) THEN431 forcing_astex = .true.432 elseif (forcing_type .eq.61) THEN433 forcing_armcu = .true.434 IF(llm.NE.19.AND.llm.NE.40) stop 'Erreur nombre de niveaux !!'435 else436 write (*,*) 'ERROR : unknown forcing_type ', forcing_type437 stop 'Forcing_type should be 0,1,2,3,4,5,6 or 40,59,60,61'438 ENDIF439 print*,"forcing type=",forcing_type440 441 ! if type_ts_forcing=0, the surface temp of 1D simulation is constant in time442 ! (specified by tsurf in lmdz1d.def); if type_ts_forcing=1, the surface temperature443 ! varies in time according to a forcing (e.g. forcing_toga) and is passed to read_tsurf1d.F444 ! through the common sst_forcing.445 446 type_ts_forcing = 0447 if (forcing_toga.or.forcing_sandu.or.forcing_astex .or. forcing_dice) &448 & type_ts_forcing = 1449 !450 ! Initialization of the logical switch for nudging451 jcode = iflag_nudge452 do i = 1,nudge_max453 nudge(i) = mod(jcode,10) .ge. 1454 jcode = jcode/10455 enddo456 !---------------------------------------------------------------------457 ! Definition of the run458 !---------------------------------------------------------------------459 460 call conf_gcm( 99, .TRUE. )461 !-----------------------------------------------------------------------462 ! Choix du calendrier463 ! -------------------464 465 ! calend = 'earth_365d'466 if (calend == 'earth_360d') then467 call ioconf_calendar('360d')468 write(*,*)'CALENDRIER CHOISI: Terrestre a 360 jours/an'469 else if (calend == 'earth_365d') then470 call ioconf_calendar('noleap')471 write(*,*)'CALENDRIER CHOISI: Terrestre a 365 jours/an'472 else if (calend == 'earth_366d') then473 call ioconf_calendar('all_leap')474 write(*,*)'CALENDRIER CHOISI: Terrestre bissextile'475 else if (calend == 'gregorian') then476 call ioconf_calendar('gregorian') ! not to be used by normal users477 write(*,*)'CALENDRIER CHOISI: Gregorien'478 else479 write (*,*) 'ERROR : unknown calendar ', calend480 stop 'calend should be 360d,earth_365d,earth_366d,gregorian'481 endif482 !-----------------------------------------------------------------------483 !484 !c Date :485 ! La date est supposee donnee sous la forme [annee, numero du jour dans486 ! l annee] ; l heure est donnee dans time_ini, lu dans lmdz1d.def.487 ! On appelle ymds2ju pour convertir [annee, jour] en [jour Julien].488 ! Le numero du jour est dans "day". L heure est traitee separement.489 ! La date complete est dans "daytime" (l'unite est le jour).490 if (nday>0) then491 fnday=nday492 else493 fnday=-nday/float(day_step)494 endif495 print *,'fnday=',fnday496 ! start_time doit etre en FRACTION DE JOUR497 start_time=time_ini/24.498 499 ! Special case for arm_cu which lasts less than one day : 53100s !! (MPL 20111026)500 IF(forcing_type .EQ. 61) fnday=53100./86400.501 IF(forcing_type .EQ. 103) fnday=53100./86400.502 ! Special case for amma which lasts less than one day : 64800s !! (MPL 20120216)503 IF(forcing_type .EQ. 6) fnday=64800./86400.504 ! IF(forcing_type .EQ. 6) fnday=50400./86400.505 IF(forcing_type .EQ. 8 ) fnday=129600./86400.506 annee_ref = anneeref507 mois = 1508 day_ref = dayref509 heure = 0.510 itau_dyn = 0511 itau_phy = 0512 call ymds2ju(annee_ref,mois,day_ref,heure,day)513 day_ini = int(day)514 day_end = day_ini + int(fnday)515 516 IF (forcing_type .eq.2) THEN517 ! Convert the initial date of Toga-Coare to Julian day518 call ymds2ju &519 & (year_ini_toga,mth_ini_toga,day_ini_toga,heure,day_ju_ini_toga)520 521 ELSEIF (forcing_type .eq.4) THEN522 ! Convert the initial date of TWPICE to Julian day523 call ymds2ju &524 & (year_ini_twpi,mth_ini_twpi,day_ini_twpi,heure_ini_twpi &525 & ,day_ju_ini_twpi)526 ELSEIF (forcing_type .eq.6) THEN527 ! Convert the initial date of AMMA to Julian day528 call ymds2ju &529 & (year_ini_amma,mth_ini_amma,day_ini_amma,heure_ini_amma &530 & ,day_ju_ini_amma)531 ELSEIF (forcing_type .eq.7) THEN532 ! Convert the initial date of DICE to Julian day533 call ymds2ju &534 & (year_ini_dice,mth_ini_dice,day_ini_dice,heure_ini_dice &535 & ,day_ju_ini_dice)536 ELSEIF (forcing_type .eq.8 ) THEN537 ! Convert the initial date of GABLS4 to Julian day538 call ymds2ju &539 & (year_ini_gabls4,mth_ini_gabls4,day_ini_gabls4,heure_ini_gabls4 &540 & ,day_ju_ini_gabls4)541 ELSEIF (forcing_type .gt.100) THEN542 ! Convert the initial date to Julian day543 day_ini_cas=day_deb544 print*,'time case',year_ini_cas,mth_ini_cas,day_ini_cas545 call ymds2ju &546 & (year_ini_cas,mth_ini_cas,day_ini_cas,heure_ini_cas*3600 &547 & ,day_ju_ini_cas)548 print*,'time case 2',day_ini_cas,day_ju_ini_cas549 ELSEIF (forcing_type .eq.59) THEN550 ! Convert the initial date of Sandu case to Julian day551 call ymds2ju &552 & (year_ini_sandu,mth_ini_sandu,day_ini_sandu, &553 & time_ini*3600.,day_ju_ini_sandu)554 555 ELSEIF (forcing_type .eq.60) THEN556 ! Convert the initial date of Astex case to Julian day557 call ymds2ju &558 & (year_ini_astex,mth_ini_astex,day_ini_astex, &559 & time_ini*3600.,day_ju_ini_astex)560 561 ELSEIF (forcing_type .eq.61) THEN562 ! Convert the initial date of Arm_cu case to Julian day563 call ymds2ju &564 & (year_ini_armcu,mth_ini_armcu,day_ini_armcu,heure_ini_armcu &565 & ,day_ju_ini_armcu)566 ENDIF567 568 IF (forcing_type .gt.100) THEN569 daytime = day + heure_ini_cas/24. ! 1st day and initial time of the simulation570 ELSE571 daytime = day + time_ini/24. ! 1st day and initial time of the simulation572 ENDIF573 ! Print out the actual date of the beginning of the simulation :574 call ju2ymds(daytime,year_print, month_print,day_print,sec_print)575 print *,' Time of beginning : ', &576 & year_print, month_print, day_print, sec_print577 578 !---------------------------------------------------------------------579 ! Initialization of dimensions, geometry and initial state580 !---------------------------------------------------------------------581 ! call init_phys_lmdz(1,1,llm,1,(/1/)) ! job now done via iniphysiq582 ! but we still need to initialize dimphy module (klon,klev,etc.) here.583 call init_dimphy(1,llm)584 call suphel585 call infotrac_init586 587 if (nqtot>nqmx) STOP 'Augmenter nqmx dans lmdz1d.F'588 allocate(q(llm,nqtot)) ; q(:,:)=0.589 allocate(dq(llm,nqtot))590 allocate(dq_dyn(llm,nqtot))591 allocate(d_q_adv(llm,nqtot))592 allocate(d_q_nudge(llm,nqtot))593 ! allocate(d_th_adv(llm))594 595 q(:,:) = 0.596 dq(:,:) = 0.597 dq_dyn(:,:) = 0.598 d_q_adv(:,:) = 0.599 d_q_nudge(:,:) = 0.600 601 !602 ! No ozone climatology need be read in this pre-initialization603 ! (phys_state_var_init is called again in physiq)604 read_climoz = 0605 !606 call phys_state_var_init(read_climoz)607 608 if (ngrid.ne.klon) then609 print*,'stop in inifis'610 print*,'Probleme de dimensions :'611 print*,'ngrid = ',ngrid612 print*,'klon = ',klon613 stop614 endif615 !!!=====================================================================616 !!! Feedback forcing values for Gateaux differentiation (al1)617 !!!=====================================================================618 !!! Surface Planck forcing bracketing call radiation619 !! surf_Planck = 0.620 !! surf_Conv = 0.621 !! write(*,*) 'Gateaux-dif Planck,Conv:',surf_Planck,surf_Conv622 !!! a mettre dans le lmdz1d.def ou autre623 !!624 !!625 qsol = qsolinp626 qsurf = fq_sat(tsurf,psurf/100.)627 day1= day_ini628 time=daytime-day629 ts_toga(1)=tsurf ! needed by read_tsurf1d.F630 rho(1)=psurf/(rd*tsurf*(1.+(rv/rd-1.)*qsurf))631 632 !633 !! mpl et jyg le 22/08/2012 :634 !! pour que les cas a flux de surface imposes marchent635 IF(.NOT.ok_flux_surf.or.max(abs(wtsurf),abs(wqsurf))>0.) THEN636 fsens=-wtsurf*rcpd*rho(1)637 flat=-wqsurf*rlvtt*rho(1)638 print *,'Flux: ok_flux wtsurf wqsurf',ok_flux_surf,wtsurf,wqsurf639 ENDIF640 print*,'Flux sol ',fsens,flat641 !! ok_flux_surf=.false.642 !! fsens=-wtsurf*rcpd*rho(1)643 !! flat=-wqsurf*rlvtt*rho(1)644 !!!!645 646 ! Vertical discretization and pressure levels at half and mid levels:647 648 pa = 5e4649 !! preff= 1.01325e5650 preff = psurf651 IF (ok_old_disvert) THEN652 call disvert0(pa,preff,ap,bp,dpres,presnivs,nivsigs,nivsig)653 print *,'On utilise disvert0'654 aps(1:llm)=0.5*(ap(1:llm)+ap(2:llm+1))655 bps(1:llm)=0.5*(bp(1:llm)+bp(2:llm+1))656 scaleheight=8.657 pseudoalt(1:llm)=-scaleheight*log(presnivs(1:llm)/preff)658 ELSE659 call disvert()660 print *,'On utilise disvert'661 ! Nouvelle version disvert permettant d imposer ap,bp (modif L.Guez) MPL 18092012662 ! Dans ce cas, on lit ap,bp dans le fichier hybrid.txt663 ENDIF664 665 sig_s=presnivs/preff666 plev =ap+bp*psurf667 play = 0.5*(plev(1:llm)+plev(2:llm+1))668 zlay=-rd*300.*log(play/psurf)/rg ! moved after reading profiles669 670 IF (forcing_type .eq. 59) THEN671 ! pour forcing_sandu, on cherche l'indice le plus proche de 700hpa#3000m672 write(*,*) '***********************'673 do l = 1, llm674 write(*,*) 'l,play(l),presnivs(l): ',l,play(l),presnivs(l)675 if (trouve_700 .and. play(l).le.70000) then676 llm700=l677 print *,'llm700,play=',llm700,play(l)/100.678 trouve_700= .false.679 endif680 enddo681 write(*,*) '***********************'682 ENDIF683 684 !685 !=====================================================================686 ! EVENTUALLY, READ FORCING DATA :687 !=====================================================================688 689 #include "1D_read_forc_cases.h"690 691 if (forcing_GCM2SCM) then692 write (*,*) 'forcing_GCM2SCM not yet implemented'693 stop 'in initialization'694 endif ! forcing_GCM2SCM695 696 print*,'mxcalc=',mxcalc697 ! print*,'zlay=',zlay(mxcalc)698 print*,'play=',play(mxcalc)699 700 !Al1 pour SST forced, appell?? depuis ocean_forced_noice701 ts_cur = tsurf ! SST used in read_tsurf1d702 !=====================================================================703 ! Initialisation de la physique :704 !=====================================================================705 706 ! Rq: conf_phys.F90 lit tous les flags de physiq.def; conf_phys appele depuis physiq.F707 !708 ! day_step, iphysiq lus dans gcm.def ci-dessus709 ! timestep: calcule ci-dessous from rday et day_step710 ! ngrid=1711 ! llm: defini dans .../modipsl/modeles/LMDZ4/libf/grid/dimension712 ! rday: defini dans suphel.F (86400.)713 ! day_ini: lu dans run.def (dayref)714 ! rlat_rad,rlon-rad: transformes en radian de rlat,rlon lus dans lmdz1d.def (en degres)715 ! airefi,zcufi,zcvfi initialises au debut de ce programme716 ! rday,ra,rg,rd,rcpd declares dans YOMCST.h et calcules dans suphel.F717 day_step = float(nsplit_phys)*day_step/float(iphysiq)718 write (*,*) 'Time step divided by nsplit_phys (=',nsplit_phys,')'719 timestep =rday/day_step720 dtime_frcg = timestep721 !722 zcufi=airefi723 zcvfi=airefi724 !725 rlat_rad(1)=xlat*rpi/180.726 rlon_rad(1)=xlon*rpi/180.727 728 ! Ehouarn: iniphysiq requires arrays related to (3D) dynamics grid,729 ! e.g. for cell boundaries, which are meaningless in 1D; so pad these730 ! with '0.' when necessary731 call iniphysiq(iim,jjm,llm, &732 1,comm_lmdz, &733 rday,day_ini,timestep, &734 (/rlat_rad(1),0./),(/0./), &735 (/0.,0./),(/rlon_rad(1),0./), &736 (/ (/airefi,0./),(/0.,0./) /), &737 (/zcufi,0.,0.,0./), &738 (/zcvfi,0./), &739 ra,rg,rd,rcpd,1)740 print*,'apres iniphysiq'741 742 ! 2 PARAMETRES QUI DEVRAIENT ETRE LUS DANS run.def MAIS NE LE SONT PAS ICI:743 co2_ppm= 330.0744 solaire=1370.0745 746 ! Ecriture du startphy avant le premier appel a la physique.747 ! On le met juste avant pour avoir acces a tous les champs748 749 if (ok_writedem) then750 751 !--------------------------------------------------------------------------752 ! pbl_surface_init (called here) and pbl_surface_final (called by phyredem)753 ! need : qsol fder snow qsurf evap rugos agesno ftsoil754 !--------------------------------------------------------------------------755 756 type_ocean = "force"757 run_off_lic_0(1) = restart_runoff758 call fonte_neige_init(run_off_lic_0)759 760 fder=0.761 snsrf(1,:)=snowmass ! masse de neige des sous surface762 qsurfsrf(1,:)=qsurf ! humidite de l'air des sous surface763 fevap=0.764 z0m(1,:)=rugos ! couverture de neige des sous surface765 z0h(1,:)=rugosh ! couverture de neige des sous surface766 agesno = xagesno767 tsoil(:,:,:)=tsurf768 !------ AMMA 2e run avec modele sol et rayonnement actif (MPL 23052012)769 ! tsoil(1,1,1)=299.18770 ! tsoil(1,2,1)=300.08771 ! tsoil(1,3,1)=301.88772 ! tsoil(1,4,1)=305.48773 ! tsoil(1,5,1)=308.00774 ! tsoil(1,6,1)=308.00775 ! tsoil(1,7,1)=308.00776 ! tsoil(1,8,1)=308.00777 ! tsoil(1,9,1)=308.00778 ! tsoil(1,10,1)=308.00779 ! tsoil(1,11,1)=308.00780 !-----------------------------------------------------------------------781 call pbl_surface_init(fder, snsrf, qsurfsrf, tsoil)782 783 !------------------ prepare limit conditions for limit.nc -----------------784 !-- Ocean force785 786 print*,'avant phyredem'787 pctsrf(1,:)=0.788 if (nat_surf.eq.0.) then789 pctsrf(1,is_oce)=1.790 pctsrf(1,is_ter)=0.791 pctsrf(1,is_lic)=0.792 pctsrf(1,is_sic)=0.793 else if (nat_surf .eq. 1) then794 pctsrf(1,is_oce)=0.795 pctsrf(1,is_ter)=1.796 pctsrf(1,is_lic)=0.797 pctsrf(1,is_sic)=0.798 else if (nat_surf .eq. 2) then799 pctsrf(1,is_oce)=0.800 pctsrf(1,is_ter)=0.801 pctsrf(1,is_lic)=1.802 pctsrf(1,is_sic)=0.803 else if (nat_surf .eq. 3) then804 pctsrf(1,is_oce)=0.805 pctsrf(1,is_ter)=0.806 pctsrf(1,is_lic)=0.807 pctsrf(1,is_sic)=1.808 809 end if810 811 812 print*,'nat_surf,pctsrf(1,is_oce),pctsrf(1,is_ter)',nat_surf &813 & ,pctsrf(1,is_oce),pctsrf(1,is_ter)814 815 zmasq=pctsrf(1,is_ter)+pctsrf(1,is_lic)816 zpic = zpicinp817 ftsol=tsurf818 nsw=6 ! on met le nb de bandes SW=6, pour initialiser819 ! 6 albedo, mais on peut quand meme tourner avec820 ! moins. Seules les 2 ou 4 premiers seront lus821 falb_dir=albedo822 falb_dif=albedo823 rugoro=rugos824 t_ancien(1,:)=temp(:)825 q_ancien(1,:)=q(:,1)826 ql_ancien = 0.827 qs_ancien = 0.828 prlw_ancien = 0.829 prsw_ancien = 0.830 prw_ancien = 0.831 !jyg<832 !! pbl_tke(:,:,:)=1.e-8833 pbl_tke(:,:,:)=0.834 pbl_tke(:,2,:)=1.e-2835 PRINT *, ' pbl_tke dans lmdz1d '836 if (prt_level .ge. 5) then837 DO nsrf = 1,4838 PRINT *,'pbl_tke(1,:,',nsrf,') ',pbl_tke(1,:,nsrf)839 ENDDO840 end if841 842 !>jyg843 844 rain_fall=0.845 snow_fall=0.846 solsw=0.847 sollw=0.848 sollwdown=rsigma*tsurf**4849 radsol=0.850 rnebcon=0.851 ratqs=0.852 clwcon=0.853 zmax0 = 0.854 zmea=0.855 zstd=0.856 zsig=0.857 zgam=0.858 zval=0.859 zthe=0.860 sig1=0.861 w01=0.862 wake_cstar = 0.863 wake_deltaq = 0.864 wake_deltat = 0.865 wake_delta_pbl_TKE(:,:,:) = 0.866 delta_tsurf = 0.867 wake_fip = 0.868 wake_pe = 0.869 wake_s = 0.870 wake_dens = 0.871 ale_bl = 0.872 ale_bl_trig = 0.873 alp_bl = 0.874 IF (ALLOCATED(du_gwd_rando)) du_gwd_rando = 0.875 IF (ALLOCATED(du_gwd_front)) du_gwd_front = 0.876 entr_therm = 0.877 detr_therm = 0.878 f0 = 0.879 fm_therm = 0.880 u_ancien(1,:)=u(:)881 v_ancien(1,:)=v(:)882 883 !------------------------------------------------------------------------884 ! Make file containing restart for the physics (startphy.nc)885 !886 ! NB: List of the variables to be written by phyredem (via put_field):887 ! rlon,rlat,zmasq,pctsrf(:,is_ter),pctsrf(:,is_lic),pctsrf(:,is_oce)888 ! pctsrf(:,is_sic),ftsol(:,nsrf),tsoil(:,isoil,nsrf),qsurf(:,nsrf)889 ! qsol,falb_dir(:,nsrf),falb_dif(:,nsrf),evap(:,nsrf),snow(:,nsrf)890 ! radsol,solsw,sollw, sollwdown,fder,rain_fall,snow_fall,frugs(:,nsrf)891 ! agesno(:,nsrf),zmea,zstd,zsig,zgam,zthe,zpic,zval,rugoro892 ! t_ancien,q_ancien,,frugs(:,is_oce),clwcon(:,1),rnebcon(:,1),ratqs(:,1)893 ! run_off_lic_0,pbl_tke(:,1:klev,nsrf), zmax0,f0,sig1,w01894 ! wake_deltat,wake_deltaq,wake_s,wake_dens,wake_cstar,895 ! wake_fip,wake_delta_pbl_tke(:,1:klev,nsrf)896 !897 ! NB2: The content of the startphy.nc file depends on some flags defined in898 ! the ".def" files. However, since conf_phys is not called in lmdz1d.F90, these flags have899 ! to be set at some arbitratry convenient values.900 !------------------------------------------------------------------------901 !Al1 =============== restart option ==========================902 if (.not.restart) then903 iflag_pbl = 5904 call phyredem ("startphy.nc")905 else906 ! (desallocations)907 print*,'callin surf final'908 call pbl_surface_final( fder, snsrf, qsurfsrf, tsoil)909 print*,'after surf final'910 CALL fonte_neige_final(run_off_lic_0)911 endif912 913 ok_writedem=.false.914 print*,'apres phyredem'915 916 endif ! ok_writedem917 918 !------------------------------------------------------------------------919 ! Make file containing boundary conditions (limit.nc) **Al1->restartdyn***920 ! --------------------------------------------------921 ! NB: List of the variables to be written in limit.nc922 ! (by writelim.F, subroutine of 1DUTILS.h):923 ! phy_nat,phy_alb,phy_sst,phy_bil,phy_rug,phy_ice,924 ! phy_fter,phy_foce,phy_flic,phy_fsic)925 !------------------------------------------------------------------------926 do i=1,yd927 phy_nat(i) = nat_surf928 phy_alb(i) = albedo929 phy_sst(i) = tsurf ! read_tsurf1d will be used instead930 phy_rug(i) = rugos931 phy_fter(i) = pctsrf(1,is_ter)932 phy_foce(i) = pctsrf(1,is_oce)933 phy_fsic(i) = pctsrf(1,is_sic)934 phy_flic(i) = pctsrf(1,is_lic)935 enddo936 937 ! fabrication de limit.nc938 call writelim (1,phy_nat,phy_alb,phy_sst,phy_bil,phy_rug, &939 & phy_ice,phy_fter,phy_foce,phy_flic,phy_fsic)940 941 942 call phys_state_var_end943 !Al1944 if (restart) then945 print*,'call to restart dyn 1d'946 Call dyn1deta0("start1dyn.nc",plev,play,phi,phis,presnivs, &947 & u,v,temp,q,omega2)948 949 print*,'fnday,annee_ref,day_ref,day_ini', &950 & fnday,annee_ref,day_ref,day_ini951 !** call ymds2ju(annee_ref,mois,day_ini,heure,day)952 day = day_ini953 day_end = day_ini + nday954 daytime = day + time_ini/24. ! 1st day and initial time of the simulation955 956 ! Print out the actual date of the beginning of the simulation :957 call ju2ymds(daytime, an, mois, jour, heure)958 print *,' Time of beginning : y m d h',an, mois,jour,heure/3600.959 960 day = int(daytime)961 time=daytime-day962 963 print*,'****** intialised fields from restart1dyn *******'964 print*,'plev,play,phi,phis,presnivs,u,v,temp,q,omega2'965 print*,'temp(1),q(1,1),u(1),v(1),plev(1),phis :'966 print*,temp(1),q(1,1),u(1),v(1),plev(1),phis967 ! raz for safety968 do l=1,llm969 dq_dyn(l,1) = 0.970 enddo971 endif972 !Al1 ================ end restart =================================973 IF (ecrit_slab_oc.eq.1) then974 open(97,file='div_slab.dat',STATUS='UNKNOWN')975 elseif (ecrit_slab_oc.eq.0) then976 open(97,file='div_slab.dat',STATUS='OLD')977 endif978 !979 !---------------------------------------------------------------------980 ! Initialize target profile for RHT nudging if needed981 !---------------------------------------------------------------------982 if (nudge(inudge_RHT)) then983 call nudge_RHT_init(plev,play,temp,q(:,1),t_targ,rh_targ)984 endif985 if (nudge(inudge_UV)) then986 call nudge_UV_init(plev,play,u,v,u_targ,v_targ)987 endif988 !989 !=====================================================================990 CALL iophys_ini991 ! START OF THE TEMPORAL LOOP :992 !=====================================================================993 994 it_end = nint(fnday*day_step)995 !test JLD it_end = 10996 do while(it.le.it_end)997 998 if (prt_level.ge.1) then999 print*,'XXXXXXXXXXXXXXXXXXX ITAP,day,time=', &1000 & it,day,time,it_end,day_step1001 print*,'PAS DE TEMPS ',timestep1002 endif1003 !Al1 demande de restartphy.nc1004 if (it.eq.it_end) lastcall=.True.1005 1006 !---------------------------------------------------------------------1007 ! Interpolation of forcings in time and onto model levels1008 !---------------------------------------------------------------------1009 1010 #include "1D_interp_cases.h"1011 1012 if (forcing_GCM2SCM) then1013 write (*,*) 'forcing_GCM2SCM not yet implemented'1014 stop 'in time loop'1015 endif ! forcing_GCM2SCM1016 1017 !---------------------------------------------------------------------1018 ! Geopotential :1019 !---------------------------------------------------------------------1020 1021 phi(1)=RD*temp(1)*(plev(1)-play(1))/(.5*(plev(1)+play(1)))1022 do l = 1, llm-11023 phi(l+1)=phi(l)+RD*(temp(l)+temp(l+1))* &1024 & (play(l)-play(l+1))/(play(l)+play(l+1))1025 enddo1026 1027 !---------------------------------------------------------------------1028 ! Listing output for debug prt_level>=11029 !---------------------------------------------------------------------1030 if (prt_level>=1) then1031 print *,' avant physiq : -------- day time ',day,time1032 write(*,*) 'firstcall,lastcall,phis', &1033 & firstcall,lastcall,phis1034 end if1035 if (prt_level>=5) then1036 write(*,'(a10,2a4,4a13)') 'BEFOR1 IT=','it','l', &1037 & 'presniv','plev','play','phi'1038 write(*,'(a10,2i4,4f13.2)') ('BEFOR1 IT= ',it,l, &1039 & presnivs(l),plev(l),play(l),phi(l),l=1,llm)1040 write(*,'(a11,2a4,a11,6a8)') 'BEFOR2','it','l', &1041 & 'presniv','u','v','temp','q1','q2','omega2'1042 write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('BEFOR2 IT= ',it,l, &1043 & presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)1044 endif1045 1046 !---------------------------------------------------------------------1047 ! Call physiq :1048 !---------------------------------------------------------------------1049 call physiq(ngrid,llm, &1050 firstcall,lastcall,timestep, &1051 plev,play,phi,phis,presnivs, &1052 u,v, rot, temp,q,omega2, &1053 du_phys,dv_phys,dt_phys,dq,dpsrf)1054 firstcall=.false.1055 1056 !---------------------------------------------------------------------1057 ! Listing output for debug1058 !---------------------------------------------------------------------1059 if (prt_level>=5) then1060 write(*,'(a11,2a4,4a13)') 'AFTER1 IT=','it','l', &1061 & 'presniv','plev','play','phi'1062 write(*,'(a11,2i4,4f13.2)') ('AFTER1 it= ',it,l, &1063 & presnivs(l),plev(l),play(l),phi(l),l=1,llm)1064 write(*,'(a11,2a4,a11,6a8)') 'AFTER2','it','l', &1065 & 'presniv','u','v','temp','q1','q2','omega2'1066 write(*,'(a11,2i4,f11.2,5f8.2,e10.2)') ('AFTER2 it= ',it,l, &1067 & presnivs(l),u(l),v(l),temp(l),q(l,1),q(l,2),omega2(l),l=1,llm)1068 write(*,'(a11,2a4,a11,5a8)') 'AFTER3','it','l', &1069 & 'presniv','du_phys','dv_phys','dt_phys','dq1','dq2'1070 write(*,'(a11,2i4,f11.2,5f8.2)') ('AFTER3 it= ',it,l, &1071 & presnivs(l),86400*du_phys(l),86400*dv_phys(l), &1072 & 86400*dt_phys(l),86400*dq(l,1),dq(l,2),l=1,llm)1073 write(*,*) 'dpsrf',dpsrf1074 endif1075 !---------------------------------------------------------------------1076 ! Add physical tendencies :1077 !---------------------------------------------------------------------1078 1079 fcoriolis=2.*sin(rpi*xlat/180.)*romega1080 if (forcing_radconv .or. forcing_fire) then1081 fcoriolis=0.01082 dt_cooling=0.01083 d_t_adv=0.01084 d_q_adv=0.01085 endif1086 ! print*, 'calcul de fcoriolis ', fcoriolis1087 1088 if (forcing_toga .or. forcing_GCSSold .or. forcing_twpice &1089 & .or.forcing_amma .or. forcing_type.eq.101) then1090 fcoriolis=0.0 ; ug=0. ; vg=0.1091 endif1092 1093 if(forcing_rico) then1094 dt_cooling=0.1095 endif1096 1097 !CRio:Attention modif sp??cifique cas de Caroline1098 if (forcing_type==-1) then1099 fcoriolis=0.1100 !Nudging1101 1102 !on calcule dt_cooling1103 do l=1,llm1104 if (play(l).ge.20000.) then1105 dt_cooling(l)=-1.5/86400.1106 elseif ((play(l).ge.10000.).and.((play(l).lt.20000.))) then1107 dt_cooling(l)=-1.5/86400.*(play(l)-10000.)/(10000.)-1./86400.*(20000.-play(l))/10000.*(temp(l)-200.)1108 else1109 dt_cooling(l)=-1.*(temp(l)-200.)/86400.1110 endif1111 enddo1112 1113 endif1114 !RC1115 if (forcing_sandu) then1116 ug(1:llm)=u_mod(1:llm)1117 vg(1:llm)=v_mod(1:llm)1118 endif1119 1120 IF (prt_level >= 5) print*, 'fcoriolis, xlat,mxcalc ', &1121 fcoriolis, xlat,mxcalc1122 1123 ! print *,'u-ug=',u-ug1124 1125 !!!!!!!!!!!!!!!!!!!!!!!!1126 ! Geostrophic wind1127 ! Le calcul ci dessous est insuffisamment precis1128 ! du_age(1:mxcalc)=fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))1129 ! dv_age(1:mxcalc)=-fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))1130 !!!!!!!!!!!!!!!!!!!!!!!!1131 sfdt = sin(0.5*fcoriolis*timestep)1132 cfdt = cos(0.5*fcoriolis*timestep)1133 ! print *,'fcoriolis,sfdt,cfdt,timestep',fcoriolis,sfdt,cfdt,timestep1134 !1135 du_age(1:mxcalc)= -2.*sfdt/timestep* &1136 & (sfdt*(u(1:mxcalc)-ug(1:mxcalc)) - &1137 & cfdt*(v(1:mxcalc)-vg(1:mxcalc)) )1138 !! : fcoriolis*(v(1:mxcalc)-vg(1:mxcalc))1139 !1140 dv_age(1:mxcalc)= -2.*sfdt/timestep* &1141 & (cfdt*(u(1:mxcalc)-ug(1:mxcalc)) + &1142 & sfdt*(v(1:mxcalc)-vg(1:mxcalc)) )1143 !! : -fcoriolis*(u(1:mxcalc)-ug(1:mxcalc))1144 !1145 !!!!!!!!!!!!!!!!!!!!!!!!1146 ! Nudging1147 !!!!!!!!!!!!!!!!!!!!!!!!1148 d_t_nudge(:) = 0.1149 d_q_nudge(:,:) = 0.1150 d_u_nudge(:) = 0.1151 d_v_nudge(:) = 0.1152 if (nudge(inudge_RHT)) then1153 call nudge_RHT(timestep,plev,play,t_targ,rh_targ,temp,q(:,1), &1154 & d_t_nudge,d_q_nudge(:,1))1155 endif1156 if (nudge(inudge_UV)) then1157 call nudge_UV(timestep,plev,play,u_targ,v_targ,u,v, &1158 & d_u_nudge,d_v_nudge)1159 endif1160 !1161 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1162 ! call writefield_phy('dv_age' ,dv_age,llm)1163 ! call writefield_phy('du_age' ,du_age,llm)1164 ! call writefield_phy('du_phys' ,du_phys,llm)1165 ! call writefield_phy('u_tend' ,u,llm)1166 ! call writefield_phy('u_g' ,ug,llm)1167 !1168 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!1169 !! Increment state variables1170 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!1171 IF (flag_inhib_forcing == 0) then ! if tendency of forcings should be added1172 1173 ! pour les cas sandu et astex, on reclacule u,v,q,temp et teta dans 1D_nudge_sandu_astex.h1174 ! au dessus de 700hpa, on relaxe vers les profils initiaux1175 if (forcing_sandu .OR. forcing_astex) then1176 #include "1D_nudge_sandu_astex.h"1177 else1178 u(1:mxcalc)=u(1:mxcalc) + timestep*( &1179 & du_phys(1:mxcalc) &1180 & +du_age(1:mxcalc)+du_adv(1:mxcalc) &1181 & +d_u_nudge(1:mxcalc) )1182 v(1:mxcalc)=v(1:mxcalc) + timestep*( &1183 & dv_phys(1:mxcalc) &1184 & +dv_age(1:mxcalc)+dv_adv(1:mxcalc) &1185 & +d_v_nudge(1:mxcalc) )1186 q(1:mxcalc,:)=q(1:mxcalc,:)+timestep*( &1187 & dq(1:mxcalc,:) &1188 & +d_q_adv(1:mxcalc,:) &1189 & +d_q_nudge(1:mxcalc,:) )1190 1191 if (prt_level.ge.3) then1192 print *, &1193 & 'physiq-> temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1) ', &1194 & temp(1),dt_phys(1),d_t_adv(1),dt_cooling(1)1195 print* ,'dv_phys=',dv_phys1196 print* ,'dv_age=',dv_age1197 print* ,'dv_adv=',dv_adv1198 print* ,'d_v_nudge=',d_v_nudge1199 print*, v1200 print*, vg1201 endif1202 1203 temp(1:mxcalc)=temp(1:mxcalc)+timestep*( &1204 & dt_phys(1:mxcalc) &1205 & +d_t_adv(1:mxcalc) &1206 & +d_t_nudge(1:mxcalc) &1207 & +dt_cooling(1:mxcalc)) ! Taux de chauffage ou refroid.1208 1209 endif ! forcing_sandu or forcing_astex1210 1211 teta=temp*(pzero/play)**rkappa1212 !1213 !---------------------------------------------------------------------1214 ! Nudge soil temperature if requested1215 !---------------------------------------------------------------------1216 1217 IF (nudge_tsoil .AND. .NOT. lastcall) THEN1218 ftsoil(1,isoil_nudge,:) = ftsoil(1,isoil_nudge,:) &1219 & -timestep/tau_soil_nudge*(ftsoil(1,isoil_nudge,:)-Tsoil_nudge)1220 ENDIF1221 1222 !---------------------------------------------------------------------1223 ! Add large-scale tendencies (advection, etc) :1224 !---------------------------------------------------------------------1225 1226 !cc nrlmd1227 !cc tmpvar=teta1228 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1229 !cc1230 !cc teta(1:mxcalc)=tmpvar(1:mxcalc)1231 !cc tmpvar(:)=q(:,1)1232 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1233 !cc q(1:mxcalc,1)=tmpvar(1:mxcalc)1234 !cc tmpvar(:)=q(:,2)1235 !cc call advect_vert(llm,omega,timestep,tmpvar,plev)1236 !cc q(1:mxcalc,2)=tmpvar(1:mxcalc)1237 1238 END IF ! end if tendency of tendency should be added1239 1240 !---------------------------------------------------------------------1241 ! Air temperature :1242 !---------------------------------------------------------------------1243 if (lastcall) then1244 print*,'Pas de temps final ',it1245 call ju2ymds(daytime, an, mois, jour, heure)1246 print*,'a la date : a m j h',an, mois, jour ,heure/3600.1247 endif1248 1249 ! incremente day time1250 ! print*,'daytime bef',daytime,1./day_step1251 daytime = daytime+1./day_step1252 !Al1dbg1253 day = int(daytime+0.1/day_step)1254 ! time = max(daytime-day,0.0)1255 !Al1&jyg: correction de bug1256 !cc time = real(mod(it,day_step))/day_step1257 time = time_ini/24.+real(mod(it,day_step))/day_step1258 ! print*,'daytime nxt time',daytime,time1259 it=it+11260 1261 enddo1262 1263 !Al11264 if (ecrit_slab_oc.ne.-1) close(97)1265 1266 !Al1 Call to 1D equivalent of dynredem (an,mois,jour,heure ?)1267 ! -------------------------------------1268 call dyn1dredem("restart1dyn.nc", &1269 & plev,play,phi,phis,presnivs, &1270 & u,v,temp,q,omega2)1271 1272 CALL abort_gcm ('lmdz1d ','The End ',0)1273 1274 end1275 27 1276 28 #include "1DUTILS.h" -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/dyn1d/mod_1D_cases_read2.F90
r2764 r3605 315 315 END SUBROUTINE read2_1D_cas 316 316 317 !********************************************************************************************** 318 SUBROUTINE read_SCM_cas 319 implicit none 320 321 #include "netcdf.inc" 322 #include "date_cas.h" 323 324 INTEGER nid,rid,ierr 325 INTEGER ii,jj,timeid 326 REAL, ALLOCATABLE :: time_val(:) 327 328 print*,'ON EST VRAIMENT LA' 329 fich_cas='cas.nc' 330 print*,'fich_cas ',fich_cas 331 ierr = NF_OPEN(fich_cas,NF_NOWRITE,nid) 332 print*,'fich_cas,NF_NOWRITE,nid ',fich_cas,NF_NOWRITE,nid 333 if (ierr.NE.NF_NOERR) then 334 write(*,*) 'ERROR: GROS Pb opening forcings nc file ' 335 write(*,*) NF_STRERROR(ierr) 336 stop "" 337 endif 338 !....................................................................... 339 ierr=NF_INQ_DIMID(nid,'lat',rid) 340 IF (ierr.NE.NF_NOERR) THEN 341 print*, 'Oh probleme lecture dimension lat' 342 ENDIF 343 ierr=NF_INQ_DIMLEN(nid,rid,ii) 344 print*,'OK1 read2: nid,rid,lat',nid,rid,ii 345 !....................................................................... 346 ierr=NF_INQ_DIMID(nid,'lon',rid) 347 IF (ierr.NE.NF_NOERR) THEN 348 print*, 'Oh probleme lecture dimension lon' 349 ENDIF 350 ierr=NF_INQ_DIMLEN(nid,rid,jj) 351 print*,'OK2 read2: nid,rid,lat',nid,rid,jj 352 !....................................................................... 353 ierr=NF_INQ_DIMID(nid,'lev',rid) 354 IF (ierr.NE.NF_NOERR) THEN 355 print*, 'Oh probleme lecture dimension nlev' 356 ENDIF 357 ierr=NF_INQ_DIMLEN(nid,rid,nlev_cas) 358 print*,'OK3 read2: nid,rid,nlev_cas',nid,rid,nlev_cas 359 IF ( .NOT. ( nlev_cas > 10 .AND. nlev_cas < 1000 )) THEN 360 print*,'Valeur de nlev_cas peu probable' 361 STOP 362 ENDIF 363 !....................................................................... 364 ierr=NF_INQ_DIMID(nid,'time',rid) 365 nt_cas=0 366 IF (ierr.NE.NF_NOERR) THEN 367 stop 'Oh probleme lecture dimension time' 368 ENDIF 369 ierr=NF_INQ_DIMLEN(nid,rid,nt_cas) 370 print*,'OK4 read2: nid,rid,nt_cas',nid,rid,nt_cas 371 ! Lecture de l'axe des temps 372 print*,'LECTURE DU TEMPS' 373 ierr=NF_INQ_VARID(nid,'time',timeid) 374 if(ierr/=NF_NOERR) then 375 print *,'Variable time manquante dans cas.nc:' 376 ierr=NF_NOERR 377 else 378 allocate(time_val(nt_cas)) 379 #ifdef NC_DOUBLE 380 ierr = NF_GET_VAR_DOUBLE(nid,timeid,time_val) 381 #else 382 ierr = NF_GET_VAR_REAL(nid,timeid,time_val) 383 #endif 384 if(ierr/=NF_NOERR) then 385 print *,'Pb a la lecture de time cas.nc: ' 386 endif 387 endif 388 IF (nt_cas>1) THEN 389 pdt_cas=time_val(2)-time_val(1) 390 ELSE 391 pdt_cas=0. 392 ENDIF 393 394 395 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 396 !profils moyens: 397 allocate(plev_cas(nlev_cas,nt_cas),plevh_cas(nlev_cas+1)) 398 allocate(z_cas(nlev_cas,nt_cas),zh_cas(nlev_cas+1)) 399 allocate(ap_cas(nlev_cas+1),bp_cas(nt_cas+1)) 400 allocate(t_cas(nlev_cas,nt_cas),q_cas(nlev_cas,nt_cas),qv_cas(nlev_cas,nt_cas),ql_cas(nlev_cas,nt_cas), & 401 qi_cas(nlev_cas,nt_cas),rh_cas(nlev_cas,nt_cas)) 402 allocate(th_cas(nlev_cas,nt_cas),thl_cas(nlev_cas,nt_cas),thv_cas(nlev_cas,nt_cas),rv_cas(nlev_cas,nt_cas)) 403 allocate(u_cas(nlev_cas,nt_cas),v_cas(nlev_cas,nt_cas),vitw_cas(nlev_cas,nt_cas),omega_cas(nlev_cas,nt_cas)) 404 405 !forcing 406 allocate(ht_cas(nlev_cas,nt_cas),vt_cas(nlev_cas,nt_cas),dt_cas(nlev_cas,nt_cas),dtrad_cas(nlev_cas,nt_cas)) 407 allocate(hq_cas(nlev_cas,nt_cas),vq_cas(nlev_cas,nt_cas),dq_cas(nlev_cas,nt_cas)) 408 allocate(hth_cas(nlev_cas,nt_cas),vth_cas(nlev_cas,nt_cas),dth_cas(nlev_cas,nt_cas)) 409 allocate(hr_cas(nlev_cas,nt_cas),vr_cas(nlev_cas,nt_cas),dr_cas(nlev_cas,nt_cas)) 410 allocate(hu_cas(nlev_cas,nt_cas),vu_cas(nlev_cas,nt_cas),du_cas(nlev_cas,nt_cas)) 411 allocate(hv_cas(nlev_cas,nt_cas),vv_cas(nlev_cas,nt_cas),dv_cas(nlev_cas,nt_cas)) 412 allocate(ug_cas(nlev_cas,nt_cas)) 413 allocate(vg_cas(nlev_cas,nt_cas)) 414 allocate(lat_cas(nt_cas),sens_cas(nt_cas),ts_cas(nt_cas),ps_cas(nt_cas),ustar_cas(nt_cas),tke_cas(nt_cas)) 415 allocate(uw_cas(nlev_cas,nt_cas),vw_cas(nlev_cas,nt_cas),q1_cas(nlev_cas,nt_cas),q2_cas(nlev_cas,nt_cas)) 416 417 418 419 !champs interpoles 420 allocate(plev_prof_cas(nlev_cas)) 421 allocate(t_prof_cas(nlev_cas)) 422 allocate(theta_prof_cas(nlev_cas)) 423 allocate(thl_prof_cas(nlev_cas)) 424 allocate(thv_prof_cas(nlev_cas)) 425 allocate(q_prof_cas(nlev_cas)) 426 allocate(qv_prof_cas(nlev_cas)) 427 allocate(ql_prof_cas(nlev_cas)) 428 allocate(qi_prof_cas(nlev_cas)) 429 allocate(rh_prof_cas(nlev_cas)) 430 allocate(rv_prof_cas(nlev_cas)) 431 allocate(u_prof_cas(nlev_cas)) 432 allocate(v_prof_cas(nlev_cas)) 433 allocate(vitw_prof_cas(nlev_cas)) 434 allocate(omega_prof_cas(nlev_cas)) 435 allocate(ug_prof_cas(nlev_cas)) 436 allocate(vg_prof_cas(nlev_cas)) 437 allocate(ht_prof_cas(nlev_cas)) 438 allocate(hth_prof_cas(nlev_cas)) 439 allocate(hq_prof_cas(nlev_cas)) 440 allocate(hu_prof_cas(nlev_cas)) 441 allocate(hv_prof_cas(nlev_cas)) 442 allocate(vt_prof_cas(nlev_cas)) 443 allocate(vth_prof_cas(nlev_cas)) 444 allocate(vq_prof_cas(nlev_cas)) 445 allocate(vu_prof_cas(nlev_cas)) 446 allocate(vv_prof_cas(nlev_cas)) 447 allocate(dt_prof_cas(nlev_cas)) 448 allocate(dth_prof_cas(nlev_cas)) 449 allocate(dtrad_prof_cas(nlev_cas)) 450 allocate(dq_prof_cas(nlev_cas)) 451 allocate(du_prof_cas(nlev_cas)) 452 allocate(dv_prof_cas(nlev_cas)) 453 allocate(uw_prof_cas(nlev_cas)) 454 allocate(vw_prof_cas(nlev_cas)) 455 allocate(q1_prof_cas(nlev_cas)) 456 allocate(q2_prof_cas(nlev_cas)) 457 458 print*,'Allocations OK' 459 call read_SCM (nid,nlev_cas,nt_cas, & 460 & ap_cas,bp_cas,z_cas,plev_cas,zh_cas,plevh_cas,t_cas,th_cas,thv_cas,thl_cas,qv_cas, & 461 & ql_cas,qi_cas,rh_cas,rv_cas,u_cas,v_cas,vitw_cas,omega_cas,ug_cas,vg_cas,du_cas,hu_cas,vu_cas, & 462 & dv_cas,hv_cas,vv_cas,dt_cas,ht_cas,vt_cas,dq_cas,hq_cas,vq_cas,dth_cas,hth_cas,vth_cas, & 463 & dr_cas,hr_cas,vr_cas,dtrad_cas,sens_cas,lat_cas,ts_cas,ps_cas,ustar_cas,tke_cas, & 464 & uw_cas,vw_cas,q1_cas,q2_cas,orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough, & 465 & o3_cas,rugos_cas,clay_cas,sand_cas) 466 print*,'Read2 cas OK' 467 do ii=1,nlev_cas 468 print*,'apres read2_cas, plev_cas=',ii,plev_cas(ii,1) 469 enddo 470 471 472 END SUBROUTINE read_SCM_cas 317 473 318 474 … … 685 841 !----------------------------------------------------------------------- 686 842 843 687 844 return 688 845 end subroutine read2_cas 846 847 !====================================================================== 848 subroutine read_SCM(nid,nlevel,ntime, & 849 & ap,bp,zz,pp,zzh,pph,temp,theta,thv,thl,qv,ql,qi,rh,rv,u,v,vitw,omega,ug,vg,& 850 & du,hu,vu,dv,hv,vv,dt,ht,vt,dq,hq,vq, & 851 & dth,hth,vth,dr,hr,vr,dtrad,sens,flat,ts,ps,ustar,tke,uw,vw,q1,q2, & 852 & orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough, & 853 & heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas) 854 855 !program reading forcing of the case study 856 implicit none 857 #include "netcdf.inc" 858 859 integer ntime,nlevel,k,t 860 861 real ap(nlevel+1),bp(nlevel+1) 862 real zz(nlevel,ntime),zzh(nlevel+1) 863 real pp(nlevel,ntime),pph(nlevel+1) 864 !profils initiaux 865 real temp0(nlevel),qv0(nlevel),ql0(nlevel),qi0(nlevel),u0(nlevel),v0(nlevel),tke0(nlevel) 866 real pp0(nlevel) 867 real temp(nlevel,ntime),qv(nlevel,ntime),ql(nlevel,ntime),qi(nlevel,ntime),rh(nlevel,ntime) 868 real theta(nlevel,ntime),thv(nlevel,ntime),thl(nlevel,ntime),rv(nlevel,ntime) 869 real u(nlevel,ntime),v(nlevel,ntime),tke(nlevel,ntime) 870 real ug(nlevel,ntime),vg(nlevel,ntime) 871 real vitw(nlevel,ntime),omega(nlevel,ntime) 872 real du(nlevel,ntime),hu(nlevel,ntime),vu(nlevel,ntime) 873 real dv(nlevel,ntime),hv(nlevel,ntime),vv(nlevel,ntime) 874 real dt(nlevel,ntime),ht(nlevel,ntime),vt(nlevel,ntime) 875 real dtrad(nlevel,ntime) 876 real dq(nlevel,ntime),hq(nlevel,ntime),vq(nlevel,ntime) 877 real dth(nlevel,ntime),hth(nlevel,ntime),vth(nlevel,ntime),hthl(nlevel,ntime) 878 real dr(nlevel,ntime),hr(nlevel,ntime),vr(nlevel,ntime) 879 real flat(ntime),sens(ntime),ustar(ntime) 880 real uw(nlevel,ntime),vw(nlevel,ntime),q1(nlevel,ntime),q2(nlevel,ntime) 881 real ts(ntime),ps(ntime) 882 real orog_cas,albedo_cas,emiss_cas,t_skin_cas,q_skin_cas,mom_rough,heat_rough,o3_cas,rugos_cas,clay_cas,sand_cas 883 real apbp(nlevel+1),resul(nlevel,ntime),resul1(nlevel),resul2(ntime),resul3 884 885 886 integer nid, ierr,ierr1,ierr2,rid,i 887 integer nbvar3d 888 parameter(nbvar3d=70) 889 integer var3didin(nbvar3d),missing_var(nbvar3d) 890 character*13 name_var(1:nbvar3d) 891 data name_var/'coor_par_a','coor_par_b','height_h','pressure_h',& 892 &'temp','qv','ql','qi','u','v','tke','pressure',& 893 &'w','omega','ug','vg','uadv','uadvh','uadvv','vadv','vadvh','vadvv','tadv','tadvh','tadvv',& 894 &'qvadv','qvadvh','qvadvv','thadv','thadvh','thadvv','thladvh','radv','radvh','radvv','radcool','q1','q2','ustress','vstress', & 895 'rh',& 896 &'height_f','pressure_forc','tempt','theta','thv','thl','qvt','qlt','qit','rv','ut','vt','tket',& 897 &'sfc_sens_flx','sfc_lat_flx','ts','ps','ustar',& 898 &'orog','albedo','emiss','t_skin','q_skin','mom_rough','heat_rough','o3','rugos','clay','sand'/ 899 do i=1,nbvar3d 900 missing_var(i)=0. 901 enddo 902 903 !----------------------------------------------------------------------- 904 905 print*,'ON EST LA' 906 do i=1,nbvar3d 907 ierr=NF_INQ_VARID(nid,name_var(i),var3didin(i)) 908 if(ierr/=NF_NOERR) then 909 print *,'Variable manquante dans cas.nc:',i,name_var(i) 910 ierr=NF_NOERR 911 missing_var(i)=1 912 else 913 !----------------------------------------------------------------------- 914 if(i.LE.4) then ! Lecture des coord pression en (nlevelp1,lat,lon) 915 #ifdef NC_DOUBLE 916 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),apbp) 917 #else 918 ierr = NF_GET_VAR_REAL(nid,var3didin(i),apbp) 919 #endif 920 print *,'read2_cas(apbp), on a lu ',i,name_var(i) 921 if(ierr/=NF_NOERR) then 922 print *,'Pb a la lecture de cas.nc: ',name_var(i) 923 stop "getvarup" 924 endif 925 !----------------------------------------------------------------------- 926 else if(i.gt.4.and.i.LE.12) then ! Lecture des variables en (time,nlevel,lat,lon) 927 #ifdef NC_DOUBLE 928 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul1) 929 #else 930 ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul1) 931 #endif 932 print *,'read2_cas(resul1), on a lu ',i,name_var(i) 933 if(ierr/=NF_NOERR) then 934 print *,'Pb a la lecture de cas.nc: ',name_var(i) 935 stop "getvarup" 936 endif 937 print*,'Lecture de la variable #i ',i,name_var(i),minval(resul1),maxval(resul1) 938 !----------------------------------------------------------------------- 939 else if(i.gt.12.and.i.LE.54) then ! Lecture des variables en (time,nlevel,lat,lon) 940 #ifdef NC_DOUBLE 941 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul) 942 #else 943 ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul) 944 #endif 945 print *,'read2_cas(resul), on a lu ',i,name_var(i) 946 if(ierr/=NF_NOERR) then 947 print *,'Pb a la lecture de cas.nc: ',name_var(i) 948 stop "getvarup" 949 endif 950 print*,'Lecture de la variable #i ',i,name_var(i),minval(resul),maxval(resul) 951 !----------------------------------------------------------------------- 952 else if (i.gt.54.and.i.LE.65) then ! Lecture des variables en (time,lat,lon) 953 #ifdef NC_DOUBLE 954 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul2) 955 #else 956 ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul2) 957 #endif 958 print *,'read2_cas(resul2), on a lu ',i,name_var(i) 959 if(ierr/=NF_NOERR) then 960 print *,'Pb a la lecture de cas.nc: ',name_var(i) 961 stop "getvarup" 962 endif 963 print*,'Lecture de la variable #i ',i,name_var(i),minval(resul2),maxval(resul2) 964 !----------------------------------------------------------------------- 965 else ! Lecture des constantes (lat,lon) 966 #ifdef NC_DOUBLE 967 ierr = NF_GET_VAR_DOUBLE(nid,var3didin(i),resul3) 968 #else 969 ierr = NF_GET_VAR_REAL(nid,var3didin(i),resul3) 970 #endif 971 print *,'read2_cas(resul3), on a lu ',i,name_var(i) 972 if(ierr/=NF_NOERR) then 973 print *,'Pb a la lecture de cas.nc: ',name_var(i) 974 stop "getvarup" 975 endif 976 print*,'Lecture de la variable #i ',i,name_var(i),resul3 977 endif 978 endif 979 !----------------------------------------------------------------------- 980 select case(i) 981 !case(1) ; ap=apbp ! donnees indexees en nlevel+1 982 ! case(2) ; bp=apbp 983 case(3) ; zzh=apbp 984 case(4) ; pph=apbp 985 case(5) ; temp0=resul1 ! donnees initiales 986 case(6) ; qv0=resul1 987 case(7) ; ql0=resul1 988 case(8) ; qi0=resul1 989 case(9) ; u0=resul1 990 case(10) ; v0=resul1 991 case(11) ; tke0=resul1 992 case(12) ; pp0=resul1 993 case(13) ; vitw=resul ! donnees indexees en nlevel,time 994 case(14) ; omega=resul 995 case(15) ; ug=resul 996 case(16) ; vg=resul 997 case(17) ; du=resul 998 case(18) ; hu=resul 999 case(19) ; vu=resul 1000 case(20) ; dv=resul 1001 case(21) ; hv=resul 1002 case(22) ; vv=resul 1003 case(23) ; dt=resul 1004 case(24) ; ht=resul 1005 case(25) ; vt=resul 1006 case(26) ; dq=resul 1007 case(27) ; hq=resul 1008 case(28) ; vq=resul 1009 case(29) ; dth=resul 1010 case(30) ; hth=resul 1011 case(31) ; vth=resul 1012 case(32) ; hthl=resul 1013 case(33) ; dr=resul 1014 case(34) ; hr=resul 1015 case(35) ; vr=resul 1016 case(36) ; dtrad=resul 1017 case(37) ; q1=resul 1018 case(38) ; q2=resul 1019 case(39) ; uw=resul 1020 case(40) ; vw=resul 1021 case(41) ; rh=resul 1022 case(42) ; zz=resul ! donnees en time,nlevel pour profil initial 1023 case(43) ; pp=resul 1024 case(44) ; temp=resul 1025 case(45) ; theta=resul 1026 case(46) ; thv=resul 1027 case(47) ; thl=resul 1028 case(48) ; qv=resul 1029 case(49) ; ql=resul 1030 case(50) ; qi=resul 1031 case(51) ; rv=resul 1032 case(52) ; u=resul 1033 case(53) ; v=resul 1034 case(54) ; tke=resul 1035 case(55) ; sens=resul2 ! donnees indexees en time 1036 case(56) ; flat=resul2 1037 case(57) ; ts=resul2 1038 case(58) ; ps=resul2 1039 case(59) ; ustar=resul2 1040 case(60) ; orog_cas=resul3 ! constantes 1041 case(61) ; albedo_cas=resul3 1042 case(62) ; emiss_cas=resul3 1043 case(63) ; t_skin_cas=resul3 1044 case(64) ; q_skin_cas=resul3 1045 case(65) ; mom_rough=resul3 1046 case(66) ; heat_rough=resul3 1047 case(67) ; o3_cas=resul3 1048 case(68) ; rugos_cas=resul3 1049 case(69) ; clay_cas=resul3 1050 case(70) ; sand_cas=resul3 1051 end select 1052 resul=0. 1053 resul1=0. 1054 resul2=0. 1055 resul3=0. 1056 enddo 1057 print*,'Lecture de la variable APRES ,sens ',minval(sens),maxval(sens) 1058 print*,'Lecture de la variable APRES ,flat ',minval(flat),maxval(flat) 1059 1060 !CR:ATTENTION EN ATTENTE DE REGLER LA QUESTION DU PAS DE TEMPS INITIAL 1061 do t=1,ntime 1062 do k=1,nlevel 1063 temp(k,t)=temp0(k) 1064 qv(k,t)=qv0(k) 1065 ql(k,t)=ql0(k) 1066 qi(k,t)=qi0(k) 1067 u(k,t)=u0(k) 1068 v(k,t)=v0(k) 1069 tke(k,t)=tke0(k) 1070 enddo 1071 enddo 1072 !----------------------------------------------------------------------- 1073 1074 return 1075 end subroutine read_SCM 1076 !====================================================================== 1077 689 1078 !====================================================================== 690 1079 SUBROUTINE interp_case_time2(day,day1,annee_ref & -
LMDZ6/branches/Ocean_skin/libf/phylmd/fisrtilp.F90
r2969 r3605 740 740 call cloudth(klon,klev,k,ztv, & 741 741 zq,zqta,fraca, & 742 qcloud,ctot,zpspsk,paprs, ztla,zthl, &742 qcloud,ctot,zpspsk,paprs,pplay,ztla,zthl, & 743 743 ratqs,zqs,t) 744 elseif (iflag_cloudth_vert>=3 ) then744 elseif (iflag_cloudth_vert>=3 .and. iflag_cloudth_vert<=5) then 745 745 call cloudth_v3(klon,klev,k,ztv, & 746 746 zq,zqta,fraca, & 747 qcloud,ctot,ctot_vol,zpspsk,paprs, ztla,zthl, &747 qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 748 748 ratqs,zqs,t) 749 !---------------------------------- 750 !Version these Jean Jouhaud, Decembre 2018 751 !---------------------------------- 752 elseif (iflag_cloudth_vert==6) then 753 call cloudth_v6(klon,klev,k,ztv, & 754 zq,zqta,fraca, & 755 qcloud,ctot,ctot_vol,zpspsk,paprs,pplay,ztla,zthl, & 756 ratqs,zqs,t) 757 749 758 endif 750 759 do i=1,klon -
LMDZ6/branches/Ocean_skin/libf/phylmd/flott_gwd_rando_m.F90
-
Property
svn:keywords
set to
Id
r3198 r3605 1 ! 2 ! $Id$ 3 ! 1 4 module FLOTT_GWD_rando_m 2 5 … … 20 23 USE ioipsl_getin_p_mod, ONLY : getin_p 21 24 USE vertical_layers_mod, ONLY : presnivs 25 CHARACTER (LEN=20) :: modname='flott_gwd_rando' 26 CHARACTER (LEN=80) :: abort_message 22 27 23 28 include "YOMCST.h" … … 115 120 LOGICAL, SAVE :: firstcall = .TRUE. 116 121 !$OMP THREADPRIVATE(firstcall,gwd_reproductibilite_mpiomp) 117 118 CHARACTER (LEN=20) :: modname='flott_gwd_rando'119 CHARACTER (LEN=80) :: abort_message120 121 122 122 123 … … 198 199 199 200 IF(DELTAT < DTIME)THEN 200 PRINT *,'flott_gwd_rando: deltat < dtime!'201 STOP 1201 abort_message='flott_gwd_rando: deltat < dtime!' 202 CALL abort_physic(modname,abort_message,1) 202 203 ENDIF 203 204 204 205 IF (KLEV < NW) THEN 205 PRINT *,'flott_gwd_rando: you will have problem with random numbers'206 STOP 1206 abort_message='flott_gwd_rando: you will have problem with random numbers' 207 CALL abort_physic(modname,abort_message,1) 207 208 ENDIF 208 209 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/geo2atm.F90
r2429 r3605 5 5 USE dimphy 6 6 USE mod_phys_lmdz_para 7 7 USE mod_grid_phy_lmdz, only: grid_type, unstructured, regular_lonlat 8 8 IMPLICIT NONE 9 9 INCLUDE 'YOMCST.h' 10 CHARACTER (len = 6) :: clmodnam 11 CHARACTER (len = 20) :: modname = 'geo2atm' 12 CHARACTER (len = 80) :: abort_message 10 13 11 14 ! Change wind coordinates from cartesian geocentric to local spherical 12 15 ! NB! Fonctionne probablement uniquement en MPI seul (sans OpenMP) 13 16 ! 17 ! Geocentric : 18 ! axe x is eastward : crosses (0N,90E) point. 19 ! axe y crosses (0N,180E) point. 20 ! axe z is 'up' : crosses north pole. 21 ! 22 ! NB! Aux poles, fonctionne probablement uniquement en MPI seul (sans OpenMP) 23 14 24 INTEGER, INTENT (IN) :: im, jm 15 25 REAL, DIMENSION (im,jm), INTENT(IN) :: px, py, pz … … 17 27 REAL, DIMENSION (im,jm), INTENT(OUT) :: pu, pv, pr 18 28 19 REAL :: rad 29 REAL :: rad,reps 20 30 21 31 22 32 rad = rpi / 180.0E0 23 33 reps = 1.0e-5 34 24 35 pu(:,:) = & 25 36 - px(:,:) * SIN(rad * plon(:,:)) & … … 36 47 + pz(:,:) * SIN(rad * plat(:,:)) 37 48 38 ! Value at North Pole 39 IF (is_north_pole_dyn) THEN 40 pu(:, 1) = -px (1,1) 41 pv(:, 1) = -py (1,1) 42 pr(:, 1) = 0.0 43 ENDIF 49 IF (grid_type==regular_lonlat) THEN 50 ! Value at North Pole 51 IF (is_north_pole_dyn) THEN 52 pu(:, 1) = -px (1,1) 53 pv(:, 1) = -py (1,1) 54 pr(:, 1) = 0.0 55 ENDIF 44 56 45 ! Value at South Pole 46 IF (is_south_pole_dyn) THEN 47 pu(:,jm) = -px (1,jm) 48 pv(:,jm) = -py (1,jm) 49 pr(:,jm) = 0.0 50 ENDIF 57 ! Value at South Pole 58 IF (is_south_pole_dyn) THEN 59 pu(:,jm) = -px (1,jm) 60 pv(:,jm) = -py (1,jm) 61 pr(:,jm) = 0.0 62 ENDIF 63 64 ELSE IF (grid_type==unstructured) THEN 65 ! Pole nord pour Dynamico 66 WHERE ( plat(:,:) >= 90.0-reps ) 67 pu(:,:) = py(:,:) 68 pv(:,:) = -px(:,:) 69 pr(:,:) = 0.0e0 70 END WHERE 71 72 ELSE 73 abort_message='Problem: unknown grid type' 74 CALL abort_physic(modname,abort_message,1) 75 END IF 76 77 78 51 79 52 80 END SUBROUTINE geo2atm -
LMDZ6/branches/Ocean_skin/libf/phylmd/grid_noro_m.F90
r2665 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE grid_noro_m 2 5 ! … … 334 337 imar=assert_eq(SIZE(x),SIZE(zphi,1),SIZE(mask,1),TRIM(modname)//" imar")-1 335 338 jmar=assert_eq(SIZE(y),SIZE(zphi,2),SIZE(mask,2),TRIM(modname)//" jmar") 336 ! IF(imar/=iim) CALL abort_gcm(TRIM(modname),'imar/=iim' ,1)337 ! IF(jmar/=jjm+1) CALL abort_gcm(TRIM(modname),'jmar/=jjm+1',1)338 339 iext=imdp/10 339 340 xpi = ACOS(-1.) -
LMDZ6/branches/Ocean_skin/libf/phylmd/ini_undefSTD.F90
r2346 r3605 55 55 56 56 IF (n==1 .AND. itap-itapm1==1 .OR. n>1 .AND. mod(itap,nint( & 57 freq_outnmc(n)/ dtime))==1) THEN57 freq_outnmc(n)/phys_tstep))==1) THEN 58 58 ! print*,'ini_undefSTD n itap',n,itap 59 59 DO k = 1, nlevstd -
LMDZ6/branches/Ocean_skin/libf/phylmd/inifis_mod.F90
r2311 r3605 6 6 SUBROUTINE inifis(punjours, prad, pg, pr, pcpp) 7 7 ! Initialize some physical constants and settings 8 USE print_control_mod, ONLY: init_print_control, lunout 8 USE init_print_control_mod, ONLY : init_print_control 9 USE print_control_mod, ONLY: lunout 9 10 IMPLICIT NONE 10 11 -
LMDZ6/branches/Ocean_skin/libf/phylmd/iophy.F90
r3266 r3605 18 18 #ifdef CPP_XIOS 19 19 INTERFACE histwrite_phy 20 !#ifdef CPP_XIOSnew21 20 MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios,histwrite0d_xios 22 !#else23 ! MODULE PROCEDURE histwrite2d_phy,histwrite3d_phy,histwrite2d_phy_old,histwrite3d_phy_old,histwrite2d_xios,histwrite3d_xios24 !#endif25 26 21 END INTERFACE 27 22 #else … … 52 47 mpi_size, mpi_rank, klon_mpi, & 53 48 is_sequential, is_south_pole_dyn 54 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo55 49 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid_type, unstructured 50 USE print_control_mod, ONLY: prt_level,lunout 56 51 #ifdef CPP_IOIPSL 57 52 USE ioipsl, ONLY: flio_dom_set 58 53 #endif 59 54 #ifdef CPP_XIOS 60 USE wxios, ONLY: wxios_domain_param55 use wxios, ONLY: wxios_domain_param, wxios_domain_param_unstructured, wxios_context_init 61 56 #endif 62 57 IMPLICIT NONE … … 77 72 INTEGER :: data_ibegin, data_iend 78 73 79 CALL gather(rlat,rlat_glo) 80 CALL bcast(rlat_glo) 81 CALL gather(rlon,rlon_glo) 82 CALL bcast(rlon_glo) 74 #ifdef CPP_XIOS 75 CALL wxios_context_init 76 #endif 77 78 79 IF (grid_type==unstructured) THEN 80 81 #ifdef CPP_XIOS 82 CALL wxios_domain_param_unstructured("dom_glo") 83 #endif 84 85 ELSE 86 87 CALL gather(rlat,rlat_glo) 88 CALL bcast(rlat_glo) 89 CALL gather(rlon,rlon_glo) 90 CALL bcast(rlon_glo) 83 91 84 92 !$OMP MASTER … … 133 141 #endif 134 142 #ifdef CPP_XIOS 135 ! Set values for the mask: 136 IF (mpi_rank == 0) THEN 137 data_ibegin = 0 138 ELSE 139 data_ibegin = ii_begin - 1 140 ENDIF 141 142 IF (mpi_rank == mpi_size-1) THEN 143 data_iend = nbp_lon 144 ELSE 145 data_iend = ii_end + 1 146 ENDIF 147 148 IF (prt_level>=10) THEN 149 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end 150 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat 151 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend 152 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend 153 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole=",is_south_pole_dyn 154 ENDIF 155 156 ! Initialize the XIOS domain coreesponding to this process: 157 CALL wxios_domain_param("dom_glo", is_sequential, nbp_lon, jj_nb, nbp_lon, nbp_lat, & 158 1, nbp_lon, ii_begin, ii_end, jj_begin, jj_end, & 159 klon_mpi+2*(nbp_lon-1), data_ibegin, data_iend, & 160 io_lat, io_lon,is_south_pole_dyn,mpi_rank) 143 ! Set values for the mask: 144 IF (mpi_rank == 0) THEN 145 data_ibegin = 0 146 ELSE 147 data_ibegin = ii_begin - 1 148 END IF 149 150 IF (mpi_rank == mpi_size-1) THEN 151 data_iend = nbp_lon 152 ELSE 153 data_iend = ii_end + 1 154 END IF 155 156 IF (prt_level>=10) THEN 157 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," iibegin=",ii_begin , " ii_end=",ii_end," jjbegin=",jj_begin," jj_nb=",jj_nb," jj_end=",jj_end 158 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," nbp_lon=",nbp_lon," nbp_lat=",nbp_lat 159 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend 160 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," data_ibegin=",data_ibegin," data_iend=",data_iend 161 write(lunout,*) "init_iophy_new: mpirank=",mpi_rank," is_south_pole_dyn=",is_south_pole_dyn 162 ENDIF 163 164 ! Initialize the XIOS domain coreesponding to this process: 161 165 #endif 162 166 !$OMP END MASTER 167 168 #ifdef CPP_XIOS 169 CALL wxios_domain_param("dom_glo") 170 #endif 171 172 ENDIF 163 173 164 174 END SUBROUTINE init_iophy_new … … 291 301 is_sequential, klon_mpi_begin, klon_mpi_end, & 292 302 mpi_rank 293 USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat 303 USE mod_grid_phy_lmdz, ONLY: klon_glo, nbp_lon, nbp_lat, grid1dTo2d_glo 294 304 USE ioipsl, ONLY: histbeg 295 305 … … 366 376 ENDDO 367 377 368 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon_glo,zx_lon)378 CALL grid1dTo2d_glo(rlon_glo,zx_lon) 369 379 IF ((nbp_lon*nbp_lat).GT.1) THEN 370 380 DO i = 1, nbp_lon … … 373 383 ENDDO 374 384 ENDIF 375 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat_glo,zx_lat)385 CALL grid1dTo2d_glo(rlat_glo,zx_lat) 376 386 377 387 DO i=1,pim … … 963 973 nid_files, swaerofree_diag, swaero_diag, dryaod_diag, ok_4xCO2atm 964 974 USE print_control_mod, ONLY: prt_level,lunout 965 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 975 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat 966 976 #ifdef CPP_XIOS 967 977 USE xios, ONLY: xios_send_field 968 978 #endif 979 USE print_control_mod, ONLY: lunout, prt_level 969 980 970 981 IMPLICIT NONE … … 1007 1018 IF (.not. ok_all_xml) THEN 1008 1019 IF (prt_level >= 10) THEN 1009 WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", trim(var%name) 1020 write(lunout,*)"histwrite2d_phy: .not.vars_defined ; time to define ", & 1021 trim(var%name) 1010 1022 ENDIF 1011 1023 DO iff=iff_beg, iff_end … … 1025 1037 1026 1038 !Et sinon on.... écrit 1027 IF (SIZE(field)/=klon .AND. SIZE(field)/=klev ) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1)1039 IF (SIZE(field)/=klon .AND. SIZE(field)/=klev .AND. SIZE(field)/=klev+1) CALL abort_physic('iophy::histwrite2d_phy','Field first DIMENSION not equal to klon/klev',1) 1028 1040 IF (prt_level >= 10) THEn 1029 1041 WRITE (lunout,*)"histwrite2d_phy: .not.vars_defined ; time to gather and write ", trim(var%name) … … 1037 1049 ENDIF 1038 1050 !$OMP MASTER 1039 CALL grid1Dto2D_mpi(buffer_omp,Field2d)1051 IF (grid_type==regular_lonlat) CALL grid1Dto2D_mpi(buffer_omp,Field2d) 1040 1052 1041 1053 ! La boucle sur les fichiers: … … 1047 1059 write(lunout,*)'Dans iophy histwrite2D,var%name ', trim(var%name) 1048 1060 ENDIF 1049 IF (SIZE(field) == klon) then 1061 1062 IF (grid_type==regular_lonlat) THEN 1063 IF (SIZE(field) == klon) then 1050 1064 CALL xios_send_field(var%name, Field2d) 1051 ELSE 1052 CALL xios_send_field(var%name, field) 1053 ENDIF 1065 ELSE 1066 CALL xios_send_field(var%name, field) 1067 ENDIF 1068 ELSE IF (grid_type==unstructured) THEN 1069 IF (SIZE(field) == klon) then 1070 CALL xios_send_field(var%name, buffer_omp) 1071 ELSE 1072 CALL xios_send_field(var%name, field) 1073 ENDIF 1074 1075 ENDIF 1054 1076 IF (prt_level >= 10) THEN 1055 WRITE (lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ', trim(var%name) 1077 write(lunout,*)'Dans iophy histwrite2D,var%name apres xios_send ',& 1078 trim(var%name) 1056 1079 ENDIF 1057 1080 #else … … 1065 1088 IF (firstx) THEN 1066 1089 IF (prt_level >= 10) THEN 1067 WRITE (lunout,*)'Dans iophy histwrite2D,iff,var%name ', iff,trim(var%name) 1068 WRITE (lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field" 1090 write(lunout,*)'Dans iophy histwrite2D,iff,var%name ',& 1091 iff,trim(var%name) 1092 write(lunout,*)"histwrite2d_phy:.NOT.clef_stations(iff)and iff==iff_beg, call xios_send_field" 1069 1093 ENDIF 1070 IF (SIZE(field) == klon) then 1071 CALL xios_send_field(var%name, Field2d) 1072 ELSE 1073 CALL xios_send_field(var%name, field) 1094 IF (grid_type==regular_lonlat) THEN 1095 IF (SIZE(field) == klon) then 1096 CALL xios_send_field(var%name, Field2d) 1097 ELSE 1098 CALL xios_send_field(var%name, field) 1099 ENDIF 1100 ELSE IF (grid_type==unstructured) THEN 1101 IF (SIZE(field) == klon) then 1102 CALL xios_send_field(var%name, buffer_omp) 1103 ELSE 1104 CALL xios_send_field(var%name, field) 1105 ENDIF 1074 1106 ENDIF 1107 1075 1108 firstx=.false. 1076 1109 ENDIF … … 1085 1118 !#ifdef CPP_XIOS 1086 1119 ! IF (iff == iff_beg) THEN 1087 ! if (prt_level >= 10) then1120 ! IF (prt_level >= 10) THEN 1088 1121 ! write(lunout,*)"histwrite2d_phy: .NOT.clef_stations(iff) and iff==iff_beg, call xios_send_field" 1089 ! endif1122 ! ENDIF 1090 1123 ! CALL xios_send_field(var%name, Field2d) 1091 1124 ! ENDIF … … 1109 1142 ENDIF ! of IF (is_sequential) 1110 1143 #ifndef CPP_IOIPSL_NO_OUTPUT 1111 IF (prt_level >= 10) THE n1144 IF (prt_level >= 10) THEN 1112 1145 write(lunout,*)"histwrite2d_phy: clef_stations(iff) and iff==iff_beg, call wxios_write_2D" 1113 1146 ENDIF … … 1141 1174 nfiles, vars_defined, clef_stations, & 1142 1175 nid_files, swaerofree_diag 1143 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 1176 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, regular_lonlat, unstructured 1144 1177 #ifdef CPP_XIOS 1145 1178 USE xios, ONLY: xios_send_field … … 1191 1224 !Et sinon on.... écrit 1192 1225 1193 IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev ) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1)1226 IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev .AND. SIZE(field,1)/=klev+1) CALL abort_physic('iophy::histwrite3d_phy','Field first DIMENSION not equal to klon/klev',1) 1194 1227 1195 1228 nlev=SIZE(field,2) … … 1206 1239 ENDIF 1207 1240 !$OMP MASTER 1208 CALL grid1Dto2D_mpi(buffer_omp,field3d)1241 IF (grid_type==regular_lonlat) CALL grid1Dto2D_mpi(buffer_omp,field3d) 1209 1242 1210 1243 ! BOUCLE SUR LES FICHIERS … … 1213 1246 IF (ok_all_xml) THEN 1214 1247 #ifdef CPP_XIOS 1215 IF (prt_level >= 10) THEN 1216 write(lunout,*)'Dans iophy histwrite3D,var%name ',trim(var%name) 1248 IF (prt_level >= 10) THEN 1249 write(lunout,*)'Dans iophy histwrite3D,var%name ',& 1250 trim(var%name) 1251 ENDIF 1252 IF (grid_type==regular_lonlat) THEN 1253 IF (SIZE(field,1) == klon) then 1254 CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) 1255 ELSE 1256 CALL xios_send_field(var%name, field) 1257 ENDIF 1258 ELSE IF (grid_type==unstructured) THEN 1259 IF (SIZE(field,1) == klon) then 1260 CALL xios_send_field(var%name, buffer_omp(:,1:nlevx)) 1261 ELSE 1262 CALL xios_send_field(var%name, field) 1263 ENDIF 1217 1264 ENDIF 1218 IF (SIZE(field,1) == klon) then 1219 CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) 1220 ELSE 1221 CALL xios_send_field(var%name, field) 1222 ENDIF 1265 1223 1266 #else 1224 1267 CALL abort_physic ('iophy','cannot have ok_all_xml = .T. without CPP_XIOS defined' ,1) … … 1230 1273 #ifdef CPP_XIOS 1231 1274 IF (firstx) THEN 1232 IF (prt_level >= 10) THE n1233 WRITE(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', &1275 IF (prt_level >= 10) THEN 1276 write(lunout,*)'Dans iophy, histwrite3D iff nlev klev firstx', & 1234 1277 iff,nlev,klev, firstx 1235 WRITE(lunout,*)'histwrite3d_phy: call xios_send_field for ', &1278 write(lunout,*)'histwrite3d_phy: call xios_send_field for ', & 1236 1279 trim(var%name), ' with iim jjm nlevx = ', & 1237 1280 nbp_lon,jj_nb,nlevx 1238 1281 ENDIF 1239 IF (SIZE(field,1) == klon) then 1240 CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) 1241 ELSE 1282 IF (grid_type==regular_lonlat) THEN 1283 IF (SIZE(field,1) == klon) then 1284 CALL xios_send_field(var%name, Field3d(:,:,1:nlevx)) 1285 ELSE 1286 CALL xios_send_field(var%name, field) 1287 ENDIF 1288 ELSE IF (grid_type==unstructured) THEN 1289 IF (SIZE(field,1) == klon) then 1290 CALL xios_send_field(var%name, buffer_omp(:,1:nlevx)) 1291 ELSE 1242 1292 CALL xios_send_field(var%name, field) 1293 ENDIF 1243 1294 ENDIF 1295 1244 1296 firstx=.false. 1245 1297 ENDIF … … 1305 1357 is_sequential, klon_mpi_begin, klon_mpi_end, & 1306 1358 jj_nb, klon_mpi, is_master 1307 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 1359 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured 1308 1360 USE xios, ONLY: xios_send_field 1309 1361 USE print_control_mod, ONLY: prt_level,lunout … … 1325 1377 IF (prt_level >= 10) WRITE(lunout,*)'Begin histrwrite2d_xios ',field_name 1326 1378 1327 !Et sinon on.... écrit 1328 IF (SIZE(field)/=klon .AND. SIZE(field)/=klev) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1) 1329 1330 IF (SIZE(field) == klev) then 1379 !Et sinon on.... écrit 1380 IF (SIZE(field)/=klon .AND. SIZE(field)/=klev .AND. SIZE(field)/=klev+1) CALL abort_physic('iophy::histwrite2d_xios','Field first DIMENSION not equal to klon/klev',1) 1381 IF (SIZE(field) == klev .OR. SIZE(field) == klev+1) then 1331 1382 !$OMP MASTER 1383 1332 1384 CALL xios_send_field(field_name,field) 1333 1385 !$OMP END MASTER … … 1335 1387 CALL Gather_omp(field,buffer_omp) 1336 1388 !$OMP MASTER 1389 1390 IF (grid_type==unstructured) THEN 1391 1392 CALL xios_send_field(field_name, buffer_omp) 1393 1394 ELSE 1395 1337 1396 CALL grid1Dto2D_mpi(buffer_omp,Field2d) 1338 1397 … … 1342 1401 !IF(.NOT.clef_stations(iff)) THEN 1343 1402 IF (.TRUE.) THEN 1344 ALLOCATE(index2d(nbp_lon*jj_nb))1345 ALLOCATE(fieldok(nbp_lon*jj_nb))1346 1347 1403 1348 1404 CALL xios_send_field(field_name, Field2d) … … 1365 1421 ENDDO 1366 1422 ENDIF 1367 1368 ENDIF1369 1370 DEALLOCATE(index2d)1371 DEALLOCATE(fieldok)1423 DEALLOCATE(index2d) 1424 DEALLOCATE(fieldok) 1425 1426 ENDIF 1427 ENDIF 1372 1428 !$OMP END MASTER 1373 1429 ENDIF … … 1385 1441 jj_nb, klon_mpi, is_master 1386 1442 USE xios, ONLY: xios_send_field 1387 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 1443 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid_type, unstructured 1388 1444 USE print_control_mod, ONLY: prt_level,lunout 1389 1445 … … 1403 1459 IF (prt_level >= 10) write(lunout,*)'Begin histrwrite3d_xios ',field_name 1404 1460 1405 !Et on.... écrit 1406 IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev) CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1) 1407 1408 IF (SIZE(field,1) == klev) then 1461 !Et on.... écrit 1462 IF (SIZE(field,1)/=klon .AND. SIZE(field,1)/=klev .AND. SIZE(field,1)/=klev+1) then 1463 write(lunout,*)' histrwrite3d_xios ', field_name, SIZE(field) 1464 CALL abort_physic('iophy::histwrite3d_xios','Field first DIMENSION not equal to klon/klev',1) 1465 ENDIF 1466 1467 IF (SIZE(field,1) == klev .OR. SIZE(field,1) == klev+1) then 1409 1468 !$OMP MASTER 1410 1469 CALL xios_send_field(field_name,field) … … 1416 1475 CALL Gather_omp(field,buffer_omp) 1417 1476 !$OMP MASTER 1477 1478 IF (grid_type==unstructured) THEN 1479 1480 CALL xios_send_field(field_name, buffer_omp(:,1:nlev)) 1481 1482 ELSE 1418 1483 CALL grid1Dto2D_mpi(buffer_omp,field3d) 1419 1484 … … 1423 1488 !IF (.NOT.clef_stations(iff)) THEN 1424 1489 IF(.TRUE.)THEN 1425 ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) 1426 ALLOCATE(fieldok(nbp_lon*jj_nb,nlev)) 1427 CALL xios_send_field(field_name, Field3d(:,:,1:nlev)) 1490 1491 CALL xios_send_field(field_name, Field3d(:,:,1:nlev)) 1428 1492 1429 1493 ELSE … … 1448 1512 ENDDO 1449 1513 ENDIF 1514 DEALLOCATE(index3d) 1515 DEALLOCATE(fieldok) 1450 1516 ENDIF 1451 DEALLOCATE(index3d) 1452 DEALLOCATE(fieldok) 1517 ENDIF 1453 1518 !$OMP END MASTER 1454 1519 ENDIF -
LMDZ6/branches/Ocean_skin/libf/phylmd/iostart.F90
r3401 r3605 25 25 26 26 PUBLIC get_field,get_var,put_field,put_var 27 PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy 27 PUBLIC Open_startphy,close_startphy,open_restartphy,close_restartphy, enddef_restartphy 28 28 29 29 CONTAINS … … 117 117 USE netcdf 118 118 USE dimphy 119 USE geometry_mod 119 120 USE mod_grid_phy_lmdz 120 121 USE mod_phys_lmdz_para … … 125 126 LOGICAL,OPTIONAL :: found 126 127 127 REAL :: field_glo(klon_glo,field_size) 128 REAL,ALLOCATABLE :: field_glo(:,:) 129 REAL,ALLOCATABLE :: field_glo_tmp(:,:) 130 INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:) 128 131 LOGICAL :: tmp_found 129 132 INTEGER :: varid 130 INTEGER :: ierr 131 132 IF (is_mpi_root .AND. is_omp_root) THEN 133 INTEGER :: ierr,i 134 135 IF (is_master) THEN 136 ALLOCATE(ind_cell_glo_glo(klon_glo)) 137 ALLOCATE(field_glo(klon_glo,field_size)) 138 ALLOCATE(field_glo_tmp(klon_glo,field_size)) 139 ELSE 140 ALLOCATE(ind_cell_glo_glo(0)) 141 ALLOCATE(field_glo(0,0)) 142 ENDIF 143 144 CALL gather(ind_cell_glo,ind_cell_glo_glo) 145 146 IF (is_master) THEN 133 147 134 148 ierr=NF90_INQ_VARID(nid_start,Field_name,varid) 135 149 136 150 IF (ierr==NF90_NOERR) THEN 137 CALL body(field_glo )151 CALL body(field_glo_tmp) 138 152 tmp_found=.TRUE. 139 153 ELSE … … 146 160 147 161 IF (tmp_found) THEN 162 IF (is_master) THEN 163 DO i=1,klon_glo 164 field_glo(i,:)=field_glo_tmp(ind_cell_glo_glo(i),:) 165 ENDDO 166 ENDIF 148 167 CALL scatter(field_glo,field) 149 168 ENDIF … … 307 326 ierr = NF90_DEF_DIM (nid_restart, "horizon_klevp1", klon_glo*klevp1, idim4) 308 327 309 ierr = NF90_ENDDEF(nid_restart)328 ! ierr = NF90_ENDDEF(nid_restart) 310 329 ENDIF 311 330 312 331 END SUBROUTINE open_restartphy 313 332 333 SUBROUTINE enddef_restartphy 334 USE netcdf 335 USE mod_phys_lmdz_para 336 IMPLICIT NONE 337 INTEGER :: ierr 338 339 IF (is_master) ierr = NF90_ENDDEF(nid_restart) 340 341 END SUBROUTINE enddef_restartphy 342 314 343 SUBROUTINE close_restartphy 315 344 USE netcdf … … 318 347 INTEGER :: ierr 319 348 320 IF (is_mpi_root .AND. is_omp_root) THEN 321 ierr = NF90_CLOSE (nid_restart) 322 ENDIF 349 IF (is_master) ierr = NF90_CLOSE (nid_restart) 323 350 324 351 END SUBROUTINE close_restartphy 325 352 326 353 327 SUBROUTINE put_field_r1(field_name,title,field) 328 IMPLICIT NONE 354 SUBROUTINE put_field_r1(pass, field_name,title,field) 355 IMPLICIT NONE 356 INTEGER, INTENT(IN) :: pass 329 357 CHARACTER(LEN=*),INTENT(IN) :: field_name 330 358 CHARACTER(LEN=*),INTENT(IN) :: title 331 359 REAL,INTENT(IN) :: field(:) 332 333 CALL put_field_rgen(field_name,title,field,1) 360 CALL put_field_rgen(pass, field_name,title,field,1) 334 361 335 362 END SUBROUTINE put_field_r1 336 363 337 SUBROUTINE put_field_r2(field_name,title,field) 338 IMPLICIT NONE 364 SUBROUTINE put_field_r2(pass, field_name,title,field) 365 IMPLICIT NONE 366 INTEGER, INTENT(IN) :: pass 339 367 CHARACTER(LEN=*),INTENT(IN) :: field_name 340 368 CHARACTER(LEN=*),INTENT(IN) :: title 341 369 REAL,INTENT(IN) :: field(:,:) 342 370 343 CALL put_field_rgen( field_name,title,field,size(field,2))371 CALL put_field_rgen(pass, field_name,title,field,size(field,2)) 344 372 345 373 END SUBROUTINE put_field_r2 346 374 347 SUBROUTINE put_field_r3(field_name,title,field) 348 IMPLICIT NONE 375 SUBROUTINE put_field_r3(pass, field_name,title,field) 376 IMPLICIT NONE 377 INTEGER, INTENT(IN) :: pass 349 378 CHARACTER(LEN=*),INTENT(IN) :: field_name 350 379 CHARACTER(LEN=*),INTENT(IN) :: title 351 380 REAL,INTENT(IN) :: field(:,:,:) 352 381 353 CALL put_field_rgen( field_name,title,field,size(field,2)*size(field,3))382 CALL put_field_rgen(pass, field_name,title,field,size(field,2)*size(field,3)) 354 383 355 384 END SUBROUTINE put_field_r3 356 385 357 SUBROUTINE put_field_rgen( field_name,title,field,field_size)386 SUBROUTINE put_field_rgen(pass, field_name,title,field,field_size) 358 387 USE netcdf 359 388 USE dimphy 389 USE geometry_mod 360 390 USE mod_grid_phy_lmdz 361 391 USE mod_phys_lmdz_para 362 392 IMPLICIT NONE 393 INTEGER, INTENT(IN) :: pass 363 394 CHARACTER(LEN=*),INTENT(IN) :: field_name 364 395 CHARACTER(LEN=*),INTENT(IN) :: title … … 366 397 REAL,INTENT(IN) :: field(klon,field_size) 367 398 368 REAL :: field_glo(klon_glo,field_size) 369 INTEGER :: ierr 399 ! REAL :: field_glo(klon_glo,field_size) 400 ! REAL :: field_glo_tmp(klon_glo,field_size) 401 REAL ,ALLOCATABLE :: field_glo(:,:) 402 REAL ,ALLOCATABLE :: field_glo_tmp(:,:) 403 INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:) 404 ! INTEGER :: ind_cell_glo_glo(klon_glo) 405 INTEGER :: ierr,i 370 406 INTEGER :: nvarid 371 407 INTEGER :: idim 372 408 373 374 CALL gather(field,field_glo)375 376 IF (is_m pi_root .AND. is_omp_root) THEN409 ! first pass : definition 410 IF (pass==1) THEN 411 412 IF (is_master) THEN 377 413 378 414 IF (field_size==1) THEN … … 387 423 ENDIF 388 424 389 ierr = NF90_REDEF (nid_restart)425 ! ierr = NF90_REDEF (nid_restart) 390 426 #ifdef NC_DOUBLE 391 427 ierr = NF90_DEF_VAR (nid_restart, field_name, NF90_DOUBLE,(/ idim /),nvarid) … … 394 430 #endif 395 431 IF (LEN_TRIM(title) > 0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) 396 ierr = NF90_ENDDEF(nid_restart) 397 ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/))) 398 ENDIF 399 400 END SUBROUTINE put_field_rgen 401 402 SUBROUTINE put_var_r0(var_name,title,var) 432 ! ierr = NF90_ENDDEF(nid_restart) 433 ENDIF 434 435 ! second pass : write 436 ELSE IF (pass==2) THEN 437 438 IF (is_master) THEN 439 ALLOCATE(ind_cell_glo_glo(klon_glo)) 440 ALLOCATE(field_glo(klon_glo,field_size)) 441 ALLOCATE(field_glo_tmp(klon_glo,field_size)) 442 ELSE 443 ALLOCATE(ind_cell_glo_glo(0)) 444 ALLOCATE(field_glo_tmp(0,0)) 445 ENDIF 446 447 CALL gather(ind_cell_glo,ind_cell_glo_glo) 448 449 CALL gather(field,field_glo_tmp) 450 451 IF (is_master) THEN 452 453 DO i=1,klon_glo 454 field_glo(ind_cell_glo_glo(i),:)=field_glo_tmp(i,:) 455 ENDDO 456 457 ierr = NF90_INQ_VARID(nid_restart, field_name, nvarid) 458 ierr = NF90_PUT_VAR(nid_restart,nvarid,RESHAPE(field_glo,(/klon_glo*field_size/))) 459 ENDIF 460 ENDIF 461 462 END SUBROUTINE put_field_rgen 463 464 465 SUBROUTINE put_var_r0(pass, var_name,title,var) 403 466 IMPLICIT NONE 467 INTEGER, INTENT(IN) :: pass 404 468 CHARACTER(LEN=*),INTENT(IN) :: var_name 405 469 CHARACTER(LEN=*),INTENT(IN) :: title … … 409 473 varin(1)=var 410 474 411 CALL put_var_rgen( var_name,title,varin,size(varin))475 CALL put_var_rgen(pass, var_name,title,varin,size(varin)) 412 476 413 477 END SUBROUTINE put_var_r0 414 478 415 479 416 SUBROUTINE put_var_r1( var_name,title,var)480 SUBROUTINE put_var_r1(pass, var_name,title,var) 417 481 IMPLICIT NONE 482 INTEGER, INTENT(IN) :: pass 418 483 CHARACTER(LEN=*),INTENT(IN) :: var_name 419 484 CHARACTER(LEN=*),INTENT(IN) :: title 420 485 REAL,INTENT(IN) :: var(:) 421 486 422 CALL put_var_rgen( var_name,title,var,size(var))487 CALL put_var_rgen(pass, var_name,title,var,size(var)) 423 488 424 489 END SUBROUTINE put_var_r1 425 490 426 SUBROUTINE put_var_r2( var_name,title,var)491 SUBROUTINE put_var_r2(pass, var_name,title,var) 427 492 IMPLICIT NONE 493 INTEGER, INTENT(IN) :: pass 428 494 CHARACTER(LEN=*),INTENT(IN) :: var_name 429 495 CHARACTER(LEN=*),INTENT(IN) :: title 430 496 REAL,INTENT(IN) :: var(:,:) 431 497 432 CALL put_var_rgen( var_name,title,var,size(var))498 CALL put_var_rgen(pass, var_name,title,var,size(var)) 433 499 434 500 END SUBROUTINE put_var_r2 435 501 436 SUBROUTINE put_var_r3( var_name,title,var)502 SUBROUTINE put_var_r3(pass, var_name,title,var) 437 503 IMPLICIT NONE 504 INTEGER, INTENT(IN) :: pass 438 505 CHARACTER(LEN=*),INTENT(IN) :: var_name 439 506 CHARACTER(LEN=*),INTENT(IN) :: title 440 507 REAL,INTENT(IN) :: var(:,:,:) 441 508 442 CALL put_var_rgen( var_name,title,var,size(var))509 CALL put_var_rgen(pass, var_name,title,var,size(var)) 443 510 444 511 END SUBROUTINE put_var_r3 445 512 446 SUBROUTINE put_var_rgen( var_name,title,var,var_size)513 SUBROUTINE put_var_rgen(pass, var_name,title,var,var_size) 447 514 USE netcdf 448 515 USE dimphy 449 516 USE mod_phys_lmdz_para 450 517 IMPLICIT NONE 451 CHARACTER(LEN=*),INTENT(IN) :: var_name 452 CHARACTER(LEN=*),INTENT(IN) :: title 453 INTEGER,INTENT(IN) :: var_size 454 REAL,INTENT(IN) :: var(var_size) 455 456 INTEGER :: ierr 457 INTEGER :: nvarid 518 INTEGER, INTENT(IN) :: pass 519 CHARACTER(LEN=*),INTENT(IN) :: var_name 520 CHARACTER(LEN=*),INTENT(IN) :: title 521 INTEGER,INTENT(IN) :: var_size 522 REAL,INTENT(IN) :: var(var_size) 523 524 INTEGER :: ierr 525 INTEGER :: nvarid 458 526 459 IF (is_m pi_root .AND. is_omp_root) THEN527 IF (is_master) THEN 460 528 461 529 IF (var_size/=length) THEN … … 463 531 call abort_physic("", "", 1) 464 532 ENDIF 465 466 ierr = NF90_REDEF (nid_restart) 533 534 ! first pass : definition 535 IF (pass==1) THEN 536 537 ! ierr = NF90_REDEF (nid_restart) 467 538 468 539 #ifdef NC_DOUBLE 469 ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid)540 ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_DOUBLE,(/ idim1 /),nvarid) 470 541 #else 471 ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid)542 ierr = NF90_DEF_VAR (nid_restart, var_name, NF90_FLOAT,(/ idim1 /),nvarid) 472 543 #endif 473 IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) 474 ierr = NF90_ENDDEF(nid_restart) 475 476 ierr = NF90_PUT_VAR(nid_restart,nvarid,var) 477 544 IF (LEN_TRIM(title)>0) ierr = NF90_PUT_ATT (nid_restart,nvarid,"title", title) 545 ! ierr = NF90_ENDDEF(nid_restart) 546 547 ! second pass : write 548 ELSE IF (pass==2) THEN 549 ierr = NF90_INQ_VARID(nid_restart, var_name, nvarid) 550 ierr = NF90_PUT_VAR(nid_restart,nvarid,var) 551 ENDIF 478 552 ENDIF 479 553 -
LMDZ6/branches/Ocean_skin/libf/phylmd/limit_read_mod.F90
r2788 r3605 1 1 ! 2 ! $ Header$2 ! $Id$ 3 3 ! 4 4 MODULE limit_read_mod … … 31 31 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 32 32 33 34 SUBROUTINE init_limit_read(first_day) 35 USE mod_grid_phy_lmdz 36 USE surface_data 37 USE mod_phys_lmdz_para 38 #ifdef CPP_XIOS 39 USE XIOS 40 #endif 41 IMPLICIT NONE 42 INTEGER, INTENT(IN) :: first_day 43 44 45 IF ( type_ocean /= 'couple') THEN 46 IF (grid_type==unstructured) THEN 47 #ifdef CPP_XIOS 48 IF (is_omp_master) CALL xios_set_file_attr("limit_read",enabled=.TRUE.,record_offset=first_day) 49 #endif 50 ENDIF 51 ENDIF 52 53 END SUBROUTINE init_limit_read 54 33 55 SUBROUTINE limit_read_frac(itime, dtime, jour, pctsrf_new, is_modified) 34 56 ! … … 150 172 USE phys_cal_mod, ONLY : calend, year_len 151 173 USE print_control_mod, ONLY: lunout, prt_level 152 174 #ifdef CPP_XIOS 175 USE XIOS, ONLY: xios_recv_field 176 #endif 177 153 178 IMPLICIT NONE 154 179 … … 179 204 REAL, DIMENSION(klon_glo) :: rug_glo ! rugosity at global grid 180 205 REAL, DIMENSION(klon_glo) :: alb_glo ! albedo at global grid 206 207 REAL, DIMENSION(klon_mpi,nbsrf) :: pct_mpi ! fraction at global grid 208 REAL, DIMENSION(klon_mpi) :: sst_mpi ! sea-surface temperature at global grid 209 REAL, DIMENSION(klon_mpi) :: rug_mpi ! rugosity at global grid 210 REAL, DIMENSION(klon_mpi) :: alb_mpi ! albedo at global grid 211 181 212 CHARACTER(len=20) :: modname='limit_read_mod' 182 213 CHARACTER(LEN=99) :: abort_message, calendar, str … … 220 251 END IF 221 252 222 !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS 223 ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid) 253 !--- ERROR IF FILE RECORDS NUMBER IS NOT EQUAL TO EXPECTED NUMBER OF DAYS 254 IF (grid_type==unstructured) THEN 255 ierr=NF90_INQ_DIMID(nid,"time_year",ndimid) 256 ELSE 257 ierr=NF90_INQUIRE(nid, UnlimitedDimID=ndimid) 258 ENDIF 224 259 ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn) 225 WRITE(abort_message,'(a,2(i 3,a))')'limit.nc records number (',nn,') does no'//&260 WRITE(abort_message,'(a,2(i0,a))')'limit.nc records number (',nn,') does no'//& 226 261 't match year length (',year_len,')' 227 262 IF(nn/=year_len) CALL abort_physic(modname,abort_message,1) 228 263 229 264 !--- ERROR IF FILES AND LMDZ HORIZONTAL RESOLUTIONS DO NOT MATCH 230 ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid) 265 IF (grid_type==unstructured) THEN 266 ierr=NF90_INQ_DIMID(nid, 'cell', ndimid) 267 ELSE 268 ierr=NF90_INQ_DIMID(nid, 'points_physiques', ndimid) 269 ENDIF 231 270 ierr=NF90_INQUIRE_DIMENSION(nid, ndimid, len=nn) 232 271 WRITE(abort_message,'(a,2(i0,a))')'limit.nc horizontal number of cells (',nn, & … … 249 288 250 289 is_modified = .FALSE. 251 IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN ! time to read 290 !ym IF (MOD(itime-1, lmt_pas) == 0 .OR. jour_lu /= jour ) THEN ! time to read 291 ! not REALLY PERIODIC 292 IF (MOD(itime-1, lmt_pas) == 0 .OR. (jour_lu /= jour .AND. grid_type /= unstructured)) THEN ! time to read 293 ! IF (MOD(itime-1, lmt_pas) == 0) THEN ! time to read 252 294 jour_lu = jour 253 295 is_modified = .TRUE. 296 297 IF (grid_type==unstructured) THEN 298 299 #ifdef CPP_XIOS 300 IF ( type_ocean /= 'couple') THEN 301 302 IF (is_omp_master) CALL xios_recv_field("foce_limin",pct_mpi(:,is_oce)) 303 IF (is_omp_master) CALL xios_recv_field("fsic_limin",pct_mpi(:,is_sic)) 304 ! IF (read_continents .OR. itime == 1) THEN 305 IF (is_omp_master) CALL xios_recv_field("fter_limin",pct_mpi(:,is_ter)) 306 IF (is_omp_master) CALL xios_recv_field("flic_limin",pct_mpi(:,is_lic)) 307 ! ENDIF 308 ENDIF! type_ocean /= couple 309 310 IF ( type_ocean /= 'couple') THEN 311 IF (is_omp_master) CALL xios_recv_field("sst_limin",sst_mpi) 312 ENDIF 313 314 IF (.NOT. ok_veget) THEN 315 IF (is_omp_master) CALL xios_recv_field("alb_limin",alb_mpi) 316 IF (is_omp_master) CALL xios_recv_field("rug_limin",rug_mpi) 317 ENDIF 318 319 IF ( type_ocean /= 'couple') THEN 320 CALL Scatter_omp(sst_mpi,sst) 321 CALL Scatter_omp(pct_mpi(:,is_oce),pctsrf(:,is_oce)) 322 CALL Scatter_omp(pct_mpi(:,is_sic),pctsrf(:,is_sic)) 323 ! IF (read_continents .OR. itime == 1) THEN 324 CALL Scatter_omp(pct_mpi(:,is_ter),pctsrf(:,is_ter)) 325 CALL Scatter_omp(pct_mpi(:,is_lic),pctsrf(:,is_lic)) 326 ! END IF 327 END IF 328 329 IF (.NOT. ok_veget) THEN 330 CALL Scatter_omp(alb_mpi, albedo) 331 CALL Scatter_omp(rug_mpi, rugos) 332 END IF 333 #endif 334 335 336 ELSE ! grid_type==regular 337 254 338 !$OMP MASTER ! Only master thread 255 IF (is_mpi_root) THEN ! Only master processus 339 IF (is_mpi_root) THEN ! Only master processus! 256 340 257 341 ierr = NF90_OPEN ('limit.nc', NF90_NOWRITE, nid) … … 371 455 END IF 372 456 457 ENDIF ! Grid type 458 373 459 ENDIF ! time to read 374 460 -
LMDZ6/branches/Ocean_skin/libf/phylmd/mo_simple_plumes.F90
r3297 r3605 78 78 ! 79 79 INTEGER :: iret, ncid, DimID, VarID, xdmy 80 CHARACTER (len = 50) :: modname = 'mo_simple_plumes.sp_setup' 81 CHARACTER (len = 80) :: abort_message 82 80 83 ! 81 84 ! ---------- … … 84 87 ! 85 88 iret = nf90_open("MACv2.0-SP_v1.nc", NF90_NOWRITE, ncid) 86 IF (iret /= NF90_NOERR) STOP 'NetCDF File not opened' 89 IF (iret /= NF90_NOERR) THEN 90 abort_message='NetCDF File not opened' 91 CALL abort_physic(modname,abort_message,1) 92 ENDIF 87 93 ! 88 94 ! read dimensions and make sure file conforms to expected size … … 90 96 iret = nf90_inq_dimid(ncid, "plume_number" , DimId) 91 97 iret = nf90_inquire_dimension(ncid, DimId, len = xdmy) 92 IF (xdmy /= nplumes) STOP 'NetCDF improperly dimensioned -- plume_number' 98 IF (xdmy /= nplumes) THEN 99 abort_message='NetCDF improperly dimensioned -- plume_number' 100 CALL abort_physic(modname,abort_message,1) 101 ENDIF 93 102 ! 94 103 iret = nf90_inq_dimid(ncid, "plume_feature", DimId) 95 104 iret = nf90_inquire_dimension(ncid, DimId, len = xdmy) 96 IF (xdmy /= nfeatures) STOP 'NetCDF improperly dimensioned -- plume_feature' 105 IF (xdmy /= nfeatures) THEN 106 abort_message='NetCDF improperly dimensioned -- plume_feature' 107 CALL abort_physic(modname,abort_message,1) 108 ENDIF 97 109 ! 98 110 iret = nf90_inq_dimid(ncid, "year_fr" , DimId) 99 111 iret = nf90_inquire_dimension(ncid, DimID, len = xdmy) 100 IF (xdmy /= ntimes) STOP 'NetCDF improperly dimensioned -- year_fr' 112 IF (xdmy /= ntimes) THEN 113 abort_message='NetCDF improperly dimensioned -- year_fr' 114 CALL abort_physic(modname,abort_message,1) 115 ENDIF 101 116 ! 102 117 iret = nf90_inq_dimid(ncid, "years" , DimId) 103 118 iret = nf90_inquire_dimension(ncid, DimID, len = xdmy) 104 IF (xdmy /= nyears) STOP 'NetCDF improperly dimensioned -- years' 119 IF (xdmy /= nyears) THEN 120 abort_message='NetCDF improperly dimensioned -- years' 121 CALL abort_physic(modname,abort_message,1) 122 ENDIF 105 123 ! 106 124 ! read variables that define the simple plume climatology … … 108 126 iret = nf90_inq_varid(ncid, "plume_lat", VarId) 109 127 iret = nf90_get_var(ncid, VarID, plume_lat(:), start=(/1/),count=(/nplumes/)) 110 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lat' 128 IF (iret /= NF90_NOERR) THEN 129 abort_message='NetCDF Error reading plume_lat' 130 CALL abort_physic(modname,abort_message,1) 131 ENDIF 111 132 iret = nf90_inq_varid(ncid, "plume_lon", VarId) 112 133 iret = nf90_get_var(ncid, VarID, plume_lon(:), start=(/1/),count=(/nplumes/)) 113 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lon' 134 IF (iret /= NF90_NOERR) THEN 135 abort_message='NetCDF Error reading plume_lon' 136 CALL abort_physic(modname,abort_message,1) 137 ENDIF 114 138 iret = nf90_inq_varid(ncid, "beta_a" , VarId) 115 139 iret = nf90_get_var(ncid, VarID, beta_a(:) , start=(/1/),count=(/nplumes/)) 116 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading beta_a' 140 IF (iret /= NF90_NOERR) THEN 141 abort_message='NetCDF Error reading beta_a' 142 CALL abort_physic(modname,abort_message,1) 143 ENDIF 117 144 iret = nf90_inq_varid(ncid, "beta_b" , VarId) 118 145 iret = nf90_get_var(ncid, VarID, beta_b(:) , start=(/1/),count=(/nplumes/)) 119 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading beta_b' 146 IF (iret /= NF90_NOERR) THEN 147 abort_message='NetCDF Error reading beta_b' 148 CALL abort_physic(modname,abort_message,1) 149 ENDIF 120 150 iret = nf90_inq_varid(ncid, "aod_spmx" , VarId) 121 151 iret = nf90_get_var(ncid, VarID, aod_spmx(:) , start=(/1/),count=(/nplumes/)) 122 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading aod_spmx' 152 IF (iret /= NF90_NOERR) THEN 153 abort_message='NetCDF Error reading aod_spmx' 154 CALL abort_physic(modname,abort_message,1) 155 ENDIF 123 156 iret = nf90_inq_varid(ncid, "aod_fmbg" , VarId) 124 157 iret = nf90_get_var(ncid, VarID, aod_fmbg(:) , start=(/1/),count=(/nplumes/)) 125 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading aod_fmbg' 158 IF (iret /= NF90_NOERR) THEN 159 abort_message='NetCDF Error reading aod_fmbg' 160 CALL abort_physic(modname,abort_message,1) 161 ENDIF 126 162 iret = nf90_inq_varid(ncid, "ssa550" , VarId) 127 163 iret = nf90_get_var(ncid, VarID, ssa550(:) , start=(/1/),count=(/nplumes/)) 128 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading ssa550' 164 IF (iret /= NF90_NOERR) THEN 165 abort_message='NetCDF Error reading ssa550' 166 CALL abort_physic(modname,abort_message,1) 167 ENDIF 129 168 iret = nf90_inq_varid(ncid, "asy550" , VarId) 130 169 iret = nf90_get_var(ncid, VarID, asy550(:) , start=(/1/),count=(/nplumes/)) 131 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading asy550' 170 IF (iret /= NF90_NOERR) THEN 171 abort_message='NetCDF Error reading asy550' 172 CALL abort_physic(modname,abort_message,1) 173 ENDIF 132 174 iret = nf90_inq_varid(ncid, "angstrom" , VarId) 133 175 iret = nf90_get_var(ncid, VarID, angstrom(:), start=(/1/),count=(/nplumes/)) 134 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading angstrom' 176 IF (iret /= NF90_NOERR) THEN 177 abort_message='NetCDF Error reading angstrom' 178 CALL abort_physic(modname,abort_message,1) 179 ENDIF 135 180 ! 136 181 iret = nf90_inq_varid(ncid, "sig_lat_W" , VarId) 137 182 iret = nf90_get_var(ncid, VarID, sig_lat_W(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 138 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lat_W' 183 IF (iret /= NF90_NOERR) THEN 184 abort_message='NetCDF Error reading sig_lat_W' 185 CALL abort_physic(modname,abort_message,1) 186 ENDIF 139 187 iret = nf90_inq_varid(ncid, "sig_lat_E" , VarId) 140 188 iret = nf90_get_var(ncid, VarID, sig_lat_E(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 141 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lat_E' 189 IF (iret /= NF90_NOERR) THEN 190 abort_message='NetCDF Error reading sig_lat_E' 191 CALL abort_physic(modname,abort_message,1) 192 ENDIF 142 193 iret = nf90_inq_varid(ncid, "sig_lon_E" , VarId) 143 194 iret = nf90_get_var(ncid, VarID, sig_lon_E(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 144 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lon_E' 195 IF (iret /= NF90_NOERR) THEN 196 abort_message='NetCDF Error reading sig_lon_E' 197 CALL abort_physic(modname,abort_message,1) 198 ENDIF 145 199 iret = nf90_inq_varid(ncid, "sig_lon_W" , VarId) 146 200 iret = nf90_get_var(ncid, VarID, sig_lon_W(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 147 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading sig_lon_W' 201 IF (iret /= NF90_NOERR) THEN 202 abort_message='NetCDF Error reading sig_lon_W' 203 CALL abort_physic(modname,abort_message,1) 204 ENDIF 148 205 iret = nf90_inq_varid(ncid, "theta" , VarId) 149 206 iret = nf90_get_var(ncid, VarID, theta(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 150 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading theta' 207 IF (iret /= NF90_NOERR) THEN 208 abort_message='NetCDF Error reading theta' 209 CALL abort_physic(modname,abort_message,1) 210 ENDIF 151 211 iret = nf90_inq_varid(ncid, "ftr_weight" , VarId) 152 212 iret = nf90_get_var(ncid, VarID, ftr_weight(:,:) , start=(/1,1/),count=(/nfeatures,nplumes/)) 153 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading plume_lat' 213 IF (iret /= NF90_NOERR) THEN 214 abort_message='NetCDF Error reading plume_lat' 215 CALL abort_physic(modname,abort_message,1) 216 ENDIF 154 217 iret = nf90_inq_varid(ncid, "year_weight" , VarId) 155 218 iret = nf90_get_var(ncid, VarID, year_weight(:,:) , start=(/1,1/),count=(/nyears,nplumes /)) 156 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading year_weight' 219 IF (iret /= NF90_NOERR) THEN 220 abort_message='NetCDF Error reading year_weight' 221 CALL abort_physic(modname,abort_message,1) 222 ENDIF 157 223 iret = nf90_inq_varid(ncid, "ann_cycle" , VarId) 158 224 iret = nf90_get_var(ncid, VarID, ann_cycle(:,:,:) , start=(/1,1,1/),count=(/nfeatures,ntimes,nplumes/)) 159 IF (iret /= NF90_NOERR) STOP 'NetCDF Error reading ann_cycle' 225 IF (iret /= NF90_NOERR) THEN 226 abort_message='NetCDF Error reading ann_cycle' 227 CALL abort_physic(modname,abort_message,1) 228 ENDIF 160 229 ! 161 230 iret = nf90_close(ncid) -
LMDZ6/branches/Ocean_skin/libf/phylmd/mod_synchro_omp.F90
-
Property
svn:keywords
changed from
Author Date Id Revision
toId
r1907 r3605 1 ! 2 ! $Id$ 3 ! 1 4 MODULE mod_synchro_omp 2 5 … … 21 24 IMPLICIT NONE 22 25 LOGICAL :: out 26 CHARACTER (LEN=20) :: modname='synchro_omp' 27 CHARACTER (LEN=80) :: abort_message 23 28 24 29 out=.FALSE. … … 46 51 47 52 IF (exit_omp/=0) THEN 48 STOP 'synchro_omp' 53 abort_message='synchro_omp' 54 CALL abort_physic(modname,abort_message,1) 49 55 ENDIF 50 56 -
Property
svn:keywords
changed from
-
LMDZ6/branches/Ocean_skin/libf/phylmd/moy_undefSTD.F90
r2380 r3605 75 75 76 76 IF (n==1 .AND. itap==itapm1 .OR. n>1 .AND. mod(itap,nint(freq_outnmc(n)/ & 77 dtime))==0) THEN77 phys_tstep))==0) THEN 78 78 79 79 ! print*,'moy_undefSTD n itap itapm1',n,itap,itapm1 … … 140 140 END DO !i 141 141 END DO !k 142 END IF !MOD(itap,NINT(freq_outNMC(n)/ dtime)).EQ.0142 END IF !MOD(itap,NINT(freq_outNMC(n)/phys_tstep)).EQ.0 143 143 144 144 END DO !n -
LMDZ6/branches/Ocean_skin/libf/phylmd/oasis.F90
r3102 r3605 104 104 #ifdef CPP_XIOS 105 105 USE wxios, ONLY : wxios_context_init 106 USE xios 106 107 #endif 107 108 USE print_control_mod, ONLY: lunout 108 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat 109 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured, regular_lonlat 110 USE geometry_mod, ONLY: ind_cell_glo 111 USE mod_phys_lmdz_mpi_data, ONLY: klon_mpi_para_nb 112 113 109 114 110 115 ! Local variables … … 113 118 INTEGER :: ierror, il_commlocal 114 119 INTEGER :: il_part_id 115 INTEGER, DIMENSION(3) :: ig_paral120 INTEGER, ALLOCATABLE :: ig_paral(:) 116 121 INTEGER, DIMENSION(2) :: il_var_nodims 117 122 INTEGER, DIMENSION(4) :: il_var_actual_shape … … 136 141 ! Define the model name 137 142 ! 138 clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp 143 IF (grid_type==unstructured) THEN 144 clmodnam = 'icosa' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp 145 ELSE IF (grid_type==regular_lonlat) THEN 146 clmodnam = 'LMDZ' ! as in $NBMODEL in Cpl/Nam/namcouple.tmp 147 ELSE 148 abort_message='Pb : type of grid unknown' 149 CALL abort_physic(modname,abort_message,1) 150 ENDIF 139 151 140 152 … … 236 248 ! Domain decomposition 237 249 !************************************************************************************ 238 ig_paral(1) = 1 ! apple partition for // 239 ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset 240 ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1 241 242 IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1 250 IF (grid_type==unstructured) THEN 251 252 ALLOCATE( ig_paral(klon_mpi_para_nb(mpi_rank) + 2) ) 253 254 ig_paral(1) = 4 ! points partition for // 255 ig_paral(2) = klon_mpi_para_nb(mpi_rank) ! nb of local cells 256 257 DO jf=1, klon_mpi_para_nb(mpi_rank) 258 ig_paral(2+jf) = ind_cell_glo(jf) 259 ENDDO 260 261 ELSE IF (grid_type==regular_lonlat) THEN 262 263 ALLOCATE( ig_paral(3) ) 264 265 ig_paral(1) = 1 ! apple partition for // 266 ig_paral(2) = (jj_begin-1)*nbp_lon+ii_begin-1 ! offset 267 ig_paral(3) = (jj_end*nbp_lon+ii_end) - (jj_begin*nbp_lon+ii_begin) + 1 268 269 IF (mpi_rank==mpi_size-1) ig_paral(3)=ig_paral(3)+nbp_lon-1 270 ELSE 271 abort_message='Pb : type of grid unknown' 272 CALL abort_physic(modname,abort_message,1) 273 ENDIF 274 275 243 276 WRITE(lunout,*) mpi_rank,'ig_paral--->',ig_paral(2),ig_paral(3) 244 277 … … 253 286 ENDIF 254 287 255 il_var_nodims(1) = 2 256 il_var_nodims(2) = 1 257 258 il_var_actual_shape(1) = 1 259 il_var_actual_shape(2) = nbp_lon 260 il_var_actual_shape(3) = 1 261 il_var_actual_shape(4) = nbp_lat 288 il_var_nodims(1) = 2 ! rank of field array (1d or 2d) 289 il_var_nodims(2) = 1 ! always 1 in current oasis version" doc oasis3mct p18 290 291 il_var_actual_shape(1) = 1 ! min of 1st dimension (always 1) 292 il_var_actual_shape(2) = nbp_lon ! max of 1st dimension 293 il_var_actual_shape(3) = 1 ! min of 2nd dimension (always 1) 294 il_var_actual_shape(4) = nbp_lat ! max of 2nd dimension 262 295 263 296 il_var_type = PRISM_Real … … 302 335 ! End definition 303 336 !************************************************************************************ 337 #ifdef CPP_XIOS 338 CALL xios_oasis_enddef() 339 #endif 304 340 CALL prism_enddef_proto(ierror) 305 341 IF (ierror .NE. PRISM_Ok) THEN … … 311 347 312 348 #ifdef CPP_XIOS 313 CALL wxios_context_init()349 ! CALL wxios_context_init() 314 350 #endif 315 351 -
LMDZ6/branches/Ocean_skin/libf/phylmd/orografi_strato.F90
r2897 r3605 1819 1819 USE mod_phys_lmdz_para 1820 1820 USE mod_grid_phy_lmdz 1821 USE geometry_mod 1821 1822 IMPLICIT NONE 1822 1823 … … 1832 1833 INTEGER jk 1833 1834 REAL zpr, ztop, zsigt, zpm1r 1834 REAL :: pplay_glo(klon_glo, nlev)1835 REAL :: paprs_glo(klon_glo, nlev+1)1835 INTEGER :: cell,ij,nstra_tmp,nktopg_tmp 1836 REAL :: current_dist, dist_min,dist_min_glo 1836 1837 1837 1838 ! * 1. SET THE VALUES OF THE PARAMETERS … … 1848 1849 ! old ZSIGT=0.85 1849 1850 1850 CALL gather(pplay, pplay_glo) 1851 CALL bcast(pplay_glo) 1852 CALL gather(paprs, paprs_glo) 1853 CALL bcast(paprs_glo) 1854 1855 DO jk = 1, nlev 1856 zpm1r = pplay_glo(klon_glo/2+1, jk)/paprs_glo(klon_glo/2+1, 1) 1857 IF (zpm1r>=zsigt) THEN 1858 nktopg = jk 1859 END IF 1860 zpm1r = pplay_glo(klon_glo/2+1, jk)/paprs_glo(klon_glo/2+1, 1) 1861 IF (zpm1r>=ztop) THEN 1862 nstra = jk 1863 END IF 1864 END DO 1865 1851 1852 !ym Take the point at equator close to (0,0) coordinates. 1853 dist_min=360 1854 dist_min_glo=360. 1855 cell=-1 1856 DO ij=1,klon 1857 current_dist=sqrt(longitude_deg(ij)**2+latitude_deg(ij)**2) 1858 current_dist=current_dist*(1+(1e-10*ind_cell_glo(ij))/klon_glo) ! For point unicity 1859 IF (dist_min>current_dist) THEN 1860 dist_min=current_dist 1861 cell=ij 1862 ENDIF 1863 ENDDO 1864 1865 !PRINT *, 'SUGWD distmin cell=', dist_min,cell 1866 CALL reduce_min(dist_min,dist_min_glo) 1867 CALL bcast(dist_min_glo) 1868 IF (dist_min/=dist_min_glo) cell=-1 1869 !ym in future find the point at equator close to (0,0) coordinates. 1870 PRINT *, 'SUGWD distmin dist_min_glo cell=', dist_min,dist_min_glo,cell 1871 1872 nktopg_tmp=nktopg 1873 nstra_tmp=nstra 1874 1875 IF (cell/=-1) THEN 1876 1877 !print*,'SUGWD shape ',shape(pplay),cell+1 1878 1879 DO jk = 1, nlev 1880 !zpm1r = pplay(cell+1, jk)/paprs(cell+1, 1) 1881 zpm1r = pplay(cell, jk)/paprs(cell, 1) 1882 IF (zpm1r>=zsigt) THEN 1883 nktopg_tmp = jk 1884 END IF 1885 IF (zpm1r>=ztop) THEN 1886 nstra_tmp = jk 1887 END IF 1888 END DO 1889 ELSE 1890 nktopg_tmp=0 1891 nstra_tmp=0 1892 ENDIF 1893 1894 CALL reduce_sum(nktopg_tmp,nktopg) 1895 CALL bcast(nktopg) 1896 CALL reduce_sum(nstra_tmp,nstra) 1897 CALL bcast(nstra) 1898 1866 1899 ! inversion car dans orodrag on compte les niveaux a l'envers 1867 1900 nktopg = nlev - nktopg + 1 -
LMDZ6/branches/Ocean_skin/libf/phylmd/pbl_surface_mod.F90
r3458 r3605 60 60 USE print_control_mod, ONLY: lunout 61 61 USE ioipsl_getin_p_mod, ONLY : getin_p 62 IMPLICIT NONE 62 63 63 64 INCLUDE "dimsoil.h" … … 288 289 USE indice_sol_mod 289 290 USE time_phylmdz_mod, ONLY : day_ini,annee_ref,itau_phy 290 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat 291 USE mod_grid_phy_lmdz, ONLY : nbp_lon, nbp_lat, grid1dto2d_glo 291 292 USE print_control_mod, ONLY : prt_level,lunout 292 293 USE ioipsl_getin_p_mod, ONLY : getin_p … … 861 862 idayref = day_ini 862 863 CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) 863 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlon,zx_lon)864 CALL grid1dTo2d_glo(rlon,zx_lon) 864 865 DO i = 1, nbp_lon 865 866 zx_lon(i,1) = rlon(i+1) 866 867 zx_lon(i,nbp_lat) = rlon(i+1) 867 868 ENDDO 868 CALL gr _fi_ecrit(1,klon,nbp_lon,nbp_lat,rlat,zx_lat)869 CALL grid1dTo2d_glo(rlat,zx_lat) 869 870 CALL histbeg("sous_index",nbp_lon,zx_lon(:,1),nbp_lat,zx_lat(1,:), & 870 871 1,nbp_lon,1,nbp_lat, & … … 1951 1952 itap, dtime, jour, knon, ni, & 1952 1953 !!jyg ypplay(:,1), zgeo1/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& 1953 ypplay(:,1), zgeo1 /RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt1, yq1,&1954 ypplay(:,1), zgeo1(1:knon)/RG, ycdragh, ycdragm, yrain_f, ysnow_f, yt(:,1), yq(:,1),& ! ym missing init 1954 1955 AcoefH, AcoefQ, BcoefH, BcoefQ, & 1955 1956 AcoefU, AcoefV, BcoefU, BcoefV, & -
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
-
LMDZ6/branches/Ocean_skin/libf/phylmd/phyetat0.F90
r3458 r3605 9 9 USE pbl_surface_mod, ONLY : pbl_surface_init 10 10 USE surface_data, ONLY : type_ocean, version_ocean 11 USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, dtime, &11 USE phys_state_var_mod, ONLY : ancien_ok, clwcon, detr_therm, phys_tstep, & 12 12 qsol, fevap, z0m, z0h, agesno, & 13 13 du_gwd_rando, du_gwd_front, entr_therm, f0, fm_therm, & … … 111 111 IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN 112 112 co2_ppm = tab_cntrl(3) 113 RCO2 = co2_ppm * 1.0e-06 * 44.011/28.97113 RCO2 = co2_ppm * 1.0e-06 * RMCO2 / RMD 114 114 ! ELSE : keep value from .def 115 END IF 116 117 ! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def) 118 co2_ppm0 = tab_cntrl(16) 115 ENDIF 116 117 ! co2_ppm0 : initial value of atmospheric CO2 (from create_etat0_limit.e .def) 118 ! co2_ppm0 = tab_cntrl(16) 119 ! initial value for interactive CO2 run when there is no tracer field for CO2 in restart 120 co2_ppm0=284.32 119 121 120 122 solaire_etat0 = tab_cntrl(4) … … 122 124 tab_cntrl(6)=nbapp_rad 123 125 124 if(iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne125 if(soil_model) tab_cntrl( 8) =1.126 if(new_oliq) tab_cntrl( 9) =1.127 if(ok_orodr) tab_cntrl(10) =1.128 if(ok_orolf) tab_cntrl(11) =1.129 if(ok_limitvrai) tab_cntrl(12) =1.126 IF (iflag_cycle_diurne.GE.1) tab_cntrl( 7) = iflag_cycle_diurne 127 IF (soil_model) tab_cntrl( 8) =1. 128 IF (new_oliq) tab_cntrl( 9) =1. 129 IF (ok_orodr) tab_cntrl(10) =1. 130 IF (ok_orolf) tab_cntrl(11) =1. 131 IF (ok_limitvrai) tab_cntrl(12) =1. 130 132 131 133 itau_phy = tab_cntrl(15) … … 164 166 DO i=1,klon 165 167 IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN 166 WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",& 167 " i=",i," lon_startphy(i)=",lon_startphy(i),& 168 " longitude_deg(i)=",longitude_deg(i) 169 ! This is presumably serious enough to abort run 170 CALL abort_physic("phyetat0","discrepancy in longitudes!",1) 168 IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i)))>=1) THEN 169 WRITE(*,*) "phyetat0: Error! Longitude discrepancy wrt startphy file:",& 170 " i=",i," lon_startphy(i)=",lon_startphy(i),& 171 " longitude_deg(i)=",longitude_deg(i) 172 ! This is presumably serious enough to abort run 173 CALL abort_physic("phyetat0","discrepancy in longitudes!",1) 174 ENDIF 171 175 ENDIF 172 IF (ABS(lon_startphy(i)-longitude_deg(i))>=0.0001) THEN 173 WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",& 174 " i=",i," lon_startphy(i)=",lon_startphy(i),& 175 " longitude_deg(i)=",longitude_deg(i) 176 IF (ABS(lon_startphy(i)-longitude_deg(i))>=1) THEN 177 IF (ABS(360-ABS(lon_startphy(i)-longitude_deg(i))) > 0.0001) THEN 178 WRITE(*,*) "phyetat0: Warning! Longitude discrepancy wrt startphy file:",& 179 " i=",i," lon_startphy(i)=",lon_startphy(i),& 180 " longitude_deg(i)=",longitude_deg(i) 181 ENDIF 176 182 ENDIF 177 183 ENDDO … … 223 229 zmasq(i) = fractint(i) 224 230 ENDIF 225 END 231 ENDDO 226 232 fractint (1 : klon) = pctsrf(1 : klon, is_oce) & 227 233 + pctsrf(1 : klon, is_sic) … … 234 240 zmasq(i) = 1. - fractint(i) 235 241 ENDIF 236 END 242 ENDDO 237 243 238 244 !=================================================================== … … 359 365 ! dummy values (as is the case when generated by ce0l, 360 366 ! or by iniaqua) 361 if ( (maxval(q_ancien).eq.minval(q_ancien)) .or. &362 (maxval(ql_ancien). eq.minval(ql_ancien)) .or. &363 (maxval(qs_ancien). eq.minval(qs_ancien)) .or. &364 (maxval(prw_ancien). eq.minval(prw_ancien)) .or. &365 (maxval(prlw_ancien). eq.minval(prlw_ancien)) .or. &366 (maxval(prsw_ancien). eq.minval(prsw_ancien)) .or. &367 (maxval(t_ancien). eq.minval(t_ancien)) ) then367 IF ( (maxval(q_ancien).EQ.minval(q_ancien)) .OR. & 368 (maxval(ql_ancien).EQ.minval(ql_ancien)) .OR. & 369 (maxval(qs_ancien).EQ.minval(qs_ancien)) .OR. & 370 (maxval(prw_ancien).EQ.minval(prw_ancien)) .OR. & 371 (maxval(prlw_ancien).EQ.minval(prlw_ancien)) .OR. & 372 (maxval(prsw_ancien).EQ.minval(prsw_ancien)) .OR. & 373 (maxval(t_ancien).EQ.minval(t_ancien)) ) THEN 368 374 ancien_ok=.false. 369 endif375 ENDIF 370 376 371 377 found=phyetat0_get(klev,clwcon,"CLWCON","CLWCON",0.) … … 434 440 found=phyetat0_get(1,trs(:,it),"trs_"//tname(iiq), & 435 441 "Surf trac"//tname(iiq),0.) 436 END 442 ENDDO 437 443 CALL traclmdz_from_restart(trs) 438 444 ENDIF … … 444 450 IF (ierr /= 0) CALL abort_physic('phyetat0', 'pb allocation co2_send', 1) 445 451 found=phyetat0_get(1,co2_send,"co2_send","co2 send",co2_ppm) 446 END 447 END 452 ENDIF 453 ENDIF 448 454 449 455 !=========================================== … … 452 458 453 459 ! ondes de gravite non orographiques 454 if(ok_gwd_rando) found = &460 IF (ok_gwd_rando) found = & 455 461 phyetat0_get(klev,du_gwd_rando,"du_gwd_rando","du_gwd_rando",0.) 456 IF (. not. ok_hines .and. ok_gwd_rando) found &462 IF (.NOT. ok_hines .AND. ok_gwd_rando) found & 457 463 = phyetat0_get(klev,du_gwd_front,"du_gwd_front","du_gwd_front",0.) 458 464 … … 473 479 474 480 IF ( type_ocean == 'slab' ) THEN 475 CALL ocean_slab_init( dtime, pctsrf)481 CALL ocean_slab_init(phys_tstep, pctsrf) 476 482 IF (nslay.EQ.1) THEN 477 483 found=phyetat0_get(1,tslab,"tslab01","tslab",0.) 478 484 IF (.NOT. found) THEN 479 485 found=phyetat0_get(1,tslab,"tslab","tslab",0.) 480 END 486 ENDIF 481 487 ELSE 482 488 DO i=1,nslay 483 489 WRITE(str2,'(i2.2)') i 484 490 found=phyetat0_get(1,tslab(:,i),"tslab"//str2,"tslab",0.) 485 END 486 END 491 ENDDO 492 ENDIF 487 493 IF (.NOT. found) THEN 488 494 PRINT*, "phyetat0: Le champ <tslab> est absent" … … 490 496 DO i=1,nslay 491 497 tslab(:,i)=MAX(ftsol(:,is_oce),271.35) 492 END 493 END 498 ENDDO 499 ENDIF 494 500 495 501 ! Sea ice variables … … 500 506 PRINT*, "Initialisation a tsol_sic" 501 507 tice(:)=ftsol(:,is_sic) 502 END 508 ENDIF 503 509 found=phyetat0_get(1,seaice,"seaice","seaice",0.) 504 510 IF (.NOT. found) THEN … … 508 514 WHERE (pctsrf(:,is_sic).GT.EPSFRA) 509 515 seaice=917. 510 END 511 END 512 END 513 END 516 ENDWHERE 517 ENDIF 518 ENDIF !sea ice INT 519 ENDIF ! Slab 514 520 515 521 ! on ferme le fichier … … 522 528 ! Initialize module ocean_cpl_mod for the case of coupled ocean 523 529 IF ( type_ocean == 'couple' ) THEN 524 CALL ocean_cpl_init( dtime, longitude_deg, latitude_deg)525 ENDIF 526 527 CALL init_iophy_new(latitude_deg, longitude_deg)530 CALL ocean_cpl_init(phys_tstep, longitude_deg, latitude_deg) 531 ENDIF 532 533 ! CALL init_iophy_new(latitude_deg, longitude_deg) 528 534 529 535 ! Initilialize module fonte_neige_mod -
LMDZ6/branches/Ocean_skin/libf/phylmd/phyredem.F90
r3458 r3605 29 29 treedrg, ds_ns, dt_ns 30 30 USE geometry_mod, ONLY : longitude_deg, latitude_deg 31 USE iostart, ONLY: open_restartphy, close_restartphy, put_field, put_var31 USE iostart, ONLY: open_restartphy, close_restartphy, enddef_restartphy, put_field, put_var 32 32 USE traclmdz_mod, ONLY : traclmdz_to_restart 33 33 USE infotrac_phy, ONLY: type_trac, niadv, tname, nbtr, nqo … … 66 66 CHARACTER (len=2) :: str2 67 67 CHARACTER (len=256) :: nam, lnam 68 INTEGER :: it, iiq 68 INTEGER :: it, iiq, pass 69 69 70 70 !====================================================================== … … 81 81 CALL open_restartphy(fichnom) 82 82 83 83 84 DO ierr = 1, length 84 85 tab_cntrl(ierr) = 0.0 … … 105 106 tab_cntrl(16) = co2_ppm0 106 107 107 CALL put_var("controle", "Parametres de controle", tab_cntrl) 108 109 CALL put_field("longitude", & 110 "Longitudes de la grille physique", longitude_deg) 111 112 CALL put_field("latitude", "Latitudes de la grille physique", latitude_deg) 113 114 ! PB ajout du masque terre/mer 115 116 CALL put_field("masque", "masque terre mer", zmasq) 117 118 ! BP ajout des fraction de chaque sous-surface 119 120 ! Get last fractions from slab ocean 121 IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN 122 WHERE (1.-zmasq(:).GT.EPSFRA) 123 pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:)) 124 pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:)) 125 END WHERE 126 END IF 127 128 ! 1. fraction de terre 129 130 CALL put_field("FTER", "fraction de continent", pctsrf(:, is_ter)) 131 132 ! 2. Fraction de glace de terre 133 134 CALL put_field("FLIC", "fraction glace de terre", pctsrf(:, is_lic)) 135 136 ! 3. fraction ocean 137 138 CALL put_field("FOCE", "fraction ocean", pctsrf(:, is_oce)) 139 140 ! 4. Fraction glace de mer 141 142 CALL put_field("FSIC", "fraction glace mer", pctsrf(:, is_sic)) 143 144 IF(nbsrf>99) THEN 145 PRINT*, "Trop de sous-mailles"; CALL abort_physic("phyredem", "", 1) 146 END IF 147 IF(nsoilmx>99) THEN 148 PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1) 149 END IF 150 IF(nsw>99) THEN 151 PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1) 152 END IF 153 154 CALL put_field_srf1("TS","Temperature",ftsol(:,:)) 108 DO pass=1,2 ! pass=1 netcdf definition ; pass=2 netcdf write 109 110 CALL put_var(pass, "controle", "Parametres de controle", tab_cntrl) 111 112 CALL put_field(pass,"longitude", & 113 "Longitudes de la grille physique", longitude_deg) 114 115 CALL put_field(pass,"latitude", "Latitudes de la grille physique", latitude_deg) 116 117 ! PB ajout du masque terre/mer 118 119 CALL put_field(pass,"masque", "masque terre mer", zmasq) 120 121 ! BP ajout des fraction de chaque sous-surface 122 123 ! Get last fractions from slab ocean 124 IF (type_ocean == 'slab' .AND. version_ocean == "sicINT") THEN 125 WHERE (1.-zmasq(:).GT.EPSFRA) 126 pctsrf(:,is_oce)=(1.-fsic(:))*(1.-zmasq(:)) 127 pctsrf(:,is_sic)=fsic(:)*(1.-zmasq(:)) 128 END WHERE 129 END IF 130 131 ! 1. fraction de terre 132 133 CALL put_field(pass,"FTER", "fraction de continent", pctsrf(:, is_ter)) 134 135 ! 2. Fraction de glace de terre 136 137 CALL put_field(pass,"FLIC", "fraction glace de terre", pctsrf(:, is_lic)) 138 139 ! 3. fraction ocean 140 141 CALL put_field(pass,"FOCE", "fraction ocean", pctsrf(:, is_oce)) 142 143 ! 4. Fraction glace de mer 144 145 CALL put_field(pass,"FSIC", "fraction glace mer", pctsrf(:, is_sic)) 146 147 IF(nbsrf>99) THEN 148 PRINT*, "Trop de sous-mailles"; CALL abort_physic("phyredem", "", 1) 149 END IF 150 IF(nsoilmx>99) THEN 151 PRINT*, "Trop de sous-surfaces"; CALL abort_physic("phyredem", "", 1) 152 END IF 153 IF(nsw>99) THEN 154 PRINT*, "Trop de bandes"; CALL abort_physic("phyredem", "", 1) 155 END IF 156 157 CALL put_field_srf1(pass,"TS","Temperature",ftsol(:,:)) 155 158 156 159 ! ================== Albedo ======================================= 157 print*,'PHYREDEM NOUVEAU'158 CALL put_field_srf2("A_dir_SW","Albedo direct",falb_dir(:,:,:))159 CALL put_field_srf2("A_dif_SW","Albedo diffus",falb_dif(:,:,:))160 161 CALL put_field_srf1("U10M", "u a 10m", u10m)162 163 CALL put_field_srf1("V10M", "v a 10m", v10m)160 print*,'PHYREDEM NOUVEAU' 161 CALL put_field_srf2(pass,"A_dir_SW","Albedo direct",falb_dir(:,:,:)) 162 CALL put_field_srf2(pass,"A_dif_SW","Albedo diffus",falb_dif(:,:,:)) 163 164 CALL put_field_srf1(pass,"U10M", "u a 10m", u10m) 165 166 CALL put_field_srf1(pass,"V10M", "v a 10m", v10m) 164 167 165 168 166 169 ! ================== Tsoil ========================================= 167 CALL put_field_srf2("Tsoil","Temperature",tsoil(:,:,:))170 CALL put_field_srf2(pass,"Tsoil","Temperature",tsoil(:,:,:)) 168 171 !FC 169 172 ! CALL put_field_srf2("treedrg","freinage arbres",treedrg(:,:,:)) 170 CALL put_field("treedrg_ter","freinage arbres",treedrg(:,:,is_ter))171 172 173 CALL put_field_srf1("QS" , "Humidite",qsurf(:,:))174 175 CALL put_field ("QSOL", "Eau dans le sol (mm)", qsol)176 177 CALL put_field_srf1("EVAP", "Evaporation", fevap(:,:))178 179 CALL put_field_srf1("SNOW", "Neige", snow(:,:))180 181 CALL put_field("RADS", "Rayonnement net a la surface", radsol)182 183 CALL put_field("solsw", "Rayonnement solaire a la surface", solsw)184 185 CALL put_field("sollw", "Rayonnement IF a la surface", sollw)186 187 CALL put_field("sollwdown", "Rayonnement down IF a la surface", sollwdown)188 189 CALL put_field("fder", "Derive de flux", fder)190 191 CALL put_field("rain_f", "precipitation liquide", rain_fall)192 193 CALL put_field("snow_f", "precipitation solide", snow_fall)194 195 CALL put_field_srf1("Z0m", "rugosite", z0m(:,:))196 197 CALL put_field_srf1("Z0h", "rugosite", z0h(:,:))198 199 CALL put_field_srf1("AGESNO", "Age de la neige", agesno(:,:))200 201 CALL put_field("ZMEA", "ZMEA", zmea)202 203 CALL put_field("ZSTD", "ZSTD", zstd)204 205 CALL put_field("ZSIG", "ZSIG", zsig)206 207 CALL put_field("ZGAM", "ZGAM", zgam)208 209 CALL put_field("ZTHE", "ZTHE", zthe)210 211 CALL put_field("ZPIC", "ZPIC", zpic)212 213 CALL put_field("ZVAL", "ZVAL", zval)214 215 CALL put_field("RUGSREL", "RUGSREL", rugoro)216 217 CALL put_field("TANCIEN", "TANCIEN", t_ancien)218 219 CALL put_field("QANCIEN", "QANCIEN", q_ancien)220 221 CALL put_field("QLANCIEN", "QLANCIEN", ql_ancien)222 223 CALL put_field("QSANCIEN", "QSANCIEN", qs_ancien)224 225 CALL put_field("PRWANCIEN", "PRWANCIEN", prw_ancien)226 227 CALL put_field("PRLWANCIEN", "PRLWANCIEN", prlw_ancien)228 229 CALL put_field("PRSWANCIEN", "PRSWANCIEN", prsw_ancien)230 231 CALL put_field("UANCIEN", "UANCIEN", u_ancien)232 233 CALL put_field("VANCIEN", "VANCIEN", v_ancien)234 235 CALL put_field("CLWCON", "Eau liquide convective", clwcon)236 237 CALL put_field("RNEBCON", "Nebulosite convective", rnebcon)238 239 CALL put_field("RATQS", "Ratqs", ratqs)240 241 ! run_off_lic_0242 243 CALL put_field("RUNOFFLIC0", "Runofflic0", run_off_lic_0)244 245 ! DEB TKE PBL !246 247 IF (iflag_pbl>1) then248 CALL put_field_srf3("TKE", "Energ. Cineti. Turb.", &249 pbl_tke(:,:,:))250 CALL put_field_srf3("DELTATKE", "Del TKE wk/env.", &251 wake_delta_pbl_tke(:,:,:))252 END IF253 254 ! FIN TKE PBL !255 !IM ajout zmax0, f0, sig1, w01256 !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip257 258 CALL put_field("ZMAX0", "ZMAX0", zmax0)259 260 CALL put_field("F0", "F0", f0)261 262 CALL put_field("sig1", "sig1 Emanuel", sig1)263 264 CALL put_field("w01", "w01 Emanuel", w01)265 266 ! wake_deltat267 CALL put_field("WAKE_DELTAT", "WAKE_DELTAT", wake_deltat)268 269 CALL put_field("WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq)270 271 CALL put_field("WAKE_S", "Wake frac. area", wake_s)272 273 CALL put_field("WAKE_DENS", "Wake num. /unit area", wake_dens)274 275 CALL put_field("WAKE_CSTAR", "WAKE_CSTAR", wake_cstar)276 277 CALL put_field("WAKE_PE", "WAKE_PE", wake_pe)278 279 CALL put_field("WAKE_FIP", "WAKE_FIP", wake_fip)280 281 ! thermiques282 283 CALL put_field("FM_THERM", "FM_THERM", fm_therm)284 285 CALL put_field("ENTR_THERM", "ENTR_THERM", entr_therm)286 287 CALL put_field("DETR_THERM", "DETR_THERM", detr_therm)288 289 CALL put_field("ALE_BL", "ALE_BL", ale_bl)290 291 CALL put_field("ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig)292 293 CALL put_field("ALP_BL", "ALP_BL", alp_bl)294 295 CALL put_field("ALE_WAKE", "ALE_WAKE", ale_wake)296 297 CALL put_field("ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat)298 299 300 ! trs from traclmdz_mod301 IF (type_trac == 'lmdz') THEN302 CALL traclmdz_to_restart(trs)303 DO it=1, nbtr173 CALL put_field(pass,"treedrg_ter","freinage arbres",treedrg(:,:,is_ter)) 174 175 176 CALL put_field_srf1(pass,"QS" , "Humidite",qsurf(:,:)) 177 178 CALL put_field (pass,"QSOL", "Eau dans le sol (mm)", qsol) 179 180 CALL put_field_srf1(pass,"EVAP", "Evaporation", fevap(:,:)) 181 182 CALL put_field_srf1(pass,"SNOW", "Neige", snow(:,:)) 183 184 CALL put_field(pass,"RADS", "Rayonnement net a la surface", radsol) 185 186 CALL put_field(pass,"solsw", "Rayonnement solaire a la surface", solsw) 187 188 CALL put_field(pass,"sollw", "Rayonnement IF a la surface", sollw) 189 190 CALL put_field(pass,"sollwdown", "Rayonnement down IF a la surface", sollwdown) 191 192 CALL put_field(pass,"fder", "Derive de flux", fder) 193 194 CALL put_field(pass,"rain_f", "precipitation liquide", rain_fall) 195 196 CALL put_field(pass,"snow_f", "precipitation solide", snow_fall) 197 198 CALL put_field_srf1(pass,"Z0m", "rugosite", z0m(:,:)) 199 200 CALL put_field_srf1(pass,"Z0h", "rugosite", z0h(:,:)) 201 202 CALL put_field_srf1(pass,"AGESNO", "Age de la neige", agesno(:,:)) 203 204 CALL put_field(pass,"ZMEA", "ZMEA", zmea) 205 206 CALL put_field(pass,"ZSTD", "ZSTD", zstd) 207 208 CALL put_field(pass,"ZSIG", "ZSIG", zsig) 209 210 CALL put_field(pass,"ZGAM", "ZGAM", zgam) 211 212 CALL put_field(pass,"ZTHE", "ZTHE", zthe) 213 214 CALL put_field(pass,"ZPIC", "ZPIC", zpic) 215 216 CALL put_field(pass,"ZVAL", "ZVAL", zval) 217 218 CALL put_field(pass,"RUGSREL", "RUGSREL", rugoro) 219 220 CALL put_field(pass,"TANCIEN", "TANCIEN", t_ancien) 221 222 CALL put_field(pass,"QANCIEN", "QANCIEN", q_ancien) 223 224 CALL put_field(pass,"QLANCIEN", "QLANCIEN", ql_ancien) 225 226 CALL put_field(pass,"QSANCIEN", "QSANCIEN", qs_ancien) 227 228 CALL put_field(pass,"PRWANCIEN", "PRWANCIEN", prw_ancien) 229 230 CALL put_field(pass,"PRLWANCIEN", "PRLWANCIEN", prlw_ancien) 231 232 CALL put_field(pass,"PRSWANCIEN", "PRSWANCIEN", prsw_ancien) 233 234 CALL put_field(pass,"UANCIEN", "UANCIEN", u_ancien) 235 236 CALL put_field(pass,"VANCIEN", "VANCIEN", v_ancien) 237 238 CALL put_field(pass,"CLWCON", "Eau liquide convective", clwcon) 239 240 CALL put_field(pass,"RNEBCON", "Nebulosite convective", rnebcon) 241 242 CALL put_field(pass,"RATQS", "Ratqs", ratqs) 243 244 ! run_off_lic_0 245 246 CALL put_field(pass,"RUNOFFLIC0", "Runofflic0", run_off_lic_0) 247 248 ! DEB TKE PBL ! 249 250 IF (iflag_pbl>1) then 251 CALL put_field_srf3(pass,"TKE", "Energ. Cineti. Turb.", & 252 pbl_tke(:,:,:)) 253 CALL put_field_srf3(pass,"DELTATKE", "Del TKE wk/env.", & 254 wake_delta_pbl_tke(:,:,:)) 255 END IF 256 257 ! FIN TKE PBL ! 258 !IM ajout zmax0, f0, sig1, w01 259 !IM wake_deltat, wake_deltaq, wake_s, wake_cstar, wake_pe, wake_fip 260 261 CALL put_field(pass,"ZMAX0", "ZMAX0", zmax0) 262 263 CALL put_field(pass,"F0", "F0", f0) 264 265 CALL put_field(pass,"sig1", "sig1 Emanuel", sig1) 266 267 CALL put_field(pass,"w01", "w01 Emanuel", w01) 268 269 ! wake_deltat 270 CALL put_field(pass,"WAKE_DELTAT", "WAKE_DELTAT", wake_deltat) 271 272 CALL put_field(pass,"WAKE_DELTAQ", "WAKE_DELTAQ", wake_deltaq) 273 274 CALL put_field(pass,"WAKE_S", "Wake frac. area", wake_s) 275 276 CALL put_field(pass,"WAKE_DENS", "Wake num. /unit area", wake_dens) 277 278 CALL put_field(pass,"WAKE_CSTAR", "WAKE_CSTAR", wake_cstar) 279 280 CALL put_field(pass,"WAKE_PE", "WAKE_PE", wake_pe) 281 282 CALL put_field(pass,"WAKE_FIP", "WAKE_FIP", wake_fip) 283 284 ! thermiques 285 286 CALL put_field(pass,"FM_THERM", "FM_THERM", fm_therm) 287 288 CALL put_field(pass,"ENTR_THERM", "ENTR_THERM", entr_therm) 289 290 CALL put_field(pass,"DETR_THERM", "DETR_THERM", detr_therm) 291 292 CALL put_field(pass,"ALE_BL", "ALE_BL", ale_bl) 293 294 CALL put_field(pass,"ALE_BL_TRIG", "ALE_BL_TRIG", ale_bl_trig) 295 296 CALL put_field(pass,"ALP_BL", "ALP_BL", alp_bl) 297 298 CALL put_field(pass,"ALE_WAKE", "ALE_WAKE", ale_wake) 299 300 CALL put_field(pass,"ALE_BL_STAT", "ALE_BL_STAT", ale_bl_stat) 301 302 303 ! trs from traclmdz_mod 304 IF (type_trac == 'lmdz') THEN 305 CALL traclmdz_to_restart(trs) 306 DO it=1, nbtr 304 307 !! iiq=niadv(it+2) ! jyg 305 iiq=niadv(it+nqo) ! jyg 306 CALL put_field("trs_"//tname(iiq), "", trs(:, it)) 307 END DO 308 IF (carbon_cycle_cpl) THEN 309 IF (.NOT. ALLOCATED(co2_send)) THEN 310 ! This is the case of create_etat0_limit, ce0l 311 ALLOCATE(co2_send(klon)) 312 co2_send(:) = co2_ppm0 308 iiq=niadv(it+nqo) ! jyg 309 CALL put_field(pass,"trs_"//tname(iiq), "", trs(:, it)) 310 END DO 311 IF (carbon_cycle_cpl) THEN 312 IF (.NOT. ALLOCATED(co2_send)) THEN 313 ! This is the case of create_etat0_limit, ce0l 314 ALLOCATE(co2_send(klon)) 315 co2_send(:) = co2_ppm0 316 END IF 317 CALL put_field(pass,"co2_send", "co2_ppm for coupling", co2_send) 318 END IF 319 END IF 320 321 ! Restart variables for Slab ocean 322 IF (type_ocean == 'slab') THEN 323 IF (nslay.EQ.1) THEN 324 CALL put_field(pass,"tslab", "Slab ocean temperature", tslab) 325 ELSE 326 DO it=1,nslay 327 WRITE(str2,'(i2.2)') it 328 CALL put_field(pass,"tslab"//str2, "Slab ocean temperature", tslab(:,it)) 329 END DO 313 330 END IF 314 CALL put_field("co2_send", "co2_ppm for coupling", co2_send) 315 END IF 316 END IF 317 318 ! Restart variables for Slab ocean 319 IF (type_ocean == 'slab') THEN 320 IF (nslay.EQ.1) THEN 321 CALL put_field("tslab", "Slab ocean temperature", tslab) 322 ELSE 323 DO it=1,nslay 324 WRITE(str2,'(i2.2)') it 325 CALL put_field("tslab"//str2, "Slab ocean temperature", tslab(:,it)) 326 END DO 327 END IF 328 IF (version_ocean == 'sicINT') THEN 329 CALL put_field("seaice", "Slab seaice (kg/m2)", seaice) 330 CALL put_field("slab_tice", "Slab sea ice temperature", tice) 331 END IF 332 END IF 333 334 if (ok_gwd_rando) call put_field("du_gwd_rando", & 335 "tendency on zonal wind due to flott gravity waves", du_gwd_rando) 336 337 IF (.not. ok_hines .and. ok_gwd_rando) call put_field("du_gwd_front", & 338 "tendency on zonal wind due to acama gravity waves", du_gwd_front) 339 340 if (activate_ocean_skin >= 1) then 341 CALL put_field("ds_ns", "delta salinity near surface", ds_ns) 342 CALL put_field("dT_ns", "delta temperature near surface", dT_ns) 343 end if 331 IF (version_ocean == 'sicINT') THEN 332 CALL put_field(pass,"seaice", "Slab seaice (kg/m2)", seaice) 333 CALL put_field(pass,"slab_tice", "Slab sea ice temperature", tice) 334 END IF 335 END IF 336 337 if (ok_gwd_rando) call put_field(pass,"du_gwd_rando", & 338 "tendency on zonal wind due to flott gravity waves", du_gwd_rando) 339 340 IF (.not. ok_hines .and. ok_gwd_rando) call put_field(pass,"du_gwd_front", & 341 "tendency on zonal wind due to acama gravity waves", du_gwd_front) 342 343 if (activate_ocean_skin >= 1) then 344 CALL put_field(pass, "ds_ns", "delta salinity near surface", ds_ns) 345 CALL put_field(pass, "dT_ns", "delta temperature near surface", dT_ns) 346 end if 347 348 IF (pass==1) CALL enddef_restartphy 349 IF (pass==2) CALL close_restartphy 350 ENDDO 344 351 345 CALL close_restartphy346 352 !$OMP BARRIER 347 353 … … 350 356 351 357 352 SUBROUTINE put_field_srf1( nam,lnam,field)358 SUBROUTINE put_field_srf1(pass,nam,lnam,field) 353 359 354 360 IMPLICIT NONE 361 INTEGER, INTENT(IN) :: pass 355 362 CHARACTER(LEN=*), INTENT(IN) :: nam, lnam 356 363 REAL, INTENT(IN) :: field(:,:) … … 360 367 nm=TRIM(nam)//TRIM(str) 361 368 lm=TRIM(lnam)//" de surface No. "//TRIM(str) 362 CALL put_field( nm,lm,field(:,nsrf))369 CALL put_field(pass,nm,lm,field(:,nsrf)) 363 370 END DO 364 371 … … 366 373 367 374 368 SUBROUTINE put_field_srf2( nam,lnam,field)375 SUBROUTINE put_field_srf2(pass,nam,lnam,field) 369 376 370 377 IMPLICIT NONE 378 INTEGER, INTENT(IN) :: pass 371 379 CHARACTER(LEN=*), INTENT(IN) :: nam, lnam 372 380 REAL, INTENT(IN) :: field(:,:,:) … … 378 386 nm=TRIM(nam)//TRIM(str) 379 387 lm=TRIM(lnam)//" du sol No. "//TRIM(str) 380 CALL put_field( nm,lm,field(:,isoil,nsrf))388 CALL put_field(pass,nm,lm,field(:,isoil,nsrf)) 381 389 END DO 382 390 END DO … … 385 393 386 394 387 SUBROUTINE put_field_srf3( nam,lnam,field)395 SUBROUTINE put_field_srf3(pass,nam,lnam,field) 388 396 389 397 IMPLICIT NONE 398 INTEGER, INTENT(IN) :: pass 390 399 CHARACTER(LEN=*), INTENT(IN) :: nam, lnam 391 400 REAL, INTENT(IN) :: field(:,:,:) … … 395 404 nm=TRIM(nam)//TRIM(str) 396 405 lm=TRIM(lnam)//TRIM(str) 397 CALL put_field( nm,lm,field(:,1:klev+1,nsrf))406 CALL put_field(pass,nm,lm,field(:,1:klev+1,nsrf)) 398 407 END DO 399 408 -
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_cal_mod.F90
-
Property
svn:keywords
set to
Id
r2802 r3605 1 ! $Id :$1 ! $Id$ 2 2 MODULE phys_cal_mod 3 3 ! This module contains information on the calendar at the current time step … … 37 37 SUBROUTINE phys_cal_init(annee_ref,day_ref) 38 38 39 USE IOIPSL, ONLY: ymds2ju 39 USE IOIPSL, ONLY: ymds2ju, ioconf_calendar 40 USE mod_phys_lmdz_para, ONLY: is_master,is_omp_master 40 41 USE ioipsl_getin_p_mod, ONLY: getin_p 41 42 … … 47 48 calend = 'earth_360d' ! default 48 49 CALL getin_p("calend",calend) 50 51 IF (is_omp_master) THEN 52 IF (calend == 'earth_360d') THEN 53 CALL ioconf_calendar('360d') 54 ELSE IF (calend == 'earth_365d') THEN 55 CALL ioconf_calendar('noleap') 56 ELSE IF (calend == 'earth_366d' .OR. calend == 'gregorian') THEN 57 CALL ioconf_calendar('gregorian') 58 ELSE 59 CALL abort_physic('phys_cal_init','Mauvais choix de calendrier',1) 60 ENDIF 61 ENDIF 62 !$OMP BARRIER 49 63 50 64 CALL ymds2ju(annee_ref, 1, day_ref, 0., jD_ref) -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_local_var_mod.F90
r3379 r3605 343 343 !$OMP THREADPRIVATE(zxfluxlat_x, zxfluxlat_w) 344 344 !jyg< 345 !!! Entr \E9es suppl\E9mentaires couche-limite345 !!! Entrees supplementaires couche-limite 346 346 !! REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: t_x, t_w 347 347 !!!$OMP THREADPRIVATE(t_x, t_w) … … 349 349 !!!$OMP THREADPRIVATE(q_x, q_w) 350 350 !>jyg 351 ! Variables suppl\E9mentaires dans physiq.F relative au splitting de la surface 351 !!! Sorties ferret 352 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dtvdf_x, dtvdf_w 353 !$OMP THREADPRIVATE(dtvdf_x, dtvdf_w) 354 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: dqvdf_x, dqvdf_w 355 !$OMP THREADPRIVATE(dqvdf_x, dqvdf_w) 356 ! Variables supplementaires dans physiq.F relative au splitting de la surface 352 357 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:,:) :: pbl_tke_input 353 358 !$OMP THREADPRIVATE(pbl_tke_input) … … 375 380 REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: t2m_min_mon, t2m_max_mon 376 381 !$OMP THREADPRIVATE(t2m_min_mon, t2m_max_mon) 382 REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zq2m_cor, zt2m_cor 383 !$OMP THREADPRIVATE(zq2m_cor, zt2m_cor) 384 REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zu10m_cor, zv10m_cor 385 !$OMP THREADPRIVATE(zu10m_cor, zv10m_cor) 386 REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: zrh2m_cor, zqsat2m_cor 387 !$OMP THREADPRIVATE(zrh2m_cor, zqsat2m_cor) 377 388 REAL,ALLOCATABLE,SAVE,DIMENSION(:) :: weak_inversion 378 389 !$OMP THREADPRIVATE(weak_inversion) … … 405 416 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: pmflxr, pmflxs 406 417 !$OMP THREADPRIVATE(pmflxr, pmflxs) 407 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: wdtrainA, wdtrain M408 !$OMP THREADPRIVATE(wdtrainA, wdtrain M)418 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: wdtrainA, wdtrainS, wdtrainM 419 !$OMP THREADPRIVATE(wdtrainA, wdtrainS, wdtrainM) 409 420 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: da, mp 410 421 !$OMP THREADPRIVATE(da, mp) … … 417 428 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: ev 418 429 !$OMP THREADPRIVATE(ev) 430 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: qtaa 431 !$OMP THREADPRIVATE(qtaa) 419 432 REAL,ALLOCATABLE,SAVE,DIMENSION(:,:) :: clw 420 433 !$OMP THREADPRIVATE(clw) … … 578 591 ALLOCATE(plul_st(klon),plul_th(klon)) 579 592 ALLOCATE(d_t_vdf(klon,klev),d_q_vdf(klon,klev),d_t_diss(klon,klev)) 593 594 ALLOCATE(d_t_vdf_w(klon,klev),d_q_vdf_w(klon,klev)) 595 ALLOCATE(d_t_vdf_x(klon,klev),d_q_vdf_x(klon,klev)) 596 580 597 ALLOCATE(d_u_vdf(klon,klev),d_v_vdf(klon,klev)) 581 598 ALLOCATE(d_t_oli(klon,klev),d_t_oro(klon,klev)) … … 589 606 ! Special RRTM 590 607 ALLOCATE(ZLWFT0_i(klon,klev+1),ZSWFT0_i(klon,klev+1),ZFLDN0(klon,klev+1)) 608 ZFLDN0= 0. 591 609 ALLOCATE(ZFLUP0(klon,klev+1),ZFSDN0(klon,klev+1),ZFSUP0(klon,klev+1)) 592 610 ! … … 603 621 ALLOCATE(dv_gwd_rando(klon,klev),dv_gwd_front(klon,klev)) 604 622 ALLOCATE(east_gwstress(klon,klev),west_gwstress(klon,klev)) 623 east_gwstress(:,:)=0 !ym missing init 624 west_gwstress(:,:)=0 !ym missing init 605 625 ALLOCATE(d_t_hin(klon,klev)) 606 626 ALLOCATE(d_q_ch4(klon,klev)) … … 627 647 ALLOCATE(od865aer(klon)) 628 648 ALLOCATE(dryod550aer(klon)) 649 dryod550aer(:) = 0. 629 650 ALLOCATE(abs550aer(klon)) 651 abs550aer(:) = 0. 630 652 ALLOCATE(ec550aer(klon,klev)) 631 653 ALLOCATE(od550lt1aer(klon)) … … 672 694 ALLOCATE(toplwad0_aerop(klon), sollwad0_aerop(klon)) 673 695 674 ! FH Ajout de celles n ??cessaires au phys_output_write_mod696 ! FH Ajout de celles necessaires au phys_output_write_mod 675 697 676 698 ALLOCATE(tal1(klon), pal1(klon), pab1(klon), pab2(klon)) … … 721 743 !! ALLOCATE(q_x(klon,klev), q_w(klon,klev)) 722 744 !>jyg 723 ALLOCATE(d_t_vdf_x(klon,klev), d_t_vdf_w(klon,klev)) 724 ALLOCATE(d_q_vdf_x(klon,klev), d_q_vdf_w(klon,klev)) 745 ALLOCATE(dtvdf_x(klon,klev), dtvdf_w(klon,klev)) 746 dtvdf_x = 0 ; dtvdf_w=0 ; !ym missing init 747 ALLOCATE(dqvdf_x(klon,klev), dqvdf_w(klon,klev)) 748 dqvdf_x = 0 ; dqvdf_w=0 ; !ym missing init 725 749 ALLOCATE(pbl_tke_input(klon,klev+1,nbsrf)) 726 750 ALLOCATE(t_therm(klon,klev), q_therm(klon,klev),u_therm(klon,klev), v_therm(klon,klev)) … … 736 760 ALLOCATE(zt2m_min_mon(klon), zt2m_max_mon(klon)) 737 761 ALLOCATE(t2m_min_mon(klon), t2m_max_mon(klon)) 762 ALLOCATE(zq2m_cor(klon), zt2m_cor(klon), zu10m_cor(klon), zv10m_cor(klon)) 763 ALLOCATE(zrh2m_cor(klon), zqsat2m_cor(klon)) 738 764 ALLOCATE(sens(klon), flwp(klon), fiwp(klon)) 739 765 ALLOCATE(alp_bl_conv(klon), alp_bl_det(klon)) 766 alp_bl_conv(:)=0 ; alp_bl_det(:)=0 740 767 ALLOCATE(alp_bl_fluct_m(klon), alp_bl_fluct_tke(klon)) 768 alp_bl_fluct_m(:)=0 ; alp_bl_fluct_tke(:)= 0. 741 769 ALLOCATE(alp_bl_stat(klon), n2(klon), s2(klon)) 770 alp_bl_stat(:)=0 742 771 ALLOCATE(proba_notrig(klon), random_notrig(klon)) 743 772 ALLOCATE(cv_gen(klon)) … … 764 793 ! Deep convective variables used in phytrac 765 794 ALLOCATE(pmflxr(klon, klev+1), pmflxs(klon, klev+1)) 766 ALLOCATE(wdtrainA(klon,klev),wdtrain M(klon,klev))795 ALLOCATE(wdtrainA(klon,klev),wdtrainS(klon,klev),wdtrainM(klon,klev)) 767 796 ALLOCATE(dnwd(klon, klev), upwd(klon, klev) ) 768 797 ALLOCATE(ep(klon,klev)) ! epmax_cape … … 774 803 ALLOCATE(ev(klon,klev) ) 775 804 ALLOCATE(elij(klon,klev,klev) ) 805 ALLOCATE(qtaa(klon,klev) ) 776 806 ALLOCATE(clw(klon,klev) ) 777 807 ALLOCATE(epmlmMm(klon,klev,klev), eplaMm(klon,klev) ) … … 968 998 DEALLOCATE(toplwad0_aerop, sollwad0_aerop) 969 999 970 ! FH Ajout de celles n ??cessaires au phys_output_write_mod1000 ! FH Ajout de celles necessaires au phys_output_write_mod 971 1001 DEALLOCATE(tal1, pal1, pab1, pab2) 972 1002 DEALLOCATE(ptstar, pt0, slp) … … 1027 1057 DEALLOCATE(zt2m_min_mon, zt2m_max_mon) 1028 1058 DEALLOCATE(t2m_min_mon, t2m_max_mon) 1059 DEALLOCATE(zq2m_cor, zt2m_cor, zu10m_cor, zv10m_cor) 1060 DEALLOCATE(zrh2m_cor, zqsat2m_cor) 1029 1061 DEALLOCATE(sens, flwp, fiwp) 1030 1062 DEALLOCATE(alp_bl_conv,alp_bl_det) … … 1053 1085 1054 1086 DEALLOCATE(pmflxr, pmflxs) 1055 DEALLOCATE(wdtrainA, wdtrain M)1087 DEALLOCATE(wdtrainA, wdtrainS, wdtrainM) 1056 1088 DEALLOCATE(upwd, dnwd) 1057 1089 DEALLOCATE(ep) … … 1063 1095 DEALLOCATE(ev ) 1064 1096 DEALLOCATE(elij ) 1097 DEALLOCATE(qtaa ) 1065 1098 DEALLOCATE(clw ) 1066 1099 DEALLOCATE(epmlmMm, eplaMm ) -
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_ctrlout_mod.F90
r3601 r3605 7 7 USE indice_sol_mod 8 8 USE aero_mod 9 10 11 9 12 10 IMPLICIT NONE … … 26 24 'io_lat', '', '', (/ ('once', i=1, 10) /)) 27 25 28 !!! Com osantes de la coordonnee sigma-hybride26 !!! Composantes de la coordonnee sigma-hybride 29 27 !!! Ap et Bp et interfaces 30 28 TYPE(ctrl_out), SAVE :: o_Ahyb = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 31 'Ahyb', ' ', '', (/ ('once', i=1, 10) /))29 'Ahyb', 'Ahyb at level interface', '', (/ ('once', i=1, 10) /)) 32 30 TYPE(ctrl_out), SAVE :: o_Bhyb = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 33 'Bhyb', '', '', (/ ('once', i=1, 10) /)) 34 TYPE(ctrl_out), SAVE :: o_Ahyb_inter = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 35 'Ahyb_inter', '', '', (/ ('once', i=1, 10) /)) 36 TYPE(ctrl_out), SAVE :: o_Bhyb_inter = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 37 'Bhyb_inter', '', '', (/ ('once', i=1, 10) /)) 31 'Bhyb', 'Bhyb at level interface', '', (/ ('once', i=1, 10) /)) 32 TYPE(ctrl_out), SAVE :: o_Ahyb_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 33 'Ahyb_bounds', '', '', (/ ('once', i=1, 10) /)) 34 TYPE(ctrl_out), SAVE :: o_Bhyb_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 35 'Bhyb_bounds', '', '', (/ ('once', i=1, 10) /)) 36 !!! Composantes de la coordonnee sigma-hybride au milieu des couches 37 !!! Aps et Bps et interfaces 38 TYPE(ctrl_out), SAVE :: o_Ahyb_mid = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 39 'Ahyb_mid', 'Ahyb at the middle of the level', '', (/ ('once', i=1, 10) /)) 40 TYPE(ctrl_out), SAVE :: o_Bhyb_mid = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 41 'Bhyb_mid', 'Bhyb at the middle of the level', '', (/ ('once', i=1, 10) /)) 42 TYPE(ctrl_out), SAVE :: o_Ahyb_mid_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 43 'Ahyb_mid_bounds', '', '', (/ ('once', i=1, 10) /)) 44 TYPE(ctrl_out), SAVE :: o_Bhyb_mid_bounds = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 45 'Bhyb_mid_bounds', '', '', (/ ('once', i=1, 10) /)) 46 38 47 TYPE(ctrl_out), SAVE :: o_Alt = ctrl_out((/ 1, 1, 1, 1, 1, 1, 11, 11, 11, 11/), & 39 48 'Alt', '', '', (/ ('', i=1, 10) /)) … … 1018 1027 !FC 1019 1028 1020 1021 1029 TYPE(ctrl_out), SAVE, DIMENSION(4) :: o_l_mixmin = (/ & 1022 1030 ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/),'l_mixmin_ter', & … … 1284 1292 !--end add ThL 1285 1293 1294 !---CO2 fluxes for interactive CO2 configuration 1295 TYPE(ctrl_out), SAVE :: o_flx_co2_ff = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1296 'flx_co2_ff', 'CO2 flux from fossil fuel and cement', '1', (/ ('', i=1, 10) /)) 1297 TYPE(ctrl_out), SAVE :: o_flx_co2_bb = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1298 'flx_co2_bb', 'CO2 flux from biomass burning', '1', (/ ('', i=1, 10) /)) 1299 TYPE(ctrl_out), SAVE :: o_flx_co2_ocean = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1300 'flx_co2_ocean', 'CO2 flux from the ocean', '1', (/ ('', i=1, 10) /)) 1301 TYPE(ctrl_out), SAVE :: o_flx_co2_land = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1302 'flx_co2_land', 'CO2 flux from the land', '1', (/ ('', i=1, 10) /)) 1303 1286 1304 #ifdef CPP_StratAer 1287 1305 !--extinction coefficient … … 1292 1310 !--strat aerosol optical depth 1293 1311 TYPE(ctrl_out), SAVE :: o_tau_strat_550 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1294 ' od550_strat_only', 'Stratospheric Aerosol Optical depth at 550 nm ', '1', (/ ('', i=1, 10) /))1312 'OD550_strat_only', 'Stratospheric Aerosol Optical depth at 550 nm ', '1', (/ ('', i=1, 10) /)) 1295 1313 TYPE(ctrl_out), SAVE :: o_tau_strat_1020 = ctrl_out((/ 11, 11, 11, 11, 11, 11, 11, 11, 11, 1/), & 1296 1314 'OD1020_strat_only', 'Stratospheric Aerosol Optical depth at 1020 nm ', '1', (/ ('', i=1, 10) /)) … … 1366 1384 TYPE(ctrl_out), SAVE :: o_temp = ctrl_out((/ 2, 3, 4, 10, 10, 10, 11, 11, 11, 11/), & 1367 1385 'temp', 'Air temperature', 'K', (/ ('', i=1, 10) /)) 1386 TYPE(ctrl_out), SAVE :: o_heat_volc = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1387 'heat_volc', 'SW heating rate due to volcano', 'K/s', (/ ('', i=1, 10) /)) 1388 TYPE(ctrl_out), SAVE :: o_cool_volc = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1389 'cool_volc', 'LW cooling rate due to volcano', 'K/s', (/ ('', i=1, 10) /)) 1368 1390 TYPE(ctrl_out), SAVE :: o_theta = ctrl_out((/ 2, 3, 4, 10, 10, 10, 11, 11, 11, 11/), & 1369 1391 'theta', 'Potential air temperature', 'K', (/ ('', i=1, 10) /)) … … 1508 1530 TYPE(ctrl_out), SAVE :: o_clwcon = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1509 1531 'clwcon', 'Convective Cloud Liquid water content', 'kg/kg', (/ ('', i=1, 10) /)) 1532 TYPE(ctrl_out), SAVE :: o_Mipsh = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1533 'Mipsh', 'mass flux shed from adiab. ascents', 'kg/m2/s', (/ ('', i=1, 10) /)) 1510 1534 TYPE(ctrl_out), SAVE :: o_Ma = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1511 'Ma', 'undilute adiab updraft ', 'kg/m2/s', (/ ('', i=1, 10) /))1535 'Ma', 'undilute adiab updraft mass flux', 'kg/m2/s', (/ ('', i=1, 10) /)) 1512 1536 TYPE(ctrl_out), SAVE :: o_dnwd = ctrl_out((/ 4, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1513 1537 'dnwd', 'saturated downdraft', 'kg/m2/s', (/ ('', i=1, 10) /)) … … 1573 1597 TYPE(ctrl_out), SAVE :: o_wdtrainA = ctrl_out((/ 4, 5, 10, 4, 10, 10, 11, 11, 11, 11 /), & 1574 1598 'wdtrainA', 'precipitation from AA', '-', (/ ('', i=1, 10) /)) 1599 TYPE(ctrl_out), SAVE :: o_wdtrainS = ctrl_out((/ 4, 5, 10, 4, 10, 10, 11, 11, 11, 11 /), & 1600 'wdtrainS', 'precipitation from shedding of AA', '-', (/ ('', i=1, 10) /)) 1575 1601 TYPE(ctrl_out), SAVE :: o_wdtrainM = ctrl_out((/ 4, 5, 10, 4, 10, 10, 11, 11, 11, 11 /), & 1576 1602 'wdtrainM', 'precipitation from mixture', '-', (/ ('', i=1, 10) /)) 1577 1603 TYPE(ctrl_out), SAVE :: o_Vprecip = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1578 1604 'Vprecip', 'precipitation vertical profile', '-', (/ ('', i=1, 10) /)) 1605 TYPE(ctrl_out), SAVE :: o_qtaa = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1606 'qtaa', 'specific total water in adiabatic ascents', 'kg/kg', (/ ('', i=1, 10) /)) 1607 TYPE(ctrl_out), SAVE :: o_clwaa = ctrl_out((/ 10, 10, 10, 10, 10, 10, 11, 11, 11, 11/), & 1608 'Clwaa', 'specific condensed water in adiabatic ascents', 'kg/kg', (/ ('', i=1, 10) /)) 1579 1609 TYPE(ctrl_out), SAVE :: o_ftd = ctrl_out((/ 4, 5, 10, 10, 10, 10, 11, 11, 11, 11/), & 1580 1610 'ftd', 'tend temp due aux descentes precip', '-', (/ ('', i=1, 10) /)) -
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_mod.F90
r3125 r3605 131 131 90., 90., 90., 90., 90. /) 132 132 REAL, DIMENSION(klev,2) :: Ahyb_bounds, Bhyb_bounds 133 REAL, DIMENSION(klev ) :: lev_index133 REAL, DIMENSION(klev+1) :: lev_index 134 134 135 135 #ifdef CPP_XIOS … … 156 156 lev_index(ilev) = REAL(ilev) 157 157 END DO 158 lev_index(klev+1) = REAL(klev+1) 158 159 159 160 IF (.NOT. ALLOCATED(o_trac)) ALLOCATE(o_trac(nqtot)) … … 361 362 CALL wxios_add_vaxis("klev", levmax(iff) - levmin(iff) + 1, & 362 363 lev_index(levmin(iff):levmax(iff))) 364 CALL wxios_add_vaxis("klevp1", klev+1, & 365 lev_index(1:klev+1)) 363 366 CALL wxios_add_vaxis("bnds", 2, (/1.,2./)) 364 367 -
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_output_write_mod.F90
r3601 r3605 17 17 SUBROUTINE phys_output_write(itap, pdtphys, paprs, pphis, & 18 18 pplay, lmax_th, aerosol_couple, & 19 ok_ade, ok_aie, ivap, iliq, isol, new_aod, ok_sync, &19 ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod, ok_sync, & 20 20 ptconv, read_climoz, clevSTD, ptconvth, & 21 21 d_u, d_t, qx, d_qx, zmasse, flag_aerosol, flag_aerosol_strat, ok_cdnc) … … 32 32 USE phys_output_ctrlout_mod, ONLY: o_phis, o_aire, is_ter, is_lic, is_oce, & 33 33 o_longitude, o_latitude, & 34 o_Ahyb, o_Bhyb,o_Ahyb_inter, o_Bhyb_inter, & 34 o_Ahyb, o_Bhyb,o_Ahyb_bounds, o_Bhyb_bounds, & 35 o_Ahyb_mid, o_Bhyb_mid,o_Ahyb_mid_bounds, o_Bhyb_mid_bounds, & 35 36 is_ave, is_sic, o_contfracATM, o_contfracOR, & 36 37 o_aireTER, o_flat, o_slp, o_ptstar, o_pt0, o_tsol, & … … 72 73 o_uwat, o_vwat, & 73 74 o_ptop, o_fbase, o_plcl, o_plfc, & 74 o_wbeff, o_convoccur, o_cape_max, o_upwd, o_ep,o_epmax_diag, o_Ma, & 75 o_wbeff, o_convoccur, o_cape_max, o_upwd, o_ep,o_epmax_diag, & 76 o_Mipsh, o_Ma, & 75 77 o_dnwd, o_dnwd0, o_ftime_deepcv, o_ftime_con, o_mc, & 76 78 o_prw, o_prlw, o_prsw, o_s_pblh, o_s_pblt, o_s_lcl, & … … 87 89 o_wake_s, o_wake_deltat, o_wake_deltaq, & 88 90 o_wake_omg, o_dtwak, o_dqwak, o_dqwak2d, o_Vprecip, & 89 o_ftd, o_fqd, o_wdtrainA, o_wdtrainM, & 91 o_qtaa, o_Clwaa, & 92 o_ftd, o_fqd, o_wdtrainA, o_wdtrainS, o_wdtrainM, & 90 93 o_n2, o_s2, o_proba_notrig, & 91 94 o_random_notrig, o_ale_bl_stat, & … … 196 199 ! Tropopause 197 200 o_p_tropopause, o_z_tropopause, o_t_tropopause, & 198 o_col_O3_strato, o_col_O3_tropo, & ! Added ThL 201 o_col_O3_strato, o_col_O3_tropo, & 202 !--interactive CO2 203 o_flx_co2_ocean, o_flx_co2_land, o_flx_co2_ff, o_flx_co2_bb, & 199 204 o_t_int, o_s_int, o_ds_ns, o_dt_ns, o_dter, o_dser, o_tkt, o_tks, & 200 205 o_rf, o_taur … … 214 219 o_vsed_aer, o_tau_strat_1020, o_ext_strat_1020, o_f_r_wet 215 220 #endif 221 222 USE phys_output_ctrlout_mod, ONLY: o_heat_volc, o_cool_volc !NL 223 USE phys_state_var_mod, ONLY: heat_volc, cool_volc !NL 216 224 217 225 USE phys_state_var_mod, ONLY: pctsrf, rain_fall, snow_fall, & … … 227 235 delta_tsurf, & 228 236 wstar, cape, ema_pcb, ema_pct, & 229 ema_cbmf, M a, fm_therm, ale_bl, alp_bl, ale, &237 ema_cbmf, Mipsh, Ma, fm_therm, ale_bl, alp_bl, ale, & 230 238 alp, cin, wake_pe, wake_dens, wake_s, wake_deltat, & 231 239 wake_deltaq, ftd, fqd, ale_bl_trig, albsol1, & … … 244 252 245 253 USE phys_local_var_mod, ONLY: zxfluxlat, slp, ptstar, pt0, zxtsol, zt2m, & 254 zt2m_cor,zq2m_cor,zu10m_cor,zv10m_cor, zrh2m_cor, zqsat2m_cor, & 246 255 t2m_min_mon, t2m_max_mon, evap, & 247 256 l_mixmin,l_mix, & … … 267 276 kh ,kh_x ,kh_w , & 268 277 cv_gen, wake_h, & 269 wake_omg, d_t_wake, d_q_wake, Vprecip, &270 wdtrainA, wdtrain M, n2, s2, proba_notrig, &278 wake_omg, d_t_wake, d_q_wake, Vprecip, qtaa, Clw, & 279 wdtrainA, wdtrainS, wdtrainM, n2, s2, proba_notrig, & 271 280 random_notrig, & 272 281 alp_bl_det, alp_bl_fluct_m, alp_bl_conv, & … … 329 338 #endif 330 339 340 USE carbon_cycle_mod, ONLY: fco2_ff, fco2_bb, fco2_land, fco2_ocean 341 331 342 USE phys_output_var_mod, ONLY: vars_defined, snow_o, zfra_o, bils_diss, & 332 343 bils_ec,bils_ech, bils_tke, bils_kinetic, bils_latent, bils_enthalp, & … … 368 379 ! ug Pour les sorties XIOS 369 380 USE xios 370 USE wxios, ONLY: wxios_closedef, missing_val 381 USE wxios, ONLY: wxios_closedef, missing_val, wxios_set_context 371 382 #endif 372 383 USE phys_cal_mod, ONLY : mth_len … … 390 401 INTEGER, DIMENSION(klon) :: lmax_th 391 402 LOGICAL :: aerosol_couple, ok_sync 392 LOGICAL :: ok_ade, ok_aie, new_aod403 LOGICAL :: ok_ade, ok_aie, ok_volcan, new_aod 393 404 LOGICAL, DIMENSION(klon, klev) :: ptconv, ptconvth 394 405 REAL :: pdtphys … … 417 428 REAL, PARAMETER :: dobson_u = 2.1415e-05 ! Dobson unit, in kg m-2 418 429 ! REAL, PARAMETER :: missing_val=nf90_fill_real 419 REAL, DIMENSION(klev,2) :: Ahyb_bounds, Bhyb_bounds 430 REAL, DIMENSION(klev+1,2) :: Ahyb_bounds, Bhyb_bounds 431 REAL, DIMENSION(klev,2) :: Ahyb_mid_bounds, Bhyb_mid_bounds 420 432 INTEGER :: ilev 421 433 #ifndef CPP_XIOS … … 440 452 CALL set_itau_iophy(itau_w) 441 453 442 IF (.NOT.vars_defined) THEN 443 iinitend = 2 444 ELSE 454 ! IF (.NOT.vars_defined) THEN 445 455 iinitend = 1 446 ENDIF 447 448 DO ilev=1,klev 449 Ahyb_bounds(ilev,1) = ap(ilev) 450 Ahyb_bounds(ilev,2) = ap(ilev+1) 451 Bhyb_bounds(ilev,1) = bp(ilev) 452 Bhyb_bounds(ilev,2) = bp(ilev+1) 456 ! ELSE 457 ! iinitend = 1 458 ! ENDIF 459 460 #ifdef CPP_XIOS 461 CALL wxios_set_context 462 #endif 463 464 Ahyb_bounds(1,1) = 0. 465 Ahyb_bounds(1,2) = aps(1) 466 Bhyb_bounds(1,1) = 1. 467 Bhyb_bounds(1,2) = bps(1) 468 DO ilev=2,klev 469 Ahyb_bounds(ilev,1) = aps(ilev-1) 470 Ahyb_bounds(ilev,2) = aps(ilev) 471 Bhyb_bounds(ilev,1) = bps(ilev-1) 472 Bhyb_bounds(ilev,2) = bps(ilev) 473 ENDDO 474 Ahyb_bounds(klev+1,1) = aps(klev) 475 Ahyb_bounds(klev+1,2) = 0. 476 Bhyb_bounds(klev+1,1) = bps(klev) 477 Bhyb_bounds(klev+1,2) = 0. 478 479 DO ilev=1, klev 480 Ahyb_mid_bounds(ilev,1) = ap(ilev) 481 Ahyb_mid_bounds(ilev,2) = ap(ilev+1) 482 Bhyb_mid_bounds(ilev,1) = bp(ilev) 483 Bhyb_mid_bounds(ilev,2) = bp(ilev+1) 453 484 END DO 454 485 … … 565 596 CALL histwrite_phy("R_incl",R_incl) 566 597 CALL histwrite_phy("solaire",solaire) 567 CALL histwrite_phy(o_Ahyb, aps) 568 CALL histwrite_phy(o_Bhyb, bps) 569 CALL histwrite_phy(o_Ahyb_inter, Ahyb_bounds) 570 CALL histwrite_phy(o_Bhyb_inter, Bhyb_bounds) 598 CALL histwrite_phy(o_Ahyb, ap) 599 CALL histwrite_phy(o_Bhyb, bp) 600 CALL histwrite_phy(o_Ahyb_bounds, Ahyb_bounds) 601 CALL histwrite_phy(o_Bhyb_bounds, Bhyb_bounds) 602 CALL histwrite_phy(o_Ahyb_mid, aps) 603 CALL histwrite_phy(o_Bhyb_mid, bps) 604 CALL histwrite_phy(o_Ahyb_mid_bounds, Ahyb_mid_bounds) 605 CALL histwrite_phy(o_Bhyb_mid_bounds, Bhyb_mid_bounds) 571 606 CALL histwrite_phy(o_longitude, longitude_deg) 572 607 CALL histwrite_phy(o_latitude, latitude_deg) … … 636 671 CALL histwrite_phy(o_slp, slp) 637 672 CALL histwrite_phy(o_tsol, zxtsol) 638 CALL histwrite_phy(o_t2m, zt2m )639 CALL histwrite_phy(o_t2m_min, zt2m )640 CALL histwrite_phy(o_t2m_max, zt2m )673 CALL histwrite_phy(o_t2m, zt2m_cor) 674 CALL histwrite_phy(o_t2m_min, zt2m_cor) 675 CALL histwrite_phy(o_t2m_max, zt2m_cor) 641 676 CALL histwrite_phy(o_t2m_max_mon, t2m_max_mon) 642 677 CALL histwrite_phy(o_t2m_min_mon, t2m_min_mon) … … 644 679 IF (vars_defined) THEN 645 680 DO i=1, klon 646 zx_tmp_fi2d(i)=SQRT(zu10m (i)*zu10m(i)+zv10m(i)*zv10m(i))681 zx_tmp_fi2d(i)=SQRT(zu10m_cor(i)*zu10m_cor(i)+zv10m_cor(i)*zv10m_cor(i)) 647 682 ENDDO 648 683 ENDIF … … 651 686 IF (vars_defined) THEN 652 687 DO i=1, klon 653 zx_tmp_fi2d(i)=SQRT(zu10m (i)*zu10m(i)+zv10m(i)*zv10m(i))688 zx_tmp_fi2d(i)=SQRT(zu10m_cor(i)*zu10m_cor(i)+zv10m_cor(i)*zv10m_cor(i)) 654 689 ENDDO 655 690 ENDIF … … 664 699 ENDIF 665 700 CALL histwrite_phy(o_sicf, zx_tmp_fi2d) 666 CALL histwrite_phy(o_q2m, zq2m )701 CALL histwrite_phy(o_q2m, zq2m_cor) 667 702 CALL histwrite_phy(o_ustar, zustar) 668 CALL histwrite_phy(o_u10m, zu10m )669 CALL histwrite_phy(o_v10m, zv10m )703 CALL histwrite_phy(o_u10m, zu10m_cor) 704 CALL histwrite_phy(o_v10m, zv10m_cor) 670 705 671 706 IF (vars_defined) THEN … … 716 751 CALL histwrite_phy(o_fsnow, zfra_o) 717 752 CALL histwrite_phy(o_evap, evap) 718 CALL histwrite_phy(o_tops, topsw*swradcorr) 719 CALL histwrite_phy(o_tops0, topsw0*swradcorr) 753 754 IF (vars_defined) THEN 755 zx_tmp_fi2d = topsw*swradcorr 756 ENDIF 757 CALL histwrite_phy(o_tops, zx_tmp_fi2d) 758 759 IF (vars_defined) THEN 760 zx_tmp_fi2d = topsw0*swradcorr 761 ENDIF 762 CALL histwrite_phy(o_tops0, zx_tmp_fi2d) 763 720 764 CALL histwrite_phy(o_topl, toplw) 721 765 CALL histwrite_phy(o_topl0, toplw0) … … 750 794 ENDIF 751 795 CALL histwrite_phy(o_nettop, zx_tmp_fi2d) 752 CALL histwrite_phy(o_SWup200, SWup200*swradcorr) 753 CALL histwrite_phy(o_SWup200clr, SWup200clr*swradcorr) 754 CALL histwrite_phy(o_SWdn200, SWdn200*swradcorr) 755 CALL histwrite_phy(o_SWdn200clr, SWdn200clr*swradcorr) 796 797 IF (vars_defined) THEN 798 zx_tmp_fi2d = SWup200*swradcorr 799 ENDIF 800 CALL histwrite_phy(o_SWup200, zx_tmp_fi2d) 801 802 IF (vars_defined) THEN 803 zx_tmp_fi2d = SWup200clr*swradcorr 804 ENDIF 805 CALL histwrite_phy(o_SWup200clr, zx_tmp_fi2d) 806 807 IF (vars_defined) THEN 808 zx_tmp_fi2d = SWdn200*swradcorr 809 ENDIF 810 CALL histwrite_phy(o_SWdn200, zx_tmp_fi2d) 811 812 813 IF (vars_defined) THEN 814 zx_tmp_fi2d = SWdn200clr*swradcorr 815 ENDIF 816 CALL histwrite_phy(o_SWdn200clr, zx_tmp_fi2d) 817 756 818 CALL histwrite_phy(o_LWup200, LWup200) 757 819 CALL histwrite_phy(o_LWup200clr, LWup200clr) 758 820 CALL histwrite_phy(o_LWdn200, LWdn200) 759 821 CALL histwrite_phy(o_LWdn200clr, LWdn200clr) 760 CALL histwrite_phy(o_sols, solsw*swradcorr) 761 CALL histwrite_phy(o_sols0, solsw0*swradcorr) 822 823 IF (vars_defined) THEN 824 zx_tmp_fi2d = solsw*swradcorr 825 ENDIF 826 CALL histwrite_phy(o_sols, zx_tmp_fi2d) 827 828 829 IF (vars_defined) THEN 830 zx_tmp_fi2d = solsw0*swradcorr 831 ENDIF 832 CALL histwrite_phy(o_sols0, zx_tmp_fi2d) 762 833 CALL histwrite_phy(o_soll, sollw) 763 834 CALL histwrite_phy(o_soll0, sollw0) … … 909 980 IF (iflag_pbl > 1) THEN 910 981 CALL histwrite_phy(o_tke_srf(nsrf), pbl_tke(:,1:klev,nsrf)) 911 CALL histwrite_phy(o_l_mix(nsrf), l_mix(:,1:klev,nsrf))982 !CALL histwrite_phy(o_l_mix(nsrf), l_mix(:,1:klev,nsrf)) 912 983 CALL histwrite_phy(o_l_mixmin(nsrf), l_mixmin(:,1:klev,nsrf)) 913 984 CALL histwrite_phy(o_tke_max_srf(nsrf), pbl_tke(:,1:klev,nsrf)) … … 954 1025 CALL histwrite_phy(o_cldt, cldt) 955 1026 CALL histwrite_phy(o_JrNt, JrNt) 956 CALL histwrite_phy(o_cldljn, cldl*JrNt) 957 CALL histwrite_phy(o_cldmjn, cldm*JrNt) 958 CALL histwrite_phy(o_cldhjn, cldh*JrNt) 959 CALL histwrite_phy(o_cldtjn, cldt*JrNt) 1027 1028 IF (vars_defined) zx_tmp_fi2d=cldl*JrNt 1029 CALL histwrite_phy(o_cldljn, zx_tmp_fi2d) 1030 1031 IF (vars_defined) zx_tmp_fi2d=cldm*JrNt 1032 CALL histwrite_phy(o_cldmjn, zx_tmp_fi2d) 1033 1034 IF (vars_defined) zx_tmp_fi2d=cldh*JrNt 1035 CALL histwrite_phy(o_cldhjn, zx_tmp_fi2d) 1036 1037 IF (vars_defined) zx_tmp_fi2d=cldt*JrNt 1038 CALL histwrite_phy(o_cldtjn, zx_tmp_fi2d) 1039 960 1040 CALL histwrite_phy(o_cldq, cldq) 961 1041 IF (vars_defined) zx_tmp_fi2d(1:klon) = flwp(1:klon) … … 1108 1188 ! Wakes 1109 1189 IF (iflag_con.EQ.3) THEN 1190 CALL histwrite_phy(o_Mipsh, Mipsh) 1110 1191 IF (iflag_wake>=1) THEN 1111 1192 CALL histwrite_phy(o_ale_wk, ale_wake) … … 1158 1239 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_wake(1:klon,1:klev)/pdtphys 1159 1240 CALL histwrite_phy(o_dqwak, zx_tmp_fi3d) 1160 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1241 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1161 1242 CALL histwrite_phy(o_dqwak2d, zx_tmp_fi2d) 1162 1243 ENDIF ! iflag_wake>=1 … … 1168 1249 ! etendue a iflag_con=3 (jyg) 1169 1250 CALL histwrite_phy(o_Vprecip, Vprecip) 1251 CALL histwrite_phy(o_qtaa, qtaa) 1252 CALL histwrite_phy(o_clwaa, clw) 1170 1253 CALL histwrite_phy(o_wdtrainA, wdtrainA) 1254 CALL histwrite_phy(o_wdtrainS, wdtrainS) 1171 1255 CALL histwrite_phy(o_wdtrainM, wdtrainM) 1172 1256 ENDIF !(iflag_con.EQ.3.or.iflag_con.EQ.30) … … 1208 1292 IF (slab_gm) THEN 1209 1293 CALL histwrite_phy(o_slab_gm, dt_gm(:,1:nslay)) 1210 END 1294 ENDIF 1211 1295 IF (slab_hdiff) THEN 1212 1296 IF (nslay.EQ.1) THEN … … 1257 1341 ! CALL histwrite_phy(o_rh2m_max, zx_tmp_fi2d) 1258 1342 1259 CALL histwrite_phy(o_qsat2m, qsat2m)1343 CALL histwrite_phy(o_qsat2m, zqsat2m_cor) 1260 1344 CALL histwrite_phy(o_tpot, tpot) 1261 1345 CALL histwrite_phy(o_tpote, tpote) … … 1322 1406 1323 1407 ! ThL -- In the following, we assume read_climoz == 1 1324 zx_tmp_fi2d = 0.0 ! Computation for strato, added ThL 1325 DO k=1, klev 1326 zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * stratomask(:,k) * 1.e3 1327 END DO 1408 IF (vars_defined) THEN 1409 zx_tmp_fi2d = 0.0 ! Computation for strato, added ThL 1410 DO k=1, klev 1411 zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * stratomask(:,k) * 1.e3 1412 END DO 1413 ENDIF 1328 1414 CALL histwrite_phy(o_col_O3_strato, zx_tmp_fi2d) ! Added ThL 1329 zx_tmp_fi2d = 0.0 ! Computation for tropo, added ThL 1330 DO k=1, klev 1331 zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * (1.0-stratomask(:,k)) * 1.e3 1332 END DO 1415 1416 IF (vars_defined) THEN 1417 zx_tmp_fi2d = 0.0 ! Computation for tropo, added ThL 1418 DO k=1, klev 1419 zx_tmp_fi2d(:) = zx_tmp_fi2d(:) + wo(:,k,1) * (1.0-stratomask(:,k)) * 1.e3 1420 END DO 1421 ENDIF 1333 1422 CALL histwrite_phy(o_col_O3_tropo, zx_tmp_fi2d) ! Added ThL 1334 1423 ! end add ThL … … 1370 1459 ENDIF 1371 1460 #endif 1461 !NL 1462 IF (ok_volcan .AND. ok_ade) THEN 1463 DO k=1, klev 1464 IF (vars_defined) zx_tmp_fi3d(:,k)=heat_volc(:,k)*swradcorr(:) 1465 ENDDO 1466 CALL histwrite_phy(o_heat_volc, zx_tmp_fi3d) 1467 DO k=1, klev 1468 IF (vars_defined) zx_tmp_fi3d(:,k)=cool_volc(:,k) 1469 ENDDO 1470 CALL histwrite_phy(o_cool_volc, zx_tmp_fi3d) 1471 ENDIF 1372 1472 IF (ok_ade) THEN 1373 CALL histwrite_phy(o_topswad, topswad_aero*swradcorr) 1374 CALL histwrite_phy(o_topswad0, topswad0_aero*swradcorr) 1375 CALL histwrite_phy(o_solswad, solswad_aero*swradcorr) 1376 CALL histwrite_phy(o_solswad0, solswad0_aero*swradcorr) 1473 IF (vars_defined) zx_tmp_fi2d(:)=topswad_aero*swradcorr 1474 CALL histwrite_phy(o_topswad, zx_tmp_fi2d) 1475 1476 IF (vars_defined) zx_tmp_fi2d(:)=topswad0_aero*swradcorr 1477 CALL histwrite_phy(o_topswad0, zx_tmp_fi2d) 1478 1479 IF (vars_defined) zx_tmp_fi2d(:)=solswad_aero*swradcorr 1480 CALL histwrite_phy(o_solswad, zx_tmp_fi2d) 1481 1482 IF (vars_defined) zx_tmp_fi2d(:)=solswad0_aero*swradcorr 1483 CALL histwrite_phy(o_solswad0, zx_tmp_fi2d) 1484 1377 1485 CALL histwrite_phy(o_toplwad, toplwad_aero) 1378 1486 CALL histwrite_phy(o_toplwad0, toplwad0_aero) … … 1381 1489 !====MS forcing diagnostics 1382 1490 IF (new_aod) THEN 1383 zx_tmp_fi2d(:)=topsw_aero(:,1)*swradcorr(:) 1491 !ym warning : topsw_aero, solsw_aero, topsw0_aero, solsw0_aero are not defined by model 1492 !ym => init to 0 in radlwsw_m.F90 ztopsw_aero, zsolsw_aero, ztopsw0_aero, zsolsw0_aero 1493 1494 IF (vars_defined) zx_tmp_fi2d(:)=topsw_aero(:,1)*swradcorr(:) 1384 1495 CALL histwrite_phy(o_swtoaas_nat,zx_tmp_fi2d) 1385 zx_tmp_fi2d(:)=solsw_aero(:,1)*swradcorr(:)1496 IF (vars_defined) zx_tmp_fi2d(:)=solsw_aero(:,1)*swradcorr(:) 1386 1497 CALL histwrite_phy(o_swsrfas_nat,zx_tmp_fi2d) 1387 zx_tmp_fi2d(:)=topsw0_aero(:,1)*swradcorr(:)1498 IF (vars_defined) zx_tmp_fi2d(:)=topsw0_aero(:,1)*swradcorr(:) 1388 1499 CALL histwrite_phy(o_swtoacs_nat,zx_tmp_fi2d) 1389 zx_tmp_fi2d(:)=solsw0_aero(:,1)*swradcorr(:)1500 IF (vars_defined) zx_tmp_fi2d(:)=solsw0_aero(:,1)*swradcorr(:) 1390 1501 CALL histwrite_phy(o_swsrfcs_nat,zx_tmp_fi2d) 1391 1502 !ant 1392 zx_tmp_fi2d(:)=topsw_aero(:,2)*swradcorr(:)1503 IF (vars_defined) zx_tmp_fi2d(:)=topsw_aero(:,2)*swradcorr(:) 1393 1504 CALL histwrite_phy(o_swtoaas_ant,zx_tmp_fi2d) 1394 zx_tmp_fi2d(:)=solsw_aero(:,2)*swradcorr(:)1505 IF (vars_defined) zx_tmp_fi2d(:)=solsw_aero(:,2)*swradcorr(:) 1395 1506 CALL histwrite_phy(o_swsrfas_ant,zx_tmp_fi2d) 1396 zx_tmp_fi2d(:)=topsw0_aero(:,2)*swradcorr(:)1507 IF (vars_defined) zx_tmp_fi2d(:)=topsw0_aero(:,2)*swradcorr(:) 1397 1508 CALL histwrite_phy(o_swtoacs_ant,zx_tmp_fi2d) 1398 zx_tmp_fi2d(:)=solsw0_aero(:,2)*swradcorr(:)1509 IF (vars_defined) zx_tmp_fi2d(:)=solsw0_aero(:,2)*swradcorr(:) 1399 1510 CALL histwrite_phy(o_swsrfcs_ant,zx_tmp_fi2d) 1400 1511 !cf 1401 1512 IF (.not. aerosol_couple) THEN 1402 zx_tmp_fi2d(:)=topswcf_aero(:,1)*swradcorr(:)1513 IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,1)*swradcorr(:) 1403 1514 CALL histwrite_phy(o_swtoacf_nat,zx_tmp_fi2d) 1404 zx_tmp_fi2d(:)=solswcf_aero(:,1)*swradcorr(:)1515 IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,1)*swradcorr(:) 1405 1516 CALL histwrite_phy(o_swsrfcf_nat,zx_tmp_fi2d) 1406 zx_tmp_fi2d(:)=topswcf_aero(:,2)*swradcorr(:)1517 IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,2)*swradcorr(:) 1407 1518 CALL histwrite_phy(o_swtoacf_ant,zx_tmp_fi2d) 1408 zx_tmp_fi2d(:)=solswcf_aero(:,2)*swradcorr(:)1519 IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,2)*swradcorr(:) 1409 1520 CALL histwrite_phy(o_swsrfcf_ant,zx_tmp_fi2d) 1410 zx_tmp_fi2d(:)=topswcf_aero(:,3)*swradcorr(:)1521 IF (vars_defined) zx_tmp_fi2d(:)=topswcf_aero(:,3)*swradcorr(:) 1411 1522 CALL histwrite_phy(o_swtoacf_zero,zx_tmp_fi2d) 1412 zx_tmp_fi2d(:)=solswcf_aero(:,3)*swradcorr(:)1523 IF (vars_defined) zx_tmp_fi2d(:)=solswcf_aero(:,3)*swradcorr(:) 1413 1524 CALL histwrite_phy(o_swsrfcf_zero,zx_tmp_fi2d) 1414 1525 ENDIF … … 1417 1528 ENDIF 1418 1529 IF (ok_aie) THEN 1419 CALL histwrite_phy(o_topswai, topswai_aero*swradcorr) 1420 CALL histwrite_phy(o_toplwai, toplwai_aero*swradcorr) 1421 CALL histwrite_phy(o_solswai, solswai_aero*swradcorr) 1422 CALL histwrite_phy(o_sollwai, sollwai_aero*swradcorr) 1530 IF (vars_defined) zx_tmp_fi2d(:)= topswai_aero*swradcorr 1531 CALL histwrite_phy(o_topswai, zx_tmp_fi2d) 1532 1533 IF (vars_defined) zx_tmp_fi2d(:)=toplwai_aero*swradcorr 1534 CALL histwrite_phy(o_toplwai, zx_tmp_fi2d) 1535 1536 IF (vars_defined) zx_tmp_fi2d(:)=solswai_aero*swradcorr 1537 CALL histwrite_phy(o_solswai, zx_tmp_fi2d) 1538 1539 IF (vars_defined) zx_tmp_fi2d(:)=sollwai_aero*swradcorr 1540 CALL histwrite_phy(o_sollwai, zx_tmp_fi2d) 1423 1541 ENDIF 1424 1542 IF (flag_aerosol.GT.0.AND.ok_cdnc) THEN … … 1435 1553 CALL histwrite_phy(o_icc3dstra, icc3dstra) 1436 1554 CALL histwrite_phy(o_cldicemxrat, zfice) 1437 zx_tmp_fi3d(:,:)=1-zfice(:,:)1555 IF (vars_defined) zx_tmp_fi3d(:,:)=1-zfice(:,:) 1438 1556 CALL histwrite_phy(o_cldwatmxrat, zx_tmp_fi3d) 1439 1557 CALL histwrite_phy(o_reffclwtop, reffclwtop) … … 1450 1568 CALL histwrite_phy(o_ovap, q_seri) 1451 1569 CALL histwrite_phy(o_oliq, ql_seri) 1452 CALL histwrite_phy(o_ocond, ql_seri+qs_seri) 1570 1571 IF (vars_defined) zx_tmp_fi3d = ql_seri+qs_seri 1572 CALL histwrite_phy(o_ocond, zx_tmp_fi3d) 1573 1453 1574 CALL histwrite_phy(o_geop, zphi) 1454 1575 CALL histwrite_phy(o_vitu, u_seri) … … 1457 1578 CALL histwrite_phy(o_pres, pplay) 1458 1579 CALL histwrite_phy(o_paprs, paprs(:,1:klev)) 1459 CALL histwrite_phy(o_zfull,zphi/RG) 1580 1581 IF (vars_defined) zx_tmp_fi3d = zphi/RG 1582 CALL histwrite_phy(o_zfull,zx_tmp_fi3d) 1460 1583 1461 1584 #ifdef CPP_XIOS … … 1502 1625 CALL histwrite_phy(o_rnebjn, zx_tmp_fi3d) 1503 1626 CALL histwrite_phy(o_rhum, zx_rh) 1504 CALL histwrite_phy(o_ozone, & 1505 wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd) 1627 1628 IF (vars_defined) zx_tmp_fi3d = wo(:, :, 1) * dobson_u * 1e3 / zmasse / rmo3 * rmd 1629 CALL histwrite_phy(o_ozone, zx_tmp_fi3d) 1506 1630 1507 1631 IF (read_climoz == 2) THEN 1508 CALL histwrite_phy(o_ozone_light, &1509 wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd)1632 IF (vars_defined) zx_tmp_fi3d = wo(:, :, 2) * dobson_u * 1e3 / zmasse / rmo3 * rmd 1633 CALL histwrite_phy(o_ozone_light, zx_tmp_fi3d) 1510 1634 ENDIF 1511 1635 … … 1515 1639 1516 1640 CALL histwrite_phy(o_dqphy, d_qx(:,:,ivap)) 1517 CALL water_int(klon,klev,d_qx(:,:,ivap),zmasse,zx_tmp_fi2d)1641 IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,ivap),zmasse,zx_tmp_fi2d) 1518 1642 CALL histwrite_phy(o_dqphy2d, zx_tmp_fi2d) 1519 1643 1520 1644 CALL histwrite_phy(o_dqlphy, d_qx(:,:,iliq)) 1521 CALL water_int(klon,klev,d_qx(:,:,iliq),zmasse,zx_tmp_fi2d)1645 IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,iliq),zmasse,zx_tmp_fi2d) 1522 1646 CALL histwrite_phy(o_dqlphy2d, zx_tmp_fi2d) 1523 1647 1524 1648 IF (nqo.EQ.3) THEN 1525 1649 CALL histwrite_phy(o_dqsphy, d_qx(:,:,isol)) 1526 CALL water_int(klon,klev,d_qx(:,:,isol),zmasse,zx_tmp_fi2d)1650 IF (vars_defined) CALL water_int(klon,klev,d_qx(:,:,isol),zmasse,zx_tmp_fi2d) 1527 1651 CALL histwrite_phy(o_dqsphy2d, zx_tmp_fi2d) 1528 1652 ELSE … … 1589 1713 ENDIF 1590 1714 CALL histwrite_phy(o_dtcon, zx_tmp_fi3d) 1591 if(iflag_thermals.eq.0)then1715 IF (iflag_thermals.EQ.0) THEN 1592 1716 IF (vars_defined) THEN 1593 1717 zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + & … … 1595 1719 ENDIF 1596 1720 CALL histwrite_phy(o_tntc, zx_tmp_fi3d) 1597 else if(iflag_thermals.ge.1.and.iflag_wake.EQ.1)then1721 ELSE IF(iflag_thermals.GE.1.AND.iflag_wake.EQ.1) THEN 1598 1722 IF (vars_defined) THEN 1599 1723 zx_tmp_fi3d(1:klon,1:klev)=d_t_con(1:klon,1:klev)/pdtphys + & … … 1602 1726 ENDIF 1603 1727 CALL histwrite_phy(o_tntc, zx_tmp_fi3d) 1604 endif1728 ENDIF 1605 1729 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_u_con(1:klon,1:klev)/pdtphys 1606 1730 CALL histwrite_phy(o_ducon, zx_tmp_fi3d) … … 1609 1733 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_con(1:klon,1:klev)/pdtphys 1610 1734 CALL histwrite_phy(o_dqcon, zx_tmp_fi3d) 1611 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1735 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1612 1736 CALL histwrite_phy(o_dqcon2d, zx_tmp_fi2d) 1613 1737 … … 1631 1755 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lsc(1:klon,1:klev)/pdtphys 1632 1756 CALL histwrite_phy(o_dqlsc, zx_tmp_fi3d) 1633 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1757 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1634 1758 CALL histwrite_phy(o_dqlsc2d, zx_tmp_fi2d) 1635 1759 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=beta_prec(1:klon,1:klev) … … 1644 1768 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lscth(1:klon,1:klev)/pdtphys 1645 1769 CALL histwrite_phy(o_dqlscth, zx_tmp_fi3d) 1646 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1770 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1647 1771 CALL histwrite_phy(o_dqlscth2d, zx_tmp_fi2d) 1648 1772 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_lscst(1:klon,1:klev)/pdtphys 1649 1773 CALL histwrite_phy(o_dqlscst, zx_tmp_fi3d) 1650 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1774 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1651 1775 CALL histwrite_phy(o_dqlscst2d, zx_tmp_fi2d) 1652 1776 CALL histwrite_phy(o_plulth, plul_th) 1653 1777 CALL histwrite_phy(o_plulst, plul_st) 1654 1778 IF (vars_defined) THEN 1655 doi=1,klon1779 DO i=1,klon 1656 1780 zx_tmp_fi2d(1:klon)=lmax_th(:) 1657 enddo1781 ENDDO 1658 1782 ENDIF 1659 1783 CALL histwrite_phy(o_lmaxth, zx_tmp_fi2d) … … 1702 1826 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_vdf(1:klon,1:klev)/pdtphys 1703 1827 CALL histwrite_phy(o_dqvdf, zx_tmp_fi3d) 1704 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1828 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1705 1829 CALL histwrite_phy(o_dqvdf2d, zx_tmp_fi2d) 1706 1830 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_eva(1:klon,1:klev)/pdtphys … … 1708 1832 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_eva(1:klon,1:klev)/pdtphys 1709 1833 CALL histwrite_phy(o_dqeva, zx_tmp_fi3d) 1710 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1834 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1711 1835 CALL histwrite_phy(o_dqeva2d, zx_tmp_fi2d) 1712 1836 CALL histwrite_phy(o_ratqs, ratqs) … … 1747 1871 ENDIF 1748 1872 CALL histwrite_phy(o_dqthe, zx_tmp_fi3d) 1749 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1873 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1750 1874 CALL histwrite_phy(o_dqthe2d, zx_tmp_fi2d) 1751 1875 ENDIF !iflag_thermals … … 1754 1878 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_q_ajsb(1:klon,1:klev)/pdtphys 1755 1879 CALL histwrite_phy(o_dqajs, zx_tmp_fi3d) 1756 CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d)1880 IF (vars_defined) CALL water_int(klon,klev,zx_tmp_fi3d,zmasse,zx_tmp_fi2d) 1757 1881 CALL histwrite_phy(o_dqajs2d, zx_tmp_fi2d) 1758 1882 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_swr(1:klon,1:klev)/pdtphys … … 1790 1914 1791 1915 IF (ok_hines) THEN 1792 CALL histwrite_phy(o_du_gwd_hines, du_gwd_hines/pdtphys) 1793 CALL histwrite_phy(o_dv_gwd_hines, dv_gwd_hines/pdtphys) 1916 IF (vars_defined) zx_tmp_fi3d=du_gwd_hines/pdtphys 1917 CALL histwrite_phy(o_du_gwd_hines, zx_tmp_fi3d) 1918 1919 IF (vars_defined) zx_tmp_fi3d= dv_gwd_hines/pdtphys 1920 CALL histwrite_phy(o_dv_gwd_hines, zx_tmp_fi3d) 1921 1794 1922 IF (vars_defined) zx_tmp_fi3d(1:klon,1:klev)=d_t_hin(1:klon,1:klev)/pdtphys 1795 1923 CALL histwrite_phy(o_dthin, zx_tmp_fi3d) … … 1799 1927 1800 1928 IF (.not. ok_hines .and. ok_gwd_rando) THEN 1801 CALL histwrite_phy(o_du_gwd_front, du_gwd_front / pdtphys) 1802 CALL histwrite_phy(o_dv_gwd_front, dv_gwd_front / pdtphys) 1929 IF (vars_defined) zx_tmp_fi3d=du_gwd_front / pdtphys 1930 CALL histwrite_phy(o_du_gwd_front, zx_tmp_fi3d) 1931 1932 IF (vars_defined) zx_tmp_fi3d=dv_gwd_front / pdtphys 1933 CALL histwrite_phy(o_dv_gwd_front, zx_tmp_fi3d) 1934 1803 1935 CALL histwrite_phy(o_ustr_gwd_front, zustr_gwd_front) 1804 1936 CALL histwrite_phy(o_vstr_gwd_front, zvstr_gwd_front) … … 1806 1938 1807 1939 IF (ok_gwd_rando) THEN 1808 CALL histwrite_phy(o_du_gwd_rando, du_gwd_rando / pdtphys) 1809 CALL histwrite_phy(o_dv_gwd_rando, dv_gwd_rando / pdtphys) 1940 IF (vars_defined) zx_tmp_fi3d=du_gwd_rando / pdtphys 1941 CALL histwrite_phy(o_du_gwd_rando, zx_tmp_fi3d) 1942 1943 IF (vars_defined) zx_tmp_fi3d=dv_gwd_rando / pdtphys 1944 CALL histwrite_phy(o_dv_gwd_rando, zx_tmp_fi3d) 1810 1945 CALL histwrite_phy(o_ustr_gwd_rando, zustr_gwd_rando) 1811 1946 CALL histwrite_phy(o_vstr_gwd_rando, zvstr_gwd_rando) … … 1815 1950 1816 1951 IF (ok_qch4) THEN 1817 CALL histwrite_phy(o_dqch4, d_q_ch4 / pdtphys) 1818 ENDIF 1819 1820 DO k=1, klevp1 1821 zx_tmp_fi3d1(:,k)=swup(:,k)*swradcorr(:) 1822 ENDDO 1952 IF (vars_defined) zx_tmp_fi3d=d_q_ch4 / pdtphys 1953 CALL histwrite_phy(o_dqch4, zx_tmp_fi3d) 1954 ENDIF 1955 1956 IF (vars_defined) THEN 1957 DO k=1, klevp1 1958 zx_tmp_fi3d1(:,k)=swup(:,k)*swradcorr(:) 1959 ENDDO 1960 ENDIF 1961 1823 1962 CALL histwrite_phy(o_rsu, zx_tmp_fi3d1) 1824 DO k=1, klevp1 1825 zx_tmp_fi3d1(:,k)=swdn(:,k)*swradcorr(:) 1826 ENDDO 1963 1964 1965 IF (vars_defined) THEN 1966 DO k=1, klevp1 1967 zx_tmp_fi3d1(:,k)=swdn(:,k)*swradcorr(:) 1968 ENDDO 1969 ENDIF 1970 1827 1971 CALL histwrite_phy(o_rsd, zx_tmp_fi3d1) 1828 DO k=1, klevp1 1829 zx_tmp_fi3d1(:,k)=swup0(:,k)*swradcorr(:) 1830 ENDDO 1972 1973 IF (vars_defined) THEN 1974 DO k=1, klevp1 1975 zx_tmp_fi3d1(:,k)=swup0(:,k)*swradcorr(:) 1976 ENDDO 1977 ENDIF 1978 1831 1979 CALL histwrite_phy(o_rsucs, zx_tmp_fi3d1) 1832 DO k=1, klevp1 1833 zx_tmp_fi3d1(:,k)=swupc0(:,k)*swradcorr(:) 1834 ENDDO 1980 1981 IF (vars_defined) THEN 1982 DO k=1, klevp1 1983 zx_tmp_fi3d1(:,k)=swupc0(:,k)*swradcorr(:) 1984 ENDDO 1985 ENDIF 1835 1986 CALL histwrite_phy(o_rsucsaf, zx_tmp_fi3d1) 1836 DO k=1, klevp1 1837 zx_tmp_fi3d1(:,k)=swdn0(:,k)*swradcorr(:) 1838 ENDDO 1987 1988 IF (vars_defined) THEN 1989 DO k=1, klevp1 1990 zx_tmp_fi3d1(:,k)=swdn0(:,k)*swradcorr(:) 1991 ENDDO 1992 ENDIF 1839 1993 CALL histwrite_phy(o_rsdcs, zx_tmp_fi3d1) 1840 DO k=1, klevp1 1841 zx_tmp_fi3d1(:,k)=swdnc0(:,k)*swradcorr(:) 1842 ENDDO 1994 1995 1996 IF (vars_defined) THEN 1997 DO k=1, klevp1 1998 zx_tmp_fi3d1(:,k)=swdnc0(:,k)*swradcorr(:) 1999 ENDDO 2000 ENDIF 1843 2001 CALL histwrite_phy(o_rsdcsaf, zx_tmp_fi3d1) 1844 2002 … … 1894 2052 ELSE IF (iflag_con == 2) THEN 1895 2053 CALL histwrite_phy(o_mcd, pmfd) 1896 CALL histwrite_phy(o_dmc, pmfu + pmfd) 2054 IF (vars_defined) zx_tmp_fi3d = pmfu + pmfd 2055 CALL histwrite_phy(o_dmc, zx_tmp_fi3d) 1897 2056 ENDIF 1898 2057 CALL histwrite_phy(o_ref_liq, ref_liq) … … 1908 2067 IF (vars_defined) zx_tmp_fi2d(:) = lwup0p(:,klevp1) 1909 2068 CALL histwrite_phy(o_rlutcs4co2, zx_tmp_fi2d) 1910 DO k=1, klevp1 1911 zx_tmp_fi3d1(:,k)=swupp(:,k)*swradcorr(:) 1912 ENDDO 2069 IF (vars_defined) THEN 2070 DO k=1, klevp1 2071 zx_tmp_fi3d1(:,k)=swupp(:,k)*swradcorr(:) 2072 ENDDO 2073 ENDIF 1913 2074 CALL histwrite_phy(o_rsu4co2, zx_tmp_fi3d1) 1914 DO k=1, klevp1 1915 zx_tmp_fi3d1(:,k)=swup0p(:,k)*swradcorr(:) 1916 ENDDO 2075 IF (vars_defined) THEN 2076 DO k=1, klevp1 2077 zx_tmp_fi3d1(:,k)=swup0p(:,k)*swradcorr(:) 2078 ENDDO 2079 ENDIF 1917 2080 CALL histwrite_phy(o_rsucs4co2, zx_tmp_fi3d1) 1918 DO k=1, klevp1 1919 zx_tmp_fi3d1(:,k)=swdnp(:,k)*swradcorr(:) 1920 ENDDO 2081 IF (vars_defined) THEN 2082 DO k=1, klevp1 2083 zx_tmp_fi3d1(:,k)=swdnp(:,k)*swradcorr(:) 2084 ENDDO 2085 ENDIF 1921 2086 CALL histwrite_phy(o_rsd4co2, zx_tmp_fi3d1) 1922 DO k=1, klevp1 1923 zx_tmp_fi3d1(:,k)=swdn0p(:,k)*swradcorr(:) 1924 ENDDO 2087 IF (vars_defined) THEN 2088 DO k=1, klevp1 2089 zx_tmp_fi3d1(:,k)=swdn0p(:,k)*swradcorr(:) 2090 ENDDO 2091 ENDIF 1925 2092 CALL histwrite_phy(o_rsdcs4co2, zx_tmp_fi3d1) 1926 2093 CALL histwrite_phy(o_rlu4co2, lwupp) … … 2071 2238 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 2072 2239 IF (iflag_phytrac == 1 ) then 2073 IF (nqtot.GE.nqo+1) THEN 2074 DO iq=nqo+1, nqtot 2075 IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag') THEN 2240 IF (type_trac == 'lmdz' .OR. type_trac == 'repr' .OR. type_trac == 'coag') THEN 2241 DO iq=nqo+1, nqtot 2076 2242 !--3D fields 2077 2243 CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo)) … … 2089 2255 CALL histwrite_phy(o_dtr_sat(iq-nqo),d_tr_sat(:,:,iq-nqo)) 2090 2256 CALL histwrite_phy(o_dtr_uscav(iq-nqo),d_tr_uscav(:,:,iq-nqo)) 2091 2257 !--2D fields 2092 2258 CALL histwrite_phy(o_dtr_dry(iq-nqo), flux_tr_dry(:,iq-nqo)) 2093 2259 zx_tmp_fi2d=0. … … 2100 2266 CALL histwrite_phy(o_trac_cum(iq-nqo), zx_tmp_fi2d) 2101 2267 #endif 2102 ENDIF 2103 ENDDO 2104 ENDIF 2105 2106 IF (type_trac == 'repr') THEN 2268 ENDDO !--iq 2269 ENDIF !--type_trac 2270 ! 2271 IF (type_trac == 'co2i') THEN 2272 DO iq=nqo+1, nqtot 2273 !--3D fields 2274 CALL histwrite_phy(o_trac(iq-nqo), tr_seri(:,:,iq-nqo)) 2275 CALL histwrite_phy(o_dtr_vdf(iq-nqo),d_tr_cl(:,:,iq-nqo)) 2276 CALL histwrite_phy(o_dtr_the(iq-nqo),d_tr_th(:,:,iq-nqo)) 2277 CALL histwrite_phy(o_dtr_con(iq-nqo),d_tr_cv(:,:,iq-nqo)) 2278 !--2D fields 2279 !--CO2 burden 2280 zx_tmp_fi2d=0. 2281 IF (vars_defined) THEN 2282 DO k=1,klev 2283 zx_tmp_fi2d(:)=zx_tmp_fi2d(:)+zmasse(:,k)*tr_seri(:,k,iq-nqo) 2284 ENDDO 2285 ENDIF 2286 CALL histwrite_phy(o_trac_cum(iq-nqo), zx_tmp_fi2d) 2287 ENDDO !--iq 2288 !--CO2 net fluxes 2289 CALL histwrite_phy(o_flx_co2_land, fco2_land) 2290 CALL histwrite_phy(o_flx_co2_ocean, fco2_ocean) 2291 CALL histwrite_phy(o_flx_co2_ff, fco2_ff) 2292 CALL histwrite_phy(o_flx_co2_bb, fco2_bb) 2293 ENDIF !--type_trac co2i 2294 2295 IF (type_trac == 'repr') THEN 2107 2296 #ifdef REPROBUS 2108 2297 DO iq=1,nbnas … … 2110 2299 ENDDO 2111 2300 #endif 2112 ENDIF2301 ENDIF 2113 2302 2114 2303 ENDIF !(iflag_phytrac==1) -
LMDZ6/branches/Ocean_skin/libf/phylmd/phys_state_var_mod.F90
r3458 r3605 18 18 INTEGER, SAVE :: radpas ! radiation is called every "radpas" step 19 19 INTEGER, SAVE :: cvpas ! convection is called every "cvpas" step 20 INTEGER, SAVE :: cvpas_0 ! reference value for cvpas20 INTEGER, SAVE :: cvpas_0 = 1 ! reference value for cvpas 21 21 INTEGER, SAVE :: wkpas ! wake scheme is called every "wkpas" step 22 22 REAL, PARAMETER :: missing_val_nf90=nf90_fill_real … … 25 25 !$OMP THREADPRIVATE(cvpas_0) 26 26 !$OMP THREADPRIVATE(wkpas) 27 REAL, SAVE :: dtime, solaire_etat028 !$OMP THREADPRIVATE( dtime, solaire_etat0)27 REAL, SAVE :: phys_tstep=0, solaire_etat0 28 !$OMP THREADPRIVATE(phys_tstep, solaire_etat0) 29 29 30 30 REAL, ALLOCATABLE, SAVE :: pctsrf(:,:) … … 202 202 REAL,ALLOCATABLE,SAVE :: ema_pcb(:), ema_pct(:) 203 203 !$OMP THREADPRIVATE(ema_pcb,ema_pct) 204 REAL,ALLOCATABLE,SAVE :: Ma(:,:) ! undilute upward mass flux 204 REAL,ALLOCATABLE,SAVE :: Mipsh(:,:) ! mass flux shed from adiab. ascents 205 !$OMP THREADPRIVATE(Mipsh) 206 REAL,ALLOCATABLE,SAVE :: Ma(:,:) ! undilute upward mass flux 205 207 !$OMP THREADPRIVATE(Ma) 206 208 REAL,ALLOCATABLE,SAVE :: qcondc(:,:) ! in-cld water content from convect … … 286 288 REAL,ALLOCATABLE,SAVE :: total_rain(:), nday_rain(:) 287 289 !$OMP THREADPRIVATE(total_rain,nday_rain) 290 REAL,ALLOCATABLE,SAVE :: paire_ter(:) 291 !$OMP THREADPRIVATE(paire_ter) 288 292 ! albsol1: albedo du sol total pour SW visible 289 293 ! albsol2: albedo du sol total pour SW proche IR … … 312 316 ! toplwdown : downward CS LW flux at TOA 313 317 ! toplwdownclr : downward CS LW flux at TOA 318 ! heat_volc : chauffage solaire du au volcanisme 319 ! cool_volc : refroidissement infrarouge du au volcanisme 314 320 REAL,ALLOCATABLE,SAVE :: clwcon0(:,:),rnebcon0(:,:) 315 321 !$OMP THREADPRIVATE(clwcon0,rnebcon0) … … 322 328 REAL,ALLOCATABLE,SAVE :: cool0(:,:) 323 329 !$OMP THREADPRIVATE(cool0) 330 REAL,ALLOCATABLE,SAVE :: heat_volc(:,:) 331 !$OMP THREADPRIVATE(heat_volc) 332 REAL,ALLOCATABLE,SAVE :: cool_volc(:,:) 333 !$OMP THREADPRIVATE(cool_volc) 324 334 REAL,ALLOCATABLE,SAVE :: topsw(:), toplw(:) 325 335 !$OMP THREADPRIVATE(topsw,toplw) … … 417 427 ! tendencies on wind due to gravity waves 418 428 429 LOGICAL,SAVE :: is_initialized=.FALSE. 430 !$OMP THREADPRIVATE(is_initialized) 431 419 432 ! Ocean-atmosphere interface, subskin ocean and near-surface ocean: 420 433 … … 452 465 include "clesphys.h" 453 466 467 IF (is_initialized) RETURN 468 is_initialized=.TRUE. 454 469 ALLOCATE(pctsrf(klon,nbsrf)) 455 470 ALLOCATE(ftsol(klon,nbsrf)) … … 467 482 ALLOCATE(snow_fall(klon)) 468 483 ALLOCATE(solsw(klon), sollw(klon)) 484 sollw=0.0 469 485 ALLOCATE(radsol(klon)) 470 486 ALLOCATE(swradcorr(klon)) … … 542 558 ALLOCATE(ema_pcb(klon), ema_pct(klon)) 543 559 ! 560 ALLOCATE(Mipsh(klon,klev)) 544 561 ALLOCATE(Ma(klon,klev)) 545 562 ALLOCATE(qcondc(klon,klev)) … … 551 568 ALLOCATE(ale_wake(klon)) 552 569 ALLOCATE(ale_bl_stat(klon)) 570 ale_bl_stat(:)=0 553 571 ALLOCATE(Alp_bl(klon)) 554 572 ALLOCATE(lalim_conv(klon)) … … 556 574 ALLOCATE(wake_deltat(klon,klev), wake_deltaq(klon,klev)) 557 575 ALLOCATE(wake_s(klon), awake_dens(klon), wake_dens(klon)) 576 awake_dens = 0. 558 577 ALLOCATE(wake_Cstar(klon)) 559 578 ALLOCATE(wake_pe(klon), wake_fip(klon)) … … 564 583 ALLOCATE(pfrac_1nucl(klon,klev)) 565 584 ALLOCATE(total_rain(klon), nday_rain(klon)) 585 ALLOCATE(paire_ter(klon)) 566 586 ALLOCATE(albsol1(klon), albsol2(klon)) 567 587 !albedo SB >>> … … 579 599 ALLOCATE(heat(klon,klev), heat0(klon,klev)) 580 600 ALLOCATE(cool(klon,klev), cool0(klon,klev)) 601 ALLOCATE(heat_volc(klon,klev), cool_volc(klon,klev)) 581 602 ALLOCATE(topsw(klon), toplw(klon)) 582 603 ALLOCATE(sollwdown(klon), sollwdownclr(klon)) 604 sollwdown = 0. 583 605 ALLOCATE(toplwdown(klon), toplwdownclr(klon)) 584 606 ALLOCATE(topsw0(klon),toplw0(klon),solsw0(klon),sollw0(klon)) 607 sollw0 = 0. 585 608 ALLOCATE(albpla(klon)) 586 609 !IM ajout variables CFMIP2/CMIP5 … … 619 642 ALLOCATE(ale_bl_trig(klon)) 620 643 !!! fin nrlmd le 10/04/2012 621 if (ok_gwd_rando) allocate(du_gwd_rando(klon, klev)) 622 if (.not. ok_hines .and. ok_gwd_rando) allocate(du_gwd_front(klon, klev)) 623 644 IF (ok_gwd_rando) THEN 645 allocate(du_gwd_rando(klon, klev)) 646 du_gwd_rando(:,:)=0. 647 ENDIF 648 IF (.not. ok_hines .and. ok_gwd_rando) THEN 649 ALLOCATE(du_gwd_front(klon, klev)) 650 du_gwd_front(:,:) = 0 !ym missing init 651 ENDIF 624 652 if (activate_ocean_skin >= 1) ALLOCATE(ds_ns(klon), dt_ns(klon)) 625 653 … … 693 721 deallocate(ema_cbmf) 694 722 deallocate(ema_pcb, ema_pct) 695 deallocate(M a, qcondc)723 deallocate(Mipsh, Ma, qcondc) 696 724 deallocate(wd, sigd) 697 725 deallocate(cin, ALE, ALP) … … 710 738 deallocate(pfrac_1nucl) 711 739 deallocate(total_rain, nday_rain) 740 deallocate(paire_ter) 712 741 deallocate(albsol1, albsol2) 713 742 !albedo SB >>> … … 718 747 deallocate(heat, heat0) 719 748 deallocate(cool, cool0) 749 deallocate(heat_volc, cool_volc) 720 750 deallocate(topsw, toplw) 721 751 deallocate(sollwdown, sollwdownclr) … … 757 787 deallocate(ale_bl_trig) 758 788 !!! fin nrlmd le 10/04/2012 789 759 790 if (activate_ocean_skin >= 1) deALLOCATE(ds_ns, dt_ns) 760 791 792 is_initialized=.FALSE. 793 761 794 END SUBROUTINE phys_state_var_end 762 795 -
LMDZ6/branches/Ocean_skin/libf/phylmd/physiq_mod.F90
r3418 r3605 25 25 USE dimphy 26 26 USE infotrac_phy, ONLY: nqtot, nbtr, nqo, type_trac 27 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo 27 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, nbp_lev, klon_glo, grid1dTo2d_glo, grid_type, unstructured 28 28 USE mod_phys_lmdz_para 29 29 USE iophy … … 38 38 #ifdef CPP_Dust 39 39 USE phytracr_spl_mod, ONLY: phytracr_spl 40 #endif 41 #ifdef CPP_StratAer 42 USE strataer_mod, ONLY: strataer_init 40 43 #endif 41 44 USE phys_local_var_mod, ONLY: phys_local_var_init, phys_local_var_end, & … … 117 120 zustar, zu10m, zv10m, rh2m, qsat2m, & 118 121 zq2m, zt2m, weak_inversion, & 122 zq2m_cor,zt2m_cor,zu10m_cor,zv10m_cor, & ! pour corriger d'un bug 123 zrh2m_cor,zqsat2m_cor, & 119 124 zt2m_min_mon, zt2m_max_mon, & ! pour calcul_divers.h 120 125 t2m_min_mon, t2m_max_mon, & ! pour calcul_divers.h … … 170 175 ! Deep convective variables used in phytrac 171 176 pmflxr, pmflxs, & 172 wdtrainA, wdtrain M, &177 wdtrainA, wdtrainS, wdtrainM, & 173 178 upwd, dnwd, & 174 179 ep, & … … 180 185 ev, & 181 186 elij, & 187 qtaa, & 182 188 clw, & 183 189 epmlmMm, eplaMm, & … … 243 249 #endif 244 250 USE indice_sol_mod 245 USE phytrac_mod, ONLY : phytrac 246 USE carbon_cycle_mod, ONLY : infocfields_init 251 USE phytrac_mod, ONLY : phytrac_init, phytrac 252 USE carbon_cycle_mod, ONLY : infocfields_init, RCO2_glo, carbon_cycle_rad 247 253 248 254 #ifdef CPP_RRTM … … 265 271 USE ACAMA_GWD_rando_m, only: ACAMA_GWD_rando 266 272 USE VERTICAL_LAYERS_MOD, ONLY: aps,bps 273 USE etat0_limit_unstruct_mod 274 #ifdef CPP_XIOS 275 USE xios, ONLY: xios_update_calendar, xios_context_finalize 276 #endif 277 USE limit_read_mod, ONLY : init_limit_read 278 USE regr_horiz_time_climoz_m, ONLY: regr_horiz_time_climoz 279 USE readaerosol_mod, ONLY : init_aero_fromfile 280 USE readaerosolstrato_m, ONLY : init_readaerosolstrato 267 281 268 282 IMPLICIT NONE … … 323 337 include "dimpft.h" 324 338 !====================================================================== 339 LOGICAL, SAVE :: ok_volcan ! pour activer les diagnostics volcaniques 340 !$OMP THREADPRIVATE(ok_volcan) 325 341 LOGICAL ok_cvl ! pour activer le nouveau driver pour convection KE 326 342 PARAMETER (ok_cvl=.TRUE.) 327 343 LOGICAL ok_gust ! pour activer l'effet des gust sur flux surface 328 344 PARAMETER (ok_gust=.FALSE.) 329 integer iflag_radia ! active ou non le rayonnement (MPL) 330 save iflag_radia 345 INTEGER, SAVE :: iflag_radia ! active ou non le rayonnement (MPL) 331 346 !$OMP THREADPRIVATE(iflag_radia) 332 347 !====================================================================== … … 363 378 !====================================================================== 364 379 LOGICAL ok_journe ! sortir le fichier journalier 365 saveok_journe380 SAVE ok_journe 366 381 !$OMP THREADPRIVATE(ok_journe) 367 382 ! 368 383 LOGICAL ok_mensuel ! sortir le fichier mensuel 369 saveok_mensuel384 SAVE ok_mensuel 370 385 !$OMP THREADPRIVATE(ok_mensuel) 371 386 ! 372 387 LOGICAL ok_instan ! sortir le fichier instantane 373 saveok_instan388 SAVE ok_instan 374 389 !$OMP THREADPRIVATE(ok_instan) 375 390 ! 376 391 LOGICAL ok_LES ! sortir le fichier LES 377 saveok_LES392 SAVE ok_LES 378 393 !$OMP THREADPRIVATE(ok_LES) 379 394 ! 380 395 LOGICAL callstats ! sortir le fichier stats 381 savecallstats396 SAVE callstats 382 397 !$OMP THREADPRIVATE(callstats) 383 398 ! … … 385 400 PARAMETER (ok_region=.FALSE.) 386 401 !====================================================================== 387 realseuil_inversion388 saveseuil_inversion402 REAL seuil_inversion 403 SAVE seuil_inversion 389 404 !$OMP THREADPRIVATE(seuil_inversion) 390 integeriflag_ratqs391 saveiflag_ratqs405 INTEGER iflag_ratqs 406 SAVE iflag_ratqs 392 407 !$OMP THREADPRIVATE(iflag_ratqs) 393 408 real facteur … … 396 411 REAL tau_overturning_th(klon) 397 412 398 integerlmax_th(klon)399 integerlimbas(klon)400 realratqscth(klon,klev)401 realratqsdiff(klon,klev)402 realzqsatth(klon,klev)413 INTEGER lmax_th(klon) 414 INTEGER limbas(klon) 415 REAL ratqscth(klon,klev) 416 REAL ratqsdiff(klon,klev) 417 REAL zqsatth(klon,klev) 403 418 404 419 !====================================================================== … … 497 512 CHARACTER*3 region 498 513 PARAMETER(region='3d') 499 logicalok_hf500 ! 501 saveok_hf514 LOGICAL ok_hf 515 ! 516 SAVE ok_hf 502 517 !$OMP THREADPRIVATE(ok_hf) 503 518 504 INTEGER, PARAMETER :: longcles=20505 REAL, SAVE :: clesphy0(longcles)519 INTEGER, PARAMETER :: longcles=20 520 REAL, SAVE :: clesphy0(longcles) 506 521 !$OMP THREADPRIVATE(clesphy0) 507 522 ! 508 523 ! Variables propres a la physique 509 INTEGER itap 510 SAVE itap ! compteur pour la physique 524 INTEGER, SAVE :: itap ! compteur pour la physique 511 525 !$OMP THREADPRIVATE(itap) 512 526 … … 514 528 !$OMP THREADPRIVATE(abortphy) 515 529 ! 516 REAL, save:: solarlong0530 REAL,SAVE :: solarlong0 517 531 !$OMP THREADPRIVATE(solarlong0) 518 532 … … 531 545 ! Variables liees a la convection de K. Emanuel (sb): 532 546 ! 533 REAL bas, top ! cloud base and top levels 534 SAVE bas 535 SAVE top 547 REAL, SAVE :: bas, top ! cloud base and top levels 536 548 !$OMP THREADPRIVATE(bas, top) 537 549 !------------------------------------------------------------------ … … 551 563 ! Variables li\'ees \`a la poche froide (jyg) 552 564 553 REAL mip(klon,klev) ! mass flux shed by the adiab ascent at each level 565 !! REAL mipsh(klon,klev) ! mass flux shed by the adiab ascent at each level 566 !! Moved to phys_state_var_mod 554 567 ! 555 568 REAL wape_prescr, fip_prescr … … 568 581 !! REAL, DIMENSION(klon,klev) :: dql_sat 569 582 570 real, save :: alp_bl_prescr=0. 571 real, save :: ale_bl_prescr=0. 572 573 real, save :: wake_s_min_lsp=0.1 574 583 REAL, SAVE :: alp_bl_prescr=0. 584 REAL, SAVE :: ale_bl_prescr=0. 585 REAL, SAVE :: wake_s_min_lsp=0.1 575 586 !$OMP THREADPRIVATE(alp_bl_prescr,ale_bl_prescr) 576 587 !$OMP THREADPRIVATE(wake_s_min_lsp) 577 588 578 579 real ok_wk_lsp(klon) 589 REAL ok_wk_lsp(klon) 580 590 581 591 !RC … … 590 600 ! gust-front in the grid cell. 591 601 !$OMP THREADPRIVATE(iflag_alp_wk_cond) 602 603 INTEGER, SAVE :: iflag_bug_t2m_ipslcm61=1 ! 604 !$OMP THREADPRIVATE(iflag_bug_t2m_ipslcm61) 605 INTEGER, SAVE :: iflag_bug_t2m_stab_ipslcm61=-1 ! 606 !$OMP THREADPRIVATE(iflag_bug_t2m_stab_ipslcm61) 607 592 608 REAL t_w(klon,klev),q_w(klon,klev) ! temperature and moisture profiles in the wake region 593 609 REAL t_x(klon,klev),q_x(klon,klev) ! temperature and moisture profiles in the off-wake region … … 727 743 REAL :: jD_eq 728 744 729 LOGICAL, parameter :: new_orbit = . true.745 LOGICAL, parameter :: new_orbit = .TRUE. 730 746 731 747 ! … … 913 929 INTEGER kcbot(klon), kctop(klon), kdtop(klon) 914 930 ! 915 realratqsbas,ratqshaut,tau_ratqs916 saveratqsbas,ratqshaut,tau_ratqs931 REAL ratqsbas,ratqshaut,tau_ratqs 932 SAVE ratqsbas,ratqshaut,tau_ratqs 917 933 !$OMP THREADPRIVATE(ratqsbas,ratqshaut,tau_ratqs) 918 934 REAL, SAVE :: ratqsp0=50000., ratqsdp=20000. … … 920 936 921 937 ! Parametres lies au nouveau schema de nuages (SB, PDF) 922 realfact_cldcon923 realfacttemps924 logical ok_newmicro925 saveok_newmicro938 REAL, SAVE :: fact_cldcon 939 REAL, SAVE :: facttemps 940 !$OMP THREADPRIVATE(fact_cldcon,facttemps) 941 LOGICAL, SAVE :: ok_newmicro 926 942 !$OMP THREADPRIVATE(ok_newmicro) 927 !real ref_liq_pi(klon,klev), ref_ice_pi(klon,klev) 928 save fact_cldcon,facttemps 929 !$OMP THREADPRIVATE(fact_cldcon,facttemps) 930 931 integer iflag_cld_th 932 save iflag_cld_th 943 944 INTEGER, SAVE :: iflag_cld_th 933 945 !$OMP THREADPRIVATE(iflag_cld_th) 934 946 !IM logical ptconv(klon,klev) !passe dans phys_local_var_mod 935 947 !IM cf. AM 081204 BEG 936 logicalptconvth(klon,klev)948 LOGICAL ptconvth(klon,klev) 937 949 !IM cf. AM 081204 END 938 950 ! … … 941 953 !====================================================================== 942 954 ! 943 944 955 ! 945 956 !JLD integer itau_w ! pas de temps ecriture = itap + itau_phy … … 1007 1018 !JLD REAL zstophy, zout 1008 1019 1009 character*20 modname1010 character*80 abort_message1011 logical, save:: ok_sync, ok_sync_omp1020 CHARACTER*20 modname 1021 CHARACTER*80 abort_message 1022 LOGICAL, SAVE :: ok_sync, ok_sync_omp 1012 1023 !$OMP THREADPRIVATE(ok_sync) 1013 realdate01024 REAL date0 1014 1025 1015 1026 ! essai writephys 1016 integer fid_day, fid_mth, fid_ins 1017 parameter (fid_ins = 1, fid_day = 2, fid_mth = 3) 1018 integer prof2d_on, prof3d_on, prof2d_av, prof3d_av 1019 parameter (prof2d_on = 1, prof3d_on = 2, & 1020 prof2d_av = 3, prof3d_av = 4) 1027 INTEGER fid_day, fid_mth, fid_ins 1028 PARAMETER (fid_ins = 1, fid_day = 2, fid_mth = 3) 1029 INTEGER prof2d_on, prof3d_on, prof2d_av, prof3d_av 1030 PARAMETER (prof2d_on = 1, prof3d_on = 2, prof2d_av = 3, prof3d_av = 4) 1021 1031 REAL ztsol(klon) 1022 1032 REAL q2m(klon,nbsrf) ! humidite a 2m … … 1070 1080 ! Declaration des constantes et des fonctions thermodynamiques 1071 1081 ! 1072 LOGICAL,SAVE :: first=. true.1082 LOGICAL,SAVE :: first=.TRUE. 1073 1083 !$OMP THREADPRIVATE(first) 1074 1084 … … 1106 1116 ! Declarations pour Simulateur COSP 1107 1117 !============================================================ 1108 real :: mr_ozone(klon,klev) 1118 real :: mr_ozone(klon,klev), phicosp(klon,klev) 1109 1119 1110 1120 !IM stations CFMIP … … 1164 1174 REAL zzz 1165 1175 !albedo SB >>> 1166 real,dimension(6),save :: SFRWL 1176 REAL,DIMENSION(6), SAVE :: SFRWL 1177 !$OMP THREADPRIVATE(SFRWL) 1167 1178 !albedo SB <<< 1168 1179 1169 1180 !--OB variables for mass fixer (hard coded for now) 1170 logical, parameter :: mass_fixer=.false.1171 realqql1(klon),qql2(klon),corrqql1181 LOGICAL, PARAMETER :: mass_fixer=.FALSE. 1182 REAL qql1(klon),qql2(klon),corrqql 1172 1183 1173 1184 REAL pi … … 1183 1194 pdtphys=pdtphys_ 1184 1195 CALL update_time(pdtphys) 1196 phys_tstep=NINT(pdtphys) 1197 #ifdef CPP_XIOS 1198 IF (.NOT. debut .AND. is_omp_master) CALL xios_update_calendar(itap+1) 1199 #endif 1185 1200 1186 1201 !====================================================================== … … 1211 1226 1212 1227 ! Quick check on pressure levels: 1213 callassert(paprs(:, nbp_lev + 1) < paprs(:, nbp_lev), &1228 CALL assert(paprs(:, nbp_lev + 1) < paprs(:, nbp_lev), & 1214 1229 "physiq_mod paprs bad order") 1215 1230 1216 1231 IF (first) THEN 1232 CALL init_etat0_limit_unstruct 1233 IF (.NOT. create_etat0_limit) CALL init_limit_read(days_elapsed) 1217 1234 !CR:nvelles variables convection/poches froides 1218 1235 1219 print*, '=================================================' 1220 print*, 'Allocation des variables locales et sauvegardees' 1236 WRITE(lunout,*) '=================================================' 1237 WRITE(lunout,*) 'Allocation des variables locales et sauvegardees' 1238 WRITE(lunout,*) '=================================================' 1221 1239 CALL phys_local_var_init 1222 1240 ! 1223 pasphys=pdtphys1224 1241 ! appel a la lecture du run.def physique 1225 1242 CALL conf_phys(ok_journe, ok_mensuel, & … … 1230 1247 fact_cldcon, facttemps,ok_newmicro,iflag_radia, & 1231 1248 iflag_cld_th,iflag_ratqs,ratqsbas,ratqshaut,tau_ratqs, & 1232 ok_ade, ok_aie, ok_alw, ok_cdnc, aerosol_couple, chemistry_couple, & 1249 ok_ade, ok_aie, ok_alw, ok_cdnc, ok_volcan, aerosol_couple, & 1250 chemistry_couple, & 1233 1251 flag_aerosol, flag_aerosol_strat, flag_aer_feedback, new_aod, & 1234 1252 flag_bc_internal_mixture, bl95_b0, bl95_b1, & … … 1239 1257 CALL phys_state_var_init(read_climoz) 1240 1258 CALL phys_output_var_init 1259 IF (read_climoz>=1 .AND. create_etat0_limit .AND. grid_type==unstructured) & 1260 CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz) 1261 1262 #ifdef CPP_StratAer 1263 CALL strataer_init 1264 #endif 1265 1241 1266 print*, '=================================================' 1242 1267 ! … … 1245 1270 WRITE (lunout, *) ' iflag_ice_thermo==1 requires 3 H2O tracers ', & 1246 1271 '(H2Ov, H2Ol, H2Oi) but nqo=', nqo, '. Might as well stop here.' 1247 STOP 1272 abort_message='see above' 1273 CALL abort_physic(modname,abort_message,1) 1248 1274 ENDIF 1249 1275 … … 1258 1284 1259 1285 itau_con=0 1260 first=. false.1286 first=.FALSE. 1261 1287 1262 1288 ENDIF ! first … … 1287 1313 ! secondes 1288 1314 tau_gl=86400.*tau_gl 1289 print*,'debut physiq_mod tau_gl=',tau_gl 1315 WRITE(lunout,*) 'debut physiq_mod tau_gl=',tau_gl 1316 1317 iflag_bug_t2m_ipslcm61 = 1 1318 CALL getin_p('iflag_bug_t2m_ipslcm61', iflag_bug_t2m_ipslcm61) 1319 iflag_bug_t2m_stab_ipslcm61 = -1 1320 CALL getin_p('iflag_bug_t2m_stab_ipslcm61', iflag_bug_t2m_stab_ipslcm61) 1321 1290 1322 CALL getin_p('iflag_alp_wk_cond', iflag_alp_wk_cond) 1291 1323 CALL getin_p('random_notrig_max',random_notrig_max) … … 1318 1350 CALL getin_p('NVM',nvm_lmdz) 1319 1351 1352 WRITE(lunout,*) 'iflag_alp_wk_cond=', iflag_alp_wk_cond 1353 WRITE(lunout,*) 'random_ntrig_max=', random_notrig_max 1354 WRITE(lunout,*) 'ok_adjwk=', ok_adjwk 1355 WRITE(lunout,*) 'iflag_adjwk=', iflag_adjwk 1356 WRITE(lunout,*) 'qtcon_multistep_max=',dtcon_multistep_max 1357 WRITE(lunout,*) 'qdcon_multistep_max=',dqcon_multistep_max 1358 WRITE(lunout,*) 'ratqsp0=', ratqsp0 1359 WRITE(lunout,*) 'ratqsdp=', ratqsdp 1360 WRITE(lunout,*) 'iflag_wake_tend=', iflag_wake_tend 1361 WRITE(lunout,*) 'ok_bad_ecmwf_thermo=',ok_bad_ecmwf_thermo 1362 WRITE(lunout,*) 'ok_bug_cv_trac=', ok_bug_cv_trac 1363 WRITE(lunout,*) 'ok_bug_split_th=', ok_bug_split_th 1364 WRITE(lunout,*) 'fl_ebil=', fl_ebil 1365 WRITE(lunout,*) 'fl_cor_ebil=', fl_cor_ebil 1366 WRITE(lunout,*) 'iflag_phytrac=', iflag_phytrac 1367 WRITE(lunout,*) 'NVM=', nvm_lmdz 1368 1320 1369 !--PC: defining fields to be exchanged between LMDz, ORCHIDEE and NEMO 1321 1370 WRITE(lunout,*) 'Call to infocfields from physiq' … … 1369 1418 ENDIF 1370 1419 1420 tau_aero(:,:,:,:) = 1.e-15 1421 piz_aero(:,:,:,:) = 1. 1422 cg_aero(:,:,:,:) = 0. 1423 1371 1424 IF (aerosol_couple .AND. (config_inca /= "aero" & 1372 1425 .AND. config_inca /= "aeNP ")) THEN … … 1376 1429 CALL abort_physic (modname,abort_message,1) 1377 1430 ENDIF 1378 1379 1380 1431 1381 1432 rnebcon0(:,:) = 0.0 … … 1417 1468 ! pour obtenir le meme resultat. 1418 1469 !jyg for fh< 1419 !! dtime=pdtphys 1420 dtime=NINT(pdtphys) 1421 WRITE(lunout,*) 'Pas de temps dtime pdtphys ',dtime,pdtphys 1422 IF (abs(dtime-pdtphys)>1.e-10) THEN 1470 WRITE(lunout,*) 'Pas de temps phys_tstep pdtphys ',phys_tstep,pdtphys 1471 IF (abs(phys_tstep-pdtphys)>1.e-10) THEN 1423 1472 abort_message='pas de temps doit etre entier en seconde pour orchidee et XIOS' 1424 1473 CALL abort_physic(modname,abort_message,1) 1425 1474 ENDIF 1426 1475 !>jyg 1427 IF (MOD(NINT(86400./ dtime),nbapp_rad).EQ.0) THEN1428 radpas = NINT( 86400./ dtime)/nbapp_rad1476 IF (MOD(NINT(86400./phys_tstep),nbapp_rad).EQ.0) THEN 1477 radpas = NINT( 86400./phys_tstep)/nbapp_rad 1429 1478 ELSE 1430 1479 WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', & … … 1436 1485 CALL abort_physic(modname,abort_message,1) 1437 1486 ENDIF 1438 IF (nbapp_cv .EQ. 0) nbapp_cv=86400./ dtime1439 IF (nbapp_wk .EQ. 0) nbapp_wk=86400./ dtime1487 IF (nbapp_cv .EQ. 0) nbapp_cv=86400./phys_tstep 1488 IF (nbapp_wk .EQ. 0) nbapp_wk=86400./phys_tstep 1440 1489 print *,'physiq, nbapp_cv, nbapp_wk ',nbapp_cv,nbapp_wk 1441 IF (MOD(NINT(86400./ dtime),nbapp_cv).EQ.0) THEN1442 cvpas_0 = NINT( 86400./ dtime)/nbapp_cv1490 IF (MOD(NINT(86400./phys_tstep),nbapp_cv).EQ.0) THEN 1491 cvpas_0 = NINT( 86400./phys_tstep)/nbapp_cv 1443 1492 cvpas = cvpas_0 1444 1493 print *,'physiq, cvpas ',cvpas … … 1450 1499 abort_message='nbre de pas de temps physique n est pas multiple ' & 1451 1500 // 'de nbapp_cv' 1452 callabort_physic(modname,abort_message,1)1453 ENDIF 1454 IF (MOD(NINT(86400./ dtime),nbapp_wk).EQ.0) THEN1455 wkpas = NINT( 86400./ dtime)/nbapp_wk1456 print *,'physiq, wkpas ',wkpas1501 CALL abort_physic(modname,abort_message,1) 1502 ENDIF 1503 IF (MOD(NINT(86400./phys_tstep),nbapp_wk).EQ.0) THEN 1504 wkpas = NINT( 86400./phys_tstep)/nbapp_wk 1505 ! print *,'physiq, wkpas ',wkpas 1457 1506 ELSE 1458 1507 WRITE(lunout,*) 'le nombre de pas de temps physique doit etre un ', & … … 1462 1511 abort_message='nbre de pas de temps physique n est pas multiple ' & 1463 1512 // 'de nbapp_wk' 1464 callabort_physic(modname,abort_message,1)1513 CALL abort_physic(modname,abort_message,1) 1465 1514 ENDIF 1466 1515 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1467 1516 CALL init_iophy_new(latitude_deg,longitude_deg) 1517 1518 !=================================================================== 1519 !IM stations CFMIP 1520 nCFMIP=npCFMIP 1521 OPEN(98,file='npCFMIP_param.data',status='old', & 1522 form='formatted',iostat=iostat) 1523 IF (iostat == 0) THEN 1524 READ(98,*,end=998) nCFMIP 1525 998 CONTINUE 1526 CLOSE(98) 1527 CONTINUE 1528 IF(nCFMIP.GT.npCFMIP) THEN 1529 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' 1530 CALL abort_physic("physiq", "", 1) 1531 ELSE 1532 print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP 1533 ENDIF 1534 1535 ! 1536 ALLOCATE(tabCFMIP(nCFMIP)) 1537 ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) 1538 ALLOCATE(tabijGCM(nCFMIP)) 1539 ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) 1540 ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) 1541 ! 1542 ! lecture des nCFMIP stations CFMIP, de leur numero 1543 ! et des coordonnees geographiques lonCFMIP, latCFMIP 1544 ! 1545 CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & 1546 lonCFMIP, latCFMIP) 1547 ! 1548 ! identification des 1549 ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la 1550 ! grille de LMDZ 1551 ! 2) indices points tabijGCM de la grille physique 1d sur 1552 ! klon points 1553 ! 3) indices iGCM, jGCM de la grille physique 2d 1554 ! 1555 CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & 1556 tabijGCM, lonGCM, latGCM, iGCM, jGCM) 1557 ! 1558 ELSE 1559 ALLOCATE(tabijGCM(0)) 1560 ALLOCATE(lonGCM(0), latGCM(0)) 1561 ALLOCATE(iGCM(0), jGCM(0)) 1562 ENDIF 1563 1564 #ifdef CPP_IOIPSL 1565 1566 !$OMP MASTER 1567 ! FH : if ok_sync=.true. , the time axis is written at each time step 1568 ! in the output files. Only at the end in the opposite case 1569 ok_sync_omp=.FALSE. 1570 CALL getin('ok_sync',ok_sync_omp) 1571 CALL phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, & 1572 iGCM,jGCM,lonGCM,latGCM, & 1573 jjmp1,nlevSTD,clevSTD,rlevSTD, phys_tstep,ok_veget, & 1574 type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, & 1575 ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, & 1576 read_climoz, phys_out_filestations, & 1577 new_aod, aerosol_couple, & 1578 flag_aerosol_strat, pdtphys, paprs, pphis, & 1579 pplay, lmax_th, ptconv, ptconvth, ivap, & 1580 d_u, d_t, qx, d_qx, zmasse, ok_sync_omp) 1581 !$OMP END MASTER 1582 !$OMP BARRIER 1583 ok_sync=ok_sync_omp 1584 1585 freq_outNMC(1) = ecrit_files(7) 1586 freq_outNMC(2) = ecrit_files(8) 1587 freq_outNMC(3) = ecrit_files(9) 1588 WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1) 1589 WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2) 1590 WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3) 1591 1592 #ifndef CPP_XIOS 1593 CALL ini_paramLMDZ_phy(phys_tstep,nid_ctesGCM) 1594 #endif 1595 1596 #endif 1597 ecrit_reg = ecrit_reg * un_jour 1598 ecrit_tra = ecrit_tra * un_jour 1599 1600 !XXXPB Positionner date0 pour initialisation de ORCHIDEE 1601 date0 = jD_ref 1602 WRITE(*,*) 'physiq date0 : ',date0 1603 ! 1604 1605 ! CALL create_climoz(read_climoz) 1606 IF (.NOT. create_etat0_limit) CALL init_aero_fromfile(flag_aerosol) !! initialise aero from file for XIOS interpolation (unstructured_grid) 1607 IF (.NOT. create_etat0_limit) CALL init_readaerosolstrato(flag_aerosol_strat) !! initialise aero strato from file for XIOS interpolation (unstructured_grid) 1608 1609 #ifdef CPP_COSP 1610 IF (ok_cosp) THEN 1611 DO k = 1, klev 1612 DO i = 1, klon 1613 phicosp(i,k) = pphi(i,k) + pphis(i) 1614 ENDDO 1615 ENDDO 1616 CALL phys_cosp(itap,phys_tstep,freq_cosp, & 1617 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 1618 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & 1619 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & 1620 JrNt,ref_liq,ref_ice, & 1621 pctsrf(:,is_ter)+pctsrf(:,is_lic), & 1622 zu10m,zv10m,pphis, & 1623 zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & 1624 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & 1625 prfl(:,1:klev),psfl(:,1:klev), & 1626 pmflxr(:,1:klev),pmflxs(:,1:klev), & 1627 mr_ozone,cldtau, cldemi) 1628 ENDIF 1629 #endif 1630 1631 #ifdef CPP_COSP2 1632 IF (ok_cosp) THEN 1633 DO k = 1, klev 1634 DO i = 1, klon 1635 phicosp(i,k) = pphi(i,k) + pphis(i) 1636 ENDDO 1637 ENDDO 1638 CALL phys_cosp2(itap,phys_tstep,freq_cosp, & 1639 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 1640 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & 1641 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & 1642 JrNt,ref_liq,ref_ice, & 1643 pctsrf(:,is_ter)+pctsrf(:,is_lic), & 1644 zu10m,zv10m,pphis, & 1645 zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & 1646 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & 1647 prfl(:,1:klev),psfl(:,1:klev), & 1648 pmflxr(:,1:klev),pmflxs(:,1:klev), & 1649 mr_ozone,cldtau, cldemi) 1650 ENDIF 1651 #endif 1652 1653 #ifdef CPP_COSPV2 1654 IF (ok_cosp) THEN 1655 DO k = 1, klev 1656 DO i = 1, klon 1657 phicosp(i,k) = pphi(i,k) + pphis(i) 1658 ENDDO 1659 ENDDO 1660 CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, & 1661 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 1662 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & 1663 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & 1664 JrNt,ref_liq,ref_ice, & 1665 pctsrf(:,is_ter)+pctsrf(:,is_lic), & 1666 zu10m,zv10m,pphis, & 1667 phicosp,paprs(:,1:klev),pplay,zxtsol,t_seri, & 1668 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & 1669 prfl(:,1:klev),psfl(:,1:klev), & 1670 pmflxr(:,1:klev),pmflxs(:,1:klev), & 1671 mr_ozone,cldtau, cldemi) 1672 ENDIF 1673 #endif 1674 1675 ! 1676 ! 1677 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1678 ! Nouvelle initialisation pour le rayonnement RRTM 1679 ! 1680 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 1681 1682 CALL iniradia(klon,klev,paprs(1,1:klev+1)) 1683 ! Initialisation des champs dans phytrac qui sont utilisés par phys_output_write 1684 IF (iflag_phytrac == 1 ) THEN 1685 CALL phytrac_init() 1686 ENDIF 1687 1688 CALL phys_output_write(itap, pdtphys, paprs, pphis, & 1689 pplay, lmax_th, aerosol_couple, & 1690 ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod, ok_sync,& 1691 ptconv, read_climoz, clevSTD, & 1692 ptconvth, d_u, d_t, qx, d_qx, zmasse, & 1693 flag_aerosol, flag_aerosol_strat, ok_cdnc) 1694 1695 #ifdef CPP_XIOS 1696 IF (is_omp_master) CALL xios_update_calendar(1) 1697 #endif 1698 IF(read_climoz>=1 .AND. create_etat0_limit) CALL regr_horiz_time_climoz(read_climoz,ok_daily_climoz) 1699 CALL create_etat0_limit_unstruct 1468 1700 CALL phyetat0 ("startphy.nc",clesphy0,tabcntr0) 1701 1469 1702 !jyg< 1470 IF (klon_glo==1) THEN 1471 IF (iflag_pbl > 1) THEN 1472 pbl_tke(:,:,is_ave) = 0. 1473 DO nsrf=1,nbsrf 1474 DO k = 1,klev+1 1475 pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) & 1476 +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf) 1477 ENDDO 1478 ENDDO 1479 ELSE ! (iflag_pbl > 1) 1480 pbl_tke(:,:,:) = 0. 1481 ENDIF ! (iflag_pbl > 1) 1703 IF (iflag_pbl<=1) THEN 1704 ! No TKE for Standard Physics 1705 pbl_tke(:,:,:)=0. 1706 1707 ELSE IF (klon_glo==1) THEN 1708 pbl_tke(:,:,is_ave) = 0. 1709 DO nsrf=1,nbsrf 1710 DO k = 1,klev+1 1711 pbl_tke(:,k,is_ave) = pbl_tke(:,k,is_ave) & 1712 +pctsrf(:,nsrf)*pbl_tke(:,k,nsrf) 1713 ENDDO 1714 ENDDO 1715 ELSE 1716 pbl_tke(:,:,is_ave) = 0. !ym missing init : maybe must be initialized in the same way that for klon_glo==1 ?? 1482 1717 !>jyg 1483 1718 ENDIF … … 1496 1731 ENDIF 1497 1732 1498 CALL printflag( tabcntr0,radpas,ok_journe, & 1499 ok_instan, ok_region ) 1500 ! 1501 IF (ABS(dtime-pdtphys).GT.0.001) THEN 1502 WRITE(lunout,*) 'Pas physique n est pas correct',dtime, & 1503 pdtphys 1504 abort_message='Pas physique n est pas correct ' 1505 ! call abort_physic(modname,abort_message,1) 1506 dtime=pdtphys 1507 ENDIF 1733 ! IF (ABS(phys_tstep-pdtphys).GT.0.001) THEN 1734 ! WRITE(lunout,*) 'Pas physique n est pas correct',phys_tstep, & 1735 ! pdtphys 1736 ! abort_message='Pas physique n est pas correct ' 1737 ! ! call abort_physic(modname,abort_message,1) 1738 ! phys_tstep=pdtphys 1739 ! ENDIF 1508 1740 IF (nlon .NE. klon) THEN 1509 1741 WRITE(lunout,*)'nlon et klon ne sont pas coherents', nlon, & … … 1519 1751 ENDIF 1520 1752 ! 1521 IF ( dtime*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN1753 IF (phys_tstep*REAL(radpas).GT.21600..AND.iflag_cycle_diurne.GE.1) THEN 1522 1754 WRITE(lunout,*)'Nbre d appels au rayonnement insuffisant' 1523 1755 WRITE(lunout,*)"Au minimum 4 appels par jour si cycle diurne" … … 1581 1813 ! enddo 1582 1814 1583 !=================================================================== 1584 !IM stations CFMIP 1585 nCFMIP=npCFMIP 1586 OPEN(98,file='npCFMIP_param.data',status='old', & 1587 form='formatted',iostat=iostat) 1588 IF (iostat == 0) THEN 1589 READ(98,*,end=998) nCFMIP 1590 998 CONTINUE 1591 CLOSE(98) 1592 CONTINUE 1593 IF(nCFMIP.GT.npCFMIP) THEN 1594 print*,'nCFMIP > npCFMIP : augmenter npCFMIP et recompiler' 1595 CALL abort_physic("physiq", "", 1) 1596 ELSE 1597 print*,'physiq npCFMIP=',npCFMIP,'nCFMIP=',nCFMIP 1598 ENDIF 1599 1600 ! 1601 ALLOCATE(tabCFMIP(nCFMIP)) 1602 ALLOCATE(lonCFMIP(nCFMIP), latCFMIP(nCFMIP)) 1603 ALLOCATE(tabijGCM(nCFMIP)) 1604 ALLOCATE(lonGCM(nCFMIP), latGCM(nCFMIP)) 1605 ALLOCATE(iGCM(nCFMIP), jGCM(nCFMIP)) 1606 ! 1607 ! lecture des nCFMIP stations CFMIP, de leur numero 1608 ! et des coordonnees geographiques lonCFMIP, latCFMIP 1609 ! 1610 CALL read_CFMIP_point_locations(nCFMIP, tabCFMIP, & 1611 lonCFMIP, latCFMIP) 1612 ! 1613 ! identification des 1614 ! 1) coordonnees lonGCM, latGCM des points CFMIP dans la 1615 ! grille de LMDZ 1616 ! 2) indices points tabijGCM de la grille physique 1d sur 1617 ! klon points 1618 ! 3) indices iGCM, jGCM de la grille physique 2d 1619 ! 1620 CALL LMDZ_CFMIP_point_locations(nCFMIP, lonCFMIP, latCFMIP, & 1621 tabijGCM, lonGCM, latGCM, iGCM, jGCM) 1622 ! 1623 ELSE 1624 ALLOCATE(tabijGCM(0)) 1625 ALLOCATE(lonGCM(0), latGCM(0)) 1626 ALLOCATE(iGCM(0), jGCM(0)) 1627 ENDIF 1628 ELSE 1629 ALLOCATE(tabijGCM(0)) 1630 ALLOCATE(lonGCM(0), latGCM(0)) 1631 ALLOCATE(iGCM(0), jGCM(0)) 1815 !ELSE 1816 ! ALLOCATE(tabijGCM(0)) 1817 ! ALLOCATE(lonGCM(0), latGCM(0)) 1818 ! ALLOCATE(iGCM(0), jGCM(0)) 1632 1819 ENDIF 1633 1820 … … 1665 1852 ! 1666 1853 ! 1667 lmt_pas = NINT(86400./ dtime* 1.0) ! tous les jours1854 lmt_pas = NINT(86400./phys_tstep * 1.0) ! tous les jours 1668 1855 WRITE(lunout,*)'La frequence de lecture surface est de ', & 1669 1856 lmt_pas … … 1681 1868 ! Initialisation des sorties 1682 1869 !============================================================= 1870 1871 #ifdef CPP_XIOS 1872 ! Get "missing_val" value from XML files (from temperature variable) 1873 !$OMP MASTER 1874 CALL xios_get_field_attr("temp",default_value=missing_val_omp) 1875 !$OMP END MASTER 1876 !$OMP BARRIER 1877 missing_val=missing_val_omp 1878 #endif 1683 1879 1684 1880 #ifdef CPP_XIOS … … 1693 1889 #endif 1694 1890 1695 #ifdef CPP_IOIPSL 1696 1697 !$OMP MASTER 1698 ! FH : if ok_sync=.true. , the time axis is written at each time step 1699 ! in the output files. Only at the end in the opposite case 1700 ok_sync_omp=.false. 1701 CALL getin('ok_sync',ok_sync_omp) 1702 CALL phys_output_open(longitude_deg,latitude_deg,nCFMIP,tabijGCM, & 1703 iGCM,jGCM,lonGCM,latGCM, & 1704 jjmp1,nlevSTD,clevSTD,rlevSTD, dtime,ok_veget, & 1705 type_ocean,iflag_pbl,iflag_pbl_split,ok_mensuel,ok_journe, & 1706 ok_hf,ok_instan,ok_LES,ok_ade,ok_aie, & 1707 read_climoz, phys_out_filestations, & 1708 new_aod, aerosol_couple, & 1709 flag_aerosol_strat, pdtphys, paprs, pphis, & 1710 pplay, lmax_th, ptconv, ptconvth, ivap, & 1711 d_u, d_t, qx, d_qx, zmasse, ok_sync_omp) 1712 !$OMP END MASTER 1713 !$OMP BARRIER 1714 ok_sync=ok_sync_omp 1715 1716 freq_outNMC(1) = ecrit_files(7) 1717 freq_outNMC(2) = ecrit_files(8) 1718 freq_outNMC(3) = ecrit_files(9) 1719 WRITE(lunout,*)'OK freq_outNMC(1)=',freq_outNMC(1) 1720 WRITE(lunout,*)'OK freq_outNMC(2)=',freq_outNMC(2) 1721 WRITE(lunout,*)'OK freq_outNMC(3)=',freq_outNMC(3) 1722 1723 #ifndef CPP_XIOS 1724 CALL ini_paramLMDZ_phy(dtime,nid_ctesGCM) 1725 #endif 1726 1727 #endif 1728 ecrit_reg = ecrit_reg * un_jour 1729 ecrit_tra = ecrit_tra * un_jour 1730 1731 !XXXPB Positionner date0 pour initialisation de ORCHIDEE 1732 date0 = jD_ref 1733 WRITE(*,*) 'physiq date0 : ',date0 1891 1892 CALL printflag( tabcntr0,radpas,ok_journe, & 1893 ok_instan, ok_region ) 1734 1894 ! 1735 1895 ! … … 1792 1952 #endif 1793 1953 ENDIF 1794 !1795 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1796 ! Nouvelle initialisation pour le rayonnement RRTM1797 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!1798 1799 CALL iniradia(klon,klev,paprs(1,1:klev+1))1800 1954 1801 1955 !$omp single … … 1815 1969 1816 1970 !albedo SB >>> 1817 select case(nsw)1818 case(2)1971 SELECT CASE(nsw) 1972 CASE(2) 1819 1973 SFRWL(1)=0.45538747 1820 1974 SFRWL(2)=0.54461211 1821 case(4)1975 CASE(4) 1822 1976 SFRWL(1)=0.45538747 1823 1977 SFRWL(2)=0.32870591 1824 1978 SFRWL(3)=0.18568763 1825 1979 SFRWL(4)=3.02191470E-02 1826 case(6)1980 CASE(6) 1827 1981 SFRWL(1)=1.28432794E-03 1828 1982 SFRWL(2)=0.12304168 … … 1831 1985 SFRWL(5)=0.18568763 1832 1986 SFRWL(6)=3.02191470E-02 1833 end select1987 END SELECT 1834 1988 1835 1989 … … 1870 2024 sollwdown(:)= sollwdown(:) + betalwoff *(-1.*ZFLDN0(:,1) - & 1871 2025 sollwdown(:)) 2026 2027 1872 2028 ENDIF 1873 2029 ! … … 1891 2047 ! on the surface fraction. 1892 2048 ! 1893 CALL change_srf_frac(itap, dtime, days_elapsed+1, &2049 CALL change_srf_frac(itap, phys_tstep, days_elapsed+1, & 1894 2050 pctsrf, fevap, z0m, z0h, agesno, & 1895 2051 falb_dir, falb_dif, ftsol, ustar, u10m, v10m, pbl_tke) … … 1903 2059 #endif 1904 2060 ENDIF 1905 1906 2061 1907 2062 ! Tendances bidons pour les processus qui n'affectent pas certaines … … 2005 2160 ENDDO 2006 2161 ENDIF 2162 ! 2163 ! Temporary solutions adressing ticket #104 and the non initialisation of tr_ancien 2164 ! LF 2165 IF (debut) THEN 2166 WRITE(lunout,*)' WARNING: tr_ancien initialised to tr_seri' 2167 DO iq = nqo+1, nqtot 2168 tr_ancien(:,:,iq-nqo)=tr_seri(:,:,iq-nqo) 2169 ENDDO 2170 ENDIF 2007 2171 ! 2008 2172 DO i = 1, klon … … 2021 2185 IF (ancien_ok) THEN 2022 2186 ! 2023 d_u_dyn(:,:) = (u_seri(:,:)-u_ancien(:,:))/ dtime2024 d_v_dyn(:,:) = (v_seri(:,:)-v_ancien(:,:))/ dtime2025 d_t_dyn(:,:) = (t_seri(:,:)-t_ancien(:,:))/ dtime2026 d_q_dyn(:,:) = (q_seri(:,:)-q_ancien(:,:))/ dtime2027 d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/ dtime2028 d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/ dtime2187 d_u_dyn(:,:) = (u_seri(:,:)-u_ancien(:,:))/phys_tstep 2188 d_v_dyn(:,:) = (v_seri(:,:)-v_ancien(:,:))/phys_tstep 2189 d_t_dyn(:,:) = (t_seri(:,:)-t_ancien(:,:))/phys_tstep 2190 d_q_dyn(:,:) = (q_seri(:,:)-q_ancien(:,:))/phys_tstep 2191 d_ql_dyn(:,:) = (ql_seri(:,:)-ql_ancien(:,:))/phys_tstep 2192 d_qs_dyn(:,:) = (qs_seri(:,:)-qs_ancien(:,:))/phys_tstep 2029 2193 CALL water_int(klon,klev,q_seri,zmasse,zx_tmp_fi2d) 2030 d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/ dtime2194 d_q_dyn2d(:)=(zx_tmp_fi2d(:)-prw_ancien(:))/phys_tstep 2031 2195 CALL water_int(klon,klev,ql_seri,zmasse,zx_tmp_fi2d) 2032 d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/ dtime2196 d_ql_dyn2d(:)=(zx_tmp_fi2d(:)-prlw_ancien(:))/phys_tstep 2033 2197 CALL water_int(klon,klev,qs_seri,zmasse,zx_tmp_fi2d) 2034 d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/ dtime2198 d_qs_dyn2d(:)=(zx_tmp_fi2d(:)-prsw_ancien(:))/phys_tstep 2035 2199 ! !! RomP >>> td dyn traceur 2036 2200 IF (nqtot.GT.nqo) THEN ! jyg 2037 2201 DO iq = nqo+1, nqtot ! jyg 2038 d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/ dtime! jyg2202 d_tr_dyn(:,:,iq-nqo)=(tr_seri(:,:,iq-nqo)-tr_ancien(:,:,iq-nqo))/phys_tstep ! jyg 2039 2203 ENDDO 2040 2204 ENDIF … … 2138 2302 ro3i, 'C', press_cen_climoz, pplay, wo, paprs(:,1), & 2139 2303 time_climoz ) 2140 END 2304 ENDIF 2141 2305 ! Convert from mole fraction of ozone to column density of ozone in a 2142 2306 ! cell, in kDU: … … 2158 2322 (du0,dv0,d_t_eva,d_q_eva,d_ql_eva,d_qi_eva,paprs,& 2159 2323 'eva',abortphy,flag_inhib_tend,itap,0) 2160 callprt_enerbil('eva',itap)2324 CALL prt_enerbil('eva',itap) 2161 2325 2162 2326 !========================================================================= … … 2213 2377 ! bit comparable a l ancienne formulation cycle_diurne=true 2214 2378 ! on integre entre gmtime et gmtime+radpas 2215 zdtime= dtime*REAL(radpas) ! pas de temps du rayonnement (s)2379 zdtime=phys_tstep*REAL(radpas) ! pas de temps du rayonnement (s) 2216 2380 CALL zenang(zlongi,jH_cur,0.0,zdtime, & 2217 2381 latitude_deg,longitude_deg,rmu0,fract) … … 2230 2394 ! premier pas de temps de la physique pendant lequel 2231 2395 ! itaprad=0 2232 zdtime1= dtime*REAL(-MOD(itaprad,radpas)-1)2233 zdtime2= dtime*REAL(radpas-MOD(itaprad,radpas)-1)2396 zdtime1=phys_tstep*REAL(-MOD(itaprad,radpas)-1) 2397 zdtime2=phys_tstep*REAL(radpas-MOD(itaprad,radpas)-1) 2234 2398 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & 2235 2399 latitude_deg,longitude_deg,rmu0,fract) … … 2237 2401 ! Calcul des poids 2238 2402 ! 2239 zdtime1=- dtime!--on corrige le rayonnement pour representer le2403 zdtime1=-phys_tstep !--on corrige le rayonnement pour representer le 2240 2404 zdtime2=0.0 !--pas de temps de la physique qui se termine 2241 2405 CALL zenang(zlongi,jH_cur,zdtime1,zdtime2, & … … 2295 2459 ! 2296 2460 !-------gustiness calculation-------! 2461 !ym : Warning gustiness non inialized for iflag_gusts=2 & iflag_gusts=3 2462 gustiness=0 !ym missing init 2463 2297 2464 IF (iflag_gusts==0) THEN 2298 2465 gustiness(1:klon)=0 … … 2312 2479 ENDIF 2313 2480 2314 2315 2316 2481 CALL pbl_surface( & 2317 dtime, date0, itap, days_elapsed+1, &2482 phys_tstep, date0, itap, days_elapsed+1, & 2318 2483 debut, lafin, & 2319 2484 longitude_deg, latitude_deg, rugoro, zrmu0, & … … 2382 2547 ENDIF 2383 2548 2384 2385 2386 2549 !add limitation for t,q at and wind at 10m 2550 if ( iflag_bug_t2m_ipslcm61 == 0 ) THEN 2551 CALL borne_var_surf( klon,klev,nbsrf, & 2552 iflag_bug_t2m_stab_ipslcm61, & 2553 t_seri(:,1),q_seri(:,1),u_seri(:,1),v_seri(:,1), & 2554 ftsol,zxqsurf,pctsrf,paprs, & 2555 t2m, q2m, u10m, v10m, & 2556 zt2m_cor, zq2m_cor, zu10m_cor, zv10m_cor, & 2557 zrh2m_cor, zqsat2m_cor) 2558 ELSE 2559 zt2m_cor(:)=zt2m(:) 2560 zq2m_cor(:)=zq2m(:) 2561 zu10m_cor(:)=zu10m(:) 2562 zv10m_cor(:)=zv10m(:) 2563 zqsat2m_cor=999.999 2564 ENDIF 2387 2565 2388 2566 !--------------------------------------------------------------------- … … 2397 2575 'vdf',abortphy,flag_inhib_tend,itap,0) 2398 2576 ENDIF 2399 callprt_enerbil('vdf',itap)2577 CALL prt_enerbil('vdf',itap) 2400 2578 !-------------------------------------------------------------------- 2401 2579 … … 2482 2660 DO i = 1, klon 2483 2661 conv_q(i,k) = d_q_dyn(i,k) & 2484 + d_q_vdf(i,k)/ dtime2662 + d_q_vdf(i,k)/phys_tstep 2485 2663 conv_t(i,k) = d_t_dyn(i,k) & 2486 + d_t_vdf(i,k)/ dtime2664 + d_t_vdf(i,k)/phys_tstep 2487 2665 ENDDO 2488 2666 ENDDO … … 2528 2706 pmflxs(:,:) = 0. 2529 2707 wdtrainA(:,:) = 0. 2708 wdtrainS(:,:) = 0. 2530 2709 wdtrainM(:,:) = 0. 2531 2710 upwd(:,:) = 0. … … 2543 2722 elij(:,:,:)=0. 2544 2723 ev(:,:)=0. 2724 qtaa(:,:)=0. 2545 2725 clw(:,:)=0. 2546 2726 sij(:,:,:)=0. … … 2549 2729 abort_message ='reactiver le call conlmd dans physiq.F' 2550 2730 CALL abort_physic (modname,abort_message,1) 2551 ! CALL conlmd ( dtime, paprs, pplay, t_seri, q_seri, conv_q,2731 ! CALL conlmd (phys_tstep, paprs, pplay, t_seri, q_seri, conv_q, 2552 2732 ! . d_t_con, d_q_con, 2553 2733 ! . rain_con, snow_con, ibas_con, itop_con) 2554 2734 ELSE IF (iflag_con.EQ.2) THEN 2555 CALL conflx( dtime, paprs, pplay, t_seri, q_seri, &2735 CALL conflx(phys_tstep, paprs, pplay, t_seri, q_seri, & 2556 2736 conv_t, conv_q, -evap, omega, & 2557 2737 d_t_con, d_q_con, rain_con, snow_con, & … … 2629 2809 2630 2810 !jyg< 2631 CALL alpale( debut, itap, dtime, paprs, omega, t_seri, &2811 CALL alpale( debut, itap, phys_tstep, paprs, omega, t_seri, & 2632 2812 alp_offset, it_wape_prescr, wape_prescr, fip_prescr, & 2633 2813 ale_bl_prescr, alp_bl_prescr, & … … 2671 2851 !c CALL concvl (iflag_con,iflag_clos, 2672 2852 CALL concvl (iflag_clos, & 2673 dtime, paprs, pplay, k_upper_cv, t_x,q_x, &2853 phys_tstep, paprs, pplay, k_upper_cv, t_x,q_x, & 2674 2854 t_w,q_w,wake_s, & 2675 2855 u_seri,v_seri,tr_seri,nbtr_tmp, & … … 2679 2859 rain_con, snow_con, ibas_con, itop_con, sigd, & 2680 2860 ema_cbmf,plcl,plfc,wbeff,convoccur,upwd,dnwd,dnwd0, & 2681 Ma,mip ,Vprecip,cape,cin,tvp,Tconv,iflagctrl, &2861 Ma,mipsh,Vprecip,cape,cin,tvp,Tconv,iflagctrl, & 2682 2862 pbase,bbase,dtvpdt1,dtvpdq1,dplcldt,dplcldr,qcondc,wd, & 2683 2863 ! RomP >>> 2684 2864 !! . pmflxr,pmflxs,da,phi,mp, 2685 2865 !! . ftd,fqd,lalim_conv,wght_th) 2686 pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij, clw,elij, &2866 pmflxr,pmflxs,da,phi,mp,phi2,d1a,dam,sij,qtaa,clw,elij, & 2687 2867 ftd,fqd,lalim_conv,wght_th, & 2688 2868 ev, ep,epmlmMm,eplaMm, & 2689 wdtrainA, wdtrainM,wght_cvfd,qtc_cv,sigt_cv, &2869 wdtrainA, wdtrainS, wdtrainM,wght_cvfd,qtc_cv,sigt_cv, & 2690 2870 tau_cld_cv,coefw_cld_cv,epmax_diag) 2691 2871 … … 2741 2921 DO k=1,klev 2742 2922 DO i=1,klon 2743 ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/ dtime2744 fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/ dtime2923 ftd(i,k) = ftd(i,k) + wake_s(i)*d_t_adjwk(i,k)/phys_tstep 2924 fqd(i,k) = fqd(i,k) + wake_s(i)*d_q_adjwk(i,k)/phys_tstep 2745 2925 d_t_con(i,k) = d_t_con(i,k) + wake_s(i)*d_t_adjwk(i,k) 2746 2926 d_q_con(i,k) = d_q_con(i,k) + wake_s(i)*d_q_adjwk(i,k) … … 2754 2934 2755 2935 ! MAF conema3 ne contient pas les traceurs 2756 CALL conema3 ( dtime, &2936 CALL conema3 (phys_tstep, & 2757 2937 paprs,pplay,t_seri,q_seri, & 2758 2938 u_seri,v_seri,tr_seri,ntra, & … … 2865 3045 CALL add_phys_tend(d_u_con, d_v_con, d_t_con, d_q_con, dql0, dqi0, paprs, & 2866 3046 'convection',abortphy,flag_inhib_tend,itap,0) 2867 callprt_enerbil('convection',itap)3047 CALL prt_enerbil('convection',itap) 2868 3048 2869 3049 !------------------------------------------------------------------------- … … 2886 3066 snow_con(i))*cell_area(i)/REAL(klon) 2887 3067 ENDDO 2888 zx_t = zx_t/za* dtime3068 zx_t = zx_t/za*phys_tstep 2889 3069 WRITE(lunout,*)"Precip=", zx_t 2890 3070 ENDIF … … 2900 3080 ENDDO 2901 3081 DO i = 1, klon 2902 z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))* dtime) &3082 z_factor(i) = (z_avant(i)-(rain_con(i)+snow_con(i))*phys_tstep) & 2903 3083 /z_apres(i) 2904 3084 ENDDO … … 2937 3117 M_dwn(i,k) = dnwd0(i,k) 2938 3118 M_up(i,k) = upwd(i,k) 2939 dt_a(i,k) = d_t_con(i,k)/ dtime- ftd(i,k)2940 dq_a(i,k) = d_q_con(i,k)/ dtime- fqd(i,k)3119 dt_a(i,k) = d_t_con(i,k)/phys_tstep - ftd(i,k) 3120 dq_a(i,k) = d_q_con(i,k)/phys_tstep - fqd(i,k) 2941 3121 ENDDO 2942 3122 ENDDO … … 2946 3126 DO k = 1,klev 2947 3127 dt_dwn(:,k)= dt_dwn(:,k)+ & 2948 ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/ dtime3128 ok_wk_lsp(:)*(d_t_eva(:,k)+d_t_lsc(:,k))/phys_tstep 2949 3129 dq_dwn(:,k)= dq_dwn(:,k)+ & 2950 ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/ dtime3130 ok_wk_lsp(:)*(d_q_eva(:,k)+d_q_lsc(:,k))/phys_tstep 2951 3131 ENDDO 2952 3132 ELSEIF (iflag_wake==3) THEN … … 2959 3139 ! l'eau se reevapore). 2960 3140 dt_dwn(i,k)= dt_dwn(i,k)+ & 2961 ok_wk_lsp(i)*d_t_lsc(i,k)/ dtime3141 ok_wk_lsp(i)*d_t_lsc(i,k)/phys_tstep 2962 3142 dq_dwn(i,k)= dq_dwn(i,k)+ & 2963 ok_wk_lsp(i)*d_q_lsc(i,k)/ dtime3143 ok_wk_lsp(i)*d_q_lsc(i,k)/phys_tstep 2964 3144 ENDIF 2965 3145 ENDDO … … 2969 3149 ! 2970 3150 !calcul caracteristiques de la poche froide 2971 CALL calWAKE (iflag_wake_tend, paprs, pplay, dtime, &3151 CALL calWAKE (iflag_wake_tend, paprs, pplay, phys_tstep, & 2972 3152 t_seri, q_seri, omega, & 2973 3153 dt_dwn, dq_dwn, M_dwn, M_up, & … … 2996 3176 CALL add_phys_tend(du0,dv0,d_t_wake,d_q_wake,dql0,dqi0,paprs,'wake', & 2997 3177 abortphy,flag_inhib_tend,itap,0) 2998 callprt_enerbil('wake',itap)3178 CALL prt_enerbil('wake',itap) 2999 3179 !------------------------------------------------------------------------ 3000 3180 … … 3005 3185 (d_deltat_wk, d_deltaq_wk, d_s_wk, d_dens_a_wk, d_dens_wk, wake_k, & 3006 3186 'wake', abortphy) 3007 callprt_enerbil('wake',itap)3187 CALL prt_enerbil('wake',itap) 3008 3188 ENDIF ! (iflag_wake_tend .GT. 0.) 3009 3189 ! … … 3016 3196 IF (iflag_alp_wk_cond .GT. 0.) THEN 3017 3197 3018 CALL alpale_wk( dtime, cell_area, wake_k, wake_s, wake_dens, wake_fip_0, &3198 CALL alpale_wk(phys_tstep, cell_area, wake_k, wake_s, wake_dens, wake_fip_0, & 3019 3199 wake_fip) 3020 3200 ELSE … … 3147 3327 (d_deltat_the, d_deltaq_the, dsig0, ddens0, ddens0, wake_k, 'the', abortphy) 3148 3328 ENDIF 3149 callprt_enerbil('the',itap)3329 CALL prt_enerbil('the',itap) 3150 3330 ! 3151 3331 ENDIF ! (mod(iflag_pbl_split/10,10) .GE. 1) … … 3153 3333 CALL add_phys_tend(d_u_ajs,d_v_ajs,d_t_ajs,d_q_ajs, & 3154 3334 dql0,dqi0,paprs,'thermals', abortphy,flag_inhib_tend,itap,0) 3155 callprt_enerbil('thermals',itap)3335 CALL prt_enerbil('thermals',itap) 3156 3336 ! 3157 3337 ! 3158 CALL alpale_th( dtime, lmax_th, t_seri, cell_area, &3338 CALL alpale_th( phys_tstep, lmax_th, t_seri, cell_area, & 3159 3339 cin, s2, n2, & 3160 3340 ale_bl_trig, ale_bl_stat, ale_bl, & … … 3216 3396 CALL add_phys_tend(du0,dv0,d_t_ajsb,d_q_ajsb,dql0,dqi0,paprs, & 3217 3397 'ajsb',abortphy,flag_inhib_tend,itap,0) 3218 callprt_enerbil('ajsb',itap)3398 CALL prt_enerbil('ajsb',itap) 3219 3399 d_t_ajs(:,:)=d_t_ajs(:,:)+d_t_ajsb(:,:) 3220 3400 d_q_ajs(:,:)=d_q_ajs(:,:)+d_q_ajsb(:,:) … … 3246 3426 ENDIF 3247 3427 ! 3248 CALL fisrtilp( dtime,paprs,pplay, &3428 CALL fisrtilp(phys_tstep,paprs,pplay, & 3249 3429 t_seri, q_seri,ptconv,ratqs, & 3250 3430 d_t_lsc, d_q_lsc, d_ql_lsc, d_qi_lsc, rneb, cldliq, & … … 3267 3447 CALL add_phys_tend(du0,dv0,d_t_lsc,d_q_lsc,d_ql_lsc,d_qi_lsc,paprs, & 3268 3448 'lsc',abortphy,flag_inhib_tend,itap,0) 3269 callprt_enerbil('lsc',itap)3449 CALL prt_enerbil('lsc',itap) 3270 3450 rain_num(:)=0. 3271 3451 DO k = 1, klev … … 3306 3486 + snow_lsc(i))*cell_area(i)/REAL(klon) 3307 3487 ENDDO 3308 zx_t = zx_t/za* dtime3488 zx_t = zx_t/za*phys_tstep 3309 3489 WRITE(lunout,*)"Precip=", zx_t 3310 3490 ENDIF … … 3526 3706 calday = REAL(days_elapsed + 1) + jH_cur 3527 3707 3528 CALL chemtime(itap+itau_phy-1, date0, dtime, itap) 3529 IF (config_inca == 'aero' .OR. config_inca == 'aeNP') THEN 3530 CALL AEROSOL_METEO_CALC( & 3531 calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, & 3532 prfl,psfl,pctsrf,cell_area, & 3533 latitude_deg,longitude_deg,u10m,v10m) 3534 ENDIF 3708 CALL chemtime(itap+itau_phy-1, date0, phys_tstep, itap) 3709 CALL AEROSOL_METEO_CALC( & 3710 calday,pdtphys,pplay,paprs,t,pmflxr,pmflxs, & 3711 prfl,psfl,pctsrf,cell_area, & 3712 latitude_deg,longitude_deg,u10m,v10m) 3535 3713 3536 3714 zxsnow_dummy(:) = 0.0 … … 3615 3793 #else 3616 3794 !--climatologies or INCA aerosols 3617 CALL readaerosol_optic_rrtm( debut, aerosol_couple, ok_alw, &3795 CALL readaerosol_optic_rrtm( debut, aerosol_couple, ok_alw, ok_volcan, & 3618 3796 new_aod, flag_aerosol, flag_bc_internal_mixture, itap, jD_cur-jD_ref, & 3619 3797 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & … … 3705 3883 CALL readaerosolstrato1_rrtm(debut) 3706 3884 ELSEIF (flag_aerosol_strat.EQ.2) THEN 3707 CALL readaerosolstrato2_rrtm(debut )3885 CALL readaerosolstrato2_rrtm(debut, ok_volcan) 3708 3886 ELSE 3709 3887 abort_message='flag_aerosol_strat must equal 1 or 2 for rrtm=1' … … 3717 3895 #endif 3718 3896 ENDIF 3897 ELSE 3898 tausum_aero(:,:,id_STRAT_phy) = 0. 3719 3899 ENDIF 3720 3900 ! … … 3895 4075 RCFC11 = RCFC11_act 3896 4076 RCFC12 = RCFC12_act 4077 ! 4078 !--interactive CO2 in ppm from carbon cycle 4079 IF (carbon_cycle_rad.AND..NOT.debut) THEN 4080 RCO2=RCO2_glo 4081 ENDIF 3897 4082 ! 3898 4083 IF (prt_level .GE.10) THEN 3899 4084 print *,' ->radlwsw, number 1 ' 3900 4085 ENDIF 3901 3902 4086 ! 3903 4087 CALL radlwsw & … … 3909 4093 t_seri,q_seri,wo, & 3910 4094 cldfrarad, cldemirad, cldtaurad, & 3911 ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, & 4095 ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, ok_volcan, & 4096 flag_aerosol, & 3912 4097 flag_aerosol_strat, flag_aer_feedback, & 3913 4098 tau_aero, piz_aero, cg_aero, & … … 3920 4105 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 3921 4106 heat,heat0,cool,cool0,albpla, & 4107 heat_volc,cool_volc, & 3922 4108 topsw,toplw,solsw,sollw, & 3923 4109 sollwdown, & … … 3994 4180 t_seri,q_seri,wo, & 3995 4181 cldfrarad, cldemirad, cldtaurad, & 3996 ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, flag_aerosol, & 4182 ok_ade.OR.flag_aerosol_strat.GT.0, ok_aie, ok_volcan, & 4183 flag_aerosol, & 3997 4184 flag_aerosol_strat, flag_aer_feedback, & 3998 4185 tau_aero, piz_aero, cg_aero, & … … 4005 4192 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 4006 4193 heatp,heat0p,coolp,cool0p,albplap, & 4194 heat_volc,cool_volc, & 4007 4195 topswp,toplwp,solswp,sollwp, & 4008 4196 sollwdownp, & … … 4072 4260 4073 4261 DO k=1, klev 4074 d_t_swr(:,k)=swradcorr(:)*heat(:,k)* dtime/RDAY4075 d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)* dtime/RDAY4076 d_t_lwr(:,k)=-cool(:,k)* dtime/RDAY4077 d_t_lw0(:,k)=-cool0(:,k)* dtime/RDAY4262 d_t_swr(:,k)=swradcorr(:)*heat(:,k)*phys_tstep/RDAY 4263 d_t_sw0(:,k)=swradcorr(:)*heat0(:,k)*phys_tstep/RDAY 4264 d_t_lwr(:,k)=-cool(:,k)*phys_tstep/RDAY 4265 d_t_lw0(:,k)=-cool0(:,k)*phys_tstep/RDAY 4078 4266 ENDDO 4079 4267 4080 4268 CALL add_phys_tend(du0,dv0,d_t_swr,dq0,dql0,dqi0,paprs,'SW',abortphy,flag_inhib_tend,itap,0) 4081 callprt_enerbil('SW',itap)4269 CALL prt_enerbil('SW',itap) 4082 4270 CALL add_phys_tend(du0,dv0,d_t_lwr,dq0,dql0,dqi0,paprs,'LW',abortphy,flag_inhib_tend,itap,0) 4083 callprt_enerbil('LW',itap)4271 CALL prt_enerbil('LW',itap) 4084 4272 4085 4273 ! … … 4131 4319 IF (ok_strato) THEN 4132 4320 4133 CALL drag_noro_strato(0,klon,klev, dtime,paprs,pplay, &4321 CALL drag_noro_strato(0,klon,klev,phys_tstep,paprs,pplay, & 4134 4322 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 4135 4323 igwd,idx,itest, & … … 4139 4327 4140 4328 ELSE 4141 CALL drag_noro(klon,klev, dtime,paprs,pplay, &4329 CALL drag_noro(klon,klev,phys_tstep,paprs,pplay, & 4142 4330 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 4143 4331 igwd,idx,itest, & … … 4152 4340 CALL add_phys_tend(d_u_oro,d_v_oro,d_t_oro,dq0,dql0,dqi0,paprs,'oro', & 4153 4341 abortphy,flag_inhib_tend,itap,0) 4154 callprt_enerbil('oro',itap)4342 CALL prt_enerbil('oro',itap) 4155 4343 !---------------------------------------------------------------------- 4156 4344 ! … … 4180 4368 IF (ok_strato) THEN 4181 4369 4182 CALL lift_noro_strato(klon,klev, dtime,paprs,pplay, &4370 CALL lift_noro_strato(klon,klev,phys_tstep,paprs,pplay, & 4183 4371 latitude_deg,zmea,zstd,zpic,zgam,zthe,zpic,zval, & 4184 4372 igwd,idx,itest, & … … 4188 4376 4189 4377 ELSE 4190 CALL lift_noro(klon,klev, dtime,paprs,pplay, &4378 CALL lift_noro(klon,klev,phys_tstep,paprs,pplay, & 4191 4379 latitude_deg,zmea,zstd,zpic, & 4192 4380 itest, & … … 4199 4387 CALL add_phys_tend(d_u_lif, d_v_lif, d_t_lif, dq0, dql0, dqi0, paprs, & 4200 4388 'lif', abortphy,flag_inhib_tend,itap,0) 4201 callprt_enerbil('lif',itap)4389 CALL prt_enerbil('lif',itap) 4202 4390 ENDIF ! fin de test sur ok_orolf 4203 4391 … … 4208 4396 du_gwd_hines=0. 4209 4397 dv_gwd_hines=0. 4210 CALL hines_gwd(klon, klev, dtime, paprs, pplay, latitude_deg, t_seri, &4398 CALL hines_gwd(klon, klev, phys_tstep, paprs, pplay, latitude_deg, t_seri, & 4211 4399 u_seri, v_seri, zustr_gwd_hines, zvstr_gwd_hines, d_t_hin, & 4212 4400 du_gwd_hines, dv_gwd_hines) … … 4214 4402 zvstr_gwd_hines=0. 4215 4403 DO k = 1, klev 4216 zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/ dtime&4404 zustr_gwd_hines(:)=zustr_gwd_hines(:)+ du_gwd_hines(:, k)/phys_tstep & 4217 4405 * (paprs(:, k)-paprs(:, k+1))/rg 4218 zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/ dtime&4406 zvstr_gwd_hines(:)=zvstr_gwd_hines(:)+ dv_gwd_hines(:, k)/phys_tstep & 4219 4407 * (paprs(:, k)-paprs(:, k+1))/rg 4220 4408 ENDDO … … 4223 4411 CALL add_phys_tend(du_gwd_hines, dv_gwd_hines, d_t_hin, dq0, dql0, & 4224 4412 dqi0, paprs, 'hin', abortphy,flag_inhib_tend,itap,0) 4225 callprt_enerbil('hin',itap)4413 CALL prt_enerbil('hin',itap) 4226 4414 ENDIF 4227 4415 4228 4416 IF (.not. ok_hines .and. ok_gwd_rando) then 4229 CALL acama_GWD_rando(DTIME, pplay, latitude_deg, t_seri, u_seri, & 4417 ! ym missing init for east_gwstress & west_gwstress -> added in phys_local_var_mod 4418 CALL acama_GWD_rando(PHYS_TSTEP, pplay, latitude_deg, t_seri, u_seri, & 4230 4419 v_seri, rot, zustr_gwd_front, zvstr_gwd_front, du_gwd_front, & 4231 4420 dv_gwd_front, east_gwstress, west_gwstress) … … 4233 4422 zvstr_gwd_front=0. 4234 4423 DO k = 1, klev 4235 zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/ dtime&4424 zustr_gwd_front(:)=zustr_gwd_front(:)+ du_gwd_front(:, k)/phys_tstep & 4236 4425 * (paprs(:, k)-paprs(:, k+1))/rg 4237 zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/ dtime&4426 zvstr_gwd_front(:)=zvstr_gwd_front(:)+ dv_gwd_front(:, k)/phys_tstep & 4238 4427 * (paprs(:, k)-paprs(:, k+1))/rg 4239 4428 ENDDO … … 4241 4430 CALL add_phys_tend(du_gwd_front, dv_gwd_front, dt0, dq0, dql0, dqi0, & 4242 4431 paprs, 'front_gwd_rando', abortphy,flag_inhib_tend,itap,0) 4243 callprt_enerbil('front_gwd_rando',itap)4432 CALL prt_enerbil('front_gwd_rando',itap) 4244 4433 ENDIF 4245 4434 4246 4435 IF (ok_gwd_rando) THEN 4247 CALL FLOTT_GWD_rando( DTIME, pplay, t_seri, u_seri, v_seri, &4436 CALL FLOTT_GWD_rando(PHYS_TSTEP, pplay, t_seri, u_seri, v_seri, & 4248 4437 rain_fall + snow_fall, zustr_gwd_rando, zvstr_gwd_rando, & 4249 4438 du_gwd_rando, dv_gwd_rando, east_gwstress, west_gwstress) 4250 4439 CALL add_phys_tend(du_gwd_rando, dv_gwd_rando, dt0, dq0, dql0, dqi0, & 4251 4440 paprs, 'flott_gwd_rando', abortphy,flag_inhib_tend,itap,0) 4252 callprt_enerbil('flott_gwd_rando',itap)4441 CALL prt_enerbil('flott_gwd_rando',itap) 4253 4442 zustr_gwd_rando=0. 4254 4443 zvstr_gwd_rando=0. 4255 4444 DO k = 1, klev 4256 zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/ dtime&4445 zustr_gwd_rando(:)=zustr_gwd_rando(:)+ du_gwd_rando(:, k)/phys_tstep & 4257 4446 * (paprs(:, k)-paprs(:, k+1))/rg 4258 zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/ dtime&4447 zvstr_gwd_rando(:)=zvstr_gwd_rando(:)+ dv_gwd_rando(:, k)/phys_tstep & 4259 4448 * (paprs(:, k)-paprs(:, k+1))/rg 4260 4449 ENDDO … … 4276 4465 DO k = 1, klev 4277 4466 DO i = 1, klon 4278 zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/ dtime* &4467 zustrph(i)=zustrph(i)+(u_seri(i,k)-u(i,k))/phys_tstep* & 4279 4468 (paprs(i,k)-paprs(i,k+1))/rg 4280 zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/ dtime* &4469 zvstrph(i)=zvstrph(i)+(v_seri(i,k)-v(i,k))/phys_tstep* & 4281 4470 (paprs(i,k)-paprs(i,k+1))/rg 4282 4471 ENDDO … … 4296 4485 !IM cf. FLott END 4297 4486 !DC Calcul de la tendance due au methane 4298 IF (ok_qch4) THEN4487 IF (ok_qch4) THEN 4299 4488 CALL METHOX(1,klon,klon,klev,q_seri,d_q_ch4,pplay) 4300 4489 ! ajout de la tendance d'humidite due au methane 4301 d_q_ch4_dtime(:,:) = d_q_ch4(:,:)* dtime4490 d_q_ch4_dtime(:,:) = d_q_ch4(:,:)*phys_tstep 4302 4491 CALL add_phys_tend(du0, dv0, dt0, d_q_ch4_dtime, dql0, dqi0, paprs, & 4303 4492 'q_ch4', abortphy,flag_inhib_tend,itap,0) 4304 d_q_ch4(:,:) = d_q_ch4_dtime(:,:)/ dtime4493 d_q_ch4(:,:) = d_q_ch4_dtime(:,:)/phys_tstep 4305 4494 ENDIF 4306 4495 ! … … 4313 4502 ! Inititialization 4314 4503 !------------------ 4315 4316 4317 4504 4318 4505 addtkeoro=0 … … 4326 4513 alphatkeoro=min(max(0.,alphatkeoro),1.) 4327 4514 4328 smallscales_tkeoro=. false.4515 smallscales_tkeoro=.FALSE. 4329 4516 CALL getin_p('smallscales_tkeoro',smallscales_tkeoro) 4330 4517 4331 4518 4332 dtadd(:,:)=0. 4333 duadd(:,:)=0. 4334 dvadd(:,:)=0. 4335 4336 4519 dtadd(:,:)=0. 4520 duadd(:,:)=0. 4521 dvadd(:,:)=0. 4337 4522 4338 4523 ! Choices for addtkeoro: … … 4349 4534 4350 4535 4351 4352 4536 IF (addtkeoro .EQ. 1 ) THEN 4353 4537 … … 4357 4541 ELSE IF (addtkeoro .EQ. 2) THEN 4358 4542 4359 4360 4361 IF (smallscales_tkeoro) THEN 4543 IF (smallscales_tkeoro) THEN 4362 4544 igwd=0 4363 4545 DO i=1,klon … … 4382 4564 igwd=igwd+1 4383 4565 idx(igwd)=i 4384 ENDIF 4385 ENDDO 4386 4387 END IF 4388 4389 4390 4391 4392 CALL drag_noro_strato(addtkeoro,klon,klev,dtime,paprs,pplay, & 4566 ENDIF 4567 ENDDO 4568 4569 ENDIF 4570 4571 CALL drag_noro_strato(addtkeoro,klon,klev,phys_tstep,paprs,pplay, & 4393 4572 zmea,zstd, zsig, zgam, zthe,zpic,zval, & 4394 4573 igwd,idx,itest, & … … 4397 4576 d_t_oro_gw, d_u_oro_gw, d_v_oro_gw) 4398 4577 4399 zustrdr(:)=0. 4400 zvstrdr(:)=0. 4401 zulow(:)=0. 4402 zvlow(:)=0. 4403 4404 duadd(:,:)=alphatkeoro*d_u_oro_gw(:,:) 4405 dvadd(:,:)=alphatkeoro*d_v_oro_gw(:,:) 4406 END IF 4407 4578 zustrdr(:)=0. 4579 zvstrdr(:)=0. 4580 zulow(:)=0. 4581 zvlow(:)=0. 4582 4583 duadd(:,:)=alphatkeoro*d_u_oro_gw(:,:) 4584 dvadd(:,:)=alphatkeoro*d_v_oro_gw(:,:) 4585 ENDIF 4408 4586 4409 4587 … … 4416 4594 4417 4595 4418 4419 4596 ENDIF 4420 4597 ! ----- 4421 4598 !=============================================================== 4422 4423 4599 4424 4600 … … 4431 4607 ! adeclarer 4432 4608 #ifdef CPP_COSP 4433 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/ dtime)).EQ.0) THEN4609 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN 4434 4610 4435 4611 IF (prt_level .GE.10) THEN … … 4439 4615 ! print*,'Dans physiq.F avant appel cosp ref_liq,ref_ice=', 4440 4616 ! s ref_liq,ref_ice 4441 CALL phys_cosp(itap, dtime,freq_cosp, &4617 CALL phys_cosp(itap,phys_tstep,freq_cosp, & 4442 4618 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 4443 4619 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & … … 4462 4638 4463 4639 #ifdef CPP_COSP2 4464 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/ dtime)).EQ.0) THEN4640 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN 4465 4641 4466 4642 IF (prt_level .GE.10) THEN … … 4470 4646 print*,'Dans physiq.F avant appel ' 4471 4647 ! s ref_liq,ref_ice 4472 CALL phys_cosp2(itap, dtime,freq_cosp, &4648 CALL phys_cosp2(itap,phys_tstep,freq_cosp, & 4473 4649 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 4474 4650 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & … … 4485 4661 #endif 4486 4662 4663 #ifdef CPP_COSPV2 4664 IF (itap.eq.1.or.MOD(itap,NINT(freq_cosp/phys_tstep)).EQ.0) THEN 4665 4666 IF (prt_level .GE.10) THEN 4667 print*,'freq_cosp',freq_cosp 4668 ENDIF 4669 mr_ozone=wo(:, :, 1) * dobson_u * 1e3 / zmasse 4670 print*,'Dans physiq.F avant appel ' 4671 ! s ref_liq,ref_ice 4672 CALL lmdz_cosp_interface(itap,phys_tstep,freq_cosp, & 4673 ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & 4674 ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & 4675 klon,klev,longitude_deg,latitude_deg,presnivs,overlap, & 4676 JrNt,ref_liq,ref_ice, & 4677 pctsrf(:,is_ter)+pctsrf(:,is_lic), & 4678 zu10m,zv10m,pphis, & 4679 zphi,paprs(:,1:klev),pplay,zxtsol,t_seri, & 4680 qx(:,:,ivap),zx_rh,cldfra,rnebcon,flwc,fiwc, & 4681 prfl(:,1:klev),psfl(:,1:klev), & 4682 pmflxr(:,1:klev),pmflxs(:,1:klev), & 4683 mr_ozone,cldtau, cldemi) 4684 ENDIF 4685 #endif 4686 4487 4687 ENDIF !ok_cosp 4488 4688 … … 4492 4692 IF (ok_airs) then 4493 4693 4494 IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/ dtime)).EQ.0) THEN4694 IF (itap.eq.1.or.MOD(itap,NINT(freq_airs/phys_tstep)).EQ.0) THEN 4495 4695 write(*,*) 'je vais appeler simu_airs, ok_airs, freq_airs=', ok_airs, freq_airs 4496 4696 CALL simu_airs(itap,rneb, t_seri, cldemi, fiwc, ref_ice, pphi, pplay, paprs,& … … 4547 4747 CALL phytrac ( & 4548 4748 itap, days_elapsed+1, jH_cur, debut, & 4549 lafin, dtime, u, v, t, &4749 lafin, phys_tstep, u, v, t, & 4550 4750 paprs, pplay, pmfu, pmfd, & 4551 4751 pen_u, pde_u, pen_d, pde_d, & … … 4582 4782 cdragh,coefh(1:klon,1:klev,is_ave),u1,v1,ftsol,pctsrf, & 4583 4783 frac_impa, frac_nucl, & 4584 pphis,cell_area, dtime,itap, &4784 pphis,cell_area,phys_tstep,itap, & 4585 4785 qx(:,:,ivap),da,phi,mp,upwd,dnwd) 4586 4786 … … 4653 4853 4654 4854 CALL chemhook_end ( & 4655 dtime, &4855 phys_tstep, & 4656 4856 pplay, & 4657 4857 t_seri, & … … 4688 4888 DO k = 1, klev 4689 4889 DO i = 1, klon 4690 d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / dtime4691 d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / dtime4692 d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / dtime4693 d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / dtime4694 d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / dtime4890 d_u(i,k) = ( u_seri(i,k) - u(i,k) ) / phys_tstep 4891 d_v(i,k) = ( v_seri(i,k) - v(i,k) ) / phys_tstep 4892 d_t(i,k) = ( t_seri(i,k)-t(i,k) ) / phys_tstep 4893 d_qx(i,k,ivap) = ( q_seri(i,k) - qx(i,k,ivap) ) / phys_tstep 4894 d_qx(i,k,iliq) = ( ql_seri(i,k) - qx(i,k,iliq) ) / phys_tstep 4695 4895 !CR: on ajoute le contenu en glace 4696 4896 IF (nqo.eq.3) THEN 4697 d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / dtime4897 d_qx(i,k,isol) = ( qs_seri(i,k) - qx(i,k,isol) ) / phys_tstep 4698 4898 ENDIF 4699 4899 ENDDO … … 4707 4907 DO k = 1, klev 4708 4908 DO i = 1, klon 4709 ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / dtime4710 d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / dtime4909 ! d_qx(i,k,iq) = ( tr_seri(i,k,iq-2) - qx(i,k,iq) ) / phys_tstep 4910 d_qx(i,k,iq) = ( tr_seri(i,k,iq-nqo) - qx(i,k,iq) ) / phys_tstep 4711 4911 ENDDO 4712 4912 ENDDO … … 4877 5077 CALL phys_output_write(itap, pdtphys, paprs, pphis, & 4878 5078 pplay, lmax_th, aerosol_couple, & 4879 ok_ade, ok_aie, ivap, iliq, isol, new_aod, &5079 ok_ade, ok_aie, ok_volcan, ivap, iliq, isol, new_aod, & 4880 5080 ok_sync, ptconv, read_climoz, clevSTD, & 4881 5081 ptconvth, d_u, d_t, qx, d_qx, zmasse, & … … 4890 5090 4891 5091 ! On remet des variables a .false. apres un premier appel 4892 if (debut) then5092 IF (debut) THEN 4893 5093 #ifdef CPP_XIOS 4894 5094 swaero_diag=.FALSE. … … 4898 5098 ! write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm 4899 5099 4900 IF (is_master) then5100 IF (is_master) THEN 4901 5101 !--setting up swaero_diag to TRUE in XIOS case 4902 5102 IF (xios_field_is_active("topswad").OR.xios_field_is_active("topswad0").OR. & … … 4929 5129 xios_field_is_active("rld4co2").OR.xios_field_is_active("rldcs4co2")) & 4930 5130 ok_4xCO2atm=.TRUE. 4931 endif5131 ENDIF 4932 5132 !$OMP BARRIER 4933 callbcast(swaero_diag)4934 callbcast(swaerofree_diag)4935 callbcast(dryaod_diag)4936 callbcast(ok_4xCO2atm)5133 CALL bcast(swaero_diag) 5134 CALL bcast(swaerofree_diag) 5135 CALL bcast(dryaod_diag) 5136 CALL bcast(ok_4xCO2atm) 4937 5137 ! write (lunout,*)'ok_4xCO2atm= ',swaero_diag, swaerofree_diag, dryaod_diag, ok_4xCO2atm 4938 5138 #endif 4939 endif5139 ENDIF 4940 5140 4941 5141 !==================================================================== … … 4962 5162 ! write(97) u_seri,v_seri,t_seri,q_seri 4963 5163 ! close(97) 4964 !$OMP MASTER 4965 IF (read_climoz >= 1) THEN 4966 IF (is_mpi_root) THEN 4967 CALL nf95_close(ncid_climoz) 4968 ENDIF 4969 DEALLOCATE(press_edg_climoz) ! pointer 4970 DEALLOCATE(press_cen_climoz) ! pointer 4971 ENDIF 4972 !$OMP END MASTER 4973 print *,' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1 5164 5165 IF (is_omp_master) THEN 5166 5167 IF (read_climoz >= 1) THEN 5168 IF (is_mpi_root) CALL nf95_close(ncid_climoz) 5169 DEALLOCATE(press_edg_climoz) ! pointer 5170 DEALLOCATE(press_cen_climoz) ! pointer 5171 ENDIF 5172 5173 ENDIF 5174 #ifdef CPP_XIOS 5175 IF (is_omp_master) CALL xios_context_finalize 5176 #endif 5177 WRITE(lunout,*) ' physiq fin, nombre de steps ou cvpas = 1 : ', Ncvpaseq1 4974 5178 ENDIF 4975 5179 4976 5180 ! first=.false. 4977 5181 4978 4979 5182 END SUBROUTINE physiq 4980 5183 -
LMDZ6/branches/Ocean_skin/libf/phylmd/phytrac_mod.F90
-
Property
svn:keywords
set to
Id
r3418 r3605 54 54 CONTAINS 55 55 56 SUBROUTINE phytrac_init() 57 USE dimphy 58 USE infotrac_phy, ONLY: nbtr 59 IMPLICIT NONE 60 61 ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr)) 62 ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr)) 63 ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr)) 64 ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr)) 65 ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr)) 66 ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr)) 67 ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr)) 68 ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr)) 69 ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr)) 70 ALLOCATE(d_tr_th(klon,klev,nbtr)) 71 ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr)) 72 73 END SUBROUTINE phytrac_init 74 56 75 SUBROUTINE phytrac( & 57 76 nstep, julien, gmtime, debutphy, & … … 332 351 ! -- INITIALIZATION -- 333 352 !###################################################################### 334 IF (debutphy) THEN335 ALLOCATE(d_tr_cl(klon,klev,nbtr),d_tr_dry(klon,nbtr))336 ALLOCATE(flux_tr_dry(klon,nbtr),d_tr_dec(klon,klev,nbtr),d_tr_cv(klon,klev,nbtr))337 ALLOCATE(d_tr_insc(klon,klev,nbtr),d_tr_bcscav(klon,klev,nbtr))338 ALLOCATE(d_tr_evapls(klon,klev,nbtr),d_tr_ls(klon,klev,nbtr))339 ALLOCATE(qPrls(klon,nbtr),d_tr_trsp(klon,klev,nbtr))340 ALLOCATE(d_tr_sscav(klon,klev,nbtr),d_tr_sat(klon,klev,nbtr))341 ALLOCATE(d_tr_uscav(klon,klev,nbtr),qPr(klon,klev,nbtr),qDi(klon,klev,nbtr))342 ALLOCATE(qPa(klon,klev,nbtr),qMel(klon,klev,nbtr))343 ALLOCATE(qTrdi(klon,klev,nbtr),dtrcvMA(klon,klev,nbtr))344 ALLOCATE(d_tr_th(klon,klev,nbtr))345 ALLOCATE(d_tr_lessi_impa(klon,klev,nbtr),d_tr_lessi_nucl(klon,klev,nbtr))346 ENDIF347 353 348 354 DO k=1,klev … … 405 411 !Config Key = convscav 406 412 !Config Desc = Convective scavenging switch: 0=off, 1=on. 407 !Config Def = . false.413 !Config Def = .FALSE. 408 414 !Config Help = 409 415 ! 410 416 !$OMP MASTER 411 convscav_omp=. false.417 convscav_omp=.FALSE. 412 418 call getin('convscav', convscav_omp) 413 419 iflag_vdf_trac_omp=1 … … 479 485 CASE('co2i') 480 486 source(:,:)=0. 487 lessivage = .FALSE. 488 aerosol(:) = .FALSE. 489 pbl_flg(:) = 1 490 iflag_the_trac= 1 491 iflag_vdf_trac= 1 492 iflag_con_trac= 1 481 493 #ifdef CPP_StratAer 482 494 CASE('coag') … … 506 518 CASE('lmdz') 507 519 IF (convscav.and.aerosol(it)) THEN 508 flag_cvltr(it)=. true.520 flag_cvltr(it)=.TRUE. 509 521 ccntrAA(it) =ccntrAA_in !--a modifier par JYG a lire depuis fichier 510 522 ccntrENV(it)=ccntrENV_in 511 523 coefcoli(it)=coefcoli_in 512 524 ELSE 513 flag_cvltr(it)=. false.525 flag_cvltr(it)=.FALSE. 514 526 ENDIF 515 527 516 528 CASE('repr') 517 flag_cvltr(it)=. false.529 flag_cvltr(it)=.FALSE. 518 530 519 531 CASE('inca') 520 532 ! IF ((it.EQ.id_Rn222) .OR. ((it.GE.id_SO2) .AND. (it.LE.id_NH3)) ) THEN 521 533 ! !--gas-phase species 522 ! flag_cvltr(it)=. false.534 ! flag_cvltr(it)=.FALSE. 523 535 ! 524 536 ! ELSEIF ( (it.GE.id_CIDUSTM) .AND. (it.LE.id_AIN) ) THEN 525 537 ! !--insoluble aerosol species 526 ! flag_cvltr(it)=. true.538 ! flag_cvltr(it)=.TRUE. 527 539 ! ccntrAA(it)=0.7 528 540 ! ccntrENV(it)=0.7 … … 530 542 ! ELSEIF ( (it.EQ.id_Pb210) .OR. ((it.GE.id_CSSSM) .AND. (it.LE.id_SSN))) THEN 531 543 ! !--soluble aerosol species 532 ! flag_cvltr(it)=. true.544 ! flag_cvltr(it)=.TRUE. 533 545 ! ccntrAA(it)=0.9 534 546 ! ccntrENV(it)=0.9 … … 540 552 !--test OB 541 553 !--for now we do not scavenge in cvltr 542 flag_cvltr(it)=. false.554 flag_cvltr(it)=.FALSE. 543 555 544 556 CASE('co2i') 545 557 !--co2 tracers are not scavenged 546 flag_cvltr(it)=. false.558 flag_cvltr(it)=.FALSE. 547 559 548 560 #ifdef CPP_StratAer 549 561 CASE('coag') 550 562 IF (convscav.and.aerosol(it)) THEN 551 flag_cvltr(it)=. true.563 flag_cvltr(it)=.TRUE. 552 564 ccntrAA(it) =ccntrAA_in 553 565 ccntrENV(it)=ccntrENV_in 554 566 coefcoli(it)=coefcoli_in 555 567 ELSE 556 flag_cvltr(it)=. false.568 flag_cvltr(it)=.FALSE. 557 569 ENDIF 558 570 #endif … … 562 574 ! 563 575 ELSE ! iflag_con .ne. 3 564 flag_cvltr(:) = . false.576 flag_cvltr(:) = .FALSE. 565 577 ENDIF 566 578 ! … … 590 602 IF (lessivage .AND. type_trac .EQ. 'inca') THEN 591 603 CALL abort_physic('phytrac', 'lessivage=T config_inca=inca impossible',1) 592 STOP604 ! STOP 593 605 ENDIF 594 606 ! 595 END 607 ENDIF ! of IF (debutphy) 596 608 !############################################ END INITIALIZATION ####### 597 609 … … 637 649 ! -- CO2 interactif -- 638 650 ! -- source is updated with FF and BB emissions 639 ! -- OB => PC need to add net fluxfrom ocean and orchidee651 ! -- and net fluxes from ocean and orchidee 640 652 ! -- sign convention : positive into the atmosphere 653 641 654 CALL tracco2i(pdtphys, debutphy, & 642 655 xlat, xlon, pphis, pphi, & … … 754 767 #endif 755 768 756 END 769 ENDIF ! convection 757 770 758 771 !====================================================================== … … 792 805 END DO ! it 793 806 794 END 807 ENDIF ! Thermiques 795 808 796 809 !====================================================================== … … 878 891 CALL abort_physic('iflag_vdf_trac', 'cas non prevu',1) 879 892 ! 880 END 893 ENDIF ! couche limite 881 894 882 895 !====================================================================== … … 968 981 zdz(i,k)=(paprs(i,k)-paprs(i,k+1))/zrho(i,k)/RG 969 982 ! 970 END 971 END 983 ENDDO 984 ENDDO 972 985 973 986 DO k=klev-1, 1, -1 … … 1014 1027 ! (1.-1./(frac_impa(i,k)*frac_nucl(i,k))) 1015 1028 !-------------- 1016 END 1017 END 1018 END 1019 END 1029 ENDDO 1030 ENDDO 1031 ENDIF 1032 ENDDO 1020 1033 ! ********* end modified old version 1021 1034 … … 1053 1066 ! ---------------------------------------------------------------------- 1054 1067 tr_seri(i,k,it)=tr_seri(i,k,it)*frac_impa(i,k)*frac_nucl(i,k) 1055 END 1056 END 1057 END 1058 END 1068 ENDDO 1069 ENDDO 1070 ENDIF 1071 ENDDO 1059 1072 1060 1073 ! ********* end old version 1061 1074 ENDIF ! iflag_lscav . EQ. 1, 2, 3 or 4 1062 1075 ! 1063 END 1076 ENDIF ! lessivage 1064 1077 1065 1078 -
Property
svn:keywords
set to
-
LMDZ6/branches/Ocean_skin/libf/phylmd/radlwsw_m.F90
r3412 r3605 16 16 t,q,wo,& 17 17 cldfra, cldemi, cldtaupd,& 18 ok_ade, ok_aie, flag_aerosol,&18 ok_ade, ok_aie, ok_volcan, flag_aerosol,& 19 19 flag_aerosol_strat, flag_aer_feedback, & 20 20 tau_aero, piz_aero, cg_aero,& … … 25 25 ref_liq, ref_ice, ref_liq_pi, ref_ice_pi, & 26 26 heat,heat0,cool,cool0,albpla,& 27 heat_volc, cool_volc,& 27 28 topsw,toplw,solsw,sollw,& 28 29 sollwdown,& … … 100 101 ! ok_ade---input-L- apply the Aerosol Direct Effect or not? 101 102 ! ok_aie---input-L- apply the Aerosol Indirect Effect or not? 103 ! ok_volcan-input-L- activate volcanic diags (SW heat & LW cool rate, SW & LW flux) 102 104 ! flag_aerosol-input-I- aerosol flag from 0 to 6 103 105 ! flag_aerosol_strat-input-I- use stratospheric aerosols flag (0, 1, 2) … … 120 122 ! solswai---output-R- ray. solaire net absorbe a la surface (aerosol ind) 121 123 ! topswai---output-R- ray. solaire absorbe au sommet de l'atm. (aerosol ind) 124 ! 125 ! heat_volc-----output-R- echauffement atmospherique du au forcage volcanique (visible) (K/s) 126 ! cool_volc-----output-R- refroidissement dans l'IR du au forcage volcanique (K/s) 122 127 ! 123 128 ! ATTENTION: swai and swad have to be interpreted in the following manner: … … 193 198 194 199 LOGICAL, INTENT(in) :: ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not 200 LOGICAL, INTENT(in) :: ok_volcan ! produce volcanic diags (SW/LW heat flux and rate) 195 201 LOGICAL :: lldebug 196 202 INTEGER, INTENT(in) :: flag_aerosol ! takes value 0 (no aerosol) or 1 to 6 (aerosols) … … 228 234 REAL, INTENT(out) :: heat(KLON,KLEV), cool(KLON,KLEV) 229 235 REAL, INTENT(out) :: heat0(KLON,KLEV), cool0(KLON,KLEV) 236 REAL, INTENT(out) :: heat_volc(KLON,KLEV), cool_volc(KLON,KLEV) !NL 230 237 REAL, INTENT(out) :: topsw(KLON), toplw(KLON) 231 238 REAL, INTENT(out) :: solsw(KLON), sollw(KLON), albpla(KLON) … … 294 301 REAL(KIND=8) zheat(kdlon,kflev), zcool(kdlon,kflev) 295 302 REAL(KIND=8) zheat0(kdlon,kflev), zcool0(kdlon,kflev) 303 REAL(KIND=8) zheat_volc(kdlon,kflev), zcool_volc(kdlon,kflev) !NL 296 304 REAL(KIND=8) ztopsw(kdlon), ztoplw(kdlon) 297 305 REAL(KIND=8) zsolsw(kdlon), zsollw(kdlon), zalbpla(kdlon) … … 308 316 REAL(KIND=8) ztopswad0aero(kdlon), zsolswad0aero(kdlon) ! Aerosol direct forcing at TOAand surface 309 317 REAL(KIND=8) ztopswaiaero(kdlon), zsolswaiaero(kdlon) ! dito, indirect 318 !--NL 319 REAL(KIND=8) zswadaero(kdlon,kflev+1) ! SW Aerosol direct forcing 320 REAL(KIND=8) zlwadaero(kdlon,kflev+1) ! LW Aerosol direct forcing 310 321 !-LW by CK 311 322 REAL(KIND=8) ztoplwadaero(kdlon), zsollwadaero(kdlon) ! LW Aerosol direct forcing at TOAand surface … … 398 409 cgaero(:,:,:,:)=0. 399 410 lldebug=.FALSE. 400 411 412 ztopsw_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4 413 ztopsw0_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4 414 zsolsw_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4 415 zsolsw0_aero(:,:) = 0. !ym missing init : warning : not initialized in SW_AEROAR4 416 417 418 ZTOPSWADAERO(:) = 0. !ym missing init 419 ZSOLSWADAERO(:) = 0. !ym missing init 420 ZTOPSWAD0AERO(:) = 0. !ym missing init 421 ZSOLSWAD0AERO(:) = 0. !ym missing init 422 ZTOPSWAIAERO(:) = 0. !ym missing init 423 ZSOLSWAIAERO(:) = 0. !ym missing init 424 ZTOPSWCF_AERO(:,:)= 0.!ym missing init 425 ZSOLSWCF_AERO(:,:) =0. !ym missing init 426 401 427 ! 402 428 !------------------------------------------- … … 415 441 heat(i,k)=0. 416 442 cool(i,k)=0. 443 heat_volc(i,k)=0. !NL 444 cool_volc(i,k)=0. !NL 417 445 heat0(i,k)=0. 418 446 cool0(i,k)=0. … … 558 586 ENDDO 559 587 DO k = 1, kflev 560 DO i = 1, kdlon 561 zcool(i,k)=0. 562 zcool0(i,k)=0. 563 ENDDO 588 DO i = 1, kdlon 589 zcool(i,k)=0. 590 zcool_volc(i,k)=0. !NL 591 zcool0(i,k)=0. 592 ENDDO 564 593 ENDDO 565 594 DO i = 1, kdlon … … 584 613 !----- Mise a zero des tableaux output du rayonnement SW-AR4 585 614 DO k = 1, kflev+1 586 DO i = 1, kdlon 587 ZFSUP(i,k)=0. 588 ZFSDN(i,k)=0. 589 ZFSUP0(i,k)=0. 590 ZFSDN0(i,k)=0. 591 ZFSUPC0(i,k)=0. 592 ZFSDNC0(i,k)=0. 593 ZFLUPC0(i,k)=0. 594 ZFLDNC0(i,k)=0. 595 ZSWFT0_i(i,k)=0. 596 ZFCUP_i(i,k)=0. 597 ZFCDWN_i(i,k)=0. 598 ZFCCUP_i(i,k)=0. 599 ZFCCDWN_i(i,k)=0. 600 ZFLCCUP_i(i,k)=0. 601 ZFLCCDWN_i(i,k)=0. 602 ENDDO 615 DO i = 1, kdlon 616 ZFSUP(i,k)=0. 617 ZFSDN(i,k)=0. 618 ZFSUP0(i,k)=0. 619 ZFSDN0(i,k)=0. 620 ZFSUPC0(i,k)=0. 621 ZFSDNC0(i,k)=0. 622 ZFLUPC0(i,k)=0. 623 ZFLDNC0(i,k)=0. 624 ZSWFT0_i(i,k)=0. 625 ZFCUP_i(i,k)=0. 626 ZFCDWN_i(i,k)=0. 627 ZFCCUP_i(i,k)=0. 628 ZFCCDWN_i(i,k)=0. 629 ZFLCCUP_i(i,k)=0. 630 ZFLCCDWN_i(i,k)=0. 631 zswadaero(i,k)=0. !--NL 632 ENDDO 603 633 ENDDO 604 634 DO k = 1, kflev 605 DO i = 1, kdlon 606 zheat(i,k)=0. 607 zheat0(i,k)=0. 608 ENDDO 635 DO i = 1, kdlon 636 zheat(i,k)=0. 637 zheat_volc(i,k)=0. 638 zheat0(i,k)=0. 639 ENDDO 609 640 ENDDO 610 641 DO i = 1, kdlon … … 708 739 ! 709 740 !--OB 710 !--aerosol TOT - anthropogenic+natural 711 !--aerosol NAT - natural only 741 !--aerosol TOT - anthropogenic+natural - index 2 742 !--aerosol NAT - natural only - index 1 712 743 ! 713 744 DO i = 1, kdlon … … 729 760 ! 730 761 !--C. Kleinschmitt 731 !--aerosol TOT - anthropogenic+natural 732 !--aerosol NAT - natural only 762 !--aerosol TOT - anthropogenic+natural - index 2 763 !--aerosol NAT - natural only - index 1 733 764 ! 734 765 DO i = 1, kdlon … … 854 885 ZTOPSWAIAERO,ZSOLSWAIAERO, & 855 886 ZTOPSWCF_AERO,ZSOLSWCF_AERO, & 887 ZSWADAERO, & !--NL 856 888 ZTOPLWADAERO,ZSOLLWADAERO,& ! rajoute par C. Kleinscmitt pour LW diagnostics 857 889 ZTOPLWAD0AERO,ZSOLLWAD0AERO,& 858 890 ZTOPLWAIAERO,ZSOLLWAIAERO, & 859 ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat, flag_aer_feedback) ! flags aerosols 891 ZLWADAERO, & !--NL 892 ok_ade, ok_aie, ok_volcan, flag_aerosol,flag_aerosol_strat, flag_aer_feedback) ! flags aerosols 860 893 861 894 ! print *,'RADLWSW: apres RECMWF' … … 936 969 ZFLDNC0(i,k+1)= ZFLCCDWN_i(i,k+1) 937 970 ZFLUPC0(i,k+1)= ZFLCCUP_i(i,k+1) 971 IF(ok_volcan) THEN 972 ZSWADAERO(i,k+1)=ZSWADAERO(i,k+1)*fract(i) !--NL 973 ENDIF 974 938 975 ! Nouveau calcul car visiblement ZSWFT et ZSWFC sont nuls dans RRTM cy32 939 976 ! en sortie de radlsw.F90 - MPL 7.01.09 … … 1016 1053 zcool(i,k)=(ZLWFT(i,k)-ZLWFT(i,k+1))*RDAY*RG/RCPD/PDP(i,k) 1017 1054 zcool0(i,k)=(ZLWFT0_i(i,k)-ZLWFT0_i(i,k+1))*RDAY*RG/RCPD/PDP(i,k) 1055 IF(ok_volcan) THEN 1056 zheat_volc(i,k)=(ZSWADAERO(i,k+1)-ZSWADAERO(i,k))*RG/RCPD/PDP(i,k) !NL 1057 zcool_volc(i,k)=(ZLWADAERO(i,k)-ZLWADAERO(i,k+1))*RG/RCPD/PDP(i,k) !NL 1058 ENDIF 1018 1059 ! print *,'heat cool heat0 cool0 ',zheat(i,k),zcool(i,k),zheat0(i,k),zcool0(i,k) 1019 1060 ! ZFLUCUP_i(i,k)=ZFLUC_i(i,1,k) … … 1125 1166 heat0(iof+i,k) = zheat0(i,k)/zznormcp 1126 1167 cool0(iof+i,k) = zcool0(i,k)/zznormcp 1168 IF(ok_volcan) THEN !NL 1169 heat_volc(iof+i,k) = zheat_volc(i,k)/zznormcp 1170 cool_volc(iof+i,k) = zcool_volc(i,k)/zznormcp 1171 ENDIF 1127 1172 ENDDO 1128 1173 ENDDO -
LMDZ6/branches/Ocean_skin/libf/phylmd/readaerosolstrato.F90
r2745 r3605 7 7 USE phys_cal_mod, ONLY : mth_cur 8 8 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, & 9 grid2dto1d_glo 9 grid2dto1d_glo, grid_type, unstructured 10 10 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 11 11 USE mod_phys_lmdz_omp_data, ONLY : is_omp_root … … 15 15 USE aero_mod 16 16 USE dimphy 17 17 USE print_control_mod, ONLY: prt_level,lunout 18 #ifdef CPP_XIOS 19 USE xios 20 #endif 18 21 implicit none 19 22 … … 43 46 real, allocatable:: tauaerstrat_mois(:, :, :) 44 47 real, allocatable:: tauaerstrat_mois_glo(:, :) 48 real, allocatable:: tau_aer_strat_mpi(:, :) 45 49 46 50 ! For NetCDF: … … 58 62 data alpha_strat_wave/3.36780953,3.34667683,3.20444202,3.0293026,2.82108808/ 59 63 64 CHARACTER (len = 20) :: modname = 'readaerosolstrato' 65 CHARACTER (len = 80) :: abort_message 66 60 67 !-------------------------------------------------------- 61 68 … … 69 76 70 77 IF (nbands.NE.2) THEN 71 print *,'nbands doit etre egal a 2 dans readaerosolstrat'72 STOP78 abort_message='nbands doit etre egal a 2 dans readaerosolstrat' 79 CALL abort_physic(modname,abort_message,1) 73 80 ENDIF 74 81 … … 79 86 n_lev = size(lev) 80 87 IF (n_lev.NE.klev) THEN 81 print *,'Le nombre de niveaux n est pas egal a klev'82 STOP88 abort_message='Le nombre de niveaux n est pas egal a klev' 89 CALL abort_physic(modname,abort_message,1) 83 90 ENDIF 84 91 … … 86 93 CALL nf95_gw_var(ncid_in, varid, latitude) 87 94 n_lat = size(latitude) 88 print *, 'LAT aerosol strato=', n_lat, latitude 89 IF (n_lat.NE.nbp_lat) THEN 90 print *,'Le nombre de lat n est pas egal a nbp_lat' 91 STOP 92 ENDIF 93 95 WRITE(lunout,*) 'LAT aerosol strato=', n_lat, latitude 96 IF (grid_type/=unstructured) THEN 97 IF (n_lat.NE.nbp_lat) THEN 98 abort_message='Le nombre de lat n est pas egal a nbp_lat' 99 CALL abort_physic(modname,abort_message,1) 100 ENDIF 101 ENDIF 102 94 103 CALL nf95_inq_varid(ncid_in, "LON", varid) 95 104 CALL nf95_gw_var(ncid_in, varid, longitude) 96 105 n_lon = size(longitude) 97 print *, 'LON aerosol strato=', n_lon, longitude 98 IF (n_lon.NE.nbp_lon) THEN 99 print *,'Le nombre de lon n est pas egal a nbp_lon' 100 STOP 101 ENDIF 102 106 IF (grid_type/=unstructured) THEN 107 WRITE(lunout,*) 'LON aerosol strato=', n_lon, longitude 108 IF (n_lon.NE.nbp_lon) THEN 109 abort_message='Le nombre de lon n est pas egal a nbp_lon' 110 CALL abort_physic(modname,abort_message,1) 111 ENDIF 112 ENDIF 113 103 114 CALL nf95_inq_varid(ncid_in, "TIME", varid) 104 115 CALL nf95_gw_var(ncid_in, varid, time) 105 116 n_month = size(time) 106 print *,'TIME aerosol strato=', n_month, time117 WRITE(lunout,*) 'TIME aerosol strato=', n_month, time 107 118 IF (n_month.NE.12) THEN 108 print *,'Le nombre de month n est pas egal a 12'109 STOP119 abort_message='Le nombre de month n est pas egal a 12' 120 CALL abort_physic(modname,abort_message,1) 110 121 ENDIF 111 122 … … 117 128 CALL nf95_inq_varid(ncid_in, "TAUSTRAT", varid) 118 129 ncerr = nf90_get_var(ncid_in, varid, tauaerstrat) 119 print *,'code erreur readaerosolstrato=', ncerr, varid130 WRITE(lunout,*) 'code erreur readaerosolstrato=', ncerr, varid 120 131 121 132 CALL nf95_close(ncid_in) … … 123 134 !---select the correct month 124 135 IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN 125 print *,'probleme avec le mois dans readaerosolstrat =', mth_cur136 WRITE(lunout,*) 'probleme avec le mois dans readaerosolstrat =', mth_cur 126 137 ENDIF 127 138 tauaerstrat_mois(:,:,:) = tauaerstrat(:,:,:,mth_cur) … … 130 141 CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo) 131 142 143 ELSE 144 ALLOCATE(tauaerstrat_mois(0,0,0)) 132 145 ENDIF !--is_mpi_root and is_omp_root 133 146 134 147 !$OMP BARRIER 135 148 149 IF (grid_type==unstructured) THEN 150 #ifdef CPP_XIOS 151 IF (is_omp_master) THEN 152 CALL xios_send_field("taustrat_in",tauaerstrat_mois) 153 ALLOCATE(tau_aer_strat_mpi(klon_mpi, klev)) 154 CALL xios_recv_field("taustrat_out",tau_aer_strat_mpi) 155 ELSE 156 ALLOCATE(tau_aer_strat_mpi(0,0)) 157 ENDIF 158 CALL scatter_omp(tau_aer_strat_mpi,tau_aer_strat) 159 #endif 160 ELSE 136 161 !--scatter on all proc 137 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 162 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 163 ENDIF 138 164 139 165 !--keep memory of previous month -
LMDZ6/branches/Ocean_skin/libf/phylmd/readchlorophyll.F90
r3298 r3605 15 15 USE mod_phys_lmdz_para, ONLY: scatter 16 16 USE phys_state_var_mod, ONLY: chl_con 17 USE print_control_mod, ONLY: prt_level,lunout 17 18 18 19 IMPLICIT NONE … … 45 46 46 47 !-------------------------------------------------------- 48 CHARACTER (len = 20) :: modname = 'readchlorophyll' 49 CHARACTER (len = 80) :: abort_message 47 50 48 51 !--only read file if beginning of run or start of new month … … 56 59 CALL nf95_gw_var(ncid_in, varid, longitude) 57 60 n_lon = size(longitude) 58 ! print *, 'LON chlorophyll=', n_lon, longitude59 61 IF (n_lon.NE.nbp_lon) THEN 60 print *,'Le nombre de lon n est pas egal a nbp_lon'61 STOP62 abort_message='Le nombre de lon n est pas egal a nbp_lon' 63 CALL abort_physic(modname,abort_message,1) 62 64 ENDIF 63 65 … … 65 67 CALL nf95_gw_var(ncid_in, varid, latitude) 66 68 n_lat = size(latitude) 67 ! print *, 'LAT chlorophyll=', n_lat, latitude68 69 IF (n_lat.NE.nbp_lat) THEN 69 print *,'Le nombre de lat n est pas egal a jnbp_lat'70 STOP70 abort_message='Le nombre de lat n est pas egal a jnbp_lat' 71 CALL abort_physic(modname,abort_message,1) 71 72 ENDIF 72 73 … … 74 75 CALL nf95_gw_var(ncid_in, varid, time) 75 76 n_month = size(time) 76 ! print *, 'TIME aerosol strato=', n_month, time77 77 IF (n_month.NE.12) THEN 78 print *,'Le nombre de month n est pas egal a 12'79 STOP78 abort_message='Le nombre de month n est pas egal a 12' 79 CALL abort_physic(modname,abort_message,1) 80 80 ENDIF 81 81 … … 87 87 CALL nf95_inq_varid(ncid_in, "CHL", varid) 88 88 ncerr = nf90_get_var(ncid_in, varid, chlorocon) 89 print *,'code erreur readchlorophyll=', ncerr, varid89 WRITE(lunout,*)'code erreur readchlorophyll=', ncerr, varid 90 90 91 91 CALL nf95_close(ncid_in) … … 93 93 !---select the correct month 94 94 IF (mth_cur.LT.1.OR.mth_cur.GT.12) THEN 95 print *,'probleme avec le mois dans readchlorophyll =', mth_cur95 WRITE(lunout,*)'probleme avec le mois dans readchlorophyll =', mth_cur 96 96 ENDIF 97 97 chlorocon_mois(:,:) = chlorocon(:,:,mth_cur) … … 100 100 CALL grid2dTo1d_glo(chlorocon_mois,chlorocon_mois_glo) 101 101 102 print *,"chrolophyll current month",mth_cur102 WRITE(lunout,*)"chrolophyll current month",mth_cur 103 103 DO i=1,klon_glo 104 104 ! if(isnan(chlorocon_mois_glo(i)))then ! isnan() is not in the Fortran standard... -
LMDZ6/branches/Ocean_skin/libf/phylmd/regr_horiz_time_climoz_m.F90
r3278 r3605 2 2 3 3 USE interpolation, ONLY: locate 4 USE mod_grid_phy_lmdz, ONLY: n lon_ou => nbp_lon, nlat_ou => nbp_lat4 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, grid_type, unstructured 5 5 USE nrtype, ONLY: pi 6 6 USE netcdf, ONLY: NF90_CLOBBER, NF90_FLOAT, NF90_GET_VAR, NF90_OPEN, & … … 11 11 NF95_CLOSE, NF95_ENDDEF, NF95_PUT_ATT, NF95_PUT_VAR, NF95_COPY_ATT 12 12 USE print_control_mod, ONLY: lunout 13 USE dimphy 13 14 IMPLICIT NONE 14 15 PRIVATE … … 16 17 REAL, PARAMETER :: deg2rad=pi/180. 17 18 CHARACTER(LEN=13), PARAMETER :: vars_in(2)=['tro3 ','tro3_daylight'] 19 20 INTEGER :: nlat_ou, nlon_ou 21 REAL, ALLOCATABLE :: latitude_glo(:) 22 !$OMP THREADPRIVATE(latitude_glo) 23 INTEGER, ALLOCATABLE :: ind_cell_glo_glo(:) 24 !$OMP THREADPRIVATE(ind_cell_glo_glo) 18 25 19 26 CONTAINS … … 52 59 USE assert_m, ONLY: assert 53 60 USE cal_tools_m, ONLY: year_len, mid_month 54 USE control_mod, ONLY: anneeref 61 !! USE control_mod, ONLY: anneeref 62 USE time_phylmdz_mod, ONLY: annee_ref 55 63 USE ioipsl, ONLY: ioget_year_len, ioget_calendar 56 64 USE regr_conserv_m, ONLY: regr_conserv … … 58 66 USE regular_lonlat_mod, ONLY: boundslon_reg, boundslat_reg, south, west, east 59 67 USE slopes_m, ONLY: slopes 68 #ifdef CPP_XIOS 69 USE xios 70 #endif 71 USE mod_phys_lmdz_para, ONLY: is_mpi_root, is_master, is_omp_master, gather, gather_mpi, bcast_mpi, klon_mpi 72 USE geometry_mod, ONLY : latitude_deg, ind_cell_glo 73 USE mod_grid_phy_lmdz, ONLY: klon_glo 74 60 75 !------------------------------------------------------------------------------- 61 76 ! Arguments: … … 83 98 CHARACTER(LEN=20) :: cal_in ! Calendar 84 99 REAL, ALLOCATABLE :: o3_in3(:,:,:,:,:) ! Ozone climatologies 100 REAL, ALLOCATABLE :: o3_in3bis(:,:,:,:,:) ! Ozone climatologies 85 101 REAL, ALLOCATABLE :: o3_in2 (:,:,:,:) ! Ozone climatologies 102 REAL, ALLOCATABLE :: o3_in2bis(:,:,:,:,:) ! Ozone climatologies 86 103 ! last index: 1 for the day-night average, 2 for the daylight field. 87 104 REAL :: NaN … … 91 108 REAL, ALLOCATABLE :: o3_regr_lonlat(:,:,:,:,:) ! (nlon_ou,nlat_ou,:,0:13 ,:) 92 109 REAL, ALLOCATABLE :: o3_out3 (:,:,:,:,:) ! (nlon_ou,nlat_ou,:,ntim_ou,:) 110 REAL, ALLOCATABLE :: o3_out3_glo (:,:,:,:) ! (nbp_lat,:,ntim_ou,:) 93 111 REAL, ALLOCATABLE :: o3_regr_lat (:,:,:,:) ! (nlat_in,:,0:13 ,:) 94 112 REAL, ALLOCATABLE :: o3_out2 (:,:,:,:) ! (nlat_ou,:,ntim_ou,:) 113 REAL, ALLOCATABLE :: o3_out2_glo (:,:,:,:) ! (nbp_lat,:,ntim_ou,:) 114 REAL, ALLOCATABLE :: o3_out (:,:,:,:) ! (nbp_lat,:,ntim_ou,:) 95 115 ! Dimension number | Interval | Contains | For variables: 96 116 ! 1 (longitude) | [rlonu(i-1), rlonu(i)] | rlonv(i) | all … … 116 136 INTEGER, ALLOCATABLE :: sta(:), cnt(:) 117 137 CHARACTER(LEN=80) :: sub, dim_nam, msg 118 !------------------------------------------------------------------------------- 119 sub="regr_horiz_time_climoz" 120 WRITE(lunout,*)"Call sequence information: "//TRIM(sub) 121 CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz") 122 123 CALL NF95_OPEN("climoz.nc" , NF90_NOWRITE, fID_in) 124 lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR 125 lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR 126 127 !--- Get coordinates from the input file. Converts lon/lat in radians. 128 ! Few inversions because "regr_conserv" and gcm need ascending vectors. 129 CALL NF95_INQ_VARID(fID_in, vars_in(1), varid) 130 CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims) 131 l3D=ndims==4; l2D=ndims==3 132 IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields." 133 IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields." 134 DO i=1,ndims 135 CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln) 136 CALL NF95_INQ_VARID(fID_in, dim_nam, varid) 137 ii=i; IF(l2D) ii=i+1 !--- ndims==3:NO LONGITUDE 138 SELECT CASE(ii) 139 CASE(1) !--- LONGITUDE 140 CALL NF95_GW_VAR(fID_in, varid, lon_in) 141 ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1) 142 nlon_in=dln; lon_in=lon_in*deg2rad 143 CASE(2) !--- LATITUDE 144 CALL NF95_GW_VAR(fID_in, varid, lat_in) 145 ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1) 146 nlat_in=dln; lat_in=lat_in*deg2rad 147 CASE(3) !--- PRESSURE LEVELS 148 CALL NF95_GW_VAR(fID_in, varid, lev_in) 149 ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1) 150 nlev_in=dln 151 CALL NF95_GET_ATT(fID_in, varid, "units", press_unit) 152 k=LEN_TRIM(press_unit) 153 DO WHILE(ICHAR(press_unit(k:k))==0) 154 press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR 155 END DO 156 IF(press_unit == "Pa") THEN 157 lev_in = lev_in/100. !--- CONVERT TO hPa 158 ELSE IF(press_unit /= "hPa") THEN 159 CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1) 138 REAL :: null_array(0) 139 LOGICAL,SAVE :: first=.TRUE. 140 !$OMP THREADPRIVATE(first) 141 REAL, ALLOCATABLE :: test_o3_in(:,:) 142 REAL, ALLOCATABLE :: test_o3_out(:) 143 144 145 IF (grid_type==unstructured) THEN 146 IF (first) THEN 147 IF (is_master) THEN 148 ALLOCATE(latitude_glo(klon_glo)) 149 ALLOCATE(ind_cell_glo_glo(klon_glo)) 150 ELSE 151 ALLOCATE(latitude_glo(0)) 152 ALLOCATE(ind_cell_glo_glo(0)) 153 ENDIF 154 CALL gather(latitude_deg, latitude_glo) 155 CALL gather(ind_cell_glo, ind_cell_glo_glo) 156 ENDIF 157 ENDIF 158 159 IF (is_omp_master) THEN 160 nlat_ou=nbp_lat 161 nlon_ou=nbp_lon 162 163 !------------------------------------------------------------------------------- 164 IF (is_mpi_root) THEN 165 sub="regr_horiz_time_climoz" 166 WRITE(lunout,*)"Call sequence information: "//TRIM(sub) 167 CALL assert(read_climoz == 1 .OR. read_climoz == 2, "regr_lat_time_climoz") 168 169 CALL NF95_OPEN("climoz.nc" , NF90_NOWRITE, fID_in) 170 lprev=NF90_OPEN("climoz_m.nc", NF90_NOWRITE, fID_in_m)==NF90_NOERR 171 lnext=NF90_OPEN("climoz_p.nc", NF90_NOWRITE, fID_in_p)==NF90_NOERR 172 173 !--- Get coordinates from the input file. Converts lon/lat in radians. 174 ! Few inversions because "regr_conserv" and gcm need ascending vectors. 175 CALL NF95_INQ_VARID(fID_in, vars_in(1), varid) 176 CALL NF95_INQUIRE_VARIABLE(fID_in, varid, dimids=dIDs, ndims=ndims) 177 l3D=ndims==4; l2D=ndims==3 178 IF(l3D) WRITE(lunout,*)"Input files contain full 3D ozone fields." 179 IF(l2D) WRITE(lunout,*)"Input files contain zonal 2D ozone fields." 180 DO i=1,ndims 181 CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), name=dim_nam, nclen=dln) 182 CALL NF95_INQ_VARID(fID_in, dim_nam, varid) 183 ii=i; IF(l2D) ii=i+1 !--- ndims==3:NO LONGITUDE 184 SELECT CASE(ii) 185 CASE(1) !--- LONGITUDE 186 CALL NF95_GW_VAR(fID_in, varid, lon_in) 187 ldec_lon=lon_in(1)>lon_in(dln); IF(ldec_lon) lon_in=lon_in(dln:1:-1) 188 nlon_in=dln; lon_in=lon_in*deg2rad 189 CASE(2) !--- LATITUDE 190 CALL NF95_GW_VAR(fID_in, varid, lat_in) 191 ldec_lat=lat_in(1)>lat_in(dln); IF(ldec_lat) lat_in=lat_in(dln:1:-1) 192 nlat_in=dln; lat_in=lat_in*deg2rad 193 CASE(3) !--- PRESSURE LEVELS 194 CALL NF95_GW_VAR(fID_in, varid, lev_in) 195 ldec_lev=lev_in(1)>lev_in(dln); IF(ldec_lev) lev_in=lev_in(dln:1:-1) 196 nlev_in=dln 197 CALL NF95_GET_ATT(fID_in, varid, "units", press_unit) 198 k=LEN_TRIM(press_unit) 199 DO WHILE(ICHAR(press_unit(k:k))==0) 200 press_unit(k:k)=' '; k=LEN_TRIM(press_unit) !--- REMOVE NULL END CHAR 201 END DO 202 IF(press_unit == "Pa") THEN 203 lev_in = lev_in/100. !--- CONVERT TO hPa 204 ELSE IF(press_unit /= "hPa") THEN 205 CALL abort_physic(sub, "the only recognized units are Pa and hPa.",1) 206 END IF 207 CASE(4) !--- TIME 208 CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in) 209 cal_in='gregorian' 210 IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR) & 211 WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'// & 212 TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".' 213 k=LEN_TRIM(cal_in) 214 DO WHILE(ICHAR(cal_in(k:k))==0) 215 cal_in(k:k)=' '; k=LEN_TRIM(cal_in) !--- REMOVE NULL END CHAR 216 END DO 217 END SELECT 218 END DO 219 220 !--- Prepare quantities for time interpolation 221 tmidmonth=mid_month(annee_ref, cal_in) 222 IF(interpt) THEN 223 ntim_ou=ioget_year_len(annee_ref) 224 ALLOCATE(tmidday(ntim_ou)) 225 tmidday=[(REAL(k)-0.5,k=1,ntim_ou)] 226 CALL ioget_calendar(cal_ou) 227 ELSE 228 ntim_ou=14 229 cal_ou=cal_in 230 END IF 231 ENDIF 232 233 IF (grid_type==unstructured) THEN 234 CALL bcast_mpi(nlon_in) 235 CALL bcast_mpi(nlat_in) 236 CALL bcast_mpi(nlev_in) 237 CALL bcast_mpi(l3d) 238 CALL bcast_mpi(tmidmonth) 239 CALL bcast_mpi(tmidday) 240 CALL bcast_mpi(ntim_ou) 241 242 #ifdef CPP_XIOS 243 IF (is_mpi_root) THEN 244 CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=nlat_in, jbegin=0, latvalue_1d=lat_in/deg2rad) 245 IF (l3D) THEN 246 CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=nlon_in, ibegin=0, lonvalue_1d=lon_in/deg2rad) 247 ELSE 248 CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=8, ibegin=0, lonvalue_1d = (/ 0.,45.,90.,135.,180.,225.,270., 315. /)) 249 ENDIF 250 ELSE 251 CALL xios_set_domain_attr("domain_climoz",nj_glo=nlat_in, nj=0, jbegin=0, latvalue_1d=null_array ) 252 IF (l3D) THEN 253 CALL xios_set_domain_attr("domain_climoz",ni_glo=nlon_in, ni=0, ibegin=0, lonvalue_1d=null_array) 254 ELSE 255 CALL xios_set_domain_attr("domain_climoz",ni_glo=8, ni=0, ibegin=0, lonvalue_1d=null_array) 256 ENDIF 257 ENDIF 258 CALL xios_set_axis_attr("axis_climoz", n_glo=nlev_in) 259 CALL xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou) 260 CALL xios_set_axis_attr("time_axis_climoz", n_glo=ntim_ou) 261 CALL xios_set_axis_attr("tr_climoz", n_glo=read_climoz) 262 CALL xios_set_field_attr("tro3_out", enabled=.TRUE.) 263 CALL xios_set_field_attr("tro3_out", enabled=.TRUE.) 264 #endif 265 266 IF (first) THEN 267 first=.FALSE. 268 RETURN 269 ENDIF 270 ENDIF 271 272 273 IF (is_mpi_root) THEN 274 !--- Longitudes management: 275 ! * Need to shift data if the origin of input file longitudes /= -pi 276 ! * Need to add some margin in longitude to ensure input interval contains 277 ! all the output intervals => at least one longitudes slice has to be 278 ! duplicated, possibly more for undersampling. 279 IF(l3D) THEN 280 IF (grid_type==unstructured) THEN 281 dx2=0 282 ELSE 283 !--- Compute input edges longitudes vector (no end point yet) 284 ALLOCATE(v1(nlon_in+1)) 285 v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi 286 FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2. 287 v1(nlon_in+1)=v1(1)+2.*pi 288 DEALLOCATE(lon_in) 289 290 !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west) 291 v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi))) 292 293 !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west) 294 dx1=locate(v1,boundslon_reg(1,west))-1 295 v1=CSHIFT(v1,SHIFT=dx1,DIM=1) 296 v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi 297 298 !--- Extend input longitudes vector until last interval contains boundslon_reg(nlat_ou,east) 299 dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO 300 301 !--- Final edges longitudes vector (with margin and end point) 302 ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi] 303 DEALLOCATE(v1) 304 ENDIF 305 END IF 306 307 !--- Compute sinus of intervals edges latitudes: 308 ALLOCATE(sinlat_in_edge(nlat_in+1)) 309 sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1. 310 FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.) 311 DEALLOCATE(lat_in) 312 313 314 315 !--- Check for contiguous years: 316 ib=0; ie=13 317 IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE. 318 WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...' 319 ELSE 320 IF( lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).' 321 IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity." 322 IF( lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).' 323 IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity." 324 IF(.NOT.lprev) ib=1 325 IF(.NOT.lnext) ie=12 326 END IF 327 ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1 328 IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1] 329 IF(l2D) cnt=[ nlat_in,nlev_in,1] 330 IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz)) 331 IF(l2D) ALLOCATE(o3_in2( nlat_in,nlev_in,ib:ie,read_climoz)) 332 333 !--- Read full current file and one record each available contiguous file 334 DO iv=1,read_climoz 335 msg=TRIM(sub)//" NF90_GET_VAR "//TRIM(vars_in(iv)) 336 CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv)) 337 IF(l3D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv)) 338 IF(l2D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in2( :,:,1:12,iv)) 339 CALL handle_err(TRIM(msg), ncerr, fID_in) 340 IF(lprev) THEN; sta(ndims)=12 341 CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv)) 342 IF(l3D) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt) 343 IF(l2d) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in2( :,:, 0,iv),sta,cnt) 344 CALL handle_err(TRIM(msg)//" previous", ncerr, fID_in_m) 160 345 END IF 161 CASE(4) !--- TIME 162 CALL NF95_INQUIRE_DIMENSION(fID_in, dIDs(i), nclen=nmth_in) 163 cal_in='gregorian' 164 IF(NF90_GET_ATT(fID_in, varid, 'calendar', cal_in)/=NF90_NOERR) & 165 WRITE(lunout,*)'WARNING: missing "calendar" attribute for "'// & 166 TRIM(dim_nam)//'" in "climoz.nc". Choosing default: "gregorian".' 167 k=LEN_TRIM(cal_in) 168 DO WHILE(ICHAR(cal_in(k:k))==0) 169 cal_in(k:k)=' '; k=LEN_TRIM(cal_in) !--- REMOVE NULL END CHAR 170 END DO 171 END SELECT 172 END DO 173 174 !--- Longitudes management: 175 ! * Need to shift data if the origin of input file longitudes /= -pi 176 ! * Need to add some margin in longitude to ensure input interval contains 177 ! all the output intervals => at least one longitudes slice has to be 178 ! duplicated, possibly more for undersampling. 179 IF(l3D) THEN 180 !--- Compute input edges longitudes vector (no end point yet) 181 ALLOCATE(v1(nlon_in+1)) 182 v1(1)=(lon_in(nlon_in)+lon_in(1))/2.-pi 183 FORALL(i=2:nlon_in) v1(i)=(lon_in(i-1)+lon_in(i))/2. 184 v1(nlon_in+1)=v1(1)+2.*pi 185 DEALLOCATE(lon_in) 186 187 !--- Shift input longitudes vector until it contains first output point boundslon_reg(1,west) 188 v1=v1+2*pi*REAL(FLOOR((boundslon_reg(1,west)-v1(1))/(2.*pi))) 189 190 !--- Ensure first input longitudes interval contains first output point boundslon_reg(1,west) 191 dx1=locate(v1,boundslon_reg(1,west))-1 192 v1=CSHIFT(v1,SHIFT=dx1,DIM=1); v1(nlon_in-dx1+2:)=v1(nlon_in-dx1+2:)+2.*pi 193 194 !--- Extend input longitudes vector until last interval contains boundslon_reg(nlon_ou,east) 195 dx2=0; DO WHILE(v1(1+dx2)+2.*pi<=boundslon_reg(nlon_ou,east)); dx2=dx2+1; END DO 196 197 !--- Final edges longitudes vector (with margin and end point) 198 ALLOCATE(lon_in_edge(nlon_in+dx2+1)); lon_in_edge=[v1,v1(2:1+dx2)+2.*pi] 199 DEALLOCATE(v1) 200 END IF 201 202 !--- Compute sinus of intervals edges latitudes: 203 ALLOCATE(sinlat_in_edge(nlat_in+1)) 204 sinlat_in_edge(1) = -1. ; sinlat_in_edge(nlat_in+1) = 1. 205 FORALL(j=2:nlat_in) sinlat_in_edge(j)=SIN((lat_in(j-1)+lat_in(j))/2.) 206 DEALLOCATE(lat_in) 207 208 !--- Prepare quantities for time interpolation 209 tmidmonth=mid_month(anneeref, cal_in) 210 IF(interpt) THEN 211 ntim_ou=ioget_year_len(anneeref) 212 ALLOCATE(tmidday(ntim_ou)) 213 tmidday=[(REAL(k)-0.5,k=1,ntim_ou)] 214 CALL ioget_calendar(cal_ou) 215 ELSE 216 ntim_ou=14 217 cal_ou=cal_in 218 END IF 219 220 !--- Create the output file and get the variable IDs: 221 CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, & 222 ndims, cal_ou) 223 224 !--- Write remaining coordinate variables: 225 CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in) 226 IF( interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday) 227 IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth) 228 229 !--- Check for contiguous years: 230 ib=0; ie=13 231 IF(nmth_in == 14) THEN; lprev=.FALSE.; lnext=.FALSE. 232 WRITE(lunout,*)'Using 14 months ozone climatology "climoz.nc"...' 233 ELSE 234 IF( lprev) WRITE(lunout,*)'Using "climoz_m.nc" last record (previous year).' 235 IF(.NOT.lprev) WRITE(lunout,*)"No previous year file ; assuming periodicity." 236 IF( lnext) WRITE(lunout,*)'Using "climoz_p.nc" first record (next year).' 237 IF(.NOT.lnext) WRITE(lunout,*)"No next year file ; assuming periodicity." 238 IF(.NOT.lprev) ib=1 239 IF(.NOT.lnext) ie=12 240 END IF 241 ALLOCATE(sta(ndims),cnt(ndims)); sta(:)=1 242 IF(l3D) cnt=[nlon_in,nlat_in,nlev_in,1] 243 IF(l2D) cnt=[ nlat_in,nlev_in,1] 244 IF(l3D) ALLOCATE(o3_in3(nlon_in+dx2,nlat_in,nlev_in,ib:ie,read_climoz)) 245 IF(l2D) ALLOCATE(o3_in2( nlat_in,nlev_in,ib:ie,read_climoz)) 246 247 !--- Read full current file and one record each available contiguous file 248 DO iv=1,read_climoz 249 msg=TRIM(sub)//" NF90_GET_VAR "//TRIM(vars_in(iv)) 250 CALL NF95_INQ_VARID(fID_in, vars_in(1), vID_in(iv)) 251 IF(l3D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in3(1:nlon_in,:,:,1:12,iv)) 252 IF(l2D) ncerr=NF90_GET_VAR(fID_in, vID_in(iv), o3_in2( :,:,1:12,iv)) 253 CALL handle_err(TRIM(msg), ncerr, fID_in) 254 IF(lprev) THEN; sta(ndims)=12 255 CALL NF95_INQ_VARID(fID_in_m, vars_in(1), vID_in(iv)) 256 IF(l3D) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in3(1:nlon_in,:,:, 0,iv),sta,cnt) 257 IF(l2d) ncerr=NF90_GET_VAR(fID_in_m,vID_in(iv),o3_in2( :,:, 0,iv),sta,cnt) 258 CALL handle_err(TRIM(msg)//" previous", ncerr, fID_in_m) 346 IF(lnext) THEN; sta(ndims)=1 347 CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv)) 348 IF(l3D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt) 349 IF(l2D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in2( :,:,13,iv),sta,cnt) 350 CALL handle_err(TRIM(msg)//" next", ncerr, fID_in_p) 351 END IF 352 END DO 353 IF(lprev.OR.lnext) DEALLOCATE(sta,cnt) 354 IF(lprev) CALL NF95_CLOSE(fID_in_m) 355 IF(lnext) CALL NF95_CLOSE(fID_in_p) 356 357 !--- Revert decreasing coordinates vector 358 IF(l3D) THEN 359 IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:) 360 IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:) 361 IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:) 362 363 IF (grid_type /= unstructured) THEN 364 !--- Shift values for longitude and duplicate some longitudes slices 365 o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1) 366 o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:) 367 ENDIF 368 ELSE 369 IF(ldec_lat) o3_in2 = o3_in2( nlat_in:1:-1,:,:,:) 370 IF(ldec_lev) o3_in2 = o3_in2( :,nlev_in:1:-1,:,:) 371 END IF 372 373 !--- Deal with missing values 374 DO m=1, read_climoz 375 WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m 376 IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN 377 IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN 378 WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE 379 END IF 380 END IF 381 WRITE(lunout,*)TRIM(msg)//": missing value attribute found." 382 WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better." 383 384 !--- Check top layer contains no NaNs & search NaNs from top to ground 385 msg=TRIM(sub)//": NaNs in top layer !" 386 IF(l3D) THEN 387 IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1) 388 DO k = 2,nlev_in 389 WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m) 390 END DO 391 ELSE 392 IF(ANY(o3_in2( :,1,:,m)==NaN)) THEN 393 WRITE(lunout,*)msg 394 !--- Fill in latitudes where all values are missing 395 DO l=1,nmth_in 396 !--- Next to south pole 397 j=1; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO 398 IF(j>1) & 399 o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1) 400 !--- Next to north pole 401 j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO 402 IF(j<nlat_in) & 403 o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j) 404 END DO 405 END IF 406 407 !--- Fill in high latitudes missing values 408 !--- Highest level been filled-in, so has always valid values. 409 DO k = 2,nlev_in 410 WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m) 411 END DO 412 END IF 413 END DO 414 415 ENDIF 416 417 !============================================================================= 418 IF(l3D) THEN !=== 3D FIELDS 419 !============================================================================= 420 IF (grid_type==unstructured) THEN 421 #ifdef CPP_XIOS 422 nlat_ou=klon_mpi 423 424 IF (is_mpi_root) THEN 425 ALLOCATE(o3_in3bis(nlon_in,nlat_in,nlev_in,0:13,read_climoz)) 426 o3_in3bis(:,:,:,ib:ie,:)=o3_in3(1:nlon_in,:,:,ib:ie,:) 427 ELSE 428 ALLOCATE(o3_in3bis(0,0,0,0,read_climoz)) 429 ENDIF 430 ALLOCATE(o3_regr_lonlat(1, nlat_ou, nlev_in, 0:13, read_climoz)) 431 432 CALL xios_send_field("tro3_in",o3_in3bis(:,:,:,:,:)) 433 CALL xios_recv_field("tro3_out",o3_regr_lonlat(1,:,:,:,:)) 434 #endif 435 ELSE 436 437 !--- Regrid in longitude 438 ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz)) 439 CALL regr_conserv(1, o3_in3, xs = lon_in_edge, & 440 xt = [boundslon_reg(1,west),boundslon_reg(:,east)], & 441 vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge)) 442 DEALLOCATE(o3_in3) 443 444 !--- Regrid in latitude: averaging with respect to SIN(lat) is 445 ! equivalent to weighting by COS(lat) 446 !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing) 447 ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz)) 448 CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge, & 449 xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], & 450 vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:), & 451 slope = slopes(2,o3_regr_lon, sinlat_in_edge)) 452 DEALLOCATE(o3_regr_lon) 453 454 ENDIF 455 456 !--- Duplicate previous/next record(s) if they are not available 457 IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:) 458 IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:) 459 460 !--- Regrid in time by linear interpolation: 461 ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz)) 462 IF( interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3) 463 IF(.NOT.interpt) o3_out3=o3_regr_lonlat 464 DEALLOCATE(o3_regr_lonlat) 465 466 nlat_ou=nbp_lat 467 IF (grid_type==unstructured) THEN 468 #ifdef CPP_XIOS 469 CALL xios_send_field('o3_out',o3_out3) 470 ndims=3 471 ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz)) 472 CALL gather_mpi(o3_out3(1,:,:,:,:), o3_out3_glo) 473 #endif 474 ENDIF 475 476 !--- Create the output file and get the variable IDs: 477 CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, & 478 ndims, cal_ou) 479 480 IF (is_mpi_root) THEN 481 !--- Write remaining coordinate variables: 482 CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in) 483 IF( interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday) 484 IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth) 485 486 !--- Write to file (the order of "rlatu" is inverted in the output file): 487 IF (grid_type==unstructured) THEN 488 489 ALLOCATE(o3_out(nlat_ou, nlev_in, ntim_ou, read_climoz)) 490 DO i=1,klon_glo 491 o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out3_glo(i,:,:,:) 492 ENDDO 493 494 DO m = 1, read_climoz 495 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m)) 496 END DO 497 498 ELSE 499 DO m = 1, read_climoz 500 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m)) 501 END DO 502 ENDIF 503 CALL NF95_CLOSE(fID_ou) 504 505 506 ENDIF 507 508 509 !============================================================================= 510 ELSE !=== ZONAL FIELDS 511 !============================================================================= 512 513 IF (grid_type==unstructured) THEN 514 #ifdef CPP_XIOS 515 nlat_ou=klon_mpi 516 517 IF (is_mpi_root) THEN 518 ALLOCATE(o3_in2bis(8,nlat_in,nlev_in,0:13,read_climoz)) 519 o3_in2bis(:,:,:,ib:ie,:)=SPREAD(o3_in2,1,8) 520 ELSE 521 ALLOCATE(o3_in2bis(0,0,0,0,read_climoz)) 522 ENDIF 523 ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz)) 524 CALL xios_send_field("tro3_in",o3_in2bis(:,:,:,:,:)) 525 CALL xios_recv_field("tro3_out",o3_regr_lat(:,:,:,:)) 526 IF(.NOT.lprev) o3_regr_lat(:,:, 0, :) = o3_regr_lat(:,:,12,:) 527 IF(.NOT.lnext) o3_regr_lat(:,:,13, :) = o3_regr_lat(:,:, 1,:) 528 #endif 529 530 ELSE 531 !--- Regrid in latitude: averaging with respect to SIN(lat) is 532 ! equivalent to weighting by COS(lat) 533 !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing) 534 ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz)) 535 CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge, & 536 xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], & 537 vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:), & 538 slope = slopes(1,o3_in2, sinlat_in_edge)) 539 DEALLOCATE(o3_in2) 540 541 !--- Duplicate previous/next record(s) if they are not available 542 IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:) 543 IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:) 544 545 ENDIF 546 547 !--- Regrid in time by linear interpolation: 548 ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz)) 549 IF( interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2) 550 IF(.NOT.interpt) o3_out2=o3_regr_lat 551 DEALLOCATE(o3_regr_lat) 552 553 nlat_ou=nbp_lat 554 555 IF (grid_type==unstructured) THEN 556 ndims=3 557 ALLOCATE(o3_out2_glo(nlat_ou, nlev_in, ntim_ou, read_climoz)) 558 CALL gather_mpi(o3_out2, o3_out2_glo) 559 ENDIF 560 561 !--- Create the output file and get the variable IDs: 562 CALL prepare_out(fID_in,nlev_in,ntim_ou, fID_ou,levID_ou,timID_ou,vID_ou, & 563 ndims, cal_ou) 564 565 IF (is_mpi_root) THEN 566 567 !--- Write remaining coordinate variables: 568 CALL NF95_PUT_VAR(fID_ou, levID_ou, lev_in); DEALLOCATE(lev_in) 569 IF( interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidday) 570 IF(.NOT.interpt) CALL NF95_PUT_VAR(fID_ou, timID_ou, tmidmonth) 571 572 IF (grid_type==unstructured) THEN 573 574 ALLOCATE(o3_out3_glo(nlat_ou, nlev_in, ntim_ou, read_climoz)) 575 DO i=1,klon_glo 576 o3_out(ind_cell_glo_glo(i),:,:,:)=o3_out2_glo(i,:,:,:) 577 ENDDO 578 579 580 DO m = 1, read_climoz 581 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out(nlat_ou:1:-1,:,:,m)) 582 END DO 583 ELSE 584 !--- Write to file (the order of "rlatu" is inverted in the output file): 585 DO m = 1, read_climoz 586 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m)) 587 END DO 588 ENDIF 589 590 CALL NF95_CLOSE(fID_ou) 591 592 ENDIF 593 594 !============================================================================= 259 595 END IF 260 IF(lnext) THEN; sta(ndims)=1 261 CALL NF95_INQ_VARID(fID_in_p, vars_in(1), vID_in(iv)) 262 IF(l3D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in3(1:nlon_in,:,:,13,iv),sta,cnt) 263 IF(l2D) ncerr=NF90_GET_VAR(fID_in_p,vID_in(iv),o3_in2( :,:,13,iv),sta,cnt) 264 CALL handle_err(TRIM(msg)//" next", ncerr, fID_in_p) 265 END IF 266 END DO 267 IF(lprev.OR.lnext) DEALLOCATE(sta,cnt) 268 IF(lprev) CALL NF95_CLOSE(fID_in_m) 269 IF(lnext) CALL NF95_CLOSE(fID_in_p) 270 271 !--- Revert decreasing coordinates vector 272 IF(l3D) THEN 273 IF(ldec_lon) o3_in3(1:nlon_in,:,:,:,:) = o3_in3(nlon_in:1:-1,:,:,:,:) 274 IF(ldec_lat) o3_in3 = o3_in3(:,nlat_in:1:-1,:,:,:) 275 IF(ldec_lev) o3_in3 = o3_in3(:,:,nlev_in:1:-1,:,:) 276 !--- Shift values for longitude and duplicate some longitudes slices 277 o3_in3(1:nlon_in,:,:,:,:)=CSHIFT(o3_in3(1:nlon_in,:,:,:,:),SHIFT=dx1,DIM=1) 278 o3_in3(nlon_in+1:nlon_in+dx2,:,:,:,:)=o3_in3(1:dx2,:,:,:,:) 279 ELSE 280 IF(ldec_lat) o3_in2 = o3_in2( nlat_in:1:-1,:,:,:) 281 IF(ldec_lev) o3_in2 = o3_in2( :,nlev_in:1:-1,:,:) 282 END IF 283 284 !--- Deal with missing values 285 DO m=1, read_climoz 286 WRITE(msg,'(a,i0)')"regr_lat_time_climoz: field Nr.",m 287 IF(NF90_GET_ATT(fID_in,vID_in(m),"missing_value",NaN)/= NF90_NOERR) THEN 288 IF(NF90_GET_ATT(fID_in, vID_in(m),"_FillValue",NaN)/= NF90_NOERR) THEN 289 WRITE(lunout,*)TRIM(msg)//": no missing value attribute found."; CYCLE 290 END IF 291 END IF 292 WRITE(lunout,*)TRIM(msg)//": missing value attribute found." 293 WRITE(lunout,*)"Trying to fill in NaNs ; a full field would be better." 294 295 !--- Check top layer contains no NaNs & search NaNs from top to ground 296 msg=TRIM(sub)//": NaNs in top layer !" 297 IF(l3D) THEN 298 IF(ANY(o3_in3(:,:,1,:,m)==NaN)) CALL abort_physic(sub,msg,1) 299 DO k = 2,nlev_in 300 WHERE(o3_in3(:,:,k,:,m)==NaN) o3_in3(:,:,k,:,m)=o3_in3(:,:,k-1,:,m) 301 END DO 302 ELSE 303 IF(ANY(o3_in2( :,1,:,m)==NaN)) THEN 304 WRITE(lunout,*)msg 305 !--- Fill in latitudes where all values are missing 306 DO l=1,nmth_in 307 !--- Next to south pole 308 j=1; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO 309 IF(j>1) & 310 o3_in2(:j-1,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=j-1) 311 !--- Next to north pole 312 j=nlat_in; DO WHILE(o3_in2(j,1,l,m)==NaN); j=j+1; END DO 313 IF(j<nlat_in) & 314 o3_in2(j+1:,:,l,m)=SPREAD(o3_in2(j,:,l,m),DIM=1,ncopies=nlat_in-j) 315 END DO 316 END IF 317 318 !--- Fill in high latitudes missing values 319 !--- Highest level been filled-in, so has always valid values. 320 DO k = 2,nlev_in 321 WHERE(o3_in2(:,k,:,m)==NaN) o3_in2(:,k,:,m)=o3_in2(:,k-1,:,m) 322 END DO 323 END IF 324 END DO 325 CALL NF95_CLOSE(fID_in) 326 327 !============================================================================= 328 IF(l3D) THEN !=== 3D FIELDS 329 !============================================================================= 330 !--- Regrid in longitude 331 ALLOCATE(o3_regr_lon(nlon_ou, nlat_in, nlev_in, ie-ib+1, read_climoz)) 332 CALL regr_conserv(1, o3_in3, xs = lon_in_edge, & 333 xt = [boundslon_reg(1,west),boundslon_reg(:,east)], & 334 vt = o3_regr_lon, slope = slopes(1,o3_in3, lon_in_edge)) 335 DEALLOCATE(o3_in3) 336 337 !--- Regrid in latitude: averaging with respect to SIN(lat) is 338 ! equivalent to weighting by COS(lat) 339 !--- (inverted indices in "o3_regr_lonlat" because "rlatu" is decreasing) 340 ALLOCATE(o3_regr_lonlat(nlon_ou, nlat_ou, nlev_in, 0:13, read_climoz)) 341 CALL regr_conserv(2, o3_regr_lon, xs = sinlat_in_edge, & 342 xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], & 343 vt = o3_regr_lonlat(:,nlat_ou:1:- 1,:,ib:ie,:), & 344 slope = slopes(2,o3_regr_lon, sinlat_in_edge)) 345 DEALLOCATE(o3_regr_lon) 346 347 !--- Duplicate previous/next record(s) if they are not available 348 IF(.NOT.lprev) o3_regr_lonlat(:,:,:, 0,:) = o3_regr_lonlat(:,:,:,12,:) 349 IF(.NOT.lnext) o3_regr_lonlat(:,:,:,13,:) = o3_regr_lonlat(:,:,:, 1,:) 350 351 !--- Regrid in time by linear interpolation: 352 ALLOCATE(o3_out3(nlon_ou, nlat_ou, nlev_in, ntim_ou, read_climoz)) 353 IF( interpt) CALL regr_lint(4,o3_regr_lonlat,tmidmonth,tmidday,o3_out3) 354 IF(.NOT.interpt) o3_out3=o3_regr_lonlat 355 DEALLOCATE(o3_regr_lonlat) 356 357 !--- Write to file (the order of "rlatu" is inverted in the output file): 358 DO m = 1, read_climoz 359 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out3(:,nlat_ou:1:-1,:,:,m)) 360 END DO 361 362 !============================================================================= 363 ELSE !=== ZONAL FIELDS 364 !============================================================================= 365 !--- Regrid in latitude: averaging with respect to SIN(lat) is 366 ! equivalent to weighting by COS(lat) 367 !--- (inverted indices in "o3_regr_lat" because "rlatu" is decreasing) 368 ALLOCATE(o3_regr_lat(nlat_ou, nlev_in, 0:13, read_climoz)) 369 CALL regr_conserv(1, o3_in2, xs = sinlat_in_edge, & 370 xt = [- 1., SIN(boundslat_reg(nlat_ou-1:1:-1,south)), 1.], & 371 vt = o3_regr_lat(nlat_ou:1:- 1,:,ib:ie,:), & 372 slope = slopes(1,o3_in2, sinlat_in_edge)) 373 DEALLOCATE(o3_in2) 374 375 !--- Duplicate previous/next record(s) if they are not available 376 IF(.NOT.lprev) o3_regr_lat(:,:, 0,:) = o3_regr_lat(:,:,12,:) 377 IF(.NOT.lnext) o3_regr_lat(:,:,13,:) = o3_regr_lat(:,:, 1,:) 378 379 !--- Regrid in time by linear interpolation: 380 ALLOCATE(o3_out2(nlat_ou, nlev_in, ntim_ou, read_climoz)) 381 IF( interpt) CALL regr_lint(3,o3_regr_lat, tmidmonth, tmidday, o3_out2) 382 IF(.NOT.interpt) o3_out2=o3_regr_lat 383 DEALLOCATE(o3_regr_lat) 384 385 !--- Write to file (the order of "rlatu" is inverted in the output file): 386 DO m = 1, read_climoz 387 CALL NF95_PUT_VAR(fID_ou, vID_ou(m), o3_out2(nlat_ou:1:-1,:,:,m)) 388 END DO 389 390 !============================================================================= 391 END IF 392 !============================================================================= 393 394 CALL NF95_CLOSE(fID_ou) 395 596 !============================================================================= 597 598 IF (is_mpi_root) CALL NF95_CLOSE(fID_in) 599 600 ENDIF ! is_omp_master 601 602 first=.FALSE. 396 603 END SUBROUTINE regr_horiz_time_climoz 397 604 ! … … 408 615 !------------------------------------------------------------------------------- 409 616 USE regular_lonlat_mod, ONLY: lon_reg, lat_reg 617 USE regular_lonlat_mod, ONLY: lon_reg, lat_reg 618 USE mod_phys_lmdz_para, ONLY: is_mpi_root 619 USE mod_grid_phy_lmdz, ONLY: klon_glo 620 ! 410 621 !------------------------------------------------------------------------------- 411 622 ! Arguments: … … 419 630 INTEGER :: dlonID, dlatID, dlevID, dtimID, dIDs(4) 420 631 INTEGER :: vlonID, vlatID, ncerr, is 632 REAL,ALLOCATABLE :: latitude_glo_(:) 421 633 CHARACTER(LEN=80) :: sub 422 !------------------------------------------------------------------------------- 423 sub="prepare_out" 424 WRITE(lunout,*)"CALL sequence information: "//TRIM(sub) 425 CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou) 634 INTEGER :: i 635 636 637 !------------------------------------------------------------------------------- 638 639 IF (is_mpi_root) THEN 640 sub="prepare_out" 641 WRITE(lunout,*)"CALL sequence information: "//TRIM(sub) 642 CALL NF95_CREATE("climoz_LMDZ.nc", NF90_clobber, fID_ou) 426 643 427 644 !--- Dimensions: 428 IF(ndims==4) &429 CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID)430 CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID)431 CALL NF95_DEF_DIM(fID_ou, "plev", nlev_in, dlevID)432 CALL NF95_DEF_DIM(fID_ou, "time", ntim_ou, dtimID)433 434 !--- Define coordinate variables:435 IF(ndims==4) &436 CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID)437 CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID)438 CALL NF95_DEF_VAR(fID_ou, "plev", NF90_FLOAT, dlevID, vlevID)439 CALL NF95_DEF_VAR(fID_ou, "time", NF90_FLOAT, dtimID, vtimID)440 IF(ndims==4) &441 CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east")442 CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north")443 CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar")444 CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1")445 IF(ndims==4) &446 CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude")447 CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude")448 CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure")449 CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time")450 CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name", "air pressure")451 CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar", cal_ou)645 IF(ndims==4) & 646 CALL NF95_DEF_DIM(fID_ou, "rlonv", nlon_ou, dlonID) 647 CALL NF95_DEF_DIM(fID_ou, "rlatu", nlat_ou, dlatID) 648 CALL NF95_DEF_DIM(fID_ou, "plev", nlev_in, dlevID) 649 CALL NF95_DEF_DIM(fID_ou, "time", ntim_ou, dtimID) 650 651 !--- Define coordinate variables: 652 IF(ndims==4) & 653 CALL NF95_DEF_VAR(fID_ou, "rlonv", NF90_FLOAT, dlonID, vlonID) 654 CALL NF95_DEF_VAR(fID_ou, "rlatu", NF90_FLOAT, dlatID, vlatID) 655 CALL NF95_DEF_VAR(fID_ou, "plev", NF90_FLOAT, dlevID, vlevID) 656 CALL NF95_DEF_VAR(fID_ou, "time", NF90_FLOAT, dtimID, vtimID) 657 IF(ndims==4) & 658 CALL NF95_PUT_ATT(fID_ou, vlonID, "units", "degrees_east") 659 CALL NF95_PUT_ATT(fID_ou, vlatID, "units", "degrees_north") 660 CALL NF95_PUT_ATT(fID_ou, vlevID, "units", "millibar") 661 CALL NF95_PUT_ATT(fID_ou, vtimID, "units", "days since 2000-1-1") 662 IF(ndims==4) & 663 CALL NF95_PUT_ATT(fID_ou, vlonID, "standard_name", "longitude") 664 CALL NF95_PUT_ATT(fID_ou, vlatID, "standard_name", "latitude") 665 CALL NF95_PUT_ATT(fID_ou, vlevID, "standard_name", "air_pressure") 666 CALL NF95_PUT_ATT(fID_ou, vtimID, "standard_name", "time") 667 CALL NF95_PUT_ATT(fID_ou, vlevID, "long_name", "air pressure") 668 CALL NF95_PUT_ATT(fID_ou, vtimID, "calendar", cal_ou) 452 669 453 670 !--- Define the main variables: 454 IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID]455 IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID]456 CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1))457 CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction")458 CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone&671 IF(ndims==3) dIDs(1:3) = [ dlatID, dlevID, dtimID] 672 IF(ndims==4) dIDs=[dlonID, dlatID, dlevID, dtimID] 673 CALL NF95_DEF_VAR(fID_ou, vars_in(1), NF90_FLOAT, dIDs(1:ndims), vID_ou(1)) 674 CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "long_name", "ozone mole fraction") 675 CALL NF95_PUT_ATT(fID_ou, vID_ou(1), "standard_name", "mole_fraction_of_ozone& 459 676 &_in_air") 460 IF(SIZE(vID_ou) == 2) THEN461 CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2))462 CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da&463 &ylight")464 END IF677 IF(SIZE(vID_ou) == 2) THEN 678 CALL NF95_DEF_VAR(fID_ou, vars_in(2), NF90_FLOAT, dIDs(1:ndims), vID_ou(2)) 679 CALL NF95_PUT_ATT(fID_ou, vID_ou(2), "long_name","ozone mole fraction in da& 680 &ylight") 681 END IF 465 682 466 683 !--- Global attributes: 467 684 ! The following commands, copying attributes, may fail. That is OK. 468 685 ! It should just mean that the attribute is not defined in the input file. 469 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr) 470 CALL handle_err_copy_att("Conventions") 471 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title", fID_ou,NF90_GLOBAL, ncerr) 472 CALL handle_err_copy_att("title") 473 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr) 474 CALL handle_err_copy_att("institution") 475 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source", fID_ou,NF90_GLOBAL, ncerr) 476 CALL handle_err_copy_att("source") 477 CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ") 478 CALL NF95_ENDDEF(fID_ou) 479 480 !--- Write one of the coordinate variables: 481 IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad) 482 CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad) 483 ! (convert from rad to degrees and sort in ascending order) 484 686 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"Conventions",fID_ou,NF90_GLOBAL, ncerr) 687 CALL handle_err_copy_att("Conventions") 688 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"title", fID_ou,NF90_GLOBAL, ncerr) 689 CALL handle_err_copy_att("title") 690 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"institution",fID_ou,NF90_GLOBAL, ncerr) 691 CALL handle_err_copy_att("institution") 692 CALL NF95_COPY_ATT(fID_in,NF90_GLOBAL,"source", fID_ou,NF90_GLOBAL, ncerr) 693 CALL handle_err_copy_att("source") 694 CALL NF95_PUT_ATT (fID_ou,NF90_GLOBAL,"comment", "Regridded for LMDZ") 695 CALL NF95_ENDDEF(fID_ou) 696 697 IF (grid_type==unstructured) THEN 698 ALLOCATE(latitude_glo_(klon_glo)) 699 DO i=1,klon_glo 700 latitude_glo_(ind_cell_glo_glo(i))=latitude_glo(i) 701 ENDDO 702 CALL NF95_PUT_VAR(fID_ou, vlatID, latitude_glo_) 703 ELSE 704 !--- Write one of the coordinate variables: 705 IF(ndims==4) CALL NF95_PUT_VAR(fID_ou, vlonID, lon_reg/deg2rad) 706 CALL NF95_PUT_VAR(fID_ou, vlatID, lat_reg(nlat_ou:1:-1)/deg2rad) 707 ! (convert from rad to degrees and sort in ascending order) 708 ENDIF 709 ENDIF 710 485 711 CONTAINS 486 712 -
LMDZ6/branches/Ocean_skin/libf/phylmd/regr_pr_time_av_m.F90
r3141 r3605 118 118 USE assert_m, ONLY: assert 119 119 USE assert_eq_m, ONLY: assert_eq 120 USE comvert_mod, ONLY: scaleheight120 !! USE comvert_mod, ONLY: scaleheight 121 121 USE interpolation, ONLY: locate 122 122 USE regr_conserv_m, ONLY: regr_conserv 123 123 USE regr_lint_m, ONLY: regr_lint 124 124 USE slopes_m, ONLY: slopes 125 USE mod_phys_lmdz_ mpi_data, ONLY: is_mpi_root126 USE mod_grid_phy_lmdz, ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev127 USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter 125 USE mod_phys_lmdz_para, ONLY: is_mpi_root,is_master 126 USE mod_grid_phy_lmdz, ONLY: nlon=>nbp_lon, nlat=>nbp_lat, nlev_ou=>nbp_lev, klon_glo, grid_type, unstructured 127 USE mod_phys_lmdz_transfert_para, ONLY: scatter2d, scatter, gather 128 128 USE phys_cal_mod, ONLY: calend, year_len, days_elapsed, jH_cur 129 USE geometry_mod, ONLY: ind_cell_glo 129 130 !------------------------------------------------------------------------------- 130 131 ! Arguments: … … 175 176 v2i(klon,SIZE(Pre_in)-1,SIZE(nam)), & !--- v2 in Ploc=='I' case 176 177 v2c(klon,SIZE(Pre_in) ,SIZE(nam)) !--- v2 in Ploc=='C' case 178 INTEGER,ALLOCATABLE :: ind_cell_glo_glo(:) 177 179 LOGICAL :: ll 178 180 !--- For debug … … 247 249 IF(lO3Tfile) ot1=al*otm+(1.-al)*otp 248 250 END IF 251 ELSE 252 IF (lfirst) ALLOCATE(v1(0,0,0,0)) 249 253 END IF 250 254 !$OMP END MASTER 255 !$OMP BARRIER 251 256 IF(lfirst) THEN 252 257 lfirst=.FALSE.; CALL bcast(lfirst) … … 255 260 CALL bcast(lO3Tfile); CALL bcast(linterp) 256 261 END IF 262 263 IF (is_master) THEN 264 ALLOCATE(ind_cell_glo_glo(klon_glo)) 265 ELSE 266 ALLOCATE(ind_cell_glo_glo(0)) 267 ENDIF 268 CALL gather(ind_cell_glo,ind_cell_glo_glo) 269 IF (is_master .AND. grid_type==unstructured) v1(:,:,:,:)=v1(:,ind_cell_glo_glo(:),:,:) 270 257 271 CALL scatter2d(v1,v2) 258 IF(lPrSfile) CALL scatter2d(pg1,Pgnd_in) 259 IF(lPrTfile) CALL scatter2d(pt1,Ptrp_in) 260 IF(lO3Tfile) CALL scatter2d(ot1,Otrp_in) 272 273 !--- No "ps" in input file => assumed to be equal to current LMDZ ground press 274 IF(lPrSfile) THEN 275 IF (is_master .AND. grid_type==unstructured) pg1(:,:)=pg1(:,ind_cell_glo_glo(:)) 276 CALL scatter2d(pg1,Pgnd_in) 277 ELSE 278 Pgnd_in=Pre_ou(:,1) 279 END IF 280 281 IF(lPrTfile) THEN 282 IF (is_master .AND. grid_type==unstructured) pt1(:,:)=pt1(:,ind_cell_glo_glo(:)) 283 CALL scatter2d(pt1,Ptrp_in) 284 ENDIF 285 286 IF(lO3Tfile) THEN 287 IF (is_master .AND. grid_type==unstructured) ot1(:,:)=ot1(:,ind_cell_glo_glo(:)) 288 CALL scatter2d(ot1,Otrp_in) 289 ENDIF 261 290 !--- No ground pressure in input file => choose it to be the one of LMDZ 262 291 IF(lAdjTro.AND..NOT.lPrSfile) Pgnd_in(:)=Pgrnd_ou(:) 263 264 !------------------------------------------------------------------------------- 265 IF(.NOT.lAdjTro) THEN !--- REGRID IN PRESSURE ; NO TROPOPAUSE ADJUSTMENT 266 !------------------------------------------------------------------------------- 292 293 !--- REGRID IN PRESSURE ; 3rd index inverted because "paprs" is decreasing 294 IF(.NOT.lAdjTro) THEN 267 295 DO i=1,klon 268 296 Pres_ou=Pre_ou(i,SIZE(Pre_ou,2):1:-1) !--- pplay & paprs are decreasing -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/aeropt_6bands_rrtm.F90
r3288 r3605 6 6 tau_allaer, piz_allaer, & 7 7 cg_allaer, m_allaer_pi, & 8 flag_aerosol, flag_bc_internal_mixture, zrho )8 flag_aerosol, flag_bc_internal_mixture, zrho, ok_volcan ) 9 9 10 10 USE dimphy … … 32 32 LOGICAL, INTENT(IN) :: flag_bc_internal_mixture 33 33 REAL, DIMENSION(klon,klev), INTENT(IN) :: zrho 34 LOGICAL, INTENT(IN) :: ok_volcan ! volcanic diags 34 35 ! 35 36 ! Output arguments: … … 794 795 cg_allaer(i,k,2,inu)=MIN(MAX(cg_allaer(i,k,2,inu),0.0),1.0) 795 796 796 !--natural aerosol 797 !--ASBCM aerosols take _pi value because of internal mixture option 798 tau_allaer(i,k,1,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ & 799 tau_ae_pi(i,k,id_ASBCM_phy,inu)+tau_ae_pi(i,k,id_AIBCM_phy,inu)+ & 800 tau_ae_pi(i,k,id_ASPOMM_phy,inu)+tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ & 801 tau_ae_pi(i,k,id_ASSSM_phy,inu)+tau_ae_pi(i,k,id_CSSSM_phy,inu)+ & 802 tau_ae_pi(i,k,id_SSSSM_phy,inu)+ tau_ae_pi(i,k,id_CIDUSTM_phy,inu) 803 tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),tau_min) 804 805 piz_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ & 806 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ & 807 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)+ & 808 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+ & 809 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ & 810 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ & 811 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+ & 812 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+ & 813 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+ & 814 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) & 815 /tau_allaer(i,k,1,inu) 816 piz_allaer(i,k,1,inu)=MIN(MAX(piz_allaer(i,k,1,inu),0.01),1.0) 817 IF (tau_allaer(i,k,1,inu).LE.tau_min) piz_allaer(i,k,1,inu)=1.0 818 819 cg_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ & 820 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+ & 821 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)*cg_ae_pi(i,k,id_ASBCM_phy,inu)+ & 822 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+ & 823 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+ & 824 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+ & 825 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+ & 826 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+ & 827 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+ & 828 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*cg_ae(i,k,id_CIDUSTM_phy,inu))/ & 829 (tau_allaer(i,k,1,inu)*piz_allaer(i,k,1,inu)) 830 cg_allaer(i,k,1,inu)=MIN(MAX(cg_allaer(i,k,1,inu),0.0),1.0) 831 797 IF (.NOT. ok_volcan) THEN 798 ! 799 !--this is the default case 800 !--in this case, index 1 of tau_allaer contains natural aerosols only 801 !--because the objective is to perform the double radiation call with and without anthropogenic aerosols 802 ! 803 tau_allaer(i,k,1,inu)=tau_ae_pi(i,k,id_ASSO4M_phy,inu)+tau_ae_pi(i,k,id_CSSO4M_phy,inu)+ & 804 tau_ae_pi(i,k,id_ASBCM_phy,inu)+tau_ae_pi(i,k,id_AIBCM_phy,inu)+ & 805 tau_ae_pi(i,k,id_ASPOMM_phy,inu)+tau_ae_pi(i,k,id_AIPOMM_phy,inu)+ & 806 tau_ae_pi(i,k,id_ASSSM_phy,inu)+tau_ae_pi(i,k,id_CSSSM_phy,inu)+ & 807 tau_ae_pi(i,k,id_SSSSM_phy,inu)+ tau_ae_pi(i,k,id_CIDUSTM_phy,inu) 808 tau_allaer(i,k,1,inu)=MAX(tau_allaer(i,k,1,inu),tau_min) 809 810 piz_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)+ & 811 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)+ & 812 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)+ & 813 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)+ & 814 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)+ & 815 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)+ & 816 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)+ & 817 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)+ & 818 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)+ & 819 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)) & 820 /tau_allaer(i,k,1,inu) 821 piz_allaer(i,k,1,inu)=MIN(MAX(piz_allaer(i,k,1,inu),0.01),1.0) 822 IF (tau_allaer(i,k,1,inu).LE.tau_min) piz_allaer(i,k,1,inu)=1.0 823 824 cg_allaer(i,k,1,inu)=(tau_ae_pi(i,k,id_ASSO4M_phy,inu)*piz_ae(i,k,id_ASSO4M_phy,inu)*cg_ae(i,k,id_ASSO4M_phy,inu)+ & 825 tau_ae_pi(i,k,id_CSSO4M_phy,inu)*piz_ae(i,k,id_CSSO4M_phy,inu)*cg_ae(i,k,id_CSSO4M_phy,inu)+ & 826 tau_ae_pi(i,k,id_ASBCM_phy,inu)*piz_ae_pi(i,k,id_ASBCM_phy,inu)*cg_ae_pi(i,k,id_ASBCM_phy,inu)+ & 827 tau_ae_pi(i,k,id_AIBCM_phy,inu)*piz_ae(i,k,id_AIBCM_phy,inu)*cg_ae(i,k,id_AIBCM_phy,inu)+ & 828 tau_ae_pi(i,k,id_ASPOMM_phy,inu)*piz_ae(i,k,id_ASPOMM_phy,inu)*cg_ae(i,k,id_ASPOMM_phy,inu)+ & 829 tau_ae_pi(i,k,id_AIPOMM_phy,inu)*piz_ae(i,k,id_AIPOMM_phy,inu)*cg_ae(i,k,id_AIPOMM_phy,inu)+ & 830 tau_ae_pi(i,k,id_ASSSM_phy,inu)*piz_ae(i,k,id_ASSSM_phy,inu)*cg_ae(i,k,id_ASSSM_phy,inu)+ & 831 tau_ae_pi(i,k,id_CSSSM_phy,inu)*piz_ae(i,k,id_CSSSM_phy,inu)*cg_ae(i,k,id_CSSSM_phy,inu)+ & 832 tau_ae_pi(i,k,id_SSSSM_phy,inu)*piz_ae(i,k,id_SSSSM_phy,inu)*cg_ae(i,k,id_SSSSM_phy,inu)+ & 833 tau_ae_pi(i,k,id_CIDUSTM_phy,inu)*piz_ae(i,k,id_CIDUSTM_phy,inu)*cg_ae(i,k,id_CIDUSTM_phy,inu))/ & 834 (tau_allaer(i,k,1,inu)*piz_allaer(i,k,1,inu)) 835 cg_allaer(i,k,1,inu)=MIN(MAX(cg_allaer(i,k,1,inu),0.0),1.0) 836 ! 837 ELSE 838 ! 839 !--this is the case for VOLMIP 840 !--in this case index 1 of tau_allaer contains all (natural+anthropogenic) aerosols (same as index 2 above) 841 !--but stratospheric aerosols will not be added in rrtm/readaerosolstrato2 as 842 !--the objective is to have the double radiation call with and without stratospheric aerosols 843 ! 844 tau_allaer(i,k,1,inu)=tau_allaer(i,k,2,inu) 845 846 piz_allaer(i,k,1,inu)=piz_allaer(i,k,2,inu) 847 848 cg_allaer(i,k,1,inu) =cg_allaer(i,k,2,inu) 849 ! 850 ENDIF 832 851 ENDDO 833 852 ENDDO -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/radlsw.F90
r2192 r3605 502 502 ELSEIF (NRADLP == 3) THEN 503 503 ! one uses the cloud droplet radius from newmicro 504 ! IKL or JK ?? - I think IKL but needs to be verified 504 ! IKL or JK ?? - I think IKL but needs to be verified > ref_liq_i 505 ! (inverted) is used in the call of RECMWF_AERO in radlwsw_m.F90, 506 ! so everything is fine - JBM 6/2019 505 507 ZRADLP(JL)=PREF_LIQ(JL,IKL) 506 508 ENDIF -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosol_optic_rrtm.F90
r3333 r3605 1 1 ! $Id$ 2 2 ! 3 SUBROUTINE readaerosol_optic_rrtm(debut, aerosol_couple, ok_alw, &3 SUBROUTINE readaerosol_optic_rrtm(debut, aerosol_couple, ok_alw, ok_volcan, & 4 4 new_aod, flag_aerosol, flag_bc_internal_mixture, itap, rjourvrai, & 5 5 pdtphys, pplay, paprs, t_seri, rhcl, presnivs, & … … 32 32 LOGICAL, INTENT(IN) :: aerosol_couple 33 33 LOGICAL, INTENT(IN) :: ok_alw 34 LOGICAL, INTENT(IN) :: ok_volcan 34 35 LOGICAL, INTENT(IN) :: new_aod 35 36 INTEGER, INTENT(IN) :: flag_aerosol … … 313 314 tau_aero, piz_aero, cg_aero, & 314 315 m_allaer_pi, flag_aerosol, & 315 flag_bc_internal_mixture, zrho )316 flag_bc_internal_mixture, zrho, ok_volcan ) 316 317 317 318 ! aeropt_5wv only for validation and diagnostics -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosolstrato1_rrtm.F90
r2744 r3605 2 2 ! $Id: readaerosolstrato1_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $ 3 3 ! 4 4 5 SUBROUTINE readaerosolstrato1_rrtm(debut) 5 6 … … 9 10 10 11 USE phys_cal_mod, ONLY : mth_cur 11 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo 12 USE mod_phys_lmdz_mpi_data, ONLY : is_mpi_root 13 USE mod_phys_lmdz_omp_data, ONLY : is_omp_root 12 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo, grid_type, unstructured 14 13 USE mod_phys_lmdz_para 15 14 USE phys_state_var_mod … … 19 18 USE YOERAD, ONLY : NLW 20 19 USE YOMCST 20 #ifdef CPP_XIOS 21 USE xios 22 #endif 21 23 22 24 IMPLICIT NONE … … 45 47 REAL, ALLOCATABLE:: tauaerstrat_mois(:, :, :) 46 48 REAL, ALLOCATABLE:: tauaerstrat_mois_glo(:, :) 49 REAL, ALLOCATABLE:: tauaerstrat_mpi(:, :) 47 50 48 51 ! For NetCDF: … … 102 105 n_lat = size(latitude) 103 106 print *, 'LAT aerosol strato=', n_lat, latitude 104 IF (n_lat.NE.nbp_lat) THEN 105 print *,'Le nombre de lat n est pas egal a nbp_lat' 106 STOP 107 ENDIF 108 107 108 IF (grid_type/=unstructured) THEN 109 IF (n_lat.NE.nbp_lat) THEN 110 print *,'Le nombre de lat n est pas egal a nbp_lat' 111 STOP 112 ENDIF 113 ENDIF 114 109 115 CALL nf95_inq_varid(ncid_in, "LON", varid) 110 116 CALL nf95_gw_var(ncid_in, varid, longitude) 111 117 n_lon = size(longitude) 112 118 print *, 'LON aerosol strato=', n_lon, longitude 113 IF (n_lon.NE.nbp_lon) THEN 114 print *,'Le nombre de lon n est pas egal a nbp_lon' 115 STOP 116 ENDIF 117 119 120 IF (grid_type/=unstructured) THEN 121 IF (n_lon.NE.nbp_lon) THEN 122 print *,'Le nombre de lon n est pas egal a nbp_lon' 123 STOP 124 ENDIF 125 ENDIF 126 127 118 128 CALL nf95_inq_varid(ncid_in, "TIME", varid) 119 129 CALL nf95_gw_var(ncid_in, varid, time) … … 144 154 !---reduce to a klon_glo grid 145 155 CALL grid2dTo1d_glo(tauaerstrat_mois,tauaerstrat_mois_glo) 146 156 157 ELSE 158 ALLOCATE(tauaerstrat_mois(0,0,0)) 147 159 ENDIF !--is_mpi_root and is_omp_root 148 160 … … 153 165 154 166 !--scatter on all proc 155 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 156 167 168 IF (grid_type==unstructured) THEN 169 #ifdef CPP_XIOS 170 IF (is_omp_master) THEN 171 ALLOCATE(tauaerstrat_mpi(klon_mpi,klev)) 172 CALL xios_send_field("taustrat_in",tauaerstrat_mois) 173 CALL xios_recv_field("taustrat_out",tauaerstrat_mpi) 174 ELSE 175 ALLOCATE(tauaerstrat_mpi(0,0)) 176 ENDIF 177 CALL scatter_omp(tauaerstrat_mpi,tau_aer_strat) 178 #endif 179 ELSE 180 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 181 ENDIF 182 157 183 IF (is_mpi_root.AND.is_omp_root) THEN 158 184 ! -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/readaerosolstrato2_rrtm.F90
r2744 r3605 2 2 ! $Id: readaerosolstrato2_rrtm.F90 2526 2016-05-26 22:13:40Z oboucher $ 3 3 ! 4 SUBROUTINE readaerosolstrato2_rrtm(debut )4 SUBROUTINE readaerosolstrato2_rrtm(debut, ok_volcan) 5 5 6 6 USE netcdf95, ONLY: nf95_close, nf95_gw_var, nf95_inq_dimid, & … … 9 9 10 10 USE phys_cal_mod, ONLY : mth_cur 11 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo 12 USE mod_phys_lmdz_mpi_data , ONLY : is_mpi_root13 USE mod_phys_lmdz_omp_data , ONLY : is_omp_root11 USE mod_grid_phy_lmdz, ONLY: nbp_lon, nbp_lat, klon_glo, grid2dTo1d_glo, grid_type, unstructured 12 USE mod_phys_lmdz_mpi_data 13 USE mod_phys_lmdz_omp_data 14 14 USE mod_phys_lmdz_para 15 15 USE phys_state_var_mod … … 19 19 USE YOERAD, ONLY : NLW 20 20 USE YOMCST 21 #ifdef CPP_XIOS 22 USE xios 23 #endif 21 24 22 25 IMPLICIT NONE … … 29 32 ! Variable input 30 33 LOGICAL, INTENT(IN) :: debut 34 LOGICAL, INTENT(IN) :: ok_volcan !activate volcanic diags 31 35 32 36 ! Variables locales … … 65 69 REAL, ALLOCATABLE:: cgaerstrat_mois_glo(:, :, :) 66 70 REAL, ALLOCATABLE:: taulwaerstrat_mois_glo(:, :, :) 71 REAL, ALLOCATABLE:: tauaerstrat_mpi(:, :, :) 72 REAL, ALLOCATABLE:: pizaerstrat_mpi(:, :, :) 73 REAL, ALLOCATABLE:: cgaerstrat_mpi(:, :, :) 74 REAL, ALLOCATABLE:: taulwaerstrat_mpi(:, :, :) 67 75 68 76 ! For NetCDF: … … 107 115 CALL nf95_gw_var(ncid_in, varid, latitude) 108 116 n_lat = size(latitude) 109 IF (n_lat.NE.nbp_lat) THEN 110 print *, 'latitude=', n_lat, nbp_lat 111 abort_message='Le nombre de lat n est pas egal a nbp_lat' 112 CALL abort_physic(modname,abort_message,1) 117 118 IF (grid_type/=unstructured) THEN 119 IF (n_lat.NE.nbp_lat) THEN 120 print *, 'latitude=', n_lat, nbp_lat 121 abort_message='Le nombre de lat n est pas egal a nbp_lat' 122 CALL abort_physic(modname,abort_message,1) 123 ENDIF 113 124 ENDIF 114 125 … … 134 145 ALLOCATE(cgaerstrat(n_lat, n_lev, n_wav, n_month)) 135 146 136 ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev, n_wav))137 ALLOCATE(pizaerstrat_mois(n_lon, n_lat, n_lev, n_wav))138 ALLOCATE(cgaerstrat_mois(n_lon, n_lat, n_lev, n_wav))139 140 ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev, n_wav))141 ALLOCATE(pizaerstrat_mois_glo(klon_glo, n_lev, n_wav))142 ALLOCATE(cgaerstrat_mois_glo(klon_glo, n_lev, n_wav))143 144 147 !--reading stratospheric aerosol tau per layer 145 148 CALL nf95_inq_varid(ncid_in, "TAU_SUN", varid) … … 159 162 CALL nf95_close(ncid_in) 160 163 164 165 IF (grid_type/=unstructured) THEN 166 ALLOCATE(tauaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) 167 ALLOCATE(pizaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) 168 ALLOCATE(cgaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) 169 170 ALLOCATE(tauaerstrat_mois_glo(klon_glo, n_lev, n_wav)) 171 ALLOCATE(pizaerstrat_mois_glo(klon_glo, n_lev, n_wav)) 172 ALLOCATE(cgaerstrat_mois_glo(klon_glo, n_lev, n_wav)) 161 173 !--select the correct month 162 174 !--and copy into 1st longitude 163 tauaerstrat_mois(1,:,:,:) = tauaerstrat(:,:,:,mth_cur)164 pizaerstrat_mois(1,:,:,:) = pizaerstrat(:,:,:,mth_cur)165 cgaerstrat_mois(1,:,:,:) = cgaerstrat(:,:,:,mth_cur)175 tauaerstrat_mois(1,:,:,:) = tauaerstrat(:,:,:,mth_cur) 176 pizaerstrat_mois(1,:,:,:) = pizaerstrat(:,:,:,mth_cur) 177 cgaerstrat_mois(1,:,:,:) = cgaerstrat(:,:,:,mth_cur) 166 178 167 179 !--copy longitudes 168 DO i=2, n_lon169 tauaerstrat_mois(i,:,:,:) = tauaerstrat_mois(1,:,:,:)170 pizaerstrat_mois(i,:,:,:) = pizaerstrat_mois(1,:,:,:)171 cgaerstrat_mois(i,:,:,:) = cgaerstrat_mois(1,:,:,:)172 ENDDO180 DO i=2, n_lon 181 tauaerstrat_mois(i,:,:,:) = tauaerstrat_mois(1,:,:,:) 182 pizaerstrat_mois(i,:,:,:) = pizaerstrat_mois(1,:,:,:) 183 cgaerstrat_mois(i,:,:,:) = cgaerstrat_mois(1,:,:,:) 184 ENDDO 173 185 174 186 !---reduce to a klon_glo grid 175 DO band=1, NSW176 CALL grid2dTo1d_glo(tauaerstrat_mois(:,:,:,band),tauaerstrat_mois_glo(:,:,band))177 CALL grid2dTo1d_glo(pizaerstrat_mois(:,:,:,band),pizaerstrat_mois_glo(:,:,band))178 CALL grid2dTo1d_glo(cgaerstrat_mois(:,:,:,band),cgaerstrat_mois_glo(:,:,band))179 ENDDO180 187 DO band=1, NSW 188 CALL grid2dTo1d_glo(tauaerstrat_mois(:,:,:,band),tauaerstrat_mois_glo(:,:,band)) 189 CALL grid2dTo1d_glo(pizaerstrat_mois(:,:,:,band),pizaerstrat_mois_glo(:,:,band)) 190 CALL grid2dTo1d_glo(cgaerstrat_mois(:,:,:,band),cgaerstrat_mois_glo(:,:,band)) 191 ENDDO 192 ENDIF 181 193 !--Now LW optical properties 182 194 ! 195 183 196 CALL nf95_open("taulwstrat.2D.nc", nf90_nowrite, ncid_in) 184 197 … … 194 207 CALL nf95_gw_var(ncid_in, varid, latitude) 195 208 n_lat = size(latitude) 196 IF (n_lat.NE.nbp_lat) THEN 197 abort_message='Le nombre de lat n est pas egal a nbp_lat' 198 CALL abort_physic(modname,abort_message,1) 199 ENDIF 200 209 210 IF (grid_type/=unstructured) THEN 211 IF (n_lat.NE.nbp_lat) THEN 212 abort_message='Le nombre de lat n est pas egal a nbp_lat' 213 CALL abort_physic(modname,abort_message,1) 214 ENDIF 215 ENDIF 216 201 217 CALL nf95_inq_varid(ncid_in, "TIME", varid) 202 218 CALL nf95_gw_var(ncid_in, varid, time) … … 217 233 218 234 ALLOCATE(taulwaerstrat(n_lat, n_lev, n_wav, n_month)) 219 ALLOCATE(taulwaerstrat_mois(n_lon, n_lat, n_lev, n_wav))220 ALLOCATE(taulwaerstrat_mois_glo(klon_glo, n_lev, n_wav))221 235 222 236 !--reading stratospheric aerosol lw tau per layer … … 227 241 CALL nf95_close(ncid_in) 228 242 243 IF (grid_type/=unstructured) THEN 244 245 ALLOCATE(taulwaerstrat_mois(n_lon, n_lat, n_lev, n_wav)) 246 ALLOCATE(taulwaerstrat_mois_glo(klon_glo, n_lev, n_wav)) 247 229 248 !--select the correct month 230 249 !--and copy into 1st longitude 231 taulwaerstrat_mois(1,:,:,:) = taulwaerstrat(:,:,:,mth_cur)250 taulwaerstrat_mois(1,:,:,:) = taulwaerstrat(:,:,:,mth_cur) 232 251 !--copy longitudes 233 DO i=2, n_lon234 taulwaerstrat_mois(i,:,:,:) = taulwaerstrat_mois(1,:,:,:)235 ENDDO252 DO i=2, n_lon 253 taulwaerstrat_mois(i,:,:,:) = taulwaerstrat_mois(1,:,:,:) 254 ENDDO 236 255 237 256 !---reduce to a klon_glo grid 238 DO band=1, NLW 239 CALL grid2dTo1d_glo(taulwaerstrat_mois(:,:,:,band),taulwaerstrat_mois_glo(:,:,band)) 240 ENDDO 241 257 DO band=1, NLW 258 CALL grid2dTo1d_glo(taulwaerstrat_mois(:,:,:,band),taulwaerstrat_mois_glo(:,:,band)) 259 ENDDO 260 ENDIF 261 242 262 ELSE !--proc other than mpi_root and omp_root 243 263 !--dummy allocation needed for debug mode … … 248 268 ALLOCATE(taulwaerstrat_mois_glo(1,1,1)) 249 269 270 ALLOCATE(tauaerstrat(0,0,0,12)) 271 ALLOCATE(pizaerstrat(0,0,0,12)) 272 ALLOCATE(cgaerstrat(0,0,0,12)) 273 ALLOCATE(taulwaerstrat(0,0,0,12)) 274 275 250 276 ENDIF !--is_mpi_root and is_omp_root 251 277 … … 255 281 mth_pre=mth_cur 256 282 283 IF (grid_type==unstructured) THEN 284 285 #ifdef CPP_XIOS 286 287 IF (is_omp_master) THEN 288 ALLOCATE(tauaerstrat_mpi(klon_mpi, klev, NSW)) 289 ALLOCATE(pizaerstrat_mpi(klon_mpi, klev, NSW)) 290 ALLOCATE(cgaerstrat_mpi(klon_mpi, klev, NSW)) 291 ALLOCATE(taulwaerstrat_mpi(klon_mpi, klev, NLW)) 292 293 CALL xios_send_field("tauaerstrat_in",SPREAD(tauaerstrat(:,:,:,mth_cur),1,8)) 294 CALL xios_recv_field("tauaerstrat_out",tauaerstrat_mpi) 295 CALL xios_send_field("pizaerstrat_in",SPREAD(pizaerstrat(:,:,:,mth_cur),1,8)) 296 CALL xios_recv_field("pizaerstrat_out",pizaerstrat_mpi) 297 CALL xios_send_field("cgaerstrat_in",SPREAD(cgaerstrat(:,:,:,mth_cur),1,8)) 298 CALL xios_recv_field("cgaerstrat_out",cgaerstrat_mpi) 299 CALL xios_send_field("taulwaerstrat_in",SPREAD(taulwaerstrat(:,:,:,mth_cur),1,8)) 300 CALL xios_recv_field("taulwaerstrat_out",taulwaerstrat_mpi) 301 ELSE 302 ALLOCATE(tauaerstrat_mpi(0, 0, 0)) 303 ALLOCATE(pizaerstrat_mpi(0, 0, 0)) 304 ALLOCATE(cgaerstrat_mpi(0, 0, 0)) 305 ALLOCATE(taulwaerstrat_mpi(0, 0, 0)) 306 ENDIF 307 308 CALL scatter_omp(tauaerstrat_mpi,tau_aer_strat) 309 CALL scatter_omp(pizaerstrat_mpi,piz_aer_strat) 310 CALL scatter_omp(cgaerstrat_mpi,cg_aer_strat) 311 CALL scatter_omp(taulwaerstrat_mpi,taulw_aer_strat) 312 #endif 313 ELSE 314 257 315 !--scatter on all proc 258 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 259 CALL scatter(pizaerstrat_mois_glo,piz_aer_strat) 260 CALL scatter(cgaerstrat_mois_glo,cg_aer_strat) 261 CALL scatter(taulwaerstrat_mois_glo,taulw_aer_strat) 316 CALL scatter(tauaerstrat_mois_glo,tau_aer_strat) 317 CALL scatter(pizaerstrat_mois_glo,piz_aer_strat) 318 CALL scatter(cgaerstrat_mois_glo,cg_aer_strat) 319 CALL scatter(taulwaerstrat_mois_glo,taulw_aer_strat) 320 IF (is_mpi_root.AND.is_omp_root) DEALLOCATE(tauaerstrat_mois, pizaerstrat_mois, cgaerstrat_mois, taulwaerstrat_mois) 321 322 ENDIF 262 323 263 324 IF (is_mpi_root.AND.is_omp_root) THEN 264 ! 265 DEALLOCATE(tauaerstrat, pizaerstrat, cgaerstrat) 266 DEALLOCATE(tauaerstrat_mois, pizaerstrat_mois, cgaerstrat_mois) 267 DEALLOCATE(taulwaerstrat,taulwaerstrat_mois) 268 ! 269 ENDIF !--is_mpi_root and is_omp_root 270 271 DEALLOCATE(tauaerstrat_mois_glo,pizaerstrat_mois_glo,cgaerstrat_mois_glo) 272 DEALLOCATE(taulwaerstrat_mois_glo) 325 DEALLOCATE(tauaerstrat, pizaerstrat, cgaerstrat,taulwaerstrat) 326 ENDIF 327 273 328 274 329 !$OMP BARRIER … … 290 345 ENDDO 291 346 347 IF (.NOT. ok_volcan) THEN 348 ! 349 !--this is the default case 350 !--stratospheric aerosols are added to both index 2 and 1 for double radiation calls 292 351 !--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones 293 352 DO band=1, NSW 294 353 WHERE (stratomask.GT.0.999999) 295 !-- anthropogenic aerosolsbands 1 to NSW354 !--strat aerosols are added to index 2 : natural and anthropogenic aerosols for bands 1 to NSW 296 355 cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & 297 356 cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & … … 302 361 MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 ) 303 362 tau_aero_sw_rrtm(:,:,2,band) = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band) 304 !-- natural aerosolsbands 1 to NSW363 !--strat aerosols are added to index 1 : natural aerosols only for bands 1 to NSW 305 364 cg_aero_sw_rrtm(:,:,1,band) = ( cg_aero_sw_rrtm(:,:,1,band)*piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & 365 cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & 366 MAX( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & 367 piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 ) 368 piz_aero_sw_rrtm(:,:,1,band) = ( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + & 369 piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & 370 MAX( tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band), 1.e-15 ) 371 tau_aero_sw_rrtm(:,:,1,band) = tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band) 372 ENDWHERE 373 ENDDO 374 ! 375 ELSE 376 ! 377 !--this is the VOLMIP case 378 !--stratospheric aerosols are only added to index 2 in this case 379 !--weighted average for cg, piz and tau, adding strat aerosols on top of tropospheric ones 380 DO band=1, NSW 381 WHERE (stratomask.GT.0.999999) 382 !--strat aerosols are added to index 2 : natural and anthropogenic aerosols for bands 1 to NSW 383 cg_aero_sw_rrtm(:,:,2,band) = ( cg_aero_sw_rrtm(:,:,2,band)*piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & 306 384 cg_aer_strat(:,:,band)*piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & 307 MAX( piz_aero_sw_rrtm(:,:, 1,band)*tau_aero_sw_rrtm(:,:,1,band) + &385 MAX( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & 308 386 piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band), 1.e-15 ) 309 piz_aero_sw_rrtm(:,:, 1,band) = ( piz_aero_sw_rrtm(:,:,1,band)*tau_aero_sw_rrtm(:,:,1,band) + &387 piz_aero_sw_rrtm(:,:,2,band) = ( piz_aero_sw_rrtm(:,:,2,band)*tau_aero_sw_rrtm(:,:,2,band) + & 310 388 piz_aer_strat(:,:,band)*tau_aer_strat(:,:,band) ) / & 311 MAX( tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band), 1.e-15 ) 312 tau_aero_sw_rrtm(:,:,1,band) = tau_aero_sw_rrtm(:,:,1,band) + tau_aer_strat(:,:,band) 313 !--no stratospheric aerosol in index 1 for these tests 314 ! cg_aero_sw_rrtm(:,:,1,band) = cg_aero_sw_rrtm(:,:,1,band) 315 ! piz_aero_sw_rrtm(:,:,1,band) = piz_aero_sw_rrtm(:,:,1,band) 316 ! tau_aero_sw_rrtm(:,:,1,band) = tau_aero_sw_rrtm(:,:,1,band) 317 ENDWHERE 318 ENDDO 389 MAX( tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band), 1.e-15 ) 390 tau_aero_sw_rrtm(:,:,2,band) = tau_aero_sw_rrtm(:,:,2,band) + tau_aer_strat(:,:,band) 391 ENDWHERE 392 ENDDO 393 ENDIF 319 394 320 395 !--total vertical aod at 10 um … … 331 406 ENDDO 332 407 408 IF (.NOT. ok_volcan) THEN 409 !--this is the default case 410 !--stratospheric aerosols are added to both index 2 and 1 333 411 DO band=1, NLW 334 412 WHERE (stratomask.GT.0.999999) 335 413 tau_aero_lw_rrtm(:,:,2,band) = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band) 336 414 tau_aero_lw_rrtm(:,:,1,band) = tau_aero_lw_rrtm(:,:,1,band) + taulw_aer_strat(:,:,band) 337 !--no stratospheric aerosols in index 1 for these tests338 ! tau_aero_lw_rrtm(:,:,1,band) = tau_aero_lw_rrtm(:,:,1,band)339 415 ENDWHERE 340 416 ENDDO 417 ! 418 ELSE 419 ! 420 !--this is the VOLMIP case 421 DO band=1, NLW 422 !--stratospheric aerosols are not added to index 1 423 !--and we copy index 2 in index 1 because we want the same dust aerosol LW properties as above 424 tau_aero_lw_rrtm(:,:,1,band) = tau_aero_lw_rrtm(:,:,2,band) 425 ! 426 WHERE (stratomask.GT.0.999999) 427 !--stratospheric aerosols are only added to index 2 428 tau_aero_lw_rrtm(:,:,2,band) = tau_aero_lw_rrtm(:,:,2,band) + taulw_aer_strat(:,:,band) 429 ENDWHERE 430 ENDDO 431 ENDIF 341 432 342 433 !--default SSA value if there is no aerosol -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/recmwf_aero.F90
r3412 r3605 30 30 & PTOPSWAIAERO,PSOLSWAIAERO,& 31 31 & PTOPSWCFAERO,PSOLSWCFAERO,& 32 & PSWADAERO,& !--NL 32 33 !--LW diagnostics CK 33 34 & PTOPLWADAERO,PSOLLWADAERO,& 34 35 & PTOPLWAD0AERO,PSOLLWAD0AERO,& 35 36 & PTOPLWAIAERO,PSOLLWAIAERO,& 37 & PLWADAERO,& !--NL 36 38 !..end 37 & ok_ade, ok_aie, flag_aerosol,flag_aerosol_strat,flag_aer_feedback) 39 & ok_ade, ok_aie, ok_volcan, flag_aerosol,flag_aerosol_strat,& 40 & flag_aer_feedback) 38 41 !--fin 39 42 … … 82 85 ! ok_ade---input-L- apply the Aerosol Direct Effect or not? 83 86 ! ok_aie---input-L- apply the Aerosol Indirect Effect or not? 87 ! ok_volcan-input-L- activate volcanic diags (SW heat & LW cool rate, SW & LW flux) 84 88 ! flag_aerosol-input-I- aerosol flag from 0 to 7 85 89 ! flag_aerosol_strat-input-I- use stratospheric aerosols flag (T/F) … … 213 217 REAL(KIND=JPRB) ,INTENT(IN) :: PREF_ICE_PI(KPROMA,KLEV) 214 218 LOGICAL, INTENT(in) :: ok_ade, ok_aie ! switches whether to use aerosol direct (indirect) effects or not 219 LOGICAL, INTENT(in) :: ok_volcan ! produce volcanic diags (SW/LW heat flux and rate) 215 220 INTEGER, INTENT(in) :: flag_aerosol ! takes value 0 (no aerosol) or 1 to 6 (aerosols) 216 221 LOGICAL, INTENT(in) :: flag_aerosol_strat ! use stratospheric aerosols … … 221 226 REAL(KIND=JPRB) ,INTENT(OUT) :: PTOPSWCFAERO(KPROMA,3), PSOLSWCFAERO(KPROMA,3) !--do we keep this ? 222 227 !--fin 228 !--NL 229 REAL(KIND=JPRB) ,INTENT(OUT) :: PSWADAERO(KPROMA, KLEV+1) ! SW Aerosol direct forcing 230 REAL(KIND=JPRB) ,INTENT(OUT) :: PLWADAERO(KPROMA, KLEV+1) ! LW Aerosol direct forcing 223 231 !--CK 224 232 REAL(KIND=JPRB) ,INTENT(out) :: PTOPLWADAERO(KPROMA), PSOLLWADAERO(KPROMA) ! LW Aerosol direct forcing at TOA + surface … … 811 819 PSOLSWAD0AERO(:) = (ZFSDN0_AERO(:,1,4) -ZFSUP0_AERO(:,1,4)) -(ZFSDN0_AERO(:,1,2) -ZFSUP0_AERO(:,1,2)) 812 820 PTOPSWAD0AERO(:) = (ZFSDN0_AERO(:,KLEV+1,4)-ZFSUP0_AERO(:,KLEV+1,4))-(ZFSDN0_AERO(:,KLEV+1,2)-ZFSUP0_AERO(:,KLEV+1,2)) 821 IF(ok_volcan) THEN 822 PSWADAERO(:,:) = (ZFSDN_AERO(:,:,4) -ZFSUP_AERO(:,:,4)) -(ZFSDN_AERO(:,:,2) -ZFSUP_AERO(:,:,2)) !--NL 823 ENDIF 813 824 814 825 ! indirect anthropogenic forcing … … 831 842 PSOLLWAD0AERO(:) = (-LWDN0_AERO(:,1,4) -LWUP0_AERO(:,1,4)) -(-LWDN0_AERO(:,1,2) -LWUP0_AERO(:,1,2)) 832 843 PTOPLWAD0AERO(:) = (-LWDN0_AERO(:,KLEV+1,4)-LWUP0_AERO(:,KLEV+1,4))-(-LWDN0_AERO(:,KLEV+1,2)-LWUP0_AERO(:,KLEV+1,2)) 844 IF(ok_volcan) THEN 845 PLWADAERO(:,:) = (-LWDN_AERO(:,:,4) -LWUP_AERO(:,:,4)) -(-LWDN_AERO(:,:,2) -LWUP_AERO(:,:,2)) !--NL 846 ENDIF 833 847 834 848 ! LW indirect anthropogenic forcing … … 845 859 PSOLSWAD0AERO(:) = (ZFSDN0_AERO(:,1,3) -ZFSUP0_AERO(:,1,3)) -(ZFSDN0_AERO(:,1,1) -ZFSUP0_AERO(:,1,1)) 846 860 PTOPSWAD0AERO(:) = (ZFSDN0_AERO(:,KLEV+1,3)-ZFSUP0_AERO(:,KLEV+1,3))-(ZFSDN0_AERO(:,KLEV+1,1)-ZFSUP0_AERO(:,KLEV+1,1)) 861 IF(ok_volcan) THEN 862 PSWADAERO(:,:) = (ZFSDN_AERO(:,:,3) -ZFSUP_AERO(:,:,3)) -(ZFSDN_AERO(:,:,1) -ZFSUP_AERO(:,:,1)) !--NL 863 ENDIF 847 864 848 865 ! indirect anthropogenic forcing … … 865 882 PSOLLWAD0AERO(:) = (-LWDN0_AERO(:,1,3) -LWUP0_AERO(:,1,3)) -(-LWDN0_AERO(:,1,1) -LWUP0_AERO(:,1,1)) 866 883 PTOPLWAD0AERO(:) = (-LWDN0_AERO(:,KLEV+1,3)-LWUP0_AERO(:,KLEV+1,3))-(-LWDN0_AERO(:,KLEV+1,1)-LWUP0_AERO(:,KLEV+1,1)) 867 884 IF(ok_volcan) THEN 885 PLWADAERO(:,:) = (-LWDN_AERO(:,:,3) -LWUP_AERO(:,:,3)) -(-LWDN_AERO(:,:,1) -LWUP_AERO(:,:,1)) !--NL 886 ENDIF 887 868 888 ! LW indirect anthropogenic forcing 869 889 PSOLLWAIAERO(:) = 0.0 … … 879 899 PSOLSWAD0AERO(:) = 0.0 880 900 PTOPSWAD0AERO(:) = 0.0 881 901 IF(ok_volcan) THEN 902 PSWADAERO(:,:) = 0.0 !--NL 903 ENDIF 904 882 905 ! indirect anthropogenic forcing 883 906 PSOLSWAIAERO(:) = (ZFSDN_AERO(:,1,2) -ZFSUP_AERO(:,1,2)) -(ZFSDN_AERO(:,1,1) -ZFSUP_AERO(:,1,1)) … … 899 922 PSOLLWAD0AERO(:) = 0.0 900 923 PTOPLWAD0AERO(:) = 0.0 901 924 IF(ok_volcan) THEN 925 PLWADAERO(:,:) = 0.0 !--NL 926 ENDIF 927 902 928 ! LW indirect anthropogenic forcing 903 929 PSOLLWAIAERO(:) = (-LWDN_AERO(:,1,2) -LWUP_AERO(:,1,2)) -(-LWDN_AERO(:,1,1) -LWUP_AERO(:,1,1)) … … 913 939 PSOLSWAD0AERO(:) = 0.0 914 940 PTOPSWAD0AERO(:) = 0.0 915 941 IF(ok_volcan) THEN 942 PSWADAERO(:,:) = 0.0 !--NL 943 ENDIF 944 916 945 ! indirect anthropogenic forcing 917 946 PSOLSWAIAERO(:) = 0.0 … … 933 962 PSOLLWAD0AERO(:) = 0.0 934 963 PTOPLWAD0AERO(:) = 0.0 935 964 IF(ok_volcan) THEN 965 PLWADAERO(:,:) = 0.0 !--NL 966 ENDIF 967 936 968 ! LW indirect anthropogenic forcing 937 969 PSOLLWAIAERO(:) = 0.0 -
LMDZ6/branches/Ocean_skin/libf/phylmd/rrtm/suinit.F90
r1990 r3605 126 126 ALLOCATE(VDELA (MAX(JPMXLE,NFLEVG))) 127 127 ALLOCATE(VDELB (MAX(JPMXLE,NFLEVG))) 128 VDELB = 0 !ym missing init 128 129 ALLOCATE( VC (NFLEVG) ) 130 VC = 0 !ym missing init 129 131 ALLOCATE( NLOEN (NPROMA) ) 130 132 ALLOCATE( NLOENG (NPROMA) ) -
LMDZ6/branches/Ocean_skin/libf/phylmd/simu_airs.F90
r2585 r3605 2 2 module m_simu_airs 3 3 4 USE print_control_mod, ONLY: prt_level,lunout 5 4 6 implicit none 5 7 6 real, parameter:: tau_thresh = 0.05 ! seuil nuages detectables7 real, parameter:: p_thresh = 445. ! seuil nuages hauts8 real, parameter:: em_min = 0.2 ! seuils nuages semi-transp9 real, parameter:: em_max = 0.8510 real, parameter:: undef = 999.8 REAL, PARAMETER :: tau_thresh = 0.05 ! seuil nuages detectables 9 REAL, PARAMETER :: p_thresh = 445. ! seuil nuages hauts 10 REAL, PARAMETER :: em_min = 0.2 ! seuils nuages semi-transp 11 REAL, PARAMETER :: em_max = 0.85 12 REAL, PARAMETER :: undef = 999. 11 13 12 14 contains 13 15 14 realfunction search_tropopause(P,T,alt,N) result(P_tropo)16 REAL function search_tropopause(P,T,alt,N) result(P_tropo) 15 17 ! this function searches for the tropopause pressure in [hPa]. 16 18 ! The search is based on ideology described in … … 18 20 ! GRL, 30(20) 2042, doi:10.1029/2003GL018240, 2003 19 21 20 integerN,i,i_lev,first_point,exit_flag,i_dir21 realP(N),T(N),alt(N),slope(N)22 realP_min, P_max, slope_limit,slope_2km, &22 INTEGER N,i,i_lev,first_point,exit_flag,i_dir 23 REAL P(N),T(N),alt(N),slope(N) 24 REAL P_min, P_max, slope_limit,slope_2km, & 23 25 & delta_alt_limit,tmp,delta_alt 24 parameter(P_min=75.0, P_max=470.0) ! hPa25 parameter(slope_limit=0.002) ! 2 K/km converted to K/m26 parameter(delta_alt_limit=2000.0) ! 2000 meters26 PARAMETER(P_min=75.0, P_max=470.0) ! hPa 27 PARAMETER(slope_limit=0.002) ! 2 K/km converted to K/m 28 PARAMETER(delta_alt_limit=2000.0) ! 2000 meters 27 29 28 30 do i=1,N-1 … … 93 95 94 96 95 integer:: i, n, nss96 97 integer, intent(in) :: len_cs98 real, dimension(:), intent(in) :: rneb_cs, temp_cs99 real, dimension(:), intent(in) :: emis_cs, iwco_cs, rad_cs100 real, dimension(:), intent(in) :: pres_cs, dz_cs, rhodz_cs101 102 real, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, &97 INTEGER :: i, n, nss 98 99 INTEGER, intent(in) :: len_cs 100 REAL, DIMENSION(:), intent(in) :: rneb_cs, temp_cs 101 REAL, DIMENSION(:), intent(in) :: emis_cs, iwco_cs, rad_cs 102 REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rhodz_cs 103 104 REAL, intent(out) :: cc_tot_cs, cc_hc_cs, cc_hist_cs, & 103 105 & cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs, & 104 106 & pcld_hc_cs, tcld_hc_cs, em_hc_cs, iwp_hc_cs, & … … 109 111 & deltaz_hc_cs, deltaz_hist_cs, rad_hist_cs 110 112 111 real, dimension(len_cs) :: rneb_ord112 real:: rneb_min113 114 real, dimension(:), allocatable :: s, s_hc, s_hist, rneb_max115 real, dimension(:), allocatable :: sCb, sThCi, sAnv116 real, dimension(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,&113 REAL, DIMENSION(len_cs) :: rneb_ord 114 REAL :: rneb_min 115 116 REAL, DIMENSION(:), allocatable :: s, s_hc, s_hist, rneb_max 117 REAL, DIMENSION(:), allocatable :: sCb, sThCi, sAnv 118 REAL, DIMENSION(:), allocatable :: iwp_ss, pcld_ss, tcld_ss,& 117 119 & emis_ss 118 real, dimension(:), allocatable :: deltaz_ss, rad_ss 119 120 121 write(*,*) 'dans cloud_structure' 120 REAL, DIMENSION(:), allocatable :: deltaz_ss, rad_ss 121 122 CHARACTER (len = 50) :: modname = 'simu_airs.cloud_structure' 123 CHARACTER (len = 160) :: abort_message 124 125 126 write(lunout,*) 'dans cloud_structure' 122 127 123 128 call ordonne(len_cs, rneb_cs, rneb_ord) … … 300 305 if (cc_tot_cs .gt. maxval(rneb_cs) .and. & 301 306 & abs(cc_tot_cs-maxval(rneb_cs)) .gt. 1.e-4 ) then 302 write(*,*) 'cc_tot_cs > max rneb_cs' 303 write(*,*) cc_tot_cs, maxval(rneb_cs) 304 STOP 307 WRITE(abort_message,*) 'cc_tot_cs > max rneb_cs', cc_tot_cs, maxval(rneb_cs) 308 CALL abort_physic(modname,abort_message,1) 305 309 endif 306 310 307 311 if (iwp_hc_cs .lt. 0.) then 308 write(*,*) 'cloud_structure:' 309 write(*,*) 'iwp_hc_cs < 0' 310 STOP 312 abort_message= 'cloud_structure: iwp_hc_cs < 0' 313 CALL abort_physic(modname,abort_message,1) 311 314 endif 312 315 … … 316 319 subroutine normal_undef(num, den) 317 320 318 real, intent(in) :: den319 real, intent(inout) :: num321 REAL, intent(in) :: den 322 REAL, intent(inout) :: num 320 323 321 324 if (den .ne. 0) then … … 330 333 subroutine normal2_undef(res,num,den) 331 334 332 real, intent(in) :: den333 real, intent(in) :: num334 real, intent(out) :: res335 REAL, intent(in) :: den 336 REAL, intent(in) :: num 337 REAL, intent(out) :: res 335 338 336 339 if (den .ne. 0.) then … … 350 353 & emis, pcld, tcld, iwp, deltaz, rad) 351 354 352 integer, intent(in) :: len_cs353 real, dimension(len_cs), intent(in) :: rneb_cs, temp_cs354 real, dimension(len_cs), intent(in) :: emis_cs, iwco_cs, &355 INTEGER, intent(in) :: len_cs 356 REAL, DIMENSION(len_cs), intent(in) :: rneb_cs, temp_cs 357 REAL, DIMENSION(len_cs), intent(in) :: emis_cs, iwco_cs, & 355 358 & rneb_ord 356 real, dimension(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs 357 real, dimension(len_cs), intent(in) :: rhodz_cs 358 real, dimension(len_cs) :: tau_cs, w 359 real, intent(in) :: rnebmax 360 real, intent(inout) :: stot, shc, shist 361 real, intent(inout) :: sCb, sThCi, sAnv 362 real, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad 363 364 integer :: i, ideb, ibeg, iend, nuage, visible 365 real :: som, som_tau, som_iwc, som_dz, som_rad, tau 359 REAL, DIMENSION(len_cs), intent(in) :: pres_cs, dz_cs, rad_cs 360 REAL, DIMENSION(len_cs), intent(in) :: rhodz_cs 361 REAL, DIMENSION(len_cs) :: tau_cs, w 362 REAL, intent(in) :: rnebmax 363 REAL, intent(inout) :: stot, shc, shist 364 REAL, intent(inout) :: sCb, sThCi, sAnv 365 REAL, intent(out) :: emis, pcld, tcld, iwp, deltaz, rad 366 367 INTEGER :: i, ideb, ibeg, iend, nuage, visible 368 REAL :: som, som_tau, som_iwc, som_dz, som_rad, tau 369 370 CHARACTER (len = 50) :: modname = 'simu_airs.sous_section' 371 CHARACTER (len = 160) :: abort_message 366 372 367 373 … … 491 497 492 498 if (iwp .lt. 0.) then 493 write(*,*) 'ideb iwp =', ideb, iwp494 STOP499 WRITE(abort_message,*) 'ideb iwp =', ideb, iwp 500 CALL abort_physic(modname,abort_message,1) 495 501 endif 496 502 497 503 if (deltaz .lt. 0.) then 498 write(*,*)'ideb deltaz =', ideb, deltaz499 STOP504 WRITE(abort_message,*)'ideb deltaz =', ideb, deltaz 505 CALL abort_physic(modname,abort_message,1) 500 506 endif 501 507 502 508 if (emis .lt. 0.048 .and. emis .ne. 0.) then 503 write(*,*) 'ideb emis =', ideb, emis504 STOP509 WRITE(abort_message,*) 'ideb emis =', ideb, emis 510 CALL abort_physic(modname,abort_message,1) 505 511 endif 506 512 … … 511 517 & visible, w) 512 518 513 integer, intent(in) :: ibeg, iend514 real, intent(in) :: som_tau515 516 integer, intent(inout) :: visible517 real, dimension(:), intent(inout) :: w518 519 integer:: i519 INTEGER, intent(in) :: ibeg, iend 520 REAL, intent(in) :: som_tau 521 522 INTEGER, intent(inout) :: visible 523 REAL, DIMENSION(:), intent(inout) :: w 524 525 INTEGER :: i 520 526 521 527 … … 553 559 & som_tau, som_iwc, som_dz, som_rad) 554 560 555 integer, intent(in) :: ibeg, iend 556 real, dimension(:), intent(in) :: tau_cs, iwco_cs, temp_cs 557 real, dimension(:), intent(in) :: pres_cs, dz_cs, rad_cs 558 real, dimension(:), intent(in) :: rhodz_cs 559 real, intent(out) :: som_tau, som_iwc, som_dz, som_rad 560 real , intent(out) :: pcld, tcld 561 562 integer :: i, ibase, imid 561 INTEGER, intent(in) :: ibeg, iend 562 REAL, DIMENSION(:), intent(in) :: tau_cs, iwco_cs, temp_cs 563 REAL, DIMENSION(:), intent(in) :: pres_cs, dz_cs, rad_cs 564 REAL, DIMENSION(:), intent(in) :: rhodz_cs 565 REAL, intent(out) :: som_tau, som_iwc, som_dz, som_rad 566 REAL , intent(out) :: pcld, tcld 567 568 INTEGER :: i, ibase, imid 569 570 CHARACTER (len = 50) :: modname = 'simu_airs.caract' 571 CHARACTER (len = 160) :: abort_message 563 572 564 573 ! Somme des epaisseurs optiques et des contenus en glace sur le nuage … … 585 594 586 595 if (som_dz .ne. 0.) then 587 som_rad = som_rad/som_dz596 som_rad = som_rad/som_dz 588 597 else 589 write(*,*) 'som_dez = 0 STOP' 590 write(*,*) 'ibeg, iend =', ibeg, iend 591 do i = ibeg, iend 592 write(*,*) dz_cs(i), rhodz_cs(i) 593 enddo 594 STOP 598 write(*,*) 'som_dez = 0 STOP' 599 write(*,*) 'ibeg, iend =', ibeg, iend 600 do i = ibeg, iend 601 write(*,*) dz_cs(i), rhodz_cs(i) 602 enddo 603 abort_message='see above' 604 CALL abort_physic(modname,abort_message,1) 595 605 endif 596 606 … … 611 621 subroutine topbot(ideb,w,ibeg,iend) 612 622 613 integer, intent(in) :: ideb614 real, dimension(:), intent(in) :: w615 integer, intent(out) :: ibeg, iend616 617 integer:: i, itest623 INTEGER, intent(in) :: ideb 624 REAL, DIMENSION(:), intent(in) :: w 625 INTEGER, intent(out) :: ibeg, iend 626 627 INTEGER :: i, itest 618 628 619 629 itest = 0 … … 642 652 subroutine ordonne(len_cs, rneb_cs, rneb_ord) 643 653 644 integer, intent(in) :: len_cs645 real, dimension(:), intent(in) :: rneb_cs646 real, dimension(:), intent(out) :: rneb_ord647 648 integer:: i, j, ind_min649 650 real, dimension(len_cs) :: rneb651 real:: rneb_max654 INTEGER, intent(in) :: len_cs 655 REAL, DIMENSION(:), intent(in) :: rneb_cs 656 REAL, DIMENSION(:), intent(out) :: rneb_ord 657 658 INTEGER :: i, j, ind_min 659 660 REAL, DIMENSION(len_cs) :: rneb 661 REAL :: rneb_max 652 662 653 663 … … 689 699 USE dimphy 690 700 691 real, dimension(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, &701 REAL, DIMENSION(klev), intent(in) :: rneb_1D, temp_1D, emis_1D, & 692 702 & iwcon_1D, rad_1D 693 real, dimension(klev), intent(in) :: pres, dz, rhodz_1D694 real, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh695 real, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh696 real, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, &703 REAL, DIMENSION(klev), intent(in) :: pres, dz, rhodz_1D 704 REAL, intent(out) :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh 705 REAL, intent(out) :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh 706 REAL, intent(out) :: em_hc_mesh, pcld_hc_mesh, tcld_hc_mesh, & 697 707 & iwp_hc_mesh 698 708 699 real, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh700 real, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, &709 REAL, intent(out) :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh 710 REAL, intent(out) :: pcld_ThCi_mesh, tcld_ThCi_mesh, & 701 711 & em_ThCi_mesh 702 real, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh703 704 real, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh705 real, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh706 707 real, dimension(:), allocatable :: rneb_cs, temp_cs, emis_cs, &712 REAL, intent(out) :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh 713 714 REAL, intent(out) :: em_hist_mesh, iwp_hist_mesh, rad_hist_mesh 715 REAL, intent(out) :: deltaz_hc_mesh, deltaz_hist_mesh 716 717 REAL, DIMENSION(:), allocatable :: rneb_cs, temp_cs, emis_cs, & 708 718 & iwco_cs 709 real, dimension(:), allocatable :: pres_cs, dz_cs, rad_cs, &719 REAL, DIMENSION(:), allocatable :: pres_cs, dz_cs, rad_cs, & 710 720 & rhodz_cs 711 721 712 integer:: i,j,l713 integer:: ltop, itop, ibot, num_cs, N_cs, len_cs, ics714 715 real:: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,&722 INTEGER :: i,j,l 723 INTEGER :: ltop, itop, ibot, num_cs, N_cs, len_cs, ics 724 725 REAL :: som_emi_hc,som_pcl_hc,som_tcl_hc,som_iwp_hc,som_hc,& 716 726 & som_hist 717 real:: som_emi_hist, som_iwp_hist, som_deltaz_hc, &727 REAL :: som_emi_hist, som_iwp_hist, som_deltaz_hc, & 718 728 & som_deltaz_hist 719 real :: som_rad_hist 720 real :: som_Cb, som_ThCi, som_Anv 721 real :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb 722 real :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv 723 real :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi 724 real :: tsom_tot, tsom_hc, tsom_hist 725 real :: prod, prod_hh 726 727 real :: cc_tot_cs, cc_hc_cs, cc_hist_cs 728 real :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs 729 real :: pcld_hc_cs, tcld_hc_cs 730 real :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs 731 real :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs 732 real :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs 733 real :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs 734 real :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs 735 736 real, dimension(klev) :: test_tot, test_hc, test_hist 737 real, dimension(klev) :: test_pcld, test_tcld, test_em, test_iwp 738 729 REAL :: som_rad_hist 730 REAL :: som_Cb, som_ThCi, som_Anv 731 REAL :: som_emi_Cb, som_tcld_Cb, som_pcld_Cb 732 REAL :: som_emi_Anv, som_tcld_Anv, som_pcld_Anv 733 REAL :: som_emi_ThCi, som_tcld_ThCi, som_pcld_ThCi 734 REAL :: tsom_tot, tsom_hc, tsom_hist 735 REAL :: prod, prod_hh 736 737 REAL :: cc_tot_cs, cc_hc_cs, cc_hist_cs 738 REAL :: cc_Cb_cs, cc_ThCi_cs, cc_Anv_cs 739 REAL :: pcld_hc_cs, tcld_hc_cs 740 REAL :: em_hc_cs, iwp_hc_cs, deltaz_hc_cs 741 REAL :: pcld_Cb_cs, tcld_Cb_cs, em_Cb_cs 742 REAL :: pcld_ThCi_cs, tcld_ThCi_cs, em_ThCi_cs 743 REAL :: pcld_Anv_cs, tcld_Anv_cs, em_Anv_cs 744 REAL :: em_hist_cs, iwp_hist_cs, deltaz_hist_cs, rad_hist_cs 745 746 REAL, DIMENSION(klev) :: test_tot, test_hc, test_hist 747 REAL, DIMENSION(klev) :: test_pcld, test_tcld, test_em, test_iwp 748 749 CHARACTER (len = 50) :: modname = 'simu_airs.sim_mesh' 750 CHARACTER (len = 160) :: abort_message 751 739 752 740 753 do j = 1, klev 741 write(*,*) 'simu_airs, j, rneb_1D =', rneb_1D(j)754 WRITE(lunout,*) 'simu_airs, j, rneb_1D =', rneb_1D(j) 742 755 enddo 743 756 … … 991 1004 if (cc_tot_mesh .gt. tsom_tot .and. & 992 1005 & abs(cc_tot_mesh-tsom_tot) .gt. 1.e-4) then 993 write(*,*) 'cc_tot_mesh > tsom_tot' 994 write(*,*) cc_tot_mesh, tsom_tot 995 STOP 1006 WRITE(abort_message,*)'cc_tot_mesh > tsom_tot', cc_tot_mesh, tsom_tot 1007 CALL abort_physic(modname,abort_message,1) 996 1008 endif 997 1009 998 1010 if (cc_tot_mesh .lt. maxval(test_tot(1:N_CS)) .and. & 999 1011 & abs(cc_tot_mesh-maxval(test_tot(1:N_CS))) .gt. 1.e-4) then 1000 write(*,*) 'cc_tot_mesh < max' 1001 write(*,*) cc_tot_mesh, maxval(test_tot(1:N_CS)) 1002 STOP 1012 WRITE(abort_message,*) 'cc_tot_mesh < max', cc_tot_mesh, maxval(test_tot(1:N_CS)) 1013 CALL abort_physic(modname,abort_message,1) 1003 1014 endif 1004 1015 1005 1016 if (cc_hc_mesh .gt. tsom_hc .and. & 1006 1017 & abs(cc_hc_mesh-tsom_hc) .gt. 1.e-4) then 1007 write(*,*) 'cc_hc_mesh > tsom_hc' 1008 write(*,*) cc_hc_mesh, tsom_hc 1009 STOP 1018 WRITE(abort_message,*) 'cc_hc_mesh > tsom_hc', cc_hc_mesh, tsom_hc 1019 CALL abort_physic(modname,abort_message,1) 1010 1020 endif 1011 1021 1012 1022 if (cc_hc_mesh .lt. maxval(test_hc(1:N_CS)) .and. & 1013 1023 & abs(cc_hc_mesh-maxval(test_hc(1:N_CS))) .gt. 1.e-4) then 1014 write(*,*) 'cc_hc_mesh < max' 1015 write(*,*) cc_hc_mesh, maxval(test_hc(1:N_CS)) 1016 STOP 1024 WRITE(abort_message,*) 'cc_hc_mesh < max', cc_hc_mesh, maxval(test_hc(1:N_CS)) 1025 CALL abort_physic(modname,abort_message,1) 1017 1026 endif 1018 1027 1019 1028 if (cc_hist_mesh .gt. tsom_hist .and. & 1020 1029 & abs(cc_hist_mesh-tsom_hist) .gt. 1.e-4) then 1021 write(*,*) 'cc_hist_mesh > tsom_hist' 1022 write(*,*) cc_hist_mesh, tsom_hist 1023 STOP 1030 WRITE(abort_message,*) 'cc_hist_mesh > tsom_hist', cc_hist_mesh, tsom_hist 1031 CALL abort_physic(modname,abort_message,1) 1024 1032 endif 1025 1033 1026 1034 if (cc_hist_mesh .lt. 0.) then 1027 write(*,*) 'cc_hist_mesh < 0' 1028 write(*,*) cc_hist_mesh 1029 STOP 1035 WRITE(abort_message,*) 'cc_hist_mesh < 0', cc_hist_mesh 1036 CALL abort_physic(modname,abort_message,1) 1030 1037 endif 1031 1038 … … 1035 1042 & maxval(test_pcld(1:N_CS)) .ne. 999. & 1036 1043 & .and. minval(test_pcld(1:N_CS)) .ne. 999.) then 1037 write(*,*) 'pcld_hc_mesh est faux' 1038 write(*,*) pcld_hc_mesh, maxval(test_pcld(1:N_CS)), & 1044 WRITE(abort_message,*) 'pcld_hc_mesh est faux', pcld_hc_mesh, maxval(test_pcld(1:N_CS)), & 1039 1045 & minval(test_pcld(1:N_CS)) 1040 STOP1046 CALL abort_physic(modname,abort_message,1) 1041 1047 endif 1042 1048 … … 1046 1052 & maxval(test_tcld(1:N_CS)) .ne. 999. & 1047 1053 & .and. minval(test_tcld(1:N_CS)) .ne. 999.) then 1048 write(*,*) 'tcld_hc_mesh est faux'1049 write(*,*) tcld_hc_mesh, maxval(test_tcld(1:N_CS)), &1050 & minval(test_tcld(1:N_CS))1054 WRITE(abort_message,*) 'tcld_hc_mesh est faux', tcld_hc_mesh, maxval(test_tcld(1:N_CS)), & 1055 & minval(test_tcld(1:N_CS)) 1056 CALL abort_physic(modname,abort_message,1) 1051 1057 endif 1052 1058 … … 1056 1062 & minval(test_em(1:N_CS)) .ne. 999. .and. & 1057 1063 & maxval(test_em(1:N_CS)) .ne. 999. ) then 1058 write(*,*) 'em_hc_mesh est faux' 1059 write(*,*) em_hc_mesh, maxval(test_em(1:N_CS)), & 1064 WRITE(abort_message,*) 'em_hc_mesh est faux', em_hc_mesh, maxval(test_em(1:N_CS)), & 1060 1065 & minval(test_em(1:N_CS)) 1061 STOP1066 CALL abort_physic(modname,abort_message,1) 1062 1067 endif 1063 1068 … … 1101 1106 subroutine test_bornes(sx,x,bsup,binf) 1102 1107 1103 real, intent(in) :: x, bsup, binf1108 REAL, intent(in) :: x, bsup, binf 1104 1109 character*14, intent(in) :: sx 1110 CHARACTER (len = 50) :: modname = 'simu_airs.test_bornes' 1111 CHARACTER (len = 160) :: abort_message 1105 1112 1106 1113 if (x .gt. bsup .or. x .lt. binf) then 1107 write(*,*) sx, 'est faux' 1108 write(*,*) sx, x 1109 STOP 1114 WRITE(abort_message,*) sx, 'est faux', sx, x 1115 CALL abort_physic(modname,abort_message,1) 1110 1116 endif 1111 1117 … … 1134 1140 include "YOMCST.h" 1135 1141 1136 integer,intent(in) :: itap1137 1138 real, dimension(klon,klev), intent(in) :: &1142 INTEGER,intent(in) :: itap 1143 1144 REAL, DIMENSION(klon,klev), intent(in) :: & 1139 1145 & rneb_airs, temp_airs, cldemi_airs, iwcon0_airs, & 1140 1146 & rad_airs, geop_airs, pplay_airs, paprs_airs 1141 1147 1142 real, dimension(klon,klev) :: &1148 REAL, DIMENSION(klon,klev) :: & 1143 1149 & rhodz_airs, rho_airs, iwcon_airs 1144 1150 1145 real, dimension(klon),intent(out) :: alt_tropo1146 1147 real, dimension(klev) :: rneb_1D, temp_1D, &1151 REAL, DIMENSION(klon),intent(out) :: alt_tropo 1152 1153 REAL, DIMENSION(klev) :: rneb_1D, temp_1D, & 1148 1154 & emis_1D, rad_1D, pres_1D, alt_1D, & 1149 1155 & rhodz_1D, dz_1D, iwcon_1D 1150 1156 1151 integer:: i, j1152 1153 real:: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh1154 real:: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh1155 real:: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh1156 real:: em_hist_mesh, iwp_hist_mesh1157 real:: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh1158 real:: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh1159 real:: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh1160 real:: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh1161 1162 real, dimension(klon),intent(out) :: map_prop_hc, map_prop_hist1163 real, dimension(klon),intent(out) :: map_emis_hc, map_iwp_hc1164 real, dimension(klon),intent(out) :: map_deltaz_hc, map_pcld_hc1165 real, dimension(klon),intent(out) :: map_tcld_hc1166 real, dimension(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb1167 real, dimension(klon),intent(out) :: &1157 INTEGER :: i, j 1158 1159 REAL :: cc_tot_mesh, cc_hc_mesh, cc_hist_mesh 1160 REAL :: cc_Cb_mesh, cc_ThCi_mesh, cc_Anv_mesh 1161 REAL :: pcld_hc_mesh, tcld_hc_mesh, em_hc_mesh, iwp_hc_mesh 1162 REAL :: em_hist_mesh, iwp_hist_mesh 1163 REAL :: deltaz_hc_mesh, deltaz_hist_mesh, rad_hist_mesh 1164 REAL :: pcld_Cb_mesh, tcld_Cb_mesh, em_Cb_mesh 1165 REAL :: pcld_ThCi_mesh, tcld_ThCi_mesh, em_ThCi_mesh 1166 REAL :: pcld_Anv_mesh, tcld_Anv_mesh, em_Anv_mesh 1167 1168 REAL, DIMENSION(klon),intent(out) :: map_prop_hc, map_prop_hist 1169 REAL, DIMENSION(klon),intent(out) :: map_emis_hc, map_iwp_hc 1170 REAL, DIMENSION(klon),intent(out) :: map_deltaz_hc, map_pcld_hc 1171 REAL, DIMENSION(klon),intent(out) :: map_tcld_hc 1172 REAL, DIMENSION(klon),intent(out) :: map_emis_Cb,map_pcld_Cb,map_tcld_Cb 1173 REAL, DIMENSION(klon),intent(out) :: & 1168 1174 & map_emis_ThCi,map_pcld_ThCi,map_tcld_ThCi 1169 real, dimension(klon),intent(out) :: &1175 REAL, DIMENSION(klon),intent(out) :: & 1170 1176 & map_emis_Anv,map_pcld_Anv,map_tcld_Anv 1171 real, dimension(klon),intent(out) :: &1177 REAL, DIMENSION(klon),intent(out) :: & 1172 1178 & map_emis_hist,map_iwp_hist,map_deltaz_hist,& 1173 1179 & map_rad_hist 1174 real, dimension(klon),intent(out) :: map_ntot,map_hc,map_hist1175 real, dimension(klon),intent(out) :: map_Cb,map_ThCi,map_Anv1180 REAL, DIMENSION(klon),intent(out) :: map_ntot,map_hc,map_hist 1181 REAL, DIMENSION(klon),intent(out) :: map_Cb,map_ThCi,map_Anv 1176 1182 1177 1183 -
LMDZ6/branches/Ocean_skin/libf/phylmd/sisvat/surf_sisvat_mod.F90
r2345 r3605 1540 1540 INTEGER isl, ikl, i, isn 1541 1541 CHARACTER (len=2) :: str2 1542 INTEGER :: pass 1542 1543 1543 1544 isno(:) = 0 … … 1617 1618 1618 1619 CALL open_restartphy(fichnom) 1619 CALL put_field("longitude", & 1620 DO pass = 1, 2 1621 CALL put_field(pass,"longitude", & 1620 1622 "Longitudes de la grille physique",rlon) 1621 CALL put_field("latitude","Latitudes de la grille physique",rlat)1622 1623 CALL put_field("n_snows", "number of snow/ice layers",isno)1624 CALL put_field("n_ice_top", "number of top ice layers",ispi)1625 CALL put_field("n_ice", "number of ice layers",iice)1626 CALL put_field("IR_soil", "Soil IR flux",IRs)1627 CALL put_field("LMO", "Monin-Obukhov Scale",LMO)1628 CALL put_field("surf_water", "Surficial water",rusn)1629 CALL put_field("snow_buffer", "Snow buffer layer",Bufs)1630 CALL put_field("alb_1", "albedo sw",alb1)1631 CALL put_field("alb_2", "albedo nIR",alb2)1632 CALL put_field("alb_3", "albedo fIR",alb3)1633 CALL put_field("to_ice", "Snow passed to ice",toic)1623 CALL put_field(pass,"latitude","Latitudes de la grille physique",rlat) 1624 1625 CALL put_field(pass,"n_snows", "number of snow/ice layers",isno) 1626 CALL put_field(pass,"n_ice_top", "number of top ice layers",ispi) 1627 CALL put_field(pass,"n_ice", "number of ice layers",iice) 1628 CALL put_field(pass,"IR_soil", "Soil IR flux",IRs) 1629 CALL put_field(pass,"LMO", "Monin-Obukhov Scale",LMO) 1630 CALL put_field(pass,"surf_water", "Surficial water",rusn) 1631 CALL put_field(pass,"snow_buffer", "Snow buffer layer",Bufs) 1632 CALL put_field(pass,"alb_1", "albedo sw",alb1) 1633 CALL put_field(pass,"alb_2", "albedo nIR",alb2) 1634 CALL put_field(pass,"alb_3", "albedo fIR",alb3) 1635 CALL put_field(pass,"to_ice", "Snow passed to ice",toic) 1634 1636 1635 1637 ! DO i = 1, 5 1636 1638 ! WRITE(str2,'(i2.2)') i 1637 ! CALL put_field( "turb_veloc"//str2, &1639 ! CALL put_field(pass,"turb_veloc"//str2, & 1638 1640 ! "various turbulent velocities"//str2, & 1639 1641 ! turb_vel(:,i)) … … 1641 1643 ! DO i = 1, 9 1642 1644 ! WRITE(str2,'(i2.2)') i 1643 ! CALL put_field( "rough_length"//str2, &1645 ! CALL put_field(pass,"rough_length"//str2, & 1644 1646 ! "various roughness lengths"//str2, & 1645 1647 ! rlength(:,i)) 1646 1648 ! ENDDO 1647 DO isn = 1,nsno1648 IF (isn.LE.99) THEN1649 WRITE(str2,'(i2.2)') isn1650 CALL put_field("AGESNOW"//str2, &1649 DO isn = 1,nsno 1650 IF (isn.LE.99) THEN 1651 WRITE(str2,'(i2.2)') isn 1652 CALL put_field(pass,"AGESNOW"//str2, & 1651 1653 "Age de la neige layer No."//str2, & 1652 1654 agsn(:,isn)) 1653 ELSE1654 PRINT*, "Trop de couches"1655 CALL abort1656 ENDIF1657 ENDDO1658 DO isn = 1,nsno1659 IF (isn.LE.99) THEN1660 WRITE(str2,'(i2.2)') isn1661 CALL put_field("DZSNOW"//str2, &1655 ELSE 1656 PRINT*, "Trop de couches" 1657 CALL abort 1658 ENDIF 1659 ENDDO 1660 DO isn = 1,nsno 1661 IF (isn.LE.99) THEN 1662 WRITE(str2,'(i2.2)') isn 1663 CALL put_field(pass,"DZSNOW"//str2, & 1662 1664 "Snow/ice thickness layer No."//str2, & 1663 1665 dzsn(:,isn)) 1664 ELSE1665 PRINT*, "Trop de couches"1666 CALL abort1667 ENDIF1668 ENDDO1669 DO isn = 1,nsno1670 IF (isn.LE.99) THEN1671 WRITE(str2,'(i2.2)') isn1672 CALL put_field("G2SNOW"//str2, &1666 ELSE 1667 PRINT*, "Trop de couches" 1668 CALL abort 1669 ENDIF 1670 ENDDO 1671 DO isn = 1,nsno 1672 IF (isn.LE.99) THEN 1673 WRITE(str2,'(i2.2)') isn 1674 CALL put_field(pass,"G2SNOW"//str2, & 1673 1675 "Snow Property 2, layer No."//str2, & 1674 1676 G2sn(:,isn)) 1675 ELSE1676 PRINT*, "Trop de couches"1677 CALL abort1678 ENDIF1679 ENDDO1680 DO isn = 1,nsno1681 IF (isn.LE.99) THEN1682 WRITE(str2,'(i2.2)') isn1683 CALL put_field("G1SNOW"//str2, &1677 ELSE 1678 PRINT*, "Trop de couches" 1679 CALL abort 1680 ENDIF 1681 ENDDO 1682 DO isn = 1,nsno 1683 IF (isn.LE.99) THEN 1684 WRITE(str2,'(i2.2)') isn 1685 CALL put_field(pass,"G1SNOW"//str2, & 1684 1686 "Snow Property 1, layer No."//str2, & 1685 1687 G1sn(:,isn)) 1686 ELSE1687 PRINT*, "Trop de couches"1688 CALL abort1689 ENDIF1690 ENDDO1691 DO isn = 1,nsismx1692 IF (isn.LE.99) THEN1693 WRITE(str2,'(i2.2)') isn1694 CALL put_field("ETA"//str2, &1688 ELSE 1689 PRINT*, "Trop de couches" 1690 CALL abort 1691 ENDIF 1692 ENDDO 1693 DO isn = 1,nsismx 1694 IF (isn.LE.99) THEN 1695 WRITE(str2,'(i2.2)') isn 1696 CALL put_field(pass,"ETA"//str2, & 1695 1697 "Soil/snow water content layer No."//str2, & 1696 1698 eta(:,isn)) 1697 ELSE 1698 PRINT*, "Trop de couches" 1699 CALL abort 1700 ENDIF 1699 ELSE 1700 PRINT*, "Trop de couches" 1701 CALL abort 1702 ENDIF 1703 ENDDO 1704 DO isn = 1,nsismx !nsno 1705 IF (isn.LE.99) THEN 1706 WRITE(str2,'(i2.2)') isn 1707 CALL put_field(pass,"RO"//str2, & 1708 "Snow density layer No."//str2, & 1709 ro(:,isn)) 1710 ELSE 1711 PRINT*, "Trop de couches" 1712 CALL abort 1713 ENDIF 1714 ENDDO 1715 DO isn = 1,nsismx 1716 IF (isn.LE.99) THEN 1717 WRITE(str2,'(i2.2)') isn 1718 CALL put_field(pass,"TSS"//str2, & 1719 "Soil/snow temperature layer No."//str2, & 1720 Tsis(:,isn)) 1721 ELSE 1722 PRINT*, "Trop de couches" 1723 CALL abort 1724 ENDIF 1725 ENDDO 1726 DO isn = 1,nsno 1727 IF (isn.LE.99) THEN 1728 WRITE(str2,'(i2.2)') isn 1729 CALL put_field(pass,"HISTORY"//str2, & 1730 "Snow history layer No."//str2, & 1731 isto(:,isn)) 1732 ELSE 1733 PRINT*, "Trop de couches" 1734 CALL abort 1735 ENDIF 1736 ENDDO 1701 1737 ENDDO 1702 DO isn = 1,nsismx !nsno1703 IF (isn.LE.99) THEN1704 WRITE(str2,'(i2.2)') isn1705 CALL put_field("RO"//str2, &1706 "Snow density layer No."//str2, &1707 ro(:,isn))1708 ELSE1709 PRINT*, "Trop de couches"1710 CALL abort1711 ENDIF1712 ENDDO1713 DO isn = 1,nsismx1714 IF (isn.LE.99) THEN1715 WRITE(str2,'(i2.2)') isn1716 CALL put_field("TSS"//str2, &1717 "Soil/snow temperature layer No."//str2, &1718 Tsis(:,isn))1719 ELSE1720 PRINT*, "Trop de couches"1721 CALL abort1722 ENDIF1723 ENDDO1724 DO isn = 1,nsno1725 IF (isn.LE.99) THEN1726 WRITE(str2,'(i2.2)') isn1727 CALL put_field("HISTORY"//str2, &1728 "Snow history layer No."//str2, &1729 isto(:,isn))1730 ELSE1731 PRINT*, "Trop de couches"1732 CALL abort1733 ENDIF1734 ENDDO1735 1738 1736 1739 END SUBROUTINE sisvatredem -
LMDZ6/branches/Ocean_skin/libf/phylmd/slab_heat_transp_mod.F90
r3002 r3605 83 83 cu_,cuvsurcv_,cv_,cvusurcu_, & 84 84 aire_,apoln_,apols_, & 85 aireu_,airev_,rlatv) 86 USE comconst_mod, ONLY: omeg, rad 85 aireu_,airev_,rlatv, rad, omeg) 87 86 ! number of points in lon, lat 88 87 IMPLICIT NONE … … 104 103 REAL,INTENT(IN) :: airev_(ip1jm) 105 104 REAL,INTENT(IN) :: rlatv(nbp_lat-1) 106 105 REAL,INTENT(IN) :: rad 106 REAL,INTENT(IN) :: omeg 107 108 CHARACTER (len = 20) :: modname = 'slab_heat_transp' 109 CHARACTER (len = 80) :: abort_message 110 107 111 ! Sanity check on dimensions 108 112 if ((ip1jm.ne.((nbp_lon+1)*(nbp_lat-1))).or. & 109 113 (ip1jmp1.ne.((nbp_lon+1)*nbp_lat))) then 110 write(*,*)"ini_slab_transp_geom Error: wrong array sizes"111 stop114 abort_message="ini_slab_transp_geom Error: wrong array sizes" 115 CALL abort_physic(modname,abort_message,1) 112 116 endif 113 117 ! Allocations could be done only on master process/thread... … … 924 928 INTEGER j,ifield,ig 925 929 930 CHARACTER (len = 20) :: modname = 'slab_heat_transp' 931 CHARACTER (len = 80) :: abort_message 932 926 933 ! Sanity check: 927 934 IF(klon_glo.NE.2+(jm-2)*(im-1)) THEN 928 WRITE(*,*)"gr_dyn_fi error, wrong sizes"929 STOP935 abort_message="gr_dyn_fi error, wrong sizes" 936 CALL abort_physic(modname,abort_message,1) 930 937 ENDIF 931 938 -
LMDZ6/branches/Ocean_skin/libf/phylmd/suphel.F90
r3429 r3605 118 118 rmo3 = 47.9942 119 119 rmco2 = 44.011 120 rmch4 = 16.043 121 rmn2o = 44.013 122 rmcfc11 = 137.3686 123 rmcfc12 = 120.9140 120 124 rmc = 12.0107 121 125 rmv = 18.0153 … … 134 138 WRITE (UNIT=6, FMT='('' Ozone mass = '',e13.7)') rmo3 135 139 WRITE (UNIT=6, FMT='('' CO2 mass = '',e13.7)') rmco2 136 WRITE (UNIT=6, FMT='('' CO2 mass = '',e13.7)') rmc 140 WRITE (UNIT=6, FMT='('' C mass = '',e13.7)') rmc 141 WRITE (UNIT=6, FMT='('' CH4 mass = '',e13.7)') rmch4 142 WRITE (UNIT=6, FMT='('' N2O mass = '',e13.7)') rmn2o 143 WRITE (UNIT=6, FMT='('' CFC11 mass = '',e13.7)') rmcfc11 144 WRITE (UNIT=6, FMT='('' CFC12 mass = '',e13.7)') rmcfc12 137 145 WRITE (UNIT=6, FMT='('' Vapour mass = '',e13.7)') rmv 138 146 WRITE (UNIT=6, FMT='('' Dry air cst. = '',e13.7)') rd -
LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_mod.F90
r3391 r3605 41 41 USE surf_land_orchidee_nofrein_mod 42 42 #else 43 #if ORCHIDEE_NOUNSTRUCT 44 ! Compilation with cpp key ORCHIDEE_NOUNSTRUCT 45 USE surf_land_orchidee_nounstruct_mod 46 #else 43 47 USE surf_land_orchidee_mod 48 #endif 44 49 #endif 45 50 #endif -
LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_orchidee_mod.F90
r3391 r3605 4 4 #ifndef ORCHIDEE_NOZ0H 5 5 #ifndef ORCHIDEE_NOFREIN 6 #ifndef ORCHIDEE_NOUNSTRUCT 6 7 ! 7 8 ! This module controles the interface towards the model ORCHIDEE. … … 23 24 USE cpl_mod, ONLY : cpl_send_land_fields 24 25 USE surface_data, ONLY : type_ocean 25 USE geometry_mod, ONLY : dx, dy 26 USE geometry_mod, ONLY : dx, dy, boundslon, boundslat,longitude, latitude, cell_area, ind_cell_glo 26 27 USE mod_grid_phy_lmdz 27 28 USE mod_phys_lmdz_para, mpi_root_rank=>mpi_master 28 29 USE carbon_cycle_mod, ONLY : nbcf_in_orc, nbcf_out, fields_in, yfields_in, yfields_out, cfname_in, cfname_out 29 30 USE nrtype, ONLY : PI 31 30 32 IMPLICIT NONE 31 33 … … 165 167 REAL, ALLOCATABLE, DIMENSION(:,:), SAVE :: lalo 166 168 !$OMP THREADPRIVATE(lalo) 169 ! boundaries of cells 170 REAL, ALLOCATABLE, DIMENSION(:,:,:), SAVE :: bounds_lalo 171 !$OMP THREADPRIVATE(bounds_lalo) 167 172 ! pts voisins 168 173 INTEGER,ALLOCATABLE, DIMENSION(:,:), SAVE :: neighbours … … 178 183 !$OMP THREADPRIVATE(lon_scat,lat_scat) 179 184 185 ! area of cells 186 REAL, ALLOCATABLE, DIMENSION (:), SAVE :: area 187 !$OMP THREADPRIVATE(area) 188 180 189 LOGICAL, SAVE :: lrestart_read = .TRUE. 181 190 !$OMP THREADPRIVATE(lrestart_read) … … 209 218 !$OMP THREADPRIVATE(riverflow) 210 219 220 INTEGER :: orch_mpi_rank 221 INTEGER :: orch_mpi_size 211 222 INTEGER :: orch_omp_rank 212 223 INTEGER :: orch_omp_size 224 225 REAL, ALLOCATABLE, DIMENSION(:) :: longitude_glo 226 REAL, ALLOCATABLE, DIMENSION(:) :: latitude_glo 227 REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslon_glo 228 REAL, ALLOCATABLE, DIMENSION(:,:) :: boundslat_glo 229 INTEGER, ALLOCATABLE, DIMENSION(:) :: ind_cell_glo_glo 230 INTEGER, ALLOCATABLE, SAVE,DIMENSION(:) :: ind_cell 231 !$OMP THREADPRIVATE(ind_cell) 232 INTEGER :: begin, end 213 233 ! 214 234 ! Fin definition … … 253 273 jg(klon) = nbp_lat 254 274 255 IF ((.NOT. ALLOCATED( lalo))) THEN256 ALLOCATE( lalo(knon,2), stat = error)275 IF ((.NOT. ALLOCATED(area))) THEN 276 ALLOCATE(area(knon), stat = error) 257 277 IF (error /= 0) THEN 278 abort_message='Pb allocation area' 279 CALL abort_physic(modname,abort_message,1) 280 ENDIF 281 ENDIF 282 DO igrid = 1, knon 283 area(igrid) = cell_area(knindex(igrid)) 284 ENDDO 285 286 IF (grid_type==unstructured) THEN 287 288 289 IF ((.NOT. ALLOCATED(lon_scat))) THEN 290 ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error) 291 IF (error /= 0) THEN 292 abort_message='Pb allocation lon_scat' 293 CALL abort_physic(modname,abort_message,1) 294 ENDIF 295 ENDIF 296 297 IF ((.NOT. ALLOCATED(lat_scat))) THEN 298 ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error) 299 IF (error /= 0) THEN 300 abort_message='Pb allocation lat_scat' 301 CALL abort_physic(modname,abort_message,1) 302 ENDIF 303 ENDIF 304 CALL Gather(rlon,rlon_g) 305 CALL Gather(rlat,rlat_g) 306 307 IF (is_mpi_root) THEN 308 index = 1 309 DO jj = 2, nbp_lat-1 310 DO ij = 1, nbp_lon 311 index = index + 1 312 lon_scat(ij,jj) = rlon_g(index) 313 lat_scat(ij,jj) = rlat_g(index) 314 ENDDO 315 ENDDO 316 lon_scat(:,1) = lon_scat(:,2) 317 lat_scat(:,1) = rlat_g(1) 318 lon_scat(:,nbp_lat) = lon_scat(:,2) 319 lat_scat(:,nbp_lat) = rlat_g(klon_glo) 320 ENDIF 321 322 CALL bcast(lon_scat) 323 CALL bcast(lat_scat) 324 325 ELSE IF (grid_type==regular_lonlat) THEN 326 327 IF ((.NOT. ALLOCATED(lalo))) THEN 328 ALLOCATE(lalo(knon,2), stat = error) 329 IF (error /= 0) THEN 330 abort_message='Pb allocation lalo' 331 CALL abort_physic(modname,abort_message,1) 332 ENDIF 333 ENDIF 334 335 IF ((.NOT. ALLOCATED(bounds_lalo))) THEN 336 ALLOCATE(bounds_lalo(knon,nvertex,2), stat = error) 337 IF (error /= 0) THEN 258 338 abort_message='Pb allocation lalo' 259 339 CALL abort_physic(modname,abort_message,1) 260 ENDIF 261 ENDIF 262 IF ((.NOT. ALLOCATED(lon_scat))) THEN 263 ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error) 264 IF (error /= 0) THEN 265 abort_message='Pb allocation lon_scat' 266 CALL abort_physic(modname,abort_message,1) 267 ENDIF 268 ENDIF 269 IF ((.NOT. ALLOCATED(lat_scat))) THEN 270 ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error) 271 IF (error /= 0) THEN 272 abort_message='Pb allocation lat_scat' 273 CALL abort_physic(modname,abort_message,1) 274 ENDIF 275 ENDIF 276 lon_scat = 0. 277 lat_scat = 0. 278 DO igrid = 1, knon 279 index = knindex(igrid) 280 lalo(igrid,2) = rlon(index) 281 lalo(igrid,1) = rlat(index) 282 ENDDO 283 284 285 286 CALL Gather(rlon,rlon_g) 287 CALL Gather(rlat,rlat_g) 288 289 IF (is_mpi_root) THEN 290 index = 1 291 DO jj = 2, nbp_lat-1 292 DO ij = 1, nbp_lon 293 index = index + 1 294 lon_scat(ij,jj) = rlon_g(index) 295 lat_scat(ij,jj) = rlat_g(index) 296 ENDDO 297 ENDDO 298 lon_scat(:,1) = lon_scat(:,2) 299 lat_scat(:,1) = rlat_g(1) 300 lon_scat(:,nbp_lat) = lon_scat(:,2) 301 lat_scat(:,nbp_lat) = rlat_g(klon_glo) 302 ENDIF 340 ENDIF 341 ENDIF 342 343 IF ((.NOT. ALLOCATED(lon_scat))) THEN 344 ALLOCATE(lon_scat(nbp_lon,nbp_lat), stat = error) 345 IF (error /= 0) THEN 346 abort_message='Pb allocation lon_scat' 347 CALL abort_physic(modname,abort_message,1) 348 ENDIF 349 ENDIF 350 IF ((.NOT. ALLOCATED(lat_scat))) THEN 351 ALLOCATE(lat_scat(nbp_lon,nbp_lat), stat = error) 352 IF (error /= 0) THEN 353 abort_message='Pb allocation lat_scat' 354 CALL abort_physic(modname,abort_message,1) 355 ENDIF 356 ENDIF 357 lon_scat = 0. 358 lat_scat = 0. 359 DO igrid = 1, knon 360 index = knindex(igrid) 361 lalo(igrid,2) = rlon(index) 362 lalo(igrid,1) = rlat(index) 363 bounds_lalo(igrid,:,2)=boundslon(index,:)*180./PI 364 bounds_lalo(igrid,:,1)=boundslat(index,:)*180./PI 365 ENDDO 366 367 368 369 CALL Gather(rlon,rlon_g) 370 CALL Gather(rlat,rlat_g) 371 372 IF (is_mpi_root) THEN 373 index = 1 374 DO jj = 2, nbp_lat-1 375 DO ij = 1, nbp_lon 376 index = index + 1 377 lon_scat(ij,jj) = rlon_g(index) 378 lat_scat(ij,jj) = rlat_g(index) 379 ENDDO 380 ENDDO 381 lon_scat(:,1) = lon_scat(:,2) 382 lat_scat(:,1) = rlat_g(1) 383 lon_scat(:,nbp_lat) = lon_scat(:,2) 384 lat_scat(:,nbp_lat) = rlat_g(klon_glo) 385 ENDIF 303 386 304 CALL bcast(lon_scat) 305 CALL bcast(lat_scat) 387 CALL bcast(lon_scat) 388 CALL bcast(lat_scat) 389 390 ENDIF 306 391 ! 307 392 ! Allouer et initialiser le tableau des voisins et des fraction de continents 308 393 ! 309 IF ( (.NOT.ALLOCATED(neighbours))) THEN310 ALLOCATE(neighbours(knon,8), stat = error)311 IF (error /= 0) THEN312 abort_message='Pb allocation neighbours'313 CALL abort_physic(modname,abort_message,1)314 ENDIF315 ENDIF316 neighbours = -1.317 394 IF (( .NOT. ALLOCATED(contfrac))) THEN 318 395 ALLOCATE(contfrac(knon), stat = error) … … 329 406 330 407 331 CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) 408 IF (grid_type==regular_lonlat) THEN 409 410 IF ( (.NOT.ALLOCATED(neighbours))) THEN 411 ALLOCATE(neighbours(knon,8), stat = error) 412 IF (error /= 0) THEN 413 abort_message='Pb allocation neighbours' 414 CALL abort_physic(modname,abort_message,1) 415 ENDIF 416 ENDIF 417 neighbours = -1. 418 CALL Init_neighbours(knon,neighbours,knindex,pctsrf(:,is_ter)) 419 420 ELSE IF (grid_type==unstructured) THEN 421 422 IF ( (.NOT.ALLOCATED(neighbours))) THEN 423 ALLOCATE(neighbours(knon,12), stat = error) 424 IF (error /= 0) THEN 425 abort_message='Pb allocation neighbours' 426 CALL abort_physic(modname,abort_message,1) 427 ENDIF 428 ENDIF 429 neighbours = -1. 430 431 ENDIF 432 332 433 333 434 ! … … 340 441 ENDIF 341 442 ENDIF 342 DO igrid = 1, knon 343 ij = knindex(igrid) 344 resolution(igrid,1) = dx(ij) 345 resolution(igrid,2) = dy(ij) 346 ENDDO 347 443 444 IF (grid_type==regular_lonlat) THEN 445 DO igrid = 1, knon 446 ij = knindex(igrid) 447 resolution(igrid,1) = dx(ij) 448 resolution(igrid,2) = dy(ij) 449 ENDDO 450 ENDIF 451 348 452 ALLOCATE(coastalflow(klon), stat = error) 349 453 IF (error /= 0) THEN … … 397 501 IF (debut) THEN 398 502 CALL Init_orchidee_index(knon,knindex,offset,ktindex) 399 CALL Get_orchidee_communicator(orch_comm,orch_omp_size,orch_omp_rank) 503 CALL Get_orchidee_communicator(orch_comm,orch_mpi_size,orch_mpi_rank, orch_omp_size,orch_omp_rank) 504 505 IF (grid_type==unstructured) THEN 506 IF (knon==0) THEN 507 begin=1 508 end=0 509 ELSE 510 begin=offset+1 511 end=offset+ktindex(knon) 512 ENDIF 513 514 IF (orch_mpi_rank==orch_mpi_size-1 .AND. orch_omp_rank==orch_omp_size-1) end=nbp_lon*nbp_lat 515 516 ALLOCATE(lalo(end-begin+1,2)) 517 ALLOCATE(bounds_lalo(end-begin+1,nvertex,2)) 518 ALLOCATE(ind_cell(end-begin+1)) 519 520 ALLOCATE(longitude_glo(klon_glo)) 521 CALL gather(longitude,longitude_glo) 522 CALL bcast(longitude_glo) 523 lalo(:,2)=longitude_glo(begin:end)*180./PI 524 525 ALLOCATE(latitude_glo(klon_glo)) 526 CALL gather(latitude,latitude_glo) 527 CALL bcast(latitude_glo) 528 lalo(:,1)=latitude_glo(begin:end)*180./PI 529 530 ALLOCATE(boundslon_glo(klon_glo,nvertex)) 531 CALL gather(boundslon,boundslon_glo) 532 CALL bcast(boundslon_glo) 533 bounds_lalo(:,:,2)=boundslon_glo(begin:end,:)*180./PI 534 535 ALLOCATE(boundslat_glo(klon_glo,nvertex)) 536 CALL gather(boundslat,boundslat_glo) 537 CALL bcast(boundslat_glo) 538 bounds_lalo(:,:,1)=boundslat_glo(begin:end,:)*180./PI 539 540 ALLOCATE(ind_cell_glo_glo(klon_glo)) 541 CALL gather(ind_cell_glo,ind_cell_glo_glo) 542 CALL bcast(ind_cell_glo_glo) 543 ind_cell(:)=ind_cell_glo_glo(begin:end) 544 545 ENDIF 400 546 CALL Init_synchro_omp 547 548 !$OMP BARRIER 401 549 402 550 IF (knon > 0) THEN 403 551 #ifdef CPP_VEGET 404 CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm )552 CALL Init_intersurf(nbp_lon,nbp_lat,knon,ktindex,offset,orch_omp_size,orch_omp_rank,orch_comm,grid=grid_type) 405 553 #endif 406 554 ENDIF 407 555 408 409 IF (knon > 0) THEN 410 411 print *,'OB before intersurf=', SIZE(cfname_in), SIZE(cfname_out) 556 CALL Synchro_omp 557 558 559 IF (knon > 0) THEN 560 412 561 #ifdef CPP_VEGET 562 413 563 CALL intersurf_initialize_gathered (itime+itau_phy-1, nbp_lon, nbp_lat, knon, ktindex, dtime, & 414 564 lrestart_read, lrestart_write, lalo, contfrac, neighbours, resolution, date0, & … … 418 568 evap, fluxsens, fluxlat, coastalflow, riverflow, & 419 569 tsol_rad, tsurf_new, qsurf, albedo_out, emis_new, z0m_new, & 420 ! >> PC 421 !lon_scat, lat_scat, q2m, t2m, z0h_new, nvm_orch) 422 lon_scat, lat_scat, q2m, t2m, z0h_new, nvm_orch, & 570 lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon), nvm_orch, & 571 grid=grid_type, bounds_latlon=bounds_lalo, cell_area=area, ind_cell_glo=ind_cell, & 423 572 field_out_names=cfname_out, field_in_names=cfname_in(1:nbcf_in_orc)) 424 ! << PC425 573 #endif 426 574 ENDIF … … 434 582 ! swdown_vrai(1:knon) = swnet(1:knon)/(1. - albedo_keep(1:knon)) 435 583 swdown_vrai(1:knon) = swdown(1:knon) 584 !$OMP BARRIER 436 585 437 586 IF (knon > 0) THEN … … 450 599 evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & 451 600 tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0m_new(1:knon), & 452 lon_scat, lat_scat, q2m , t2m, z0h_new(1:knon),&601 lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), z0h_new(1:knon),& 453 602 veget(1:knon,:),lai(1:knon,:),height(1:knon,:),& 454 603 fields_out=yfields_out(1:knon,1:nbcf_out), & … … 542 691 ! 543 692 544 SUBROUTINE Get_orchidee_communicator(orch_comm, orch_omp_size,orch_omp_rank)693 SUBROUTINE Get_orchidee_communicator(orch_comm, orch_mpi_size, orch_mpi_rank, orch_omp_size,orch_omp_rank) 545 694 USE mod_surf_para 546 695 … … 550 699 551 700 INTEGER,INTENT(OUT) :: orch_comm 701 INTEGER,INTENT(OUT) :: orch_mpi_size 702 INTEGER,INTENT(OUT) :: orch_mpi_rank 552 703 INTEGER,INTENT(OUT) :: orch_omp_size 553 704 INTEGER,INTENT(OUT) :: orch_omp_rank … … 568 719 #ifdef CPP_MPI 569 720 CALL MPI_COMM_SPLIT(COMM_LMDZ_PHY,color,mpi_rank,orch_comm,ierr) 721 CALL MPI_COMM_SIZE(orch_comm,orch_mpi_size,ierr) 722 CALL MPI_COMM_RANK(orch_comm,orch_mpi_rank,ierr) 570 723 #endif 571 724 … … 696 849 #endif 697 850 #endif 851 #endif 698 852 END MODULE surf_land_orchidee_mod -
LMDZ6/branches/Ocean_skin/libf/phylmd/surf_land_orchidee_noz0h_mod.F90
r3102 r3605 440 440 IF (knon > 0) THEN 441 441 #ifdef CPP_VEGET 442 442 443 CALL intersurf_main (itime+itau_phy, nbp_lon, nbp_lat, knon, ktindex, dtime, & 443 444 lrestart_read, lrestart_write, lalo, & … … 448 449 evap(1:knon), fluxsens(1:knon), fluxlat(1:knon), coastalflow(1:knon), riverflow(1:knon), & 449 450 tsol_rad(1:knon), tsurf_new(1:knon), qsurf(1:knon), albedo_out(1:knon,:), emis_new(1:knon), z0_new(1:knon), & 450 lon_scat, lat_scat, q2m , t2m, coszang=yrmu0(1:knon))451 lon_scat, lat_scat, q2m(1:knon), t2m(1:knon), coszang=yrmu0(1:knon)) 451 452 #endif 452 453 ENDIF -
LMDZ6/branches/Ocean_skin/libf/phylmd/thermcell_main.F90
r2387 r3605 440 440 ! 441 441 if (prt_level.ge.1) print*,'avant thermcell_plume ',lev_out 442 !IM 140508 CALL thermcell_plume(ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz, & 443 444 ! Gestion temporaire de plusieurs appels à thermcell_plume au travers 445 ! de la variable iflag_thermals 446 447 ! print*,'THERM thermcell_main iflag_thermals_ed=',iflag_thermals_ed 442 443 !===================================================================== 444 ! Old version of thermcell_plume in thermcell_plume_6A.F90 445 ! It includes both thermcell_plume_6A and thermcell_plume_5B corresponding 446 ! to the 5B and 6A versions used for CMIP5 and CMIP6. 447 ! The latest was previously named thermcellV1_plume. 448 ! The new thermcell_plume is a clean version (removing obsolete 449 ! options) of thermcell_plume_6A. 450 ! The 3 versions are controled by 451 ! flag_thermals_ed <= 9 thermcell_plume_6A 452 ! <= 19 thermcell_plume_5B 453 ! else thermcell_plume (default 20 for convergence with 6A) 454 ! Fredho 455 !===================================================================== 456 448 457 if (iflag_thermals_ed<=9) then 449 458 ! print*,'THERM NOUVELLE/NOUVELLE Arnaud' 459 CALL thermcell_plume_6A(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& 460 & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & 461 & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & 462 & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & 463 & ,lev_out,lunout1,igout) 464 465 elseif (iflag_thermals_ed<=19) then 466 ! print*,'THERM RIO et al 2010, version d Arnaud' 467 CALL thermcell_plume_5B(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& 468 & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & 469 & lalim,f0,detr_star,entr_star,f_star,csc,ztva, & 470 & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & 471 & ,lev_out,lunout1,igout) 472 else 450 473 CALL thermcell_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,& 451 474 & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, & … … 453 476 & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter & 454 477 & ,lev_out,lunout1,igout) 455 456 elseif (iflag_thermals_ed>9) then457 ! print*,'THERM RIO et al 2010, version d Arnaud'458 CALL thermcellV1_plume(itap,ngrid,nlay,ptimestep,ztv,zthl,po,zl,rhobarz,&459 & zlev,pplev,pphi,zpspsk,alim_star,alim_star_tot, &460 & lalim,f0,detr_star,entr_star,f_star,csc,ztva, &461 & ztla,zqla,zqta,zha,zw2,zw_est,ztva_est,zqsatth,lmix,lmix_bis,linter &462 & ,lev_out,lunout1,igout)463 464 478 endif 465 479 -
LMDZ6/branches/Ocean_skin/libf/phylmd/tracco2i_mod.F90
r3421 r3605 2 2 ! 3 3 ! This module does the work for the interactive CO2 tracers 4 ! Authors: Patricia Cadule and Olivier Boucher 5 ! 6 ! Purpose and description: 7 ! ----------------------- 8 ! Main routine for the interactive carbon cycle 9 ! Gather all carbon fluxes and emissions from ORCHIDEE, PISCES and fossil fuel 10 ! Compute the net flux in source field which is used in phytrac 11 ! Compute global CO2 mixing ratio for radiation scheme if option is activated 12 ! Redistribute CO2 evenly over the atmosphere if transport is desactivated 4 13 ! 5 14 CONTAINS … … 10 19 11 20 USE dimphy 12 USE infotrac 13 USE geometry_mod, ONLY : cell_area 14 USE carbon_cycle_mod, ONLY : nbcf_in, fields_in, cfname_in, fco2_ocn_day, fco2_ff, fco2_bb 21 USE infotrac_phy 22 USE geometry_mod, ONLY: cell_area 23 USE carbon_cycle_mod, ONLY: carbon_cycle_init 24 USE carbon_cycle_mod, ONLY: id_CO2, nbcf_in, fields_in, cfname_in 25 USE carbon_cycle_mod, ONLY: fco2_ocn_day, fco2_ff, fco2_bb, fco2_land, fco2_ocean 26 USE carbon_cycle_mod, ONLY: fco2_land_nbp, fco2_land_nep, fco2_land_fLuc 27 USE carbon_cycle_mod, ONLY: fco2_land_fwoodharvest, fco2_land_fHarvest 28 USE carbon_cycle_mod, ONLY: carbon_cycle_cpl, carbon_cycle_tr, carbon_cycle_rad, RCO2_glo, RCO2_tot 15 29 USE mod_grid_phy_lmdz 16 USE mod_phys_lmdz_mpi_data, ONLY :is_mpi_root30 USE mod_phys_lmdz_mpi_data, ONLY: is_mpi_root 17 31 USE mod_phys_lmdz_para, ONLY: gather, bcast, scatter 18 32 USE phys_cal_mod 33 USE phys_state_var_mod, ONLY: pctsrf 34 USE indice_sol_mod, ONLY: nbsrf, is_ter, is_lic, is_oce, is_sic 19 35 20 36 IMPLICIT NONE … … 45 61 !---------------- 46 62 47 INTEGER, PARAMETER :: id_CO2=1 !--temporaire OB -- to be changed48 63 INTEGER :: it, k, i, nb 49 64 REAL, DIMENSION(klon,klev) :: m_air ! mass of air in every grid box [kg] 50 REAL, DIMENSION(klon) :: co2land ! surface land CO2 emissions [kg CO2/m2/s]51 REAL, DIMENSION(klon) :: co2ocean ! surface ocean CO2 emissions [kg CO2/m2/s]52 65 REAL, DIMENSION(klon_glo,klev) :: co2_glo ! variable temporaire sur la grille global 53 66 REAL, DIMENSION(klon_glo,klev) :: m_air_glo ! variable temporaire sur la grille global 54 67 55 56 INTEGER, SAVE :: mth_pre=0 57 !$OMP THREADPRIVATE(mth_pre) 58 REAL, SAVE :: RCO2_glo 59 !$OMP THREADPRIVATE(RCO2_glo) 68 LOGICAL, SAVE :: check_fCO2_nbp_in_cfname 69 !$OMP THREADPRIVATE(check_fCO2_nbp_in_cfname) 70 INTEGER, SAVE :: day_pre=-1 71 !$OMP THREADPRIVATE(day_pre) 60 72 61 73 IF (is_mpi_root) THEN … … 67 79 !--convert 280 ppm into kg CO2 / kg air 68 80 IF (debutphy) THEN 81 82 ! Initialisation de module carbon_cycle_mod 83 IF (carbon_cycle_cpl) THEN 84 CALL carbon_cycle_init() 85 ENDIF 86 87 ! Initialisation de tr_seri(id_CO2) si pas initialise 69 88 IF (MAXVAL(tr_seri(:,:,id_CO2)).LT.1.e-15) THEN 70 tr_seri(:,:,id_CO2)= 280.e-6/RMD*RMCO289 tr_seri(:,:,id_CO2)=co2_ppm0*1.e-6/RMD*RMCO2 !--initialised from co2_ppm0 in rdem 71 90 ENDIF 91 92 !--check if fCO2_nbp is in 93 check_fCO2_nbp_in_cfname=.FALSE. 94 DO nb=1, nbcf_in 95 IF (cfname_in(nb)=="fCO2_nbp") check_fCO2_nbp_in_cfname=.TRUE. 96 ENDDO 97 72 98 ENDIF 73 99 … … 85 111 86 112 !--retrieving land and ocean CO2 flux 87 !--fCO2_nep comes in unit of g CO2 m-2 dt_stomate-1 88 !--this needs to be changed in ORCHIDEE 89 co2land(:)=0.0 90 co2ocean(:)=0.0 113 fco2_land(:)=0.0 114 fco2_ocean(:)=0.0 115 fco2_land_nbp(:)=0. 116 fco2_land_nep(:)=0. 117 fco2_land_fLuc(:)=0. 118 fco2_land_fwoodharvest(:)=0. 119 fco2_land_fHarvest(:)=0. 120 91 121 DO nb=1, nbcf_in 92 IF (cfname_in(nb) == "fCO2_nep" ) co2land(:)=fields_in(:,nb)*RMCO2/RMC/86400./1000. 93 !!IF (cfname_in(nb) == "fCO2_fgco2" ) co2ocean(:)=fco2_ocn_day(:) !--for now 122 123 SELECT CASE(cfname_in(nb)) 124 !--dealing with the different fluxes coming from ORCHIDEE 125 !--fluxes come in unit of kg C m-2 s-1 is converted into kg CO2 m-2 s-1 126 CASE("fCO2_nep") 127 fco2_land_nep(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter) 128 CASE("fCO2_fLuc") 129 fco2_land_fLuc(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter) 130 CASE("fCO2_fwoodharvest") 131 fco2_land_fwoodharvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter) 132 CASE("fCO2_fHarvest") 133 fco2_land_fHarvest(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter) 134 CASE("fCO2_nbp") 135 fco2_land_nbp(:)=fields_in(:,nb)*RMCO2/RMC*pctsrf(:,is_ter) 136 !--fCO2_fco2_ocn comes in unit of mol C02 m-2 s-1 is converted into kg CO2 m-2 s-1 + change sign 137 CASE("fCO2_fgco2") 138 fco2_ocean(:)=-1.*fco2_ocn_day(:)*RMCO2/1.e3*(pctsrf(:,is_oce)+pctsrf(:,is_sic)) 139 END SELECT 140 94 141 ENDDO 95 142 96 !--preparing the net anthropogenic flux at the surface for mixing layer 97 !--unit kg CO2 / m2 / s 98 source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+co2land(:)+co2ocean(:) 143 !--if fCO2_nbp is transferred we use it, otherwise we use the sum of what has been passed from ORCHIDEE 144 IF (check_fCO2_nbp_in_cfname) THEN 145 fco2_land(:)=fco2_land_nbp(:) 146 ELSE 147 fco2_land(:)=fco2_land_nep(:)+fco2_land_fLuc(:)+fco2_land_fwoodharvest(:)+fco2_land_fHarvest(:) 148 ENDIF 149 150 !!--preparing the net anthropogenic flux at the surface for mixing layer 151 !!--unit kg CO2 / m2 / s 152 ! PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ff) ',MAXVAL(fco2_ff) 153 ! PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ff) ',MINVAL(fco2_ff) 154 ! PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_bb) ',MAXVAL(fco2_bb) 155 ! PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_bb) ',MINVAL(fco2_bb) 156 ! PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_land) ',MAXVAL(fco2_land) 157 ! PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_land) ',MINVAL(fco2_land) 158 ! PRINT *, 'tracco2i_mod.F90 --- MAXVAL(fco2_ocean) ',MAXVAL(fco2_ocean) 159 ! PRINT *, 'tracco2i_mod.F90 --- MINVAL(fco2_ocean) ',MINVAL(fco2_ocean) 160 ! PRINT *, 'tracco2i_mod.F90 --- MAXVAL(source(:,id_CO2)) ',MAXVAL(source(:,id_CO2)) 161 ! PRINT *, 'tracco2i_mod.F90 --- MINVAL(source(:,id_CO2)) ',MINVAL(source(:,id_CO2)) 162 ! 163 !--build final source term for CO2 164 source(:,id_CO2)=fco2_ff(:)+fco2_bb(:)+fco2_land(:)+fco2_ocean(:) 99 165 100 166 !--computing global mean CO2 for radiation 101 !--every timestep for now but enough every month 102 ! IF (debutphy.OR.mth_cur.NE.mth_pre) THEN 167 !--for every timestep comment out the IF ENDIF statements 168 !--otherwise this is updated every day 169 IF (debutphy.OR.day_cur.NE.day_pre) THEN 170 103 171 CALL gather(tr_seri(:,:,id_CO2),co2_glo) 104 172 CALL gather(m_air,m_air_glo) 173 105 174 !$OMP MASTER 106 !--conversion from kg CO2/kg air into ppm 175 176 !--compute a global mean CO2 value and print its value in ppm 107 177 IF (is_mpi_root) THEN 108 RCO2_glo=SUM(co2_glo*m_air_glo)/SUM(m_air_glo)*1.e6*RMD/RMCO2 178 RCO2_tot=SUM(co2_glo*m_air_glo) !--unit kg CO2 179 RCO2_glo=RCO2_tot/SUM(m_air_glo) !--unit kg CO2 / kg air 180 PRINT *,'tracco2i: global CO2 in ppm =', RCO2_glo*1.e6*RMD/RMCO2 181 PRINT *,'tracco2i: total CO2 in kg =', RCO2_tot 109 182 ENDIF 110 PRINT *,'toto in tracco2i: global CO2 in ppm =', RCO2_glo111 183 !$OMP END MASTER 112 184 CALL bcast(RCO2_glo) 113 mth_pre=mth_cur 114 ! ENDIF 185 day_pre=day_cur 186 !--if not carbon_cycle_tr, then we reinitialize the CO2 each day to its global mean value 187 IF (.NOT.carbon_cycle_tr) THEN 188 tr_seri(:,:,id_CO2)=RCO2_glo 189 ENDIF 190 ENDIF 115 191 116 192 END SUBROUTINE tracco2i … … 119 195 120 196 USE dimphy 121 USE infotrac 197 USE infotrac_phy 122 198 USE geometry_mod, ONLY : cell_area 123 199 USE mod_grid_phy_lmdz … … 129 205 USE netcdf, ONLY: nf90_get_var, nf90_noerr, nf90_nowrite 130 206 131 USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb 207 USE carbon_cycle_mod, ONLY : fco2_ff, fco2_bb, fco2_land, fco2_ocean 132 208 133 209 IMPLICIT NONE … … 150 226 !! may be controlled via the .def later on 151 227 !! also co2bb for now comes from ORCHIDEE 152 LOGICAL, PARAMETER :: readco2ff=.TRUE., readco2bb=.FALSE. 228 LOGICAL, PARAMETER :: readco2ff=.TRUE. 229 !! this should be left to FALSE for now 230 LOGICAL, PARAMETER :: readco2bb=.FALSE. 231 232 CHARACTER (len = 20) :: modname = 'tracco2i.co2_emissions' 233 CHARACTER (len = 80) :: abort_message 153 234 154 235 IF (debutphy) THEN … … 173 254 n_glo = size(vector) 174 255 IF (n_glo.NE.klon_glo) THEN 175 PRINT *,'sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo'176 STOP256 abort_message='sflx_lmdz_co2_ff: le nombre de points n est pas egal a klon_glo' 257 CALL abort_physic(modname,abort_message,1) 177 258 ENDIF 178 259 … … 181 262 n_month = size(time) 182 263 IF (n_month.NE.12) THEN 183 PRINT *,'sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12'184 STOP264 abort_message='sflx_lmdz_co2_ff: le nombre de month n est pas egal a 12' 265 CALL abort_physic(modname,abort_message,1) 185 266 ENDIF 186 267 … … 196 277 197 278 !--reading CO2 biomass burning emissions 279 !--using it will be inconsistent with treatment in ORCHIDEE 198 280 IF (readco2bb) THEN 199 281 … … 205 287 n_glo = size(vector) 206 288 IF (n_glo.NE.klon_glo) THEN 207 PRINT *,'sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo'208 STOP289 abort_message='sflx_lmdz_co2_bb: le nombre de points n est pas egal a klon_glo' 290 CALL abort_physic(modname,abort_message,1) 209 291 ENDIF 210 292 … … 213 295 n_month = size(time) 214 296 IF (n_month.NE.12) THEN 215 PRINT *,'sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12'216 STOP297 abort_message='sflx_lmdz_co2_bb: le nombre de month n est pas egal a 12' 298 CALL abort_physic(modname,abort_message,1) 217 299 ENDIF 218 300 … … 247 329 PRINT *,'probleme avec le mois dans co2_ini =', mth_cur 248 330 ENDIF 249 IF (.NOT.ALLOCATED(fco2_ff)) ALLOCATE(fco2_ff(klon)) 250 IF (.NOT.ALLOCATED(fco2_bb)) ALLOCATE(fco2_bb(klon)) 331 251 332 fco2_ff(:) = flx_co2ff(:,mth_cur) 252 333 fco2_bb(:) = flx_co2bb(:,mth_cur) -
LMDZ6/branches/Ocean_skin/libf/phylmd/traclmdz_mod.F90
r2320 r3605 92 92 USE regr_pr_comb_coefoz_m, ONLY: alloc_coefoz 93 93 USE press_coefoz_m, ONLY: press_coefoz 94 USE carbon_cycle_mod, ONLY : carbon_cycle_init, carbon_cycle_tr, carbon_cycle_cpl95 94 USE mod_grid_phy_lmdz 96 95 USE mod_phys_lmdz_para … … 285 284 286 285 ! 287 ! Initialisation de module carbon_cycle_mod288 ! ----------------------------------------------289 IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN290 CALL carbon_cycle_init(tr_seri, pdtphys, aerosol, radio)291 END IF292 293 286 ! Check if all tracers have restart values 294 287 ! ---------------------------------------------- … … 346 339 USE regr_pr_comb_coefoz_m, ONLY: regr_pr_comb_coefoz 347 340 USE o3_chem_m, ONLY: o3_chem 348 USE carbon_cycle_mod, ONLY : carbon_cycle, carbon_cycle_tr, carbon_cycle_cpl349 341 USE indice_sol_mod 350 342 … … 612 604 END IF 613 605 614 !======================================================================615 ! Calcul de cycle de carbon616 !======================================================================617 IF (carbon_cycle_tr .OR. carbon_cycle_cpl) THEN618 CALL carbon_cycle(nstep, pdtphys, pctsrf, tr_seri, source)619 END IF620 621 606 END SUBROUTINE traclmdz 622 607 -
LMDZ6/branches/Ocean_skin/libf/phylmd/undefSTD.F90
r2346 r3605 43 43 ! PARAMETER(klevSTD=17) 44 44 INTEGER itap 45 ! REAL dtime46 45 47 46 ! variables locales … … 67 66 68 67 69 ! calcul variables tous les freq_calNMC(n)/ dtimepas de temps68 ! calcul variables tous les freq_calNMC(n)/phys_tstep pas de temps 70 69 ! de la physique 71 70 72 IF (mod(itap,nint(freq_calnmc(n)/ dtime))==0) THEN71 IF (mod(itap,nint(freq_calnmc(n)/phys_tstep))==0) THEN 73 72 DO k = 1, nlevstd 74 73 DO i = 1, klon … … 103 102 END DO !k 104 103 105 END IF !MOD(itap,NINT(freq_calNMC(n)/ dtime)).EQ.0104 END IF !MOD(itap,NINT(freq_calNMC(n)/phys_tstep)).EQ.0 106 105 107 106 END DO !n -
LMDZ6/branches/Ocean_skin/libf/phylmd/wake.F90
r3252 r3605 196 196 INTEGER :: nsub 197 197 REAL :: dtimesub 198 REAL :: wdensmin 198 REAL, SAVE :: wdensmin 199 !$OMP THREADPRIVATE(wdensmin) 199 200 REAL, SAVE :: sigmad, hwmin, wapecut, cstart 200 201 !$OMP THREADPRIVATE(sigmad, hwmin, wapecut, cstart) 201 REAL :: sigmaw_max 202 REAL :: dens_rate 202 REAL, SAVE :: sigmaw_max 203 !$OMP THREADPRIVATE(sigmaw_max) 204 REAL, SAVE :: dens_rate 205 !$OMP THREADPRIVATE(dens_rate) 203 206 REAL :: wdens0 204 207 ! IM 080208 … … 1015 1018 1016 1019 IF (iflag_wk_pop_dyn >= 1) THEN 1020 ! The variable "death_rate" is significant only when iflag_wk_pop_dyn = 0. 1021 ! Here, it has to be set to zero. 1022 death_rate(:) = 0. 1017 1023 1018 1024 IF (iflag_wk_act ==2) THEN -
LMDZ6/branches/Ocean_skin/libf/phylmd/write_histrac.h
r2265 r3605 8 8 9 9 CALL histwrite_phy(nid_tra,.FALSE.,"phis",itau_w,pphis) 10 CALL histwrite_phy(nid_tra,.FALSE.,"aire",itau_w, airephy)10 CALL histwrite_phy(nid_tra,.FALSE.,"aire",itau_w,cell_area) 11 11 CALL histwrite_phy(nid_tra,.FALSE.,"zmasse",itau_w,zmasse) 12 12 ! RomP >>> -
LMDZ6/branches/Ocean_skin/libf/phylmd/yamada4.F90
r3041 r3605 152 152 !$OMP THREADPRIVATE(firstcall) 153 153 154 CHARACTER (len = 20) :: modname = 'yamada4' 155 CHARACTER (len = 80) :: abort_message 156 154 157 155 158 … … 199 202 ENDIF 200 203 201 PRINT*,'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha204 WRITE(lunout,*)'YAMADA4 RIc, RIfc, Sm_min, Alpha_min',ric,rifc,seuilsm,seuilalpha 202 205 firstcall = .FALSE. 203 206 CALL getin_p('lmixmin',lmixmin) … … 216 219 217 220 IF (.NOT. (iflag_pbl>=6 .AND. iflag_pbl<=12)) THEN 218 STOP 'probleme de coherence dans appel a MY' 221 abort_message='probleme de coherence dans appel a MY' 222 CALL abort_physic(modname,abort_message,1) 219 223 END IF 220 224 … … 537 541 538 542 ELSE 539 STOP 'Cas nom prevu dans yamada4' 543 abort_message='Cas nom prevu dans yamada4' 544 CALL abort_physic(modname,abort_message,1) 540 545 541 546 END IF ! Fin du cas 8 … … 590 595 591 596 IF (prt_level>1) THEN 592 PRINT *,'YAMADA4 0'597 WRITE(lunout,*) 'YAMADA4 0' 593 598 END IF 594 599 … … 660 665 661 666 IF (prt_level>1) THEN 662 PRINT *,'YAMADA4 1'667 WRITE(lunout,*)'YAMADA4 1' 663 668 END IF !(prt_level>1) THEN 664 669 … … 734 739 IMPLICIT NONE 735 740 736 include "dimensions.h"737 738 741 ! vdif_q2: subroutine qui calcule la diffusion de la TKE par la TKE 739 742 ! avec un schema implicite en temps avec … … 825 828 IMPLICIT NONE 826 829 827 include "dimensions.h"828 !829 830 ! vdif_q2e: subroutine qui calcule la diffusion de TKE par la TKE 830 831 ! avec un schema explicite en temps
Note: See TracChangeset
for help on using the changeset viewer.